Cabal go to module's definition

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

@@ -2,52 +2,72 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TypeFamilies          #-}
 
 module Ide.Plugin.Cabal (descriptor, Log (..)) where
 
 import           Control.Concurrent.Strict
 import           Control.DeepSeq
-import           Control.Lens                                ((^.))
+import           Control.Lens                                  ((^.))
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class
-import           Control.Monad.Trans.Maybe                   (runMaybeT)
-import qualified Data.ByteString                             as BS
+import           Control.Monad.Trans.Maybe                     (runMaybeT)
+import qualified Data.ByteString                               as BS
 import           Data.Hashable
-import           Data.HashMap.Strict                         (HashMap)
-import qualified Data.HashMap.Strict                         as HashMap
-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.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.Shake                  (restartShakeSession)
-import qualified Development.IDE.Core.Shake                  as Shake
-import           Development.IDE.Graph                       (Key, alwaysRerun)
-import qualified Development.IDE.Plugin.Completions.Logic    as Ghcide
-import           Development.IDE.Types.Shake                 (toKey)
-import qualified Distribution.Fields                         as Syntax
-import qualified Distribution.Parsec.Position                as Syntax
+import           Development.IDE                               as D
+import           Development.IDE.Core.Shake                    (restartShakeSession)
+import qualified Development.IDE.Core.Shake                    as Shake
+import           Development.IDE.Graph                         (Key,
+                                                                alwaysRerun)
+import qualified Development.IDE.Plugin.Completions.Logic      as Ghcide
+import           Development.IDE.Types.Shake                   (toKey)
+import qualified Distribution.Fields                           as Syntax
+import           Distribution.PackageDescription               (Benchmark (..),
+                                                                BuildInfo (..),
+                                                                Executable (..),
+                                                                ForeignLib (..),
+                                                                Library (..),
+                                                                LibraryName (LMainLibName, LSubLibName),
+                                                                PackageDescription (..),
+                                                                TestSuite (..),
+                                                                library,
+                                                                unUnqualComponentName)
+import           Distribution.PackageDescription.Configuration (flattenPackageDescription)
+import qualified Distribution.Parsec.Position                  as Syntax
+import           Distribution.Utils.Generic                    (safeHead)
+import           Distribution.Utils.Path                       (getSymbolicPath)
 import           GHC.Generics
-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 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.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 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 qualified Ide.Plugin.Cabal.Parse                        as Parse
 import           Ide.Types
-import qualified Language.LSP.Protocol.Lens                  as JL
-import qualified Language.LSP.Protocol.Message               as LSP
+import qualified Language.LSP.Protocol.Lens                    as JL
+import qualified Language.LSP.Protocol.Message                 as LSP
 import           Language.LSP.Protocol.Types
-import qualified Language.LSP.VFS                            as VFS
+import qualified Language.LSP.VFS                              as VFS
+import           System.Directory                              (doesFileExist)
+import           System.FilePath                               (takeDirectory,
+                                                                (</>))
 
 data Log
   = LogModificationTime NormalizedFilePath FileVersion
@@ -93,6 +113,7 @@ descriptor recorder plId =
           , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder
           , mkPluginHandler LSP.SMethod_TextDocumentDocumentSymbol moduleOutline
           , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ fieldSuggestCodeAction recorder
+          , mkPluginHandler LSP.SMethod_TextDocumentDefinition gotoDefinition
           ]
     , pluginNotificationHandlers =
         mconcat
