Cabal go to module's definition (#4380)

If you click go-to definition on the field under `exposed-module` or `other-module`
it will open the file where this module was defined.

The go-to definition function compares the highlighted text with modules in the cabal file.
If there is a match, it takes the respective build target and tries to fetch their `hsSourceDirs` from the `PackageDescription`. (by looking at all `buildInfos` with matching names).

After finding them, it constructs a path using directory where the cabal file is located, the info from `hsSourceDirs` and a name of the module converted to a path.
If the file exists it returns the `Definition` with the acquired location.

---------

Co-authored-by: fendor <[email protected]>
Co-authored-by: Chrizzl <[email protected]>
Co-authored-by: VeryMilkyJoe <[email protected]>

Author: 4 people

haskell-language-server.cabal

@@ -242,6 +242,7 @@ library hls-cabal-plugin
     Ide.Plugin.Cabal.Completion.Completions
     Ide.Plugin.Cabal.Completion.Data
     Ide.Plugin.Cabal.Completion.Types
+    Ide.Plugin.Cabal.Definition
     Ide.Plugin.Cabal.FieldSuggest
     Ide.Plugin.Cabal.LicenseSuggest
     Ide.Plugin.Cabal.CabalAdd
@@ -287,11 +288,12 @@ test-suite hls-cabal-plugin-tests
   hs-source-dirs:   plugins/hls-cabal-plugin/test
   main-is:          Main.hs
   other-modules:
+    CabalAdd
     Completer
     Context
-    Utils
+    Definition
     Outline
-    CabalAdd
+    Utils
   build-depends:
     , base
     , bytestring

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

@@ -17,14 +17,12 @@ import qualified Data.ByteString                             as BS
 import           Data.Hashable
 import           Data.HashMap.Strict                         (HashMap)
 import qualified Data.HashMap.Strict                         as HashMap
-import           Data.List                                   (find)
 import qualified Data.List.NonEmpty                          as NE
 import qualified Data.Maybe                                  as Maybe
 import qualified Data.Text                                   as T
 import qualified Data.Text.Encoding                          as Encoding
 import           Data.Typeable
 import           Development.IDE                             as D
-import           Development.IDE.Core.PluginUtils
 import           Development.IDE.Core.Shake                  (restartShakeSession)
 import qualified Development.IDE.Core.Shake                  as Shake
 import           Development.IDE.Graph                       (Key, alwaysRerun)
@@ -33,20 +31,19 @@ import           Development.IDE.Types.Shake                 (toKey)
 import qualified Distribution.Fields                         as Syntax
 import qualified Distribution.Parsec.Position                as Syntax
 import           GHC.Generics
-import           Ide.Plugin.Cabal.Completion.CabalFields     as CabalFields
 import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
 import qualified Ide.Plugin.Cabal.Completion.Completions     as Completions
 import           Ide.Plugin.Cabal.Completion.Types           (ParseCabalCommonSections (ParseCabalCommonSections),
                                                               ParseCabalFields (..),
                                                               ParseCabalFile (..))
 import qualified Ide.Plugin.Cabal.Completion.Types           as Types
+import           Ide.Plugin.Cabal.Definition                 (gotoDefinition)
 import qualified Ide.Plugin.Cabal.Diagnostics                as Diagnostics
 import qualified Ide.Plugin.Cabal.FieldSuggest               as FieldSuggest
 import qualified Ide.Plugin.Cabal.LicenseSuggest             as LicenseSuggest
 import           Ide.Plugin.Cabal.Orphans                    ()
 import           Ide.Plugin.Cabal.Outline
 import qualified Ide.Plugin.Cabal.Parse                      as Parse
-import           Ide.Plugin.Error
 import           Ide.Types
 import qualified Language.LSP.Protocol.Lens                  as JL
 import qualified Language.LSP.Protocol.Message               as LSP
@@ -305,32 +302,6 @@ fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentif
       let completionTexts = fmap (^. JL.label) completions
       pure $ FieldSuggest.fieldErrorAction uri fieldName completionTexts _range
 
