Skip to content

Commit adcd5b9

Browse files
ChristophHochrainerVenInf
ChristophHochrainer
authored and
VenInf
committed
Add Goto Definition for cabal common sections (haskell#4375)
* Add goto-definitions for cabal common sections * Add default direct cradle hie.yaml file to testdata * incorporate changes requested in haskell#4375 * add tests for cabal goto-definition
1 parent 1236c06 commit adcd5b9

File tree

5 files changed

+224
-40
lines changed

5 files changed

+224
-40
lines changed

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

Lines changed: 33 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import qualified Data.Text as T
2525
import qualified Data.Text.Encoding as Encoding
2626
import Data.Typeable
2727
import Development.IDE as D
28+
import Development.IDE.Core.PluginUtils
2829
import Development.IDE.Core.Shake (restartShakeSession)
2930
import qualified Development.IDE.Core.Shake as Shake
3031
import Development.IDE.Graph (Key,
@@ -60,6 +61,7 @@ import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest
6061
import Ide.Plugin.Cabal.Orphans ()
6162
import Ide.Plugin.Cabal.Outline
6263
import qualified Ide.Plugin.Cabal.Parse as Parse
64+
import Ide.Plugin.Error
6365
import Ide.Types
6466
import qualified Language.LSP.Protocol.Lens as JL
6567
import qualified Language.LSP.Protocol.Message as LSP
@@ -309,42 +311,37 @@ fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentif
309311
-- TODO: Resolve more cases for go-to definition.
310312
gotoDefinition :: PluginMethodHandler IdeState LSP.Method_TextDocumentDefinition
311313
gotoDefinition ideState _ msgParam = do
312-
case uriToFilePath' uri of
313-
Nothing ->
314-
pure $ InR $ InR Null
315-
Just filePath -> do
316-
mCabalFields <- liftIO $ runAction "cabal-plugin.commonSections" ideState $ use ParseCabalFields $ toNormalizedFilePath filePath
317-
318-
let mCursorText = CabalFields.findTextWord cursor =<< mCabalFields
319-
case mCursorText of
320-
Nothing ->
321-
pure $ InR $ InR Null
322-
Just cursorText -> do
323-
mCommonSections <- liftIO $ runAction "cabal-plugin.commonSections" ideState $ use ParseCabalCommonSections $ toNormalizedFilePath filePath
324-
let mCommonSection = find (isSectionArgName cursorText) =<< mCommonSections
325-
case mCommonSection of
326-
Just commonSection -> do
327-
pure $ InL $ Definition $ InL $ Location uri $ CabalFields.getFieldLSPRange commonSection
328-
Nothing -> do
329-
let mModuleNames = CabalFields.getModulesNames <$> mCabalFields
330-
mModuleName = find (isModuleName cursorText) =<< mModuleNames
331-
case mModuleName of
332-
Nothing -> pure $ InR $ InR Null
333-
Just (mBuildTargetNames, moduleName) -> do
334-
mGPD <- liftIO $ runAction "cabal.GPD" ideState $ useWithStale ParseCabalFile $ toNormalizedFilePath filePath
335-
case mGPD of
336-
Nothing -> pure $ InR $ InR Null
337-
Just (gpd, _) -> do
338-
let buildInfos = foldMap (lookupBuildTargetPackageDescription
339-
(flattenPackageDescription gpd))
340-
mBuildTargetNames
341-
sourceDirs = map getSymbolicPath $ concatMap hsSourceDirs buildInfos
342-
potentialPaths = map (\dir -> takeDirectory filePath </> dir </> toHaskellFile moduleName) sourceDirs
343-
allPaths <- liftIO $ filterM doesFileExist potentialPaths
344-
let locations = map (\pth -> Location (filePathToUri pth) (mkRange 0 0 0 0)) allPaths
345-
case safeHead locations of -- We assume there could be only one source location
346-
Nothing -> pure $ InR $ InR Null
347-
Just location -> pure $ InL $ Definition $ InL location
314+
nfp <- getNormalizedFilePathE uri
315+
cabalFields <- runActionE "cabal-plugin.commonSections" ideState $ useE ParseCabalFields nfp
316+
case CabalFields.findTextWord cursor cabalFields of
317+
Nothing ->
318+
pure $ InR $ InR Null
319+
Just cursorText -> do
320+
commonSections <- runActionE "cabal-plugin.commonSections" ideState $ useE ParseCabalCommonSections nfp
321+
case find (isSectionArgName cursorText) commonSections of
322+
Just commonSection -> do
323+
pure $ InL $ Definition $ InL $ Location uri $ CabalFields.getFieldLSPRange commonSection
324+
325+
Nothing -> do
326+
let mModuleNames = CabalFields.getModulesNames <$> mCabalFields
327+
mModuleName = find (isModuleName cursorText) =<< mModuleNames
328+
case mModuleName of
329+
Nothing -> pure $ InR $ InR Null
330+
Just (mBuildTargetNames, moduleName) -> do
331+
mGPD <- liftIO $ runAction "cabal.GPD" ideState $ useWithStale ParseCabalFile nfp
332+
case mGPD of
333+
Nothing -> pure $ InR $ InR Null
334+
Just (gpd, _) -> do
335+
let buildInfos = foldMap (lookupBuildTargetPackageDescription
336+
(flattenPackageDescription gpd))
337+
mBuildTargetNames
338+
sourceDirs = map getSymbolicPath $ concatMap hsSourceDirs buildInfos
339+
potentialPaths = map (\dir -> takeDirectory filePath </> dir </> toHaskellFile moduleName) sourceDirs
340+
allPaths <- liftIO $ filterM doesFileExist potentialPaths
341+
let locations = map (\pth -> Location (filePathToUri pth) (mkRange 0 0 0 0)) allPaths
342+
case safeHead locations of -- We assume there could be only one source location
343+
Nothing -> pure $ InR $ InR Null
344+
Just location -> pure $ InL $ Definition $ InL location
348345
where
349346
cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)
350347
uri = msgParam ^. JL.textDocument . JL.uri

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

Lines changed: 71 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -16,9 +16,7 @@ import qualified Data.Text.Encoding as T
1616
import Data.Tuple (swap)
1717
import qualified Distribution.Fields as Syntax
1818
import qualified Distribution.Parsec.Position as Syntax
19-
import Ide.Plugin.Cabal.Completion.Types (FieldContext (None),
20-
StanzaContext,
21-
cabalPositionToLSPPosition)
19+
import Ide.Plugin.Cabal.Completion.Types
2220
import qualified Language.LSP.Protocol.Types as LSP
2321

2422
-- ----------------------------------------------------------------
@@ -41,7 +39,7 @@ findStanzaForColumn col ctx = case NE.uncons ctx of
4139
--
4240
-- The result is said field and its starting position
4341
-- or Nothing if the passed list of fields is empty.
44-
42+
--
4543
-- This only looks at the row of the cursor and not at the cursor's
4644
-- position within the row.
4745
--
@@ -59,6 +57,71 @@ findFieldSection cursor (x:y:ys)
5957
where
6058
cursorLine = Syntax.positionRow cursor
6159

60+
-- | Determine the field line the cursor is currently a part of.
61+
--
62+
-- The result is said field line and its starting position
63+
-- or Nothing if the passed list of fields is empty.
64+
--
65+
-- This function assumes that elements in a field's @FieldLine@ list
66+
-- do not share the same row.
67+
findFieldLine :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe (Syntax.FieldLine Syntax.Position)
68+
findFieldLine _cursor [] = Nothing
69+
findFieldLine cursor fields =
70+
case findFieldSection cursor fields of
71+
Nothing -> Nothing
72+
Just (Syntax.Field _ fieldLines) -> find filterLineFields fieldLines
73+
Just (Syntax.Section _ _ fields) -> findFieldLine cursor fields
74+
where
75+
cursorLine = Syntax.positionRow cursor
76+
-- In contrast to `Field` or `Section`, `FieldLine` must have the exact
77+
-- same line position as the cursor.
78+
filterLineFields (Syntax.FieldLine pos _) = Syntax.positionRow pos == cursorLine
79+
80+
-- | Determine the exact word at the current cursor position.
81+
--
82+
-- The result is said word or Nothing if the passed list is empty
83+
-- or the cursor position is not next to, or on a word.
84+
-- For this function, a word is a sequence of consecutive characters
85+
-- that are not a space or column.
86+
--
87+
-- This function currently only considers words inside of a @FieldLine@.
88+
findTextWord :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe T.Text
89+
findTextWord _cursor [] = Nothing
90+
findTextWord cursor fields =
91+
case findFieldLine cursor fields of
92+
Nothing -> Nothing
93+
Just (Syntax.FieldLine pos byteString) ->
94+
let decodedText = T.decodeUtf8 byteString
95+
lineFieldCol = Syntax.positionCol pos
96+
lineFieldLen = T.length decodedText
97+
offset = cursorCol - lineFieldCol in
98+
-- Range check if cursor is inside or or next to found line.
99+
-- The latter comparison includes the length of the line as offset,
100+
-- which is done to also include cursors that are at the end of a line.
101+
-- e.g. "foo,bar|"
102+
-- ^
103+
-- cursor
104+
--
105+
-- Having an offset which is outside of the line is possible because of `splitAt`.
106+
if offset >= 0 && lineFieldLen >= offset
107+
then
108+
let (lhs, rhs) = T.splitAt offset decodedText
109+
strippedLhs = T.takeWhileEnd isAllowedChar lhs
110+
strippedRhs = T.takeWhile isAllowedChar rhs
111+
resultText = T.concat [strippedLhs, strippedRhs] in
112+
-- It could be possible that the cursor was in-between separators, in this
113+
-- case the resulting text would be empty, which should result in `Nothing`.
114+
-- e.g. " foo ,| bar"
115+
-- ^
116+
-- cursor
117+
if not $ T.null resultText then Just resultText else Nothing
118+
else
119+
Nothing
120+
where
121+
cursorCol = Syntax.positionCol cursor
122+
separators = [',', ' ']
123+
isAllowedChar = (`notElem` separators)
124+
62125
type FieldName = T.Text
63126

64127
-- | Determine the field line the cursor is currently a part of.
@@ -264,6 +327,10 @@ onelineSectionArgs sectionArgs = joinedName
264327
getName (Syntax.SecArgStr _ quotedString) = T.decodeUtf8 quotedString
265328
getName (Syntax.SecArgOther _ string) = T.decodeUtf8 string
266329

330+
<<<<<<< HEAD
331+
=======
332+
333+
>>>>>>> 6f6f75bc (Add Goto Definition for cabal common sections (#4375))
267334
-- | Returns the end position of a provided field
268335
getFieldEndPosition :: Syntax.Field Syntax.Position -> Syntax.Position
269336
getFieldEndPosition (Syntax.Field name []) = getNameEndPosition name

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

Lines changed: 55 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import qualified Data.Text as Text
2020
import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion)
2121
import qualified Ide.Plugin.Cabal.Parse as Lib
2222
import qualified Language.LSP.Protocol.Lens as L
23+
import qualified Language.LSP.Protocol.Types as LSP
2324
import Outline (outlineTests)
2425
import System.FilePath
2526
import Test.Hls
@@ -36,6 +37,7 @@ main = do
3637
, contextTests
3738
, outlineTests
3839
, codeActionTests
40+
, gotoDefinitionTests
3941
]
4042

4143
-- ------------------------------------------------------------------------
@@ -227,3 +229,56 @@ codeActionTests = testGroup "Code Actions"
227229
InR action@CodeAction{_title} <- codeActions
228230
guard (_title == "Replace with " <> license)
229231
pure action
232+
233+
-- ----------------------------------------------------------------------------
234+
-- Goto Definition Tests
235+
-- ----------------------------------------------------------------------------
236+
237+
gotoDefinitionTests :: TestTree
238+
gotoDefinitionTests = testGroup "Goto Definition"
239+
[ positiveTest "middle of identifier" (mkP 27 16) (mkR 6 0 7 22)
240+
, positiveTest "left of identifier" (mkP 30 12) (mkR 10 0 17 40)
241+
, positiveTest "right of identifier" (mkP 33 22) (mkR 20 0 23 34)
242+
, positiveTest "left of '-' in identifier" (mkP 36 20) (mkR 6 0 7 22)
243+
, positiveTest "right of '-' in identifier" (mkP 39 19) (mkR 10 0 17 40)
244+
, positiveTest "identifier in identifier list" (mkP 42 16) (mkR 20 0 23 34)
245+
, positiveTest "left of ',' right of identifier" (mkP 45 33) (mkR 10 0 17 40)
246+
, positiveTest "right of ',' left of identifier" (mkP 48 34) (mkR 6 0 7 22)
247+
248+
, negativeTest "right of ',' left of space" (mkP 51 23)
249+
, negativeTest "right of ':' left of space" (mkP 54 11)
250+
, negativeTest "not a definition" (mkP 57 8)
251+
, negativeTest "empty space" (mkP 59 7)
252+
]
253+
where
254+
mkP :: UInt -> UInt -> Position
255+
mkP x1 y1 = Position x1 y1
256+
257+
mkR :: UInt -> UInt -> UInt -> UInt -> Range
258+
mkR x1 y1 x2 y2 = Range (mkP x1 y1) (mkP x2 y2)
259+
260+
getDefinition :: Show b => (Definition |? b) -> Range
261+
getDefinition (InL (Definition (InL loc))) = loc^.L.range
262+
getDefinition unk = error $ "Unexpected pattern '" ++ show unk ++ "' , expected '(InL (Definition (InL loc))'"
263+
264+
-- A positive test checks if the provided range is equal
265+
-- to the expected range from the definition in the test file.
266+
-- The test emulates a goto-definition request of an actual definition.
267+
positiveTest :: TestName -> Position -> Range -> TestTree
268+
positiveTest testName cursorPos expectedRange =
269+
runCabalTestCaseSession testName "goto-definition" $ do
270+
doc <- openDoc "simple-with-common.cabal" "cabal"
271+
definitions <- getDefinitions doc cursorPos
272+
let locationRange = getDefinition definitions
273+
liftIO $ locationRange @?= expectedRange
274+
275+
-- A negative test checks if the request failed and
276+
-- the provided result is empty, i.e. `InR $ InR Null`.
277+
-- The test emulates a goto-definition request of anything but an
278+
-- actual definition.
279+
negativeTest :: TestName -> Position -> TestTree
280+
negativeTest testName cursorPos =
281+
runCabalTestCaseSession testName "goto-definition" $ do
282+
doc <- openDoc "simple-with-common.cabal" "cabal"
283+
empty <- getDefinitions doc cursorPos
284+
liftIO $ empty @?= (InR $ InR LSP.Null)

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

Lines changed: 62 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,62 @@
1+
cabal-version: 3.0
2+
name: simple-cabal
3+
version: 0.1.0.0
4+
license: MIT
5+
6+
-- Range : (6, 0) - (7, 22)
7+
common warnings-0
8+
ghc-options: -Wall
9+
10+
-- Range : (10, 0) - (17, 40)
11+
common warnings-1
12+
ghc-options: -Wall
13+
-Wredundant-constraints
14+
-Wunused-packages
15+
16+
-Wno-name-shadowing
17+
18+
-Wno-unticked-promoted-constructors
19+
20+
-- Range : (20, 0) - (23, 34)
21+
common warnings-2
22+
ghc-options: -Wall
23+
-Wredundant-constraints
24+
-Wunused-packages
25+
26+
library
27+
28+
import: warnings-0
29+
-- ^ Position: (27, 16), middle of identifier
30+
31+
import: warnings-1
32+
-- ^ Position: (30, 12), left of identifier
33+
34+
import: warnings-2
35+
-- ^ Position: (33, 22), right of identifier
36+
37+
import: warnings-0
38+
-- ^ Position: (36, 20), left of '-' in identifier
39+
40+
import: warnings-1
41+
-- ^ Position: (39, 19), right of "-" in identifier
42+
43+
import: warnings-2,warnings-1,warnings-0
44+
-- ^ Position: (42, 16), identifier in identifier list
45+
46+
import: warnings-2,warnings-1,warnings-0
47+
-- ^ Position: (45, 33), left of ',' right of identifier
48+
49+
import: warnings-2,warnings-1,warnings-0
50+
-- ^ Position: (48, 34), right of ',' left of identifier
51+
52+
import: warnings-2, warnings-1,warnings-0
53+
-- ^ Position: (51, 37), right of ',' left of space
54+
55+
import: warnings-0
56+
-- ^ Position: (54, 11), right of ':' left of space
57+
58+
import: warnings-0
59+
-- ^ Position: (57, 8), not a definition
60+
61+
-- EOL
62+
-- ^ Position: (59, 7), empty space

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
cradle:
2+
direct:
3+
arguments: []

0 commit comments

Comments
 (0)