diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 7d23cea6c9..317f48bb3a 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/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 -- ---------------------------------------------------------------- diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs index 84ec3ec345..81b316463b 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs @@ -1,5 +1,21 @@ -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 @@ -7,6 +23,7 @@ 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 diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index ddc197c4ae..2009352bbd 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/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) diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal b/plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal new file mode 100644 index 0000000000..c71e369b30 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/hie.yaml b/plugins/hls-cabal-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..95d800026a --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] \ No newline at end of file