--- | CodeActions for going to definitions.
---
--- Provides a CodeAction for going to a definition when clicking on an identifier.
--- The definition is found by traversing the sections and comparing their name to
--- the clicked identifier.
---
--- TODO: Support more definitions than sections.
-gotoDefinition :: PluginMethodHandler IdeState LSP.Method_TextDocumentDefinition
-gotoDefinition ideState _ msgParam = do
-    nfp <- getNormalizedFilePathE uri
-    cabalFields <- runActionE "cabal-plugin.commonSections" ideState $ useE ParseCabalFields nfp
-    case CabalFields.findTextWord cursor cabalFields of
-      Nothing ->
-        pure $ InR $ InR Null
-      Just cursorText -> do
-        commonSections <- runActionE "cabal-plugin.commonSections" ideState $ useE ParseCabalCommonSections nfp
-        case find (isSectionArgName cursorText) commonSections of
-          Nothing ->
-            pure $ InR $ InR Null
-          Just commonSection -> do
-            pure $ InL $ Definition $ InL $ Location uri $ CabalFields.getFieldLSPRange commonSection
-    where
-      cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)
-      uri = msgParam ^. JL.textDocument . JL.uri
-      isSectionArgName name (Syntax.Section _ sectionArgName _) = name == CabalFields.onelineSectionArgs sectionArgName
-      isSectionArgName _ _ = False
 
 cabalAddCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
 cabalAddCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do

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

@@ -1,25 +1,29 @@
 module Ide.Plugin.Cabal.Completion.CabalFields
-  ( findStanzaForColumn,
-    findFieldSection,
-    findTextWord,
-    findFieldLine,
-    getOptionalSectionName,
-    getAnnotation,
-    getFieldName,
-    onelineSectionArgs,
-    getFieldEndPosition,
-    getSectionArgEndPosition,
-    getNameEndPosition,
-    getFieldLineEndPosition,
-    getFieldLSPRange
-    ) where
+  ( findStanzaForColumn
+  , getModulesNames
+  , getFieldLSPRange
+  , findFieldSection
+  , findTextWord
+  , findFieldLine
+  , getOptionalSectionName
+  , getAnnotation
+  , getFieldName
+  , onelineSectionArgs
+  , getFieldEndPosition
+  , getSectionArgEndPosition
+  , getNameEndPosition
+  , getFieldLineEndPosition
+  )
+  where
 
 import qualified Data.ByteString                   as BS
 import           Data.List                         (find)
+import           Data.List.Extra                   (groupSort)
 import           Data.List.NonEmpty                (NonEmpty)
 import qualified Data.List.NonEmpty                as NE
 import qualified Data.Text                         as T
 import qualified Data.Text.Encoding                as T
+import           Data.Tuple                        (swap)
 import qualified Distribution.Fields               as Syntax
 import qualified Distribution.Parsec.Position      as Syntax
 import           Ide.Plugin.Cabal.Completion.Types
@@ -138,6 +142,9 @@ getFieldName :: Syntax.Field ann -> FieldName
 getFieldName (Syntax.Field (Syntax.Name _ fn) _)     = T.decodeUtf8 fn
 getFieldName (Syntax.Section (Syntax.Name _ fn) _ _) = T.decodeUtf8 fn
 
+getFieldLineName :: Syntax.FieldLine ann -> FieldName
+getFieldLineName (Syntax.FieldLine  _ fn) = T.decodeUtf8 fn
+
 -- | Returns the name of a section if it has a name.
 --
 -- This assumes that the given section args belong to named stanza
@@ -148,6 +155,107 @@ getOptionalSectionName (x:xs) = case x of
     Syntax.SecArgName _ name -> Just (T.decodeUtf8 name)
     _                        -> getOptionalSectionName xs
 
