Skip to content

Commit a49ecea

Browse files
VenInfVenInf
committed
finding hsSourceDirs
1 parent 169fa2c commit a49ecea

File tree

2 files changed

+129
-54
lines changed

2 files changed

+129
-54
lines changed

‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

Lines changed: 115 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -2,56 +2,69 @@
22
{-# LANGUAGE DuplicateRecordFields #-}
33
{-# LANGUAGE LambdaCase #-}
44
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE RecordWildCards #-}
56
{-# LANGUAGE TypeFamilies #-}
67

78
module Ide.Plugin.Cabal (descriptor, Log (..)) where
89

910
import Control.Concurrent.Strict
1011
import Control.DeepSeq
11-
import Control.Lens ((^.))
12+
import Control.Lens ((^.))
1213
import Control.Monad.Extra
1314
import Control.Monad.IO.Class
1415
import Control.Monad.Trans.Class
15-
import Control.Monad.Trans.Maybe (runMaybeT)
16-
import qualified Data.ByteString as BS
16+
import Control.Monad.Trans.Maybe (runMaybeT)
17+
import qualified Data.ByteString as BS
1718
import Data.Hashable
18-
import Data.HashMap.Strict (HashMap)
19-
import qualified Data.HashMap.Strict as HashMap
20-
import qualified Data.List.NonEmpty as NE
21-
import qualified Data.Maybe as Maybe
22-
import qualified Data.Text as T
23-
import qualified Data.Text.Encoding as Encoding
19+
import Data.HashMap.Strict (HashMap)
20+
import qualified Data.HashMap.Strict as HashMap
21+
import Data.List (find)
22+
import qualified Data.List.NonEmpty as NE
23+
import qualified Data.Maybe as Maybe
24+
import qualified Data.Text as T
25+
import qualified Data.Text.Encoding as Encoding
2426
import Data.Typeable
25-
import Development.IDE as D
26-
import Development.IDE.Core.Shake (restartShakeSession)
27-
import qualified Development.IDE.Core.Shake as Shake
28-
import Development.IDE.Graph (Key, alwaysRerun)
29-
import qualified Development.IDE.Plugin.Completions.Logic as Ghcide
30-
import Development.IDE.Types.Shake (toKey)
31-
import qualified Distribution.Fields as Syntax
32-
import qualified Distribution.Parsec.Position as Syntax
27+
import Development.IDE as D
28+
import Development.IDE.Core.Shake (restartShakeSession)
29+
import qualified Development.IDE.Core.Shake as Shake
30+
import Development.IDE.Graph (Key,
31+
alwaysRerun)
32+
import qualified Development.IDE.Plugin.Completions.Logic as Ghcide
33+
import Development.IDE.Types.Shake (toKey)
34+
import qualified Distribution.Fields as Syntax
35+
import qualified Distribution.Parsec.Position as Syntax
3336
import GHC.Generics
34-
import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
35-
import qualified Ide.Plugin.Cabal.Completion.Completions as Completions
36-
import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections),
37-
ParseCabalFields (..),
38-
ParseCabalFile (..))
39-
import qualified Ide.Plugin.Cabal.Completion.Types as Types
40-
import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics
41-
import qualified Ide.Plugin.Cabal.FieldSuggest as FieldSuggest
42-
import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest
43-
import Ide.Plugin.Cabal.Orphans ()
37+
import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields
38+
import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
39+
import qualified Ide.Plugin.Cabal.Completion.Completions as Completions
40+
import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections),
41+
ParseCabalFields (..),
42+
ParseCabalFile (..))
43+
import qualified Ide.Plugin.Cabal.Completion.Types as Types
44+
import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics
45+
import qualified Ide.Plugin.Cabal.FieldSuggest as FieldSuggest
46+
import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest
47+
import Ide.Plugin.Cabal.Orphans ()
4448
import Ide.Plugin.Cabal.Outline
45-
import qualified Ide.Plugin.Cabal.Parse as Parse
49+
import qualified Ide.Plugin.Cabal.Parse as Parse
4650
import Ide.Types
47-
import qualified Language.LSP.Protocol.Lens as JL
48-
import qualified Language.LSP.Protocol.Message as LSP
51+
import qualified Language.LSP.Protocol.Lens as JL
52+
import qualified Language.LSP.Protocol.Message as LSP
4953
import Language.LSP.Protocol.Types
50-
import qualified Language.LSP.VFS as VFS
51-
import Data.List (find)
52-
import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields
53-
54-
import Debug.Trace
54+
import qualified Language.LSP.VFS as VFS
55+
56+
import Debug.Trace
57+
import Distribution.PackageDescription (Benchmark (..),
58+
BuildInfo (..),
59+
Executable (..),
60+
ForeignLib (..),
61+
Library (..),
62+
LibraryName (LMainLibName, LSubLibName),
63+
PackageDescription (..),
64+
TestSuite (..),
65+
library,
66+
unUnqualComponentName)
67+
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
5568