@@ -277,6 +298,105 @@ 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
+-- and clicking on exposed-module or other-module field.
+-- The definition is found by traversing the sections and comparing their name to
+-- the clicked identifier. If it's not in sections it attempts to find it in module names.
+--
+-- TODO: Resolve more cases for go-to definition.
+gotoDefinition :: PluginMethodHandler IdeState LSP.Method_TextDocumentDefinition
+gotoDefinition ideState _ msgParam = do
+  case uriToFilePath' uri of
+    Nothing ->
+      pure $ InR $ InR Null
+    Just filePath -> do
+      mCabalFields <- liftIO $ runAction "cabal-plugin.commonSections" ideState $ use ParseCabalFields $ toNormalizedFilePath filePath
+
+      let mCursorText = CabalFields.findTextWord cursor =<< mCabalFields
+      case mCursorText of
+        Nothing ->
+          pure $ InR $ InR Null
+        Just cursorText -> do
+          mCommonSections <- liftIO $ runAction "cabal-plugin.commonSections" ideState $ use ParseCabalCommonSections $ toNormalizedFilePath filePath
+          let mCommonSection = find (isSectionArgName cursorText) =<< mCommonSections
+          case mCommonSection of
+            Just commonSection -> do
+              pure $ InL $ Definition $ InL $ Location uri $ CabalFields.getFieldLSPRange commonSection
+            Nothing -> do
+              let mModuleNames = CabalFields.getModulesNames <$> mCabalFields
+                  mModuleName = find (isModuleName cursorText) =<< mModuleNames
+              case mModuleName of
+                Nothing -> pure $ InR $ InR Null
+                Just (mBuildTargetNames, moduleName) -> do
+                  mGPD <- liftIO $ runAction "cabal.GPD" ideState $ useWithStale ParseCabalFile $ toNormalizedFilePath filePath
+                  case mGPD of
+                    Nothing -> pure $ InR $ InR Null
+                    Just (gpd, _) -> do
+                      let buildInfos = foldMap (lookupBuildTargetPackageDescription
+                                                      (flattenPackageDescription gpd))
+                                                      mBuildTargetNames
+                          sourceDirs = map getSymbolicPath $ concatMap hsSourceDirs buildInfos
+                          potentialPaths = map (\dir -> takeDirectory filePath </> dir </> toHaskellFile moduleName) sourceDirs
+                      allPaths <- liftIO $ filterM doesFileExist potentialPaths
+                      let locations = map (\pth -> Location (filePathToUri pth) (mkRange 0 0 0 0)) allPaths
+                      case safeHead locations of -- We assume there could be only one source location
+                        Nothing       -> pure $ InR $ InR Null
+                        Just location -> pure $ InL $ Definition $ InL location
+    where
+      cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)
+      uri = msgParam ^. JL.textDocument . JL.uri
+      isSectionArgName name (Syntax.Section _ sectionArgName _) = name == CabalFields.onelineSectionArgs sectionArgName
+      isSectionArgName _ _ = False
+      isModuleName name (_,  moduleName) = name == moduleName
+
+      lookupBuildTargetPackageDescription :: PackageDescription -> Maybe T.Text -> [BuildInfo]
+      lookupBuildTargetPackageDescription (PackageDescription {..}) Nothing =
+        case library of
+          Nothing                       -> error "Target is a main library but no main library was found"
+          Just (Library {libBuildInfo}) -> [libBuildInfo]
+      lookupBuildTargetPackageDescription (PackageDescription {..}) (Just buildTargetName) =
+        Maybe.catMaybes $
+          map (\exec -> executableNameLookup exec buildTargetName) executables <>
+          map (\lib -> subLibraryNameLookup lib buildTargetName) subLibraries <>
+          map (\lib -> foreignLibsNameLookup lib buildTargetName) foreignLibs <>
+          map (\test -> testSuiteNameLookup test buildTargetName) testSuites <>
+          map (\bench -> benchmarkNameLookup bench buildTargetName) benchmarks
+        where
+          executableNameLookup :: Executable -> T.Text -> Maybe BuildInfo
+          executableNameLookup (Executable {exeName, buildInfo}) buildTargetName =
+            if T.pack (unUnqualComponentName exeName) == buildTargetName
+              then Just buildInfo
+              else Nothing
+          subLibraryNameLookup :: Library -> T.Text -> Maybe BuildInfo
+          subLibraryNameLookup (Library {libName, libBuildInfo}) buildTargetName =
+            case libName of
+              (LSubLibName name) ->
+                if T.pack (unUnqualComponentName name) == buildTargetName
+                  then Just libBuildInfo
+                  else Nothing
+              LMainLibName -> Nothing
+          foreignLibsNameLookup :: ForeignLib -> T.Text -> Maybe BuildInfo
+          foreignLibsNameLookup (ForeignLib {foreignLibName, foreignLibBuildInfo}) buildTargetName =
+              if T.pack (unUnqualComponentName foreignLibName) == buildTargetName
+              then Just foreignLibBuildInfo
+              else Nothing
+          testSuiteNameLookup :: TestSuite -> T.Text -> Maybe BuildInfo
+          testSuiteNameLookup (TestSuite {testName, testBuildInfo}) buildTargetName =
+            if T.pack (unUnqualComponentName testName) == buildTargetName
+              then Just testBuildInfo
+              else Nothing
+          benchmarkNameLookup :: Benchmark -> T.Text -> Maybe BuildInfo
+          benchmarkNameLookup (Benchmark {benchmarkName, benchmarkBuildInfo}) buildTargetName =
+              if T.pack (unUnqualComponentName benchmarkName) == buildTargetName
+              then Just benchmarkBuildInfo
+              else Nothing
+
+      toHaskellFile :: T.Text -> FilePath
+      toHaskellFile moduleName = foldl1 (</>) (map T.unpack $ T.splitOn "." moduleName) ++ ".hs"
+
 -- ----------------------------------------------------------------
 -- Cabal file of Interest rules and global variable
 -- ----------------------------------------------------------------