+type BuildTargetName = T.Text
+type ModuleName      = T.Text
+
+-- | Given a cabal AST returns pairs of all respective target names
+-- and the module name bound to them. If a target is a main library gives
+-- @Nothing@, otherwise @Just target-name@
+--
+-- Examples of input cabal files and the outputs:
+--
+-- * Target is a main library module:
+--
+-- >   library
+-- >     exposed-modules:
+-- >       MyLib
+--
+-- * @getModulesNames@ output:
+--
+-- >   [([Nothing], "MyLib")]
+--
+-- * Same module names in different targets:
+--
+-- >   test-suite first-target
+-- >        other-modules:
+-- >          Config
+-- >   test-suite second-target
+-- >        other-modules:
+-- >          Config
+--
+-- * @getModulesNames@ output:
+--
+-- >   [([Just "first-target", Just "second-target"], "Config")]
+getModulesNames :: [Syntax.Field any] -> [([Maybe BuildTargetName], ModuleName)]
+getModulesNames fields = map swap $ groupSort rawModuleTargetPairs
+  where
+    rawModuleTargetPairs = concatMap getSectionModuleNames sections
+    sections = getSectionsWithModules fields
+
+    getSectionModuleNames :: Syntax.Field any -> [(ModuleName, Maybe BuildTargetName)]
+    getSectionModuleNames (Syntax.Section _ secArgs fields) = map (, getArgsName secArgs) $ concatMap getFieldModuleNames fields
+    getSectionModuleNames _ = []
+
+    getArgsName [Syntax.SecArgName _ name] = Just $ T.decodeUtf8 name
+    getArgsName _                          = Nothing -- Can be only a main library, that has no name
+                                                     -- since it's impossible to have multiple names for a build target
+
+    getFieldModuleNames field@(Syntax.Field _ modules) = if getFieldName field == T.pack "exposed-modules" ||
+                                                            getFieldName field == T.pack "other-modules"
+                                                            then map getFieldLineName modules
+                                                            else []
+    getFieldModuleNames _ = []
+
+-- | Trims a given cabal AST leaving only targets and their
+-- @exposed-modules@ and @other-modules@ sections.
+--
+-- For example:
+--
+-- * Given a cabal file like this:
+--
+-- >   library
+-- >     import: extra
+-- >     hs-source-dirs: source/directory
+-- >     ...
+-- >     exposed-modules:
+-- >       Important.Exposed.Module
+-- >     other-modules:
+-- >       Important.Other.Module
+-- >
+-- >   test-suite tests
+-- >     type: type
+-- >     build-tool-depends: tool
+-- >     other-modules:
+-- >       Important.Other.Module
+--
+-- * @getSectionsWithModules@ gives output:
+--
+-- >   library
+-- >     exposed-modules:
+-- >       Important.Exposed.Module
+-- >     other-modules:
+-- >       Important.Other.Module
+-- >   test-suite tests
+-- >     other-modules:
+-- >       Important.Other.Module
+getSectionsWithModules :: [Syntax.Field any] -> [Syntax.Field any]
+getSectionsWithModules fields = concatMap go fields
+  where
+    go :: Syntax.Field any -> [Syntax.Field any]
+    go (Syntax.Field _ _) = []
+    go section@(Syntax.Section _ _ fields) = concatMap onlySectionsWithModules (section:fields)
+
+    onlySectionsWithModules :: Syntax.Field any -> [Syntax.Field any]
+    onlySectionsWithModules (Syntax.Field _ _) = []
+    onlySectionsWithModules (Syntax.Section name secArgs fields)
+      | (not . null) newFields = [Syntax.Section name secArgs newFields]
+      | otherwise = []
+      where newFields = filter subfieldHasModule fields
+
+    subfieldHasModule :: Syntax.Field any -> Bool
+    subfieldHasModule field@(Syntax.Field _ _) = getFieldName field == T.pack "exposed-modules" ||
+                                                 getFieldName field == T.pack "other-modules"
+    subfieldHasModule (Syntax.Section _ _ _) = False
 
 -- | Makes a single text line out of multiple
 --   @SectionArg@s. Allows to display conditions,
@@ -165,7 +273,6 @@ onelineSectionArgs sectionArgs = joinedName
     getName (Syntax.SecArgStr _ quotedString) = T.decodeUtf8 quotedString
     getName (Syntax.SecArgOther _ string)     = T.decodeUtf8 string
 
-
 -- | Returns the end position of a provided field
 getFieldEndPosition :: Syntax.Field Syntax.Position -> Syntax.Position
 getFieldEndPosition (Syntax.Field name [])       = getNameEndPosition name