Add Goto Definition for cabal common sections

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

@@ -17,12 +17,14 @@ 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)
@@ -31,6 +33,7 @@ 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),
@@ -43,6 +46,7 @@ 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
@@ -93,6 +97,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 +282,33 @@ 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
+
 -- ----------------------------------------------------------------
 -- Cabal file of Interest rules and global variable
 -- ----------------------------------------------------------------

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

@@ -1,12 +1,29 @@
-module Ide.Plugin.Cabal.Completion.CabalFields (findStanzaForColumn, findFieldSection, getOptionalSectionName, getAnnotation, getFieldName, onelineSectionArgs) where
+module Ide.Plugin.Cabal.Completion.CabalFields
+  ( findStanzaForColumn,
+    findFieldSection,
+    findTextWord,
+    findFieldLine,
+    getOptionalSectionName,
+    getAnnotation,
+    getFieldName,
+    onelineSectionArgs,
+    getFieldEndPosition,
+    getSectionArgEndPosition,
+    getNameEndPosition,
+    getFieldLineEndPosition,
+    getFieldLSPRange
+    ) where
 
+import qualified Data.ByteString                   as BS
+import           Data.List                         (find)
 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 qualified Distribution.Fields               as Syntax
 import qualified Distribution.Parsec.Position      as Syntax
 import           Ide.Plugin.Cabal.Completion.Types
+import qualified Language.LSP.Protocol.Types       as LSP
 
 -- ----------------------------------------------------------------
 -- Cabal-syntax utilities I don't really want to write myself
@@ -28,7 +45,7 @@ findStanzaForColumn col ctx = case NE.uncons ctx of
 --
 -- The result is said field and its starting position
 -- or Nothing if the passed list of fields is empty.
-
+--
 -- This only looks at the row of the cursor and not at the cursor's
 -- position within the row.
 --
@@ -46,6 +63,71 @@ findFieldSection cursor (x:y:ys)
   where
     cursorLine = Syntax.positionRow cursor
 
+-- | Determine the field line the cursor is currently a part of.
+--
+-- The result is said field line and its starting position
+-- or Nothing if the passed list of fields is empty.
+--
+-- This function assumes that elements in a field's @FieldLine@ list
+-- do not share the same row.
+findFieldLine :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe (Syntax.FieldLine Syntax.Position)
+findFieldLine _cursor [] = Nothing
+findFieldLine cursor fields =
+  case findFieldSection cursor fields of
+    Nothing                          -> Nothing
+    Just (Syntax.Field _ fieldLines) -> find filterLineFields fieldLines
+    Just (Syntax.Section _ _ fields) -> findFieldLine cursor fields
+  where
+    cursorLine = Syntax.positionRow cursor
+    -- In contrast to `Field` or `Section`, `FieldLine` must have the exact
+    -- same line position as the cursor.
+    filterLineFields (Syntax.FieldLine pos _) = Syntax.positionRow pos == cursorLine
+
+-- | Determine the exact word at the current cursor position.
+--
+-- The result is said word or Nothing if the passed list is empty
+-- or the cursor position is not next to, or on a word.
+-- For this function, a word is a sequence of consecutive characters
+-- that are not a space or column.
+--
+-- This function currently only considers words inside of a @FieldLine@.
+findTextWord :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe T.Text
+findTextWord _cursor [] = Nothing
+findTextWord cursor fields =
+  case findFieldLine cursor fields of
+    Nothing -> Nothing
+    Just (Syntax.FieldLine pos byteString) ->
+      let decodedText  = T.decodeUtf8 byteString
+          lineFieldCol = Syntax.positionCol pos
+          lineFieldLen = T.length decodedText
+          offset = cursorCol - lineFieldCol in
+      -- Range check if cursor is inside or or next to found line.
+      -- The latter comparison includes the length of the line as offset,
+      -- which is done to also include cursors that are at the end of a line.
+      --    e.g. "foo,bar|"
+      --                 ^
+      --               cursor
+      --
+      -- Having an offset which is outside of the line is possible because of `splitAt`.
+      if offset >= 0 && lineFieldLen >= offset
+        then
+          let (lhs, rhs)  = T.splitAt offset decodedText
+              strippedLhs = T.takeWhileEnd isAllowedChar lhs
+              strippedRhs = T.takeWhile isAllowedChar rhs
+              resultText  = T.concat [strippedLhs, strippedRhs] in
+          -- It could be possible that the cursor was in-between separators, in this
+          -- case the resulting text would be empty, which should result in `Nothing`.
+          --    e.g. " foo ,| bar"
+          --                ^
+          --              cursor
+          if not $ T.null resultText then Just resultText else Nothing
+        else
+          Nothing
+  where
+    cursorCol = Syntax.positionCol cursor
+    separators = [',', ' ']
+    isAllowedChar = (`notElem` separators)
+
 type FieldName = T.Text
 
 getAnnotation :: Syntax.Field ann -> ann