5669
data Log
5770
= LogModificationTime NormalizedFilePath FileVersion
@@ -297,31 +310,86 @@ gotoDefinition ideState _ msgParam = do
297310
pure $ InR $ InR Null
298311
Just filePath -> do
299312
mCabalFields <- liftIO $ runAction "cabal-plugin.commonSections" ideState $ use ParseCabalFields $ toNormalizedFilePath filePath
300-
let mModuleNames = CabalFields.getModulesNames <$> mCabalFields
301-
let mModuleSections = CabalFields.getSectionsWithModules <$> mCabalFields
302-
traceShowM ("mModuleNames", mModuleNames)
303-
traceShowM ("mModuleSections", mModuleSections)
304313

305314
let mCursorText = CabalFields.findTextWord cursor =<< mCabalFields
306315
case mCursorText of
307316
Nothing ->
308317
pure $ InR $ InR Null
309318
Just cursorText -> do
310319
mCommonSections <- liftIO $ runAction "cabal-plugin.commonSections" ideState $ use ParseCabalCommonSections $ toNormalizedFilePath filePath
311-
let mCommonSection = find (filterSectionArgName cursorText) =<< mCommonSections
320+
let mCommonSection = find (isSectionArgName cursorText) =<< mCommonSections
312321
case mCommonSection of
313-
Nothing ->
314-
pure $ InR $ InR Null
315322
Just commonSection -> do
316323
pure $ InL $ Definition $ InL $ Location uri $ CabalFields.getFieldLSPRange commonSection
324+
Nothing -> do
325+
let mModuleNames = CabalFields.getModulesNames <$> mCabalFields
326+
mModuleName = find (isModuleName cursorText) =<< mModuleNames
327+
case mModuleName of
328+
Nothing -> traceShowM ("NOT A MODULE")
329+
Just (mBuildTargetNames, moduleName) -> do
330+
traceShowM ("IS A MODULE", moduleName, "at", mBuildTargetNames)
331+
mGPD <- liftIO $ runAction "cabal.GPD" ideState $ useWithStale ParseCabalFile $ toNormalizedFilePath filePath
332+
case mGPD of
333+
Nothing -> traceShowM ("failed to get GPD")
334+
Just (gpd, _) -> do
335+
let debug = map (lookupBuildTargetPackageDescription
336+
(flattenPackageDescription gpd))
337+
mBuildTargetNames
338+
traceShowM ("debug is", debug)
339+
let buildInfos = foldMap (lookupBuildTargetPackageDescription
340+
(flattenPackageDescription gpd))
341+
mBuildTargetNames
342+
traceShowM ("buildInfos is", buildInfos)
343+
traceShowM ("Found hsSourceDirs", map hsSourceDirs buildInfos)
344+
pure $ InR $ InR Null
317345
where
318346
cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)
319347
uri = msgParam ^. JL.textDocument . JL.uri
320-
filterSectionArgName name (Syntax.Section _ sectionArgName _) = name == CabalFields.onelineSectionArgs sectionArgName
321-
filterSectionArgName _ _ = False
322-
323-
324-
348+
isSectionArgName name (Syntax.Section _ sectionArgName _) = name == CabalFields.onelineSectionArgs sectionArgName
349+
isSectionArgName _ _ = False
350+
isModuleName name (_, moduleName) = name == moduleName
351+
352+
lookupBuildTargetPackageDescription :: PackageDescription -> Maybe T.Text -> [BuildInfo]
353+
lookupBuildTargetPackageDescription (PackageDescription {..}) Nothing =
354+
case library of
355+
Nothing -> error "Target is a main library but no main library was found"
356+
Just (Library {libBuildInfo}) -> [libBuildInfo]
357+
lookupBuildTargetPackageDescription (PackageDescription {..}) (Just buildTargetName) =
358+
Maybe.catMaybes $
359+
map (\exec -> executableNameLookup exec buildTargetName) executables <>
360+
map (\lib -> subLibraryNameLookup lib buildTargetName) subLibraries <>
361+
map (\lib -> foreignLibsNameLookup lib buildTargetName) foreignLibs <>
362+
map (\test -> testSuiteNameLookup test buildTargetName) testSuites <>
363+
map (\bench -> benchmarkNameLookup bench buildTargetName) benchmarks
364+
where
365+
executableNameLookup :: Executable -> T.Text -> Maybe BuildInfo
366+
executableNameLookup (Executable {exeName, buildInfo}) buildTargetName =
367+
if T.pack (unUnqualComponentName exeName) == buildTargetName
368+
then Just buildInfo
369+
else Nothing
370+
subLibraryNameLookup :: Library -> T.Text -> Maybe BuildInfo
371+
subLibraryNameLookup (Library {libName, libBuildInfo}) buildTargetName =
372+
case libName of
373+
(LSubLibName name) ->
374+
if T.pack (unUnqualComponentName name) == buildTargetName
375+
then Just libBuildInfo
376+
else Nothing
377+
LMainLibName -> Nothing
378+
foreignLibsNameLookup :: ForeignLib -> T.Text -> Maybe BuildInfo
379+
foreignLibsNameLookup (ForeignLib {foreignLibName, foreignLibBuildInfo}) buildTargetName =
380+
if T.pack (unUnqualComponentName foreignLibName) == buildTargetName
381+
then Just foreignLibBuildInfo
382+
else Nothing
383+
testSuiteNameLookup :: TestSuite -> T.Text -> Maybe BuildInfo
384+
testSuiteNameLookup (TestSuite {testName, testBuildInfo}) buildTargetName =
385+
if T.pack (unUnqualComponentName testName) == buildTargetName
386+
then Just testBuildInfo
387+
else Nothing
388+
benchmarkNameLookup :: Benchmark -> T.Text -> Maybe BuildInfo
389+
benchmarkNameLookup (Benchmark {benchmarkName, benchmarkBuildInfo}) buildTargetName =
390+
if T.pack (unUnqualComponentName benchmarkName) == buildTargetName
391+
then Just benchmarkBuildInfo
392+
else Nothing
325393
-- ----------------------------------------------------------------
326394
-- Cabal file of Interest rules and global variable
327395
-- ----------------------------------------------------------------

‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs

Lines changed: 14 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,9 @@ import Ide.Plugin.Cabal.Completion.Types
1010
import qualified Data.ByteString as BS
1111
import Data.List (find)
1212
import qualified Language.LSP.Protocol.Types as LSP
13+
import Data.List.Extra (groupSort)
14+
import Data.Bifunctor (second)
15+
import Data.Tuple (swap)
1316

1417
-- ----------------------------------------------------------------
1518
-- Cabal-syntax utilities I don't really want to write myself
@@ -51,7 +54,6 @@ findFieldSection cursor (x:y:ys)
5154

5255
type FieldName = T.Text
5356

54-
5557
-- | Determine the field line the cursor is currently a part of.
5658
--
5759
-- The result is said field line and its starting position
@@ -137,17 +139,22 @@ getOptionalSectionName (x:xs) = case x of
137139
Syntax.SecArgName _ name -> Just (T.decodeUtf8 name)
138140
_ -> getOptionalSectionName xs
139141

140-
getModulesNames :: [Syntax.Field any] -> [(T.Text, T.Text)]
141-
getModulesNames fields = concatMap getSectionModuleNames sections
142+
type BuildTargetName = T.Text
143+
type ModuleName = T.Text
144+
145+
getModulesNames :: [Syntax.Field any] -> [([Maybe BuildTargetName], ModuleName)]
146+
getModulesNames fields = map swap $ groupSort rawModuleTargetPairs
142147
where
148+
rawModuleTargetPairs = concatMap getSectionModuleNames sections
143149
sections = getSectionsWithModules fields
144150

145-
getSectionModuleNames (Syntax.Section _ secArgs fields) = map (getArgsName secArgs, ) $ concatMap getFieldModuleNames fields
151+
getSectionModuleNames :: Syntax.Field any -> [(ModuleName, Maybe BuildTargetName)]
152+
getSectionModuleNames (Syntax.Section _ secArgs fields) = map (, getArgsName secArgs) $ concatMap getFieldModuleNames fields
146153
getSectionModuleNames _ = []
147154

148-
getArgsName [] = T.empty
149-
getArgsName [Syntax.SecArgName _ name] = T.decodeUtf8 name
150-
getArgsName _ = T.empty
155+
getArgsName [] = Nothing -- only a main library can have no name
156+
getArgsName [Syntax.SecArgName _ name] = Just $ T.decodeUtf8 name
157+
getArgsName _ = Nothing -- impossible to have multiple names for a build target
151158

152159
getFieldModuleNames field@(Syntax.Field _ modules) = if getFieldName field == T.pack "exposed-modules" ||
153160
getFieldName field == T.pack "other-modules"

0 commit comments

Comments
 (0)