@@ -73,12 +155,42 @@ getOptionalSectionName (x:xs) = case x of
 --
 --   For example, @flag@ @(@ @pedantic@ @)@ will be joined in
 --   one line, instead of four @SectionArg@s separately.
-onelineSectionArgs :: [Syntax.SectionArg Syntax.Position] -> T.Text
+onelineSectionArgs :: [Syntax.SectionArg ann] -> T.Text
 onelineSectionArgs sectionArgs = joinedName
   where
     joinedName = T.unwords $ map getName sectionArgs
 
-    getName :: Syntax.SectionArg Syntax.Position -> T.Text
+    getName :: Syntax.SectionArg ann -> T.Text
     getName (Syntax.SecArgName _ identifier)  = T.decodeUtf8 identifier
     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
+getFieldEndPosition (Syntax.Field _ (x:xs))      = getFieldLineEndPosition $ NE.last (x NE.:| xs)
+getFieldEndPosition (Syntax.Section name [] [])  = getNameEndPosition name
+getFieldEndPosition (Syntax.Section _ (x:xs) []) = getSectionArgEndPosition $ NE.last (x NE.:| xs)
+getFieldEndPosition (Syntax.Section _ _ (x:xs))  = getFieldEndPosition $ NE.last (x NE.:| xs)
+
+-- | Returns the end position of a provided section arg
+getSectionArgEndPosition :: Syntax.SectionArg Syntax.Position -> Syntax.Position
+getSectionArgEndPosition (Syntax.SecArgName (Syntax.Position row col) byteString)  = Syntax.Position row (col + BS.length byteString)
+getSectionArgEndPosition (Syntax.SecArgStr (Syntax.Position row col) byteString)   = Syntax.Position row (col + BS.length byteString)
+getSectionArgEndPosition (Syntax.SecArgOther (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString)
+
+-- | Returns the end position of a provided name
+getNameEndPosition :: Syntax.Name Syntax.Position -> Syntax.Position
+getNameEndPosition (Syntax.Name (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString)
+
+-- | Returns the end position of a provided field line
+getFieldLineEndPosition :: Syntax.FieldLine Syntax.Position -> Syntax.Position
+getFieldLineEndPosition (Syntax.FieldLine (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString)
+
+-- | Returns an LSP compatible range for a provided field
+getFieldLSPRange :: Syntax.Field Syntax.Position -> LSP.Range
+getFieldLSPRange field = LSP.Range startLSPPos endLSPPos
+  where
+    startLSPPos = cabalPositionToLSPPosition $ getAnnotation field
+    endLSPPos   = cabalPositionToLSPPosition $ getFieldEndPosition field

plugins/hls-cabal-plugin/test/Main.hs

@@ -20,6 +20,7 @@ import qualified Data.Text                       as Text
 import           Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion)
 import qualified Ide.Plugin.Cabal.Parse          as Lib
 import qualified Language.LSP.Protocol.Lens      as L
+import qualified Language.LSP.Protocol.Types     as LSP
 import           Outline                         (outlineTests)
 import           System.FilePath
 import           Test.Hls
@@ -36,6 +37,7 @@ main = do
             , contextTests
             , outlineTests
             , codeActionTests
+            , gotoDefinitionTests
             ]
 
 -- ------------------------------------------------------------------------
@@ -227,3 +229,56 @@ codeActionTests = testGroup "Code Actions"
         InR action@CodeAction{_title} <- codeActions
         guard (_title == "Replace with " <> license)
         pure action
+
+-- ----------------------------------------------------------------------------
+-- Goto Definition Tests
+-- ----------------------------------------------------------------------------
+
+gotoDefinitionTests :: TestTree
+gotoDefinitionTests = testGroup "Goto Definition"
+    [ positiveTest "middle of identifier"            (mkP 27 16) (mkR  6 0  7 22)
+    , positiveTest "left of identifier"              (mkP 30 12) (mkR 10 0 17 40)
+    , positiveTest "right of identifier"             (mkP 33 22) (mkR 20 0 23 34)
+    , positiveTest "left of '-' in identifier"       (mkP 36 20) (mkR  6 0  7 22)
+    , positiveTest "right of '-' in identifier"      (mkP 39 19) (mkR 10 0 17 40)
+    , positiveTest "identifier in identifier list"   (mkP 42 16) (mkR 20 0 23 34)
+    , positiveTest "left of ',' right of identifier" (mkP 45 33) (mkR 10 0 17 40)
+    , positiveTest "right of ',' left of identifier" (mkP 48 34) (mkR  6 0  7 22)
+
+    , negativeTest "right of ',' left of space"      (mkP 51 23)
+    , negativeTest "right of ':' left of space"      (mkP 54 11)
+    , negativeTest "not a definition"                (mkP 57 8)
+    , negativeTest "empty space"                     (mkP 59 7)
+    ]
+    where
+        mkP :: UInt -> UInt -> Position
+        mkP x1 y1 = Position x1 y1
+
+        mkR :: UInt -> UInt -> UInt -> UInt -> Range
+        mkR x1 y1 x2 y2 = Range (mkP x1 y1) (mkP x2 y2)
+
+        getDefinition :: Show b => (Definition |? b) -> Range
+        getDefinition (InL (Definition (InL loc))) = loc^.L.range
+        getDefinition unk = error $ "Unexpected pattern '" ++ show unk ++ "' , expected '(InL (Definition (InL loc))'"
+
+        -- A positive test checks if the provided range is equal
+        -- to the expected range from the definition in the test file.
+        -- The test emulates a goto-definition request of an actual definition.
+        positiveTest :: TestName -> Position -> Range -> TestTree
+        positiveTest testName cursorPos expectedRange =
+            runCabalTestCaseSession testName "goto-definition" $ do
+                doc <- openDoc "simple-with-common.cabal" "cabal"
+                definitions <- getDefinitions doc cursorPos
+                let locationRange = getDefinition definitions
+                liftIO $ locationRange @?= expectedRange
+
+        -- A negative test checks if the request failed and
+        -- the provided result is empty, i.e. `InR $ InR Null`.
+        -- The test emulates a goto-definition request of anything but an
+        -- actual definition.
+        negativeTest :: TestName -> Position -> TestTree
+        negativeTest testName cursorPos =
+            runCabalTestCaseSession testName "goto-definition" $ do
+                doc <- openDoc "simple-with-common.cabal" "cabal"
+                empty <- getDefinitions doc cursorPos
+                liftIO $ empty @?= (InR $ InR LSP.Null)

plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal

@@ -0,0 +1,62 @@
+cabal-version:      3.0
+name:               simple-cabal
+version:            0.1.0.0
+license:            MIT
+
+-- Range : (6, 0) - (7, 22)
+common warnings-0
+    ghc-options: -Wall
+
+-- Range : (10, 0) - (17, 40)
+common warnings-1
+    ghc-options: -Wall
+                        -Wredundant-constraints
+                 -Wunused-packages
+
+     -Wno-name-shadowing
+
+     -Wno-unticked-promoted-constructors
+
+-- Range : (20, 0) - (23, 34)
+common warnings-2
+    ghc-options: -Wall
+                 -Wredundant-constraints
+                 -Wunused-packages
+
+library
+
+    import: warnings-0
+--              ^ Position: (27, 16), middle of identifier
+
+    import: warnings-1
+--          ^ Position: (30, 12), left of identifier
+
+    import: warnings-2
+--                   ^ Position: (33, 22), right of identifier
+
+    import: warnings-0
+--                  ^ Position: (36, 20), left of '-' in identifier
+
+    import: warnings-1
+--                  ^ Position: (39, 19), right of "-" in identifier
+
+    import: warnings-2,warnings-1,warnings-0
+--              ^ Position: (42, 16), identifier in identifier list
+
+    import: warnings-2,warnings-1,warnings-0
+--                               ^ Position: (45, 33), left of ',' right of identifier
+
+    import: warnings-2,warnings-1,warnings-0
+--                               ^ Position: (48, 34), right of ',' left of identifier
+
+    import: warnings-2, warnings-1,warnings-0
+--                    ^ Position: (51, 37), right of ',' left of space
+
+    import: warnings-0
+--        ^ Position: (54, 11), right of ':' left of space
+
+    import: warnings-0
+--     ^ Position: (57, 8), not a definition
+
+          -- EOL
+--     ^ Position: (59, 7), empty space

plugins/hls-cabal-plugin/test/testdata/hie.yaml

@@ -0,0 +1,3 @@
+cradle:
+  direct:
+    arguments: []