Skip to content
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.

Commit ad60fbb

Browse files
fendorfendor
committedMay 27, 2024·
Refactor context search to use readFields
Instead of custom parsing of the cabal file, we use `readFields` to parse the cabal file, as accurately as cabal supports. This allows us to additionally benefit from future improvements to the cabal lexer. Then, we traverse the fields and find the most likely location of the cursor in the cabal file. Based on these results, we can then establish the context accurately.
1 parent 838a51f commit ad60fbb

File tree

13 files changed

+665
-249
lines changed

13 files changed

+665
-249
lines changed
 

‎ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (
1111
, getCompletions
1212
, fromIdentInfo
1313
, getCompletionPrefix
14+
, getCompletionPrefixFromRope
1415
) where
1516

1617
import Control.Applicative
@@ -897,7 +898,10 @@ mergeListsBy cmp all_lists = merge_lists all_lists
897898

898899
-- |From the given cursor position, gets the prefix module or record for autocompletion
899900
getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo
900-
getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =
901+
getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext
902+
903+
getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo
904+
getCompletionPrefixFromRope pos@(Position l c) ropetext =
901905
fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad
902906
let headMaybe = listToMaybe
903907
lastMaybe = headMaybe . reverse

‎haskell-language-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -241,6 +241,7 @@ library hls-cabal-plugin
241241
Ide.Plugin.Cabal.Completion.Data
242242
Ide.Plugin.Cabal.Completion.Types
243243
Ide.Plugin.Cabal.LicenseSuggest
244+
Ide.Plugin.Cabal.Orphans
244245
Ide.Plugin.Cabal.Parse
245246

246247

‎hls-test-utils/hls-test-utils.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@ library
4949
, lsp
5050
, lsp-test ^>=0.17
5151
, lsp-types ^>=2.2
52+
, neat-interpolation
5253
, safe-exceptions
5354
, tasty
5455
, tasty-expected-failure
@@ -57,6 +58,7 @@ library
5758
, tasty-rerun
5859
, temporary
5960
, text
61+
, text-rope
6062

6163
ghc-options:
6264
-Wall

‎hls-test-utils/src/Test/Hls.hs

Lines changed: 54 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,8 @@ module Test.Hls
3434
runSessionWithServer,
3535
runSessionWithServerInTmpDir,
3636
runSessionWithTestConfig,
37+
-- * Running parameterised tests for a set of test configurations
38+
parameterisedCursorTest,
3739
-- * Helpful re-exports
3840
PluginDescriptor,
3941
IdeState,
@@ -87,7 +89,6 @@ import Development.IDE (IdeState,
8789
LoggingColumn (ThreadIdColumn),
8890
defaultLayoutOptions,
8991
layoutPretty, renderStrict)
90-
import qualified Development.IDE.LSP.Notifications as Notifications
9192
import Development.IDE.Main hiding (Log)
9293
import qualified Development.IDE.Main as IDEMain
9394
import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
@@ -105,7 +106,6 @@ import Ide.Logger (Pretty (pretty),
105106
makeDefaultStderrRecorder,
106107
(<+>))
107108
import qualified Ide.Logger as Logger
108-
import Ide.Plugin.Properties ((&))
109109
import Ide.PluginUtils (idePluginsToPluginDesc,
110110
pluginDescToIdePlugins)
111111
import Ide.Types
@@ -136,6 +136,7 @@ import Test.Tasty.ExpectedFailure
136136
import Test.Tasty.Golden
137137
import Test.Tasty.HUnit
138138
import Test.Tasty.Ingredients.Rerun
139+
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo)
139140

140141
data Log
141142
= LogIDEMain IDEMain.Log
@@ -328,6 +329,56 @@ goldenWithDocInTmpDir languageKind config plugin title tree path desc ext act =
328329
act doc
329330
documentContents doc
330331

332+
-- | A parameterised test is similar to a normal test case but allows to run
333+
-- the same test case multiple times with different inputs.
334+
-- A 'parameterisedCursorTest' allows to define a test case based on an input file
335+
-- that specifies one or many cursor positions via the identification value '^'.
336+
--
337+
-- For example:
338+
--
339+
-- @
340+
-- parameterisedCursorTest "Cursor Test" [trimming|
341+
-- foo = 2
342+
-- ^
343+
-- bar = 3
344+
-- baz = foo + bar
345+
-- ^
346+
-- |]
347+
-- ["foo", "baz"]
348+
-- (\input cursor -> findFunctionNameUnderCursor input cursor)
349+
-- @
350+
--
351+
-- Assuming a fitting implementation for 'findFunctionNameUnderCursor'.
352+
--
353+
-- This test definition will run the test case 'findFunctionNameUnderCursor' for
354+
-- each cursor position, each in its own isolated 'testCase'.
355+
-- Cursor positions are identified via the character '^', which points to the
356+
-- above line as the actual cursor position.
357+
-- Lines containing '^' characters, are removed from the final text, that is
358+
-- passed to the testing function.
359+
--
360+
-- TODO: Many Haskell and Cabal source may contain '^' characters for good reasons.
361+
-- We likely need a way to change the character for certain test cases in the future.
362+
--
363+
-- The quasi quoter 'trimming' is very helpful to define such tests, as it additionally
364+
-- allows to interpolate haskell values and functions. We reexport this quasi quoter
365+
-- for easier usage.
366+
parameterisedCursorTest :: (Show a, Eq a) => String -> T.Text -> [a] -> (T.Text -> PosPrefixInfo -> IO a) -> TestTree
367+
parameterisedCursorTest title content expectations act
368+
| lenPrefs /= lenExpected = error $ "parameterisedCursorTest: Expected " <> show lenExpected <> " cursors but found: " <> show lenPrefs
369+
| otherwise = testGroup title $
370+
map singleTest testCaseSpec
371+
where
372+
lenPrefs = length prefInfos
373+
lenExpected = length expectations
374+
(cleanText, prefInfos) = extractCursorPositions content
375+
376+
testCaseSpec = zip [1 ::Int ..] (zip expectations prefInfos)
377+
378+
singleTest (n, (expected, info)) = testCase (title <> " " <> show n) $ do
379+
actual <- act cleanText info
380+
assertEqual (mkParameterisedLabel info) expected actual
381+
331382
-- ------------------------------------------------------------
332383
-- Helper function for initialising plugins under test
333384
-- ------------------------------------------------------------
@@ -429,6 +480,7 @@ initializeTestRecorder envVars = do
429480
-- ------------------------------------------------------------
430481
-- Run an HLS server testing a specific plugin
431482
-- ------------------------------------------------------------
483+
432484
runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a
433485
runSessionWithServerInTmpDir config plugin tree act =
434486
runSessionWithTestConfig def

‎hls-test-utils/src/Test/Hls/Util.hs

Lines changed: 145 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -42,37 +42,48 @@ module Test.Hls.Util
4242
, withCurrentDirectoryInTmp
4343
, withCurrentDirectoryInTmp'
4444
, withCanonicalTempDir
45+
-- * Extract positions from input file.
46+
, extractCursorPositions
47+
, mkParameterisedLabel
48+
, trimming
4549
)
4650
where
4751

48-
import Control.Applicative.Combinators (skipManyTill, (<|>))
49-
import Control.Exception (catch, throwIO)
50-
import Control.Lens (_Just, (&), (.~), (?~), (^.))
52+
import Control.Applicative.Combinators (skipManyTill, (<|>))
53+
import Control.Exception (catch, throwIO)
54+
import Control.Lens (_Just, (&), (.~),
55+
(?~), (^.))
5156
import Control.Monad
5257
import Control.Monad.IO.Class
53-
import qualified Data.Aeson as A
54-
import Data.Bool (bool)
58+
import qualified Data.Aeson as A
59+
import Data.Bool (bool)
5560
import Data.Default
56-
import Data.List.Extra (find)
61+
import Data.List.Extra (find)
5762
import Data.Proxy
58-
import qualified Data.Set as Set
59-
import qualified Data.Text as T
60-
import Development.IDE (GhcVersion (..), ghcVersion)
61-
import qualified Language.LSP.Protocol.Lens as L
63+
import qualified Data.Text as T
64+
import Development.IDE (GhcVersion (..),
65+
ghcVersion)
66+
import qualified Language.LSP.Protocol.Lens as L
6267
import Language.LSP.Protocol.Message
6368
import Language.LSP.Protocol.Types
64-
import qualified Language.LSP.Test as Test
69+
import qualified Language.LSP.Test as Test
6570
import System.Directory
6671
import System.FilePath
67-
import System.Info.Extra (isMac, isWindows)
72+
import System.Info.Extra (isMac, isWindows)
6873
import qualified System.IO.Extra
6974
import System.IO.Temp
70-
import System.Time.Extra (Seconds, sleep)
71-
import Test.Tasty (TestTree)
72-
import Test.Tasty.ExpectedFailure (expectFailBecause,
73-
ignoreTestBecause)
74-
import Test.Tasty.HUnit (Assertion, assertFailure,
75-
(@?=))
75+
import System.Time.Extra (Seconds, sleep)
76+
import Test.Tasty (TestTree)
77+
import Test.Tasty.ExpectedFailure (expectFailBecause,
78+
ignoreTestBecause)
79+
import Test.Tasty.HUnit (assertFailure)
80+
81+
import qualified Data.List as List
82+
import qualified Data.Text.Internal.Search as T
83+
import qualified Data.Text.Utf16.Rope.Mixed as Rope
84+
import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)
85+
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))
86+
import NeatInterpolation (trimming)
7687

7788
noLiteralCaps :: ClientCapabilities
7889
noLiteralCaps = def & L.textDocument ?~ textDocumentCaps
@@ -327,3 +338,119 @@ withCanonicalTempDir :: (FilePath -> IO a) -> IO a
327338
withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do
328339
dir' <- canonicalizePath dir
329340
f dir'
341+
342+
-- ----------------------------------------------------------------------------
343+
-- Extract Position data from the source file itself.
344+
-- ----------------------------------------------------------------------------
345+
346+
-- | Pretty labelling for tests that use the parameterised test helpers.
347+
mkParameterisedLabel :: PosPrefixInfo -> String
348+
mkParameterisedLabel posPrefixInfo = unlines
349+
[ "Full Line: \"" <> T.unpack (fullLine posPrefixInfo) <> "\""
350+
, "Cursor Column: \"" <> replicate (fromIntegral $ cursorPos posPrefixInfo ^. L.character) ' ' ++ "^" <> "\""
351+
, "Prefix Text: \"" <> T.unpack (prefixText posPrefixInfo) <> "\""
352+
]
353+
354+
-- | Given a in-memory representation of a file, where a user can specify the
355+
-- current cursor position using a '^' in the next line.
356+
--
357+
-- This function allows to generate multiple tests for a single input file, without
358+
-- the hassle of calculating by hand where there cursor is supposed to be.
359+
--
360+
-- Example (line number has been added for readability):
361+
--
362+
-- @
363+
-- 0: foo = 2
364+
-- 1: ^
365+
-- 2: bar =
366+
-- 3: ^
367+
-- @
368+
--
369+
-- This example input file contains two cursor positions (y, x), at
370+
--
371+
-- * (1, 1), and
372+
-- * (3, 5).
373+
--
374+
-- 'extractCursorPositions' will search for '^' characters, and determine there are
375+
-- two cursor positions in the text.
376+
-- First, it will normalise the text to:
377+
--
378+
-- @
379+
-- 0: foo = 2
380+
-- 1: bar =
381+
-- @
382+
--
383+
-- stripping away the '^' characters. Then, the actual cursor positions are:
384+
--
385+
-- * (0, 1) and
386+
-- * (2, 5).
387+
--
388+
extractCursorPositions :: T.Text -> (T.Text, [PosPrefixInfo])
389+
extractCursorPositions t =
390+
let
391+
textLines = T.lines t
392+
foldState = List.foldl' go emptyFoldState textLines
393+
finalText = foldStateToText foldState
394+
reconstructCompletionPrefix pos = getCompletionPrefixFromRope pos (Rope.fromText finalText)
395+
cursorPositions = reverse . fmap reconstructCompletionPrefix $ foldStatePositions foldState
396+
in
397+
(finalText, cursorPositions)
398+
399+
where
400+
go foldState l = case T.indices "^" l of
401+
[] -> addTextLine foldState l
402+
xs -> List.foldl' addTextCursor foldState xs
403+
404+
-- | 'FoldState' is an implementation detail used to parse some file contents,
405+
-- extracting the cursor positions identified by '^' and producing a cleaned
406+
-- representation of the file contents.
407+
data FoldState = FoldState
408+
{ foldStateRows :: !Int
409+
-- ^ The row index of the cleaned file contents.
410+
--
411+
-- For example, the file contents
412+
--
413+
-- @
414+
-- 0: foo
415+
-- 1: ^
416+
-- 2: bar
417+
-- @
418+
-- will report that 'bar' is actually occurring in line '1', as '^' is
419+
-- a cursor position.
420+
-- Lines containing cursor positions are removed.
421+
, foldStatePositions :: ![Position]
422+
-- ^ List of cursors positions found in the file contents.
423+
--
424+
-- List is stored in reverse for efficient 'cons'ing
425+
, foldStateFinalText :: ![T.Text]
426+
-- ^ Final file contents with all lines containing cursor positions removed.
427+
--
428+
-- List is stored in reverse for efficient 'cons'ing
429+
}
430+
431+
emptyFoldState :: FoldState
432+
emptyFoldState = FoldState
433+
{ foldStateRows = 0
434+
, foldStatePositions = []
435+
, foldStateFinalText = []
436+
}
437+
438+
-- | Produce the final file contents, without any lines containing cursor positions.
439+
foldStateToText :: FoldState -> T.Text
440+
foldStateToText state = T.unlines $ reverse $ foldStateFinalText state
441+
442+
-- | We found a '^' at some location! Add it to the list of known cursor positions.
443+
--
444+
-- If the row index is '0', we throw an error, as there can't be a cursor position above the first line.
445+
addTextCursor :: FoldState -> Int -> FoldState
446+
addTextCursor state col
447+
| foldStateRows state <= 0 = error $ "addTextCursor: Invalid '^' found at: " <> show (col, foldStateRows state)
448+
| otherwise = state
449+
{ foldStatePositions = Position (fromIntegral (foldStateRows state) - 1) (fromIntegral col) : foldStatePositions state
450+
}
451+
452+
addTextLine :: FoldState -> T.Text -> FoldState
453+
addTextLine state l = state
454+
{ foldStateFinalText = l : foldStateFinalText state
455+
, foldStateRows = foldStateRows state + 1
456+
}

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

Lines changed: 74 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ import Control.DeepSeq
1111
import Control.Lens ((^.))
1212
import Control.Monad.Extra
1313
import Control.Monad.IO.Class
14-
import Control.Monad.Trans.Class (lift)
14+
import Control.Monad.Trans.Class
1515
import Control.Monad.Trans.Maybe (runMaybeT)
1616
import qualified Data.ByteString as BS
1717
import Data.Hashable
@@ -27,12 +27,17 @@ import Development.IDE.Graph (Key, alwaysRerun)
2727
import qualified Development.IDE.Plugin.Completions.Logic as Ghcide
2828
import qualified Development.IDE.Plugin.Completions.Types as Ghcide
2929
import Development.IDE.Types.Shake (toKey)
30+
import qualified Distribution.Fields as Syntax
31+
import qualified Distribution.Parsec.Position as Syntax
3032
import GHC.Generics
3133
import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
3234
import qualified Ide.Plugin.Cabal.Completion.Completions as Completions
35+
import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..),
36+
ParseCabalFile (..))
3337
import qualified Ide.Plugin.Cabal.Completion.Types as Types
3438
import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics
3539
import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest
40+
import Ide.Plugin.Cabal.Orphans ()
3641
import qualified Ide.Plugin.Cabal.Parse as Parse
3742
import Ide.Types
3843
import qualified Language.LSP.Protocol.Lens as JL
@@ -70,7 +75,7 @@ instance Pretty Log where
7075
"Set files of interest to:" <+> viaShow files
7176
LogCompletionContext context position ->
7277
"Determined completion context:"
73-
<+> viaShow context
78+
<+> pretty context
7479
<+> "for cursor position:"
7580
<+> pretty position
7681
LogCompletions logs -> pretty logs
@@ -145,30 +150,55 @@ cabalRules recorder plId = do
145150
-- Make sure we initialise the cabal files-of-interest.
146151
ofInterestRules recorder
147152
-- Rule to produce diagnostics for cabal files.
148-
define (cmapWithPrio LogShake recorder) $ \Types.GetCabalDiagnostics file -> do
153+
define (cmapWithPrio LogShake recorder) $ \ParseCabalFields file -> do
149154
config <- getPluginConfigAction plId
150155
if not (plcGlobalOn config && plcDiagnosticsOn config)
151-
then pure ([], Nothing)
152-
else do
153-
-- whenever this key is marked as dirty (e.g., when a user writes stuff to it),
154-
-- we rerun this rule because this rule *depends* on GetModificationTime.
155-
(t, mCabalSource) <- use_ GetFileContents file
156-
log' Debug $ LogModificationTime file t
157-
contents <- case mCabalSource of
158-
Just sources ->
159-
pure $ Encoding.encodeUtf8 sources
160-
Nothing -> do
161-
liftIO $ BS.readFile $ fromNormalizedFilePath file
162-
163-
(pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents
164-
let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings
165-
case pm of
166-
Left (_cabalVersion, pErrorNE) -> do
167-
let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE
168-
allDiags = errorDiags <> warningDiags
169-
pure (allDiags, Nothing)
170-
Right gpd -> do
171-
pure (warningDiags, Just gpd)
156+
then pure ([], Nothing)
157+
else do
158+
-- whenever this key is marked as dirty (e.g., when a user writes stuff to it),
159+
-- we rerun this rule because this rule *depends* on GetModificationTime.
160+
(t, mCabalSource) <- use_ GetFileContents file
161+
log' Debug $ LogModificationTime file t
162+
contents <- case mCabalSource of
163+
Just sources ->
164+
pure $ Encoding.encodeUtf8 sources
165+
Nothing -> do
166+
liftIO $ BS.readFile $ fromNormalizedFilePath file
167+
168+
case Parse.readCabalFields file contents of
169+
Left _ ->
170+
pure ([], Nothing)
171+
Right fields ->
172+
pure ([], Just fields)
173+
174+
define (cmapWithPrio LogShake recorder) $ \ParseCabalFile file -> do
175+
config <- getPluginConfigAction plId
176+
if not (plcGlobalOn config && plcDiagnosticsOn config)
177+
then pure ([], Nothing)
178+
else do
179+
-- whenever this key is marked as dirty (e.g., when a user writes stuff to it),
180+
-- we rerun this rule because this rule *depends* on GetModificationTime.
181+
(t, mCabalSource) <- use_ GetFileContents file
182+
log' Debug $ LogModificationTime file t
183+
contents <- case mCabalSource of
184+
Just sources ->
185+
pure $ Encoding.encodeUtf8 sources
186+
Nothing -> do
187+
liftIO $ BS.readFile $ fromNormalizedFilePath file
188+
189+
-- Instead of fully reparsing the sources to get a 'GenericPackageDescription',
190+
-- we would much rather re-use the already parsed results of 'ParseCabalFields'.
191+
-- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription''
192+
-- which allows us to resume the parsing pipeline with '[Field Position]'.
193+
(pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents
194+
let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings
195+
case pm of
196+
Left (_cabalVersion, pErrorNE) -> do
197+
let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE
198+
allDiags = errorDiags <> warningDiags
199+
pure (allDiags, Nothing)
200+
Right gpd -> do
201+
pure (warningDiags, Just gpd)
172202

173203
action $ do
174204
-- Run the cabal kick. This code always runs when 'shakeRestart' is run.
@@ -188,7 +218,7 @@ function invocation.
188218
kick :: Action ()
189219
kick = do
190220
files <- HashMap.keys <$> getCabalFilesOfInterestUntracked
191-
void $ uses Types.GetCabalDiagnostics files
221+
void $ uses Types.ParseCabalFile files
192222

193223
-- ----------------------------------------------------------------
194224
-- Code Actions
@@ -281,24 +311,31 @@ completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.M
281311
completion recorder ide _ complParams = do
282312
let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument
283313
position = complParams ^. JL.position
284-
contents <- lift $ getVirtualFile $ toNormalizedUri uri
285-
case (contents, uriToFilePath' uri) of
286-
(Just cnts, Just path) -> do
287-
let pref = Ghcide.getCompletionPrefix position cnts
288-
let res = result pref path cnts
289-
liftIO $ fmap InL res
290-
_ -> pure . InR $ InR Null
314+
mVf <- lift $ getVirtualFile $ toNormalizedUri uri
315+
case (,) <$> mVf <*> uriToFilePath' uri of
316+
Just (cnts, path) -> do
317+
mFields <- liftIO $ runIdeAction "cabal-plugin.fields" (shakeExtras ide) $ useWithStaleFast ParseCabalFields $ toNormalizedFilePath path
318+
case mFields of
319+
Nothing ->
320+
pure . InR $ InR Null
321+
Just (fields, _) -> do
322+
let pref = Ghcide.getCompletionPrefix position cnts
323+
let res = produceCompletions pref path fields
324+
liftIO $ fmap InL res
325+
Nothing -> pure . InR $ InR Null
291326
where
292-
result :: Ghcide.PosPrefixInfo -> FilePath -> VFS.VirtualFile -> IO [CompletionItem]
293-
result prefix fp cnts = do
294-
runMaybeT context >>= \case
327+
completerRecorder = cmapWithPrio LogCompletions recorder
328+
329+
produceCompletions :: Ghcide.PosPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem]
330+
produceCompletions prefix fp fields = do
331+
runMaybeT (context fields) >>= \case
295332
Nothing -> pure []
296333
Just ctx -> do
297334
logWith recorder Debug $ LogCompletionContext ctx pos
298335
let completer = Completions.contextToCompleter ctx
299336
let completerData = CompleterTypes.CompleterData
300337
{ getLatestGPD = do
301-
mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast Types.GetCabalDiagnostics $ toNormalizedFilePath fp
338+
mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast ParseCabalFile $ toNormalizedFilePath fp
302339
pure $ fmap fst mGPD
303340
, cabalPrefixInfo = prefInfo
304341
, stanzaName =
@@ -309,7 +346,6 @@ completion recorder ide _ complParams = do
309346
completions <- completer completerRecorder completerData
310347
pure completions
311348
where
312-
completerRecorder = cmapWithPrio LogCompletions recorder
313349
pos = Ghcide.cursorPos prefix
314-
context = Completions.getContext completerRecorder prefInfo (cnts ^. VFS.file_text)
350+
context fields = Completions.getContext completerRecorder prefInfo fields
315351
prefInfo = Completions.getCabalPrefixInfo fp prefix

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

Lines changed: 115 additions & 109 deletions
Original file line numberDiff line numberDiff line change
@@ -4,17 +4,15 @@ module Ide.Plugin.Cabal.Completion.Completions (contextToCompleter, getContext,
44

55
import Control.Lens ((^.))
66
import Control.Monad.IO.Class (MonadIO)
7-
import Control.Monad.Trans.Maybe
8-
import Data.Foldable (asum)
9-
import qualified Data.List as List
10-
import Data.Map (Map)
7+
import Data.List.NonEmpty (NonEmpty)
8+
import qualified Data.List.NonEmpty as NE
119
import qualified Data.Map as Map
1210
import qualified Data.Text as T
13-
import qualified Data.Text.Utf16.Lines as Rope (Position (..))
14-
import Data.Text.Utf16.Rope.Mixed (Rope)
15-
import qualified Data.Text.Utf16.Rope.Mixed as Rope
11+
import qualified Data.Text.Encoding as T
1612
import Development.IDE as D
1713
import qualified Development.IDE.Plugin.Completions.Types as Ghcide
14+
import qualified Distribution.Fields as Syntax
15+
import qualified Distribution.Parsec.Position as Syntax
1816
import Ide.Plugin.Cabal.Completion.Completer.Simple
1917
import Ide.Plugin.Cabal.Completion.Completer.Snippet
2018
import Ide.Plugin.Cabal.Completion.Completer.Types (Completer)
@@ -64,32 +62,13 @@ contextToCompleter (Stanza s _, KeyWord kw) =
6462
-- Can return Nothing if an error occurs.
6563
--
6664
-- TODO: first line can only have cabal-version: keyword
67-
getContext :: (MonadIO m) => Recorder (WithPriority Log) -> CabalPrefixInfo -> Rope -> MaybeT m Context
68-
getContext recorder prefInfo ls =
69-
case prevLinesM of
70-
Just prevLines -> do
71-
let lvlContext =
72-
if completionIndentation prefInfo == 0
73-
then TopLevel
74-
else currentLevel prevLines
75-
case lvlContext of
76-
TopLevel -> do
77-
kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines (cabalVersionKeyword <> cabalKeywords)
78-
pure (TopLevel, kwContext)
79-
Stanza s n ->
80-
case Map.lookup s stanzaKeywordMap of
81-
Nothing -> do
82-
pure (Stanza s n, None)
83-
Just m -> do
84-
kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines m
85-
pure (Stanza s n, kwContext)
86-
Nothing -> do
87-
logWith recorder Warning $ LogFileSplitError pos
88-
-- basically returns nothing
89-
fail "Abort computation"
65+
getContext :: (MonadIO m) => Recorder (WithPriority Log) -> CabalPrefixInfo -> [Syntax.Field Syntax.Position] -> m Context
66+
getContext recorder prefInfo fields = do
67+
let ctx = findCursorContext cursor (NE.singleton (0, TopLevel)) (completionPrefix prefInfo) fields
68+
logWith recorder Debug $ LogCompletionContext ctx
69+
pure ctx
9070
where
91-
pos = completionCursorPosition prefInfo
92-
prevLinesM = splitAtPosition pos ls
71+
cursor = lspPositionToCabalPosition (completionCursorPosition prefInfo)
9372

9473
-- | Takes information about the current file's file path,
9574
-- and the cursor position in the file; and builds a CabalPrefixInfo
@@ -144,84 +123,111 @@ getCabalPrefixInfo fp prefixInfo =
144123
-- Implementation Details
145124
-- ----------------------------------------------------------------
146125

147-
-- | Takes prefix info about the previously written text,
148-
-- a list of lines (representing a file) and a map of
149-
-- keywords and returns a keyword context if the
150-
-- previously written keyword matches one in the map.
126+
findCursorContext ::
127+
Syntax.Position ->
128+
-- ^ The cursor position we look for in the fields
129+
NonEmpty (Int, StanzaContext) ->
130+
-- ^ A stack of current stanza contexts and their starting line numbers
131+
T.Text ->
132+
-- ^ The cursor's prefix text
133+
[Syntax.Field Syntax.Position] ->
134+
-- ^ The fields to traverse
135+
Context
136+
findCursorContext cursor parentHistory prefixText fields =
137+
case findFieldSection cursor fields of
138+
Nothing -> (snd $ NE.head parentHistory, None)
139+
-- We found the most likely section. Now, are we starting a new section or are we completing an existing one?
140+
Just field@(Syntax.Field _ _) -> classifyFieldContext parentHistory cursor field
141+
Just section@(Syntax.Section _ args sectionFields)
142+
| inSameLineAsSectionName section -> (stanzaCtx, None) -- TODO: test whether keyword in same line is parsed correctly
143+
| otherwise ->
144+
findCursorContext cursor
145+
(NE.cons (Syntax.positionCol (getAnnotation section) + 1, Stanza (getFieldName section) (getOptionalSectionName args)) parentHistory)
146+
prefixText sectionFields
147+
where
148+
inSameLineAsSectionName section = Syntax.positionRow (getAnnotation section) == Syntax.positionRow cursor
149+
stanzaCtx = snd $ NE.head parentHistory
150+
151+
-- | Finds the cursor's context, where the cursor is already found to be in a specific field
151152
--
152-
-- From a cursor position, we traverse the cabal file upwards to
153-
-- find the latest written keyword if there is any.
154-
-- Values may be written on subsequent lines,
155-
-- in order to allow for this we take the indentation of the current
156-
-- word to be completed into account to find the correct keyword context.
157-
getKeyWordContext :: CabalPrefixInfo -> [T.Text] -> Map KeyWordName a -> Maybe FieldContext
158-
getKeyWordContext prefInfo ls keywords = do
159-
case lastNonEmptyLineM of
160-
Nothing -> Just None
161-
Just lastLine' -> do
162-
let (whiteSpaces, lastLine) = T.span (== ' ') lastLine'
163-
let keywordIndentation = T.length whiteSpaces
164-
let cursorIndentation = completionIndentation prefInfo
165-
-- in order to be in a keyword context the cursor needs
166-
-- to be indented more than the keyword
167-
if cursorIndentation > keywordIndentation
168-
then -- if the last thing written was a keyword without a value
169-
case List.find (`T.isPrefixOf` lastLine) (Map.keys keywords) of
170-
Nothing -> Just None
171-
Just kw -> Just $ KeyWord kw
172-
else Just None
153+
-- Due to the way the field context is recognised for incomplete cabal files,
154+
-- an incomplete keyword is also recognised as a field, therefore we need to determine
155+
-- the specific context as we could still be in a stanza context in this case.
156+
classifyFieldContext :: NonEmpty (Int, StanzaContext) -> Syntax.Position -> Syntax.Field Syntax.Position -> Context
157+
classifyFieldContext ctx cursor field
158+
-- the cursor is not indented enough to be within the field
159+
-- but still indented enough to be within the stanza
160+
| cursorColumn <= fieldColumn && minIndent <= cursorColumn = (stanzaCtx, None)
161+
-- the cursor is not in the current stanza's context as it is not indented enough
162+
| cursorColumn < minIndent = findStanzaForColumn cursorColumn ctx
163+
| cursorIsInFieldName = (stanzaCtx, None)
164+
| cursorIsBeforeFieldName = (stanzaCtx, None)
165+
| otherwise = (stanzaCtx, KeyWord (getFieldName field <> ":"))
173166
where
174-
lastNonEmptyLineM :: Maybe T.Text
175-
lastNonEmptyLineM = do
176-
(curLine, rest) <- List.uncons ls
177-
-- represents the current line while disregarding the
178-
-- currently written text we want to complete
179-
let cur = stripPartiallyWritten curLine
180-
List.find (not . T.null . T.stripEnd) $
181-
cur : rest
182-
183-
-- | Traverse the given lines (starting before current cursor position
184-
-- up to the start of the file) to find the nearest stanza declaration,
185-
-- if none is found we are in the top level context.
167+
(minIndent, stanzaCtx) = NE.head ctx
168+
169+
cursorIsInFieldName = inSameLineAsFieldName &&
170+
fieldColumn <= cursorColumn &&
171+
cursorColumn <= fieldColumn + T.length (getFieldName field)
172+
173+
cursorIsBeforeFieldName = inSameLineAsFieldName &&
174+
cursorColumn < fieldColumn
175+
176+
inSameLineAsFieldName = Syntax.positionRow (getAnnotation field) == Syntax.positionRow cursor
177+
178+
cursorColumn = Syntax.positionCol cursor
179+
fieldColumn = Syntax.positionCol (getAnnotation field)
180+
181+
-- ----------------------------------------------------------------
182+
-- Cabal-syntax utilities I don't really want to write myself
183+
-- ----------------------------------------------------------------
184+
185+
-- | Determine the context of a cursor position within a stack of stanza contexts
186186
--
187-
-- TODO: this could be merged with getKeyWordContext in order to increase
188-
-- performance by reducing the number of times we have to traverse the cabal file.
189-
currentLevel :: [T.Text] -> StanzaContext
190-
currentLevel [] = TopLevel
191-
currentLevel (cur : xs)
192-
| Just (s, n) <- stanza = Stanza s n
193-
| otherwise = currentLevel xs
194-
where
195-
stanza = asum $ map checkStanza (Map.keys stanzaKeywordMap)
196-
checkStanza :: StanzaType -> Maybe (StanzaType, Maybe StanzaName)
197-
checkStanza t =
198-
case T.stripPrefix t (T.strip cur) of
199-
Just n
200-
| T.null n -> Just (t, Nothing)
201-
| otherwise -> Just (t, Just $ T.strip n)
202-
Nothing -> Nothing
203-
204-
-- | Get all lines before the given cursor position in the given file
205-
-- and reverse their order to traverse backwards starting from the given position.
206-
splitAtPosition :: Position -> Rope -> Maybe [T.Text]
207-
splitAtPosition pos ls = do
208-
split <- splitFile
209-
pure $ reverse $ Rope.lines $ fst split
210-
where
211-
splitFile = Rope.utf16SplitAtPosition ropePos ls
212-
ropePos =
213-
Rope.Position
214-
{ Rope.posLine = fromIntegral $ pos ^. JL.line,
215-
Rope.posColumn = fromIntegral $ pos ^. JL.character
216-
}
217-
218-
-- | Takes a line of text and removes the last partially
219-
-- written word to be completed.
220-
stripPartiallyWritten :: T.Text -> T.Text
221-
stripPartiallyWritten = T.dropWhileEnd (\y -> (y /= ' ') && (y /= ':'))
222-
223-
-- | Calculates how many spaces the currently completed item is indented.
224-
completionIndentation :: CabalPrefixInfo -> Int
225-
completionIndentation prefInfo = fromIntegral (pos ^. JL.character) - (T.length $ completionPrefix prefInfo)
187+
-- If the cursor is indented more than one of the stanzas in the stack
188+
-- the respective stanza is returned if this is never the case, the toplevel stanza
189+
-- in the stack is returned.
190+
findStanzaForColumn :: Int -> NonEmpty (Int, StanzaContext) -> (StanzaContext, FieldContext)
191+
findStanzaForColumn col ctx = case NE.uncons ctx of
192+
((_, stanza), Nothing) -> (stanza, None)
193+
((indentation, stanza), Just res)
194+
| col < indentation -> findStanzaForColumn col res
195+
| otherwise -> (stanza, None)
196+
197+
-- | Determine the field the cursor is currently a part of.
198+
--
199+
-- The result is said field and its starting position
200+
-- or Nothing if the passed list of fields is empty.
201+
202+
-- This only looks at the row of the cursor and not at the cursor's
203+
-- position within the row.
204+
--
205+
-- TODO: we do not handle braces correctly.
206+
findFieldSection :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe (Syntax.Field Syntax.Position)
207+
findFieldSection _cursor [] = Nothing
208+
findFieldSection _cursor [x] =
209+
-- Last field. We decide later, whether we are starting
210+
-- a new section.
211+
Just x
212+
findFieldSection cursor (x:y:ys)
213+
| Syntax.positionRow (getAnnotation x) <= cursorLine && cursorLine < Syntax.positionRow (getAnnotation y)
214+
= Just x
215+
| otherwise = findFieldSection cursor (y:ys)
226216
where
227-
pos = completionCursorPosition prefInfo
217+
cursorLine = Syntax.positionRow cursor
218+
219+
type FieldName = T.Text
220+
221+
getAnnotation :: Syntax.Field ann -> ann
222+
getAnnotation (Syntax.Field (Syntax.Name ann _) _) = ann
223+
getAnnotation (Syntax.Section (Syntax.Name ann _) _ _) = ann
224+
225+
getFieldName :: Syntax.Field ann -> FieldName
226+
getFieldName (Syntax.Field (Syntax.Name _ fn) _) = T.decodeUtf8 fn
227+
getFieldName (Syntax.Section (Syntax.Name _ fn) _ _) = T.decodeUtf8 fn
228+
229+
getOptionalSectionName :: [Syntax.SectionArg ann] -> Maybe T.Text
230+
getOptionalSectionName [] = Nothing
231+
getOptionalSectionName (x:xs) = case x of
232+
Syntax.SecArgName _ name -> Just (T.decodeUtf8 name)
233+
_ -> getOptionalSectionName xs

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

Lines changed: 42 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -4,13 +4,17 @@
44

55
module Ide.Plugin.Cabal.Completion.Types where
66

7-
import Control.DeepSeq (NFData)
7+
import Control.DeepSeq (NFData)
8+
import Control.Lens ((^.))
89
import Data.Hashable
9-
import qualified Data.Text as T
10+
import qualified Data.Text as T
1011
import Data.Typeable
11-
import Development.IDE as D
12+
import Development.IDE as D
13+
import qualified Distribution.Fields as Syntax
14+
import qualified Distribution.PackageDescription as PD
15+
import qualified Distribution.Parsec.Position as Syntax
1216
import GHC.Generics
13-
import qualified Ide.Plugin.Cabal.Parse as Parse
17+
import qualified Language.LSP.Protocol.Lens as JL
1418

1519
data Log
1620
= LogFileSplitError Position
@@ -21,6 +25,7 @@ data Log
2125
| LogFilePathCompleterIOError FilePath IOError
2226
| LogUseWithStaleFastNoResult
2327
| LogMapLookUpOfKnownKeyFailed T.Text
28+
| LogCompletionContext Context
2429
deriving (Show)
2530

2631
instance Pretty Log where
@@ -34,15 +39,25 @@ instance Pretty Log where
3439
"When trying to complete the file path:" <+> pretty fp <+> "the following unexpected IO error occurred" <+> viaShow ioErr
3540
LogUseWithStaleFastNoResult -> "Package description couldn't be read"
3641
LogMapLookUpOfKnownKeyFailed key -> "Lookup of key in map failed even though it should exist" <+> pretty key
42+
LogCompletionContext ctx -> "Completion context is:" <+> pretty ctx
3743

38-
type instance RuleResult GetCabalDiagnostics = Parse.GenericPackageDescription
44+
type instance RuleResult ParseCabalFile = PD.GenericPackageDescription
3945

40-
data GetCabalDiagnostics = GetCabalDiagnostics
46+
data ParseCabalFile = ParseCabalFile
4147
deriving (Eq, Show, Typeable, Generic)
4248

43-
instance Hashable GetCabalDiagnostics
49+
instance Hashable ParseCabalFile
4450

45-
instance NFData GetCabalDiagnostics
51+
instance NFData ParseCabalFile
52+
53+
type instance RuleResult ParseCabalFields = [Syntax.Field Syntax.Position]
54+
55+
data ParseCabalFields = ParseCabalFields
56+
deriving (Eq, Show, Typeable, Generic)
57+
58+
instance Hashable ParseCabalFields
59+
60+
instance NFData ParseCabalFields
4661

4762
-- | The context a cursor can be in within a cabal file.
4863
--
@@ -61,22 +76,30 @@ data StanzaContext
6176
-- Stanzas have their own fields which differ from top-level fields.
6277
-- Each stanza must be named, such as 'executable exe',
6378
-- except for the main library.
64-
Stanza StanzaType (Maybe StanzaName)
79+
Stanza !StanzaType !(Maybe StanzaName)
6580
deriving (Eq, Show, Read)
6681

82+
instance Pretty StanzaContext where
83+
pretty TopLevel = "TopLevel"
84+
pretty (Stanza t ms) = "Stanza" <+> pretty t <+> (maybe mempty pretty ms)
85+
6786
-- | Keyword context in a cabal file.
6887
--
6988
-- Used to decide whether to suggest values or keywords.
7089
data FieldContext
7190
= -- | Key word context, where a keyword
7291
-- occurs right before the current word
7392
-- to be completed
74-
KeyWord KeyWordName
93+
KeyWord !KeyWordName
7594
| -- | Keyword context where no keyword occurs
7695
-- right before the current word to be completed
7796
None
7897
deriving (Eq, Show, Read)
7998

99+
instance Pretty FieldContext where
100+
pretty (KeyWord kw) = "KeyWord" <+> pretty kw
101+
pretty None = "No Keyword"
102+
80103
type KeyWordName = T.Text
81104

82105
type StanzaName = T.Text
@@ -139,3 +162,12 @@ applyStringNotation (Just LeftSide) compl = compl <> "\""
139162
applyStringNotation Nothing compl
140163
| Just _ <- T.find (== ' ') compl = "\"" <> compl <> "\""
141164
| otherwise = compl
165+
166+
-- | Convert an LSP 'Position' to a 'Syntax.Position'.
167+
--
168+
-- Cabal Positions start their indexing at 1 while LSP starts at 0.
169+
-- This helper makes sure, the translation is done properly.
170+
lspPositionToCabalPosition :: Position -> Syntax.Position
171+
lspPositionToCabalPosition pos = Syntax.Position
172+
(fromIntegral (pos ^. JL.line) + 1)
173+
(fromIntegral (pos ^. JL.character) + 1)

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

Lines changed: 14 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@ module Ide.Plugin.Cabal.Diagnostics
44
( errorDiagnostic
55
, warningDiagnostic
66
, positionFromCabalPosition
7+
, fatalParseErrorDiagnostic
78
-- * Re-exports
89
, FileDiagnostic
910
, Diagnostic(..)
@@ -14,25 +15,30 @@ import qualified Data.Text as T
1415
import Development.IDE (FileDiagnostic,
1516
ShowDiagnostic (ShowDiag))
1617
import Distribution.Fields (showPError, showPWarning)
17-
import qualified Ide.Plugin.Cabal.Parse as Lib
1818
import Ide.PluginUtils (extendNextLine)
1919
import Language.LSP.Protocol.Types (Diagnostic (..),
2020
DiagnosticSeverity (..),
2121
NormalizedFilePath,
2222
Position (Position),
2323
Range (Range),
2424
fromNormalizedFilePath)
25+
import qualified Distribution.Parsec as Syntax
26+
27+
-- | Produce a diagnostic for a fatal Cabal parser error.
28+
fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic
29+
fatalParseErrorDiagnostic fp msg =
30+
mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine Syntax.zeroPos) msg
2531

2632
-- | Produce a diagnostic from a Cabal parser error
27-
errorDiagnostic :: NormalizedFilePath -> Lib.PError -> FileDiagnostic
28-
errorDiagnostic fp err@(Lib.PError pos _) =
33+
errorDiagnostic :: NormalizedFilePath -> Syntax.PError -> FileDiagnostic
34+
errorDiagnostic fp err@(Syntax.PError pos _) =
2935
mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg
3036
where
3137
msg = T.pack $ showPError (fromNormalizedFilePath fp) err
3238

3339
-- | Produce a diagnostic from a Cabal parser warning
34-
warningDiagnostic :: NormalizedFilePath -> Lib.PWarning -> FileDiagnostic
35-
warningDiagnostic fp warning@(Lib.PWarning _ pos _) =
40+
warningDiagnostic :: NormalizedFilePath -> Syntax.PWarning -> FileDiagnostic
41+
warningDiagnostic fp warning@(Syntax.PWarning _ pos _) =
3642
mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg
3743
where
3844
msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning
@@ -41,7 +47,7 @@ warningDiagnostic fp warning@(Lib.PWarning _ pos _) =
4147
-- only a single source code 'Lib.Position'.
4248
-- We define the range to be _from_ this position
4349
-- _to_ the first column of the next line.
44-
toBeginningOfNextLine :: Lib.Position -> Range
50+
toBeginningOfNextLine :: Syntax.Position -> Range
4551
toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos
4652
where
4753
pos = positionFromCabalPosition cabalPos
@@ -53,8 +59,8 @@ toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos
5359
--
5460
-- >>> positionFromCabalPosition $ Lib.Position 1 1
5561
-- Position 0 0
56-
positionFromCabalPosition :: Lib.Position -> Position
57-
positionFromCabalPosition (Lib.Position line column) = Position (fromIntegral line') (fromIntegral col')
62+
positionFromCabalPosition :: Syntax.Position -> Position
63+
positionFromCabalPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col')
5864
where
5965
-- LSP is zero-based, Cabal is one-based
6066
line' = line-1

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

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
module Ide.Plugin.Cabal.Orphans where
3+
import Control.DeepSeq
4+
import Distribution.Fields.Field
5+
import Distribution.Parsec.Position
6+
7+
-- ----------------------------------------------------------------
8+
-- Cabal-syntax orphan instances we need sometimes
9+
-- ----------------------------------------------------------------
10+
11+
instance NFData (Field Position) where
12+
rnf (Field name fieldLines) = rnf name `seq` rnf fieldLines
13+
rnf (Section name sectionArgs fields) = rnf name `seq` rnf sectionArgs `seq` rnf fields
14+
15+
instance NFData (Name Position) where
16+
rnf (Name ann fName) = rnf ann `seq` rnf fName
17+
18+
instance NFData (FieldLine Position) where
19+
rnf (FieldLine ann bs) = rnf ann `seq` rnf bs
20+
21+
instance NFData (SectionArg Position) where
22+
rnf (SecArgName ann bs) = rnf ann `seq` rnf bs
23+
rnf (SecArgStr ann bs) = rnf ann `seq` rnf bs
24+
rnf (SecArgOther ann bs) = rnf ann `seq` rnf bs

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

Lines changed: 52 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,8 @@
1+
{-# LANGUAGE OverloadedStrings #-}
12
module Ide.Plugin.Cabal.Parse
23
( parseCabalFileContents
3-
-- * Re-exports
4-
, FilePath
5-
, NonEmpty(..)
6-
, PWarning(..)
7-
, Version
8-
, PError(..)
9-
, Position(..)
10-
, GenericPackageDescription(..)
4+
, parseCabalVersion
5+
, readCabalFields
116
) where
127

138
import qualified Data.ByteString as BS
@@ -16,12 +11,60 @@ import Distribution.Fields (PError (..),
1611
PWarning (..))
1712
import Distribution.Fields.ParseResult (runParseResult)
1813
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
19-
import Distribution.Parsec.Position (Position (..))
2014
import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..))
2115
import Distribution.Types.Version (Version)
16+
import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics
17+
18+
import qualified Data.Text as T
19+
import Development.IDE
20+
import Distribution.CabalSpecVersion (CabalSpecVersion)
21+
import qualified Distribution.CabalSpecVersion as Syntax
22+
import qualified Distribution.Fields.Parser as Syntax
23+
import qualified Distribution.PackageDescription.Parsec as Syntax
24+
import qualified Distribution.Parsec.Position as Syntax
25+
import Distribution.Pretty (prettyShow)
26+
import qualified Distribution.Types.Version as Syntax
27+
2228

2329
parseCabalFileContents
2430
:: BS.ByteString -- ^ UTF-8 encoded bytestring
2531
-> IO ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
2632
parseCabalFileContents bs =
2733
pure $ runParseResult (parseGenericPackageDescription bs)
34+
35+
-- readCabalFields ::
36+
-- NormalizedFilePath ->
37+
-- BS.ByteString ->
38+
-- Either Diagnostics.FileDiagnostic ([Syntax.Field Syntax.Position], [Syntax.LexWarning])
39+
readCabalFields ::
40+
NormalizedFilePath ->
41+
BS.ByteString ->
42+
Either FileDiagnostic [Syntax.Field Syntax.Position]
43+
readCabalFields file contents = do
44+
case Syntax.readFields' contents of
45+
Left parseError ->
46+
Left $ Diagnostics.fatalParseErrorDiagnostic file
47+
$ "Failed to parse cabal file: " <> T.pack (show parseError)
48+
Right (fields, _warnings) -> do
49+
-- we don't want to double report diagnostics, all diagnostics are produced by 'ParseCabalFile'.
50+
Right fields
51+
52+
parseCabalVersion :: NormalizedFilePath -> BS.ByteString -> Either Diagnostics.FileDiagnostic CabalSpecVersion
53+
parseCabalVersion file contents = do
54+
let ver = Syntax.scanSpecVersion contents
55+
case ver of
56+
-- if we get too new version, fail right away
57+
Just v -> case Syntax.cabalSpecFromVersionDigits (Syntax.versionNumbers v) of
58+
Nothing ->
59+
Left $ Diagnostics.fatalParseErrorDiagnostic file $
60+
"Unsupported cabal format version in cabal-version field: "
61+
<> T.pack (prettyShow v)
62+
<> ".\n"
63+
<> cabalFormatVersionsDesc
64+
65+
Just csv -> Right csv
66+
_ -> Left $ Diagnostics.fatalParseErrorDiagnostic file $
67+
"Failed to find cabal spec version."
68+
69+
cabalFormatVersionsDesc :: T.Text
70+
cabalFormatVersionsDesc = "Current cabal-version values are listed at https://cabal.readthedocs.io/en/stable/file-format-changelog.html."

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import qualified Data.ByteString as ByteString
99
import Data.Maybe (mapMaybe)
1010
import qualified Data.Text as T
1111
import qualified Development.IDE.Plugin.Completions.Types as Ghcide
12+
import Distribution.PackageDescription (GenericPackageDescription)
1213
import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)
1314
import Ide.Plugin.Cabal.Completion.Completer.FilePath
1415
import Ide.Plugin.Cabal.Completion.Completer.Module
@@ -17,7 +18,6 @@ import Ide.Plugin.Cabal.Completion.Completer.Types (CompleterData (
1718
import Ide.Plugin.Cabal.Completion.Completions
1819
import Ide.Plugin.Cabal.Completion.Types (CabalPrefixInfo (..),
1920
StanzaName)
20-
import Ide.Plugin.Cabal.Parse (GenericPackageDescription)
2121
import qualified Language.LSP.Protocol.Lens as L
2222
import System.FilePath
2323
import Test.Hls

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

Lines changed: 136 additions & 53 deletions
Original file line numberDiff line numberDiff line change
@@ -1,28 +1,32 @@
11
{-# LANGUAGE DisambiguateRecordFields #-}
22
{-# LANGUAGE LambdaCase #-}
33
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE QuasiQuotes #-}
5+
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
6+
{-# HLINT ignore "Avoid restricted function" #-}
47

58
module Context where
69

7-
import Control.Monad.Trans.Maybe (runMaybeT)
810
import qualified Data.Text as T
9-
import qualified Data.Text.Utf16.Rope.Mixed as Rope
11+
import qualified Data.Text.Encoding as Text
1012
import Ide.Plugin.Cabal
1113
import Ide.Plugin.Cabal.Completion.Completer.Paths
1214
import Ide.Plugin.Cabal.Completion.Completions
1315
import Ide.Plugin.Cabal.Completion.Types (Context,
1416
FieldContext (KeyWord, None),
1517
StanzaContext (Stanza, TopLevel))
18+
import qualified Ide.Plugin.Cabal.Parse as Parse
1619
import Test.Hls
1720
import Utils as T
21+
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo(..))
1822

1923
cabalPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log
2024
cabalPlugin = mkPluginTestDescriptor descriptor "cabal context"
2125

2226
contextTests :: TestTree
2327
contextTests =
2428
testGroup
25-
"Context Tests "
29+
"Context Tests"
2630
[ pathCompletionInfoFromCompletionContextTests
2731
, getContextTests
2832
]
@@ -58,39 +62,39 @@ pathCompletionInfoFromCompletionContextTests =
5862
getContextTests :: TestTree
5963
getContextTests =
6064
testGroup
61-
"Context Tests"
65+
"Context Tests Real"
6266
[ testCase "Empty File - Start" $ do
6367
-- for a completely empty file, the context needs to
6468
-- be top level without a specified keyword
65-
ctx <- callGetContext (Position 0 0) "" [""]
69+
ctx <- callGetContext (Position 0 0) "" ""
6670
ctx @?= (TopLevel, None)
6771
, testCase "Cabal version keyword - no value, no space after :" $ do
6872
-- on a file, where the keyword is already written
6973
-- the context should still be toplevel but the keyword should be recognized
70-
ctx <- callGetContext (Position 0 14) "" ["cabal-version:"]
74+
ctx <- callGetContext (Position 0 14) "" "cabal-version:\n"
7175
ctx @?= (TopLevel, KeyWord "cabal-version:")
7276
, testCase "Cabal version keyword - cursor in keyword" $ do
7377
-- on a file, where the keyword is already written
7478
-- but the cursor is in the middle of the keyword,
7579
-- we are not in a keyword context
76-
ctx <- callGetContext (Position 0 5) "cabal" ["cabal-version:"]
80+
ctx <- callGetContext (Position 0 5) "cabal" "cabal-version:\n"
7781
ctx @?= (TopLevel, None)
7882
, testCase "Cabal version keyword - no value, many spaces" $ do
7983
-- on a file, where the "cabal-version:" keyword is already written
8084
-- the context should still be top level but the keyword should be recognized
81-
ctx <- callGetContext (Position 0 45) "" ["cabal-version:" <> T.replicate 50 " "]
85+
ctx <- callGetContext (Position 0 45) "" ("cabal-version:" <> T.replicate 50 " " <> "\n")
8286
ctx @?= (TopLevel, KeyWord "cabal-version:")
8387
, testCase "Cabal version keyword - keyword partly written" $ do
8488
-- in the first line of the file, if the keyword
8589
-- has not been written completely, the keyword context
8690
-- should still be None
87-
ctx <- callGetContext (Position 0 5) "cabal" ["cabal"]
91+
ctx <- callGetContext (Position 0 5) "cabal" "cabal"
8892
ctx @?= (TopLevel, None)
8993
, testCase "Cabal version keyword - value partly written" $ do
9094
-- in the first line of the file, if the keyword
9195
-- has not been written completely, the keyword context
9296
-- should still be None
93-
ctx <- callGetContext (Position 0 17) "1." ["cabal-version: 1."]
97+
ctx <- callGetContext (Position 0 17) "1." "cabal-version: 1."
9498
ctx @?= (TopLevel, KeyWord "cabal-version:")
9599
, testCase "Inside Stanza - no keyword" $ do
96100
-- on a file, where the library stanza has been defined
@@ -102,14 +106,15 @@ getContextTests =
102106
-- has been defined, the keyword and stanza should be recognized
103107
ctx <- callGetContext (Position 4 21) "" libraryStanzaData
104108
ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")
105-
, expectFailBecause "While not valid, it is not that important to make the code more complicated for this" $
106-
testCase "Cabal version keyword - no value, next line" $ do
107-
-- if the cabal version keyword has been written but without a value,
108-
-- in the next line we still should be in top level context with no keyword
109-
-- since the cabal version keyword and value pair need to be in the same line
110-
ctx <- callGetContext (Position 1 2) "" ["cabal-version:", ""]
111-
ctx @?= (TopLevel, None)
112-
, testCase "Non-cabal-version keyword - no value, next line indentented position" $ do
109+
, testCase "Cabal version keyword - no value, next line" $ do
110+
-- if the cabal version keyword has been written but without a value,
111+
-- in the next line we still should be in top level context with no keyword
112+
-- since the cabal version keyword and value pair need to be in the same line.
113+
-- However, that's too much work to implement for virtually no benefit, so we
114+
-- test here the status-quo is satisfied.
115+
ctx <- callGetContext (Position 1 2) "" "cabal-version:\n\n"
116+
ctx @?= (TopLevel, KeyWord "cabal-version:")
117+
, testCase "Non-cabal-version keyword - no value, next line indented position" $ do
113118
-- if a keyword, other than the cabal version keyword has been written
114119
-- with no value, in the next line we still should be in top level keyword context
115120
-- of the keyword with no value, since its value may be written in the next line
@@ -153,46 +158,124 @@ getContextTests =
153158
ctx @?= (TopLevel, KeyWord "name:")
154159
, testCase "Named Stanza" $ do
155160
ctx <- callGetContext (Position 2 18) "" executableStanzaData
156-
ctx @?= (Stanza "executable" (Just "exeName"), None)
161+
ctx @?= (TopLevel, None)
162+
, testCase "Multi line, finds context in same line" $ do
163+
ctx <- callGetContext (Position 5 18) "" multiLineOptsData
164+
ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")
165+
, testCase "Multi line, in the middle of option" $ do
166+
ctx <- callGetContext (Position 6 11) "" multiLineOptsData
167+
ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")
168+
, testCase "Multi line, finds context in between lines" $ do
169+
ctx <- callGetContext (Position 7 8) "" multiLineOptsData
170+
ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")
171+
, testCase "Multi line, finds context in between lines, start if line" $ do
172+
ctx <- callGetContext (Position 7 0) "" multiLineOptsData
173+
ctx @?= (TopLevel, None)
174+
, testCase "Multi line, end of option" $ do
175+
ctx <- callGetContext (Position 8 14) "" multiLineOptsData
176+
ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")
177+
, parameterisedCursorTest "Contexts in large testfile" multiPositionTestData
178+
[ (TopLevel, None)
179+
, (TopLevel, KeyWord "cabal-version:")
180+
, (TopLevel, None)
181+
, (TopLevel, KeyWord "description:")
182+
, (TopLevel, KeyWord "extra-source-files:")
183+
, (TopLevel, None)
184+
-- this might not be what we want, maybe add another Context
185+
, (TopLevel, None)
186+
-- this might not be what we want, maybe add another Context
187+
, (TopLevel, None)
188+
, (Stanza "source-repository" (Just "head"), None)
189+
, (Stanza "source-repository" (Just "head"), KeyWord "type:")
190+
, (Stanza "source-repository" (Just "head"), KeyWord "type:")
191+
, (Stanza "source-repository" (Just "head"), KeyWord "type:")
192+
, (Stanza "source-repository" (Just "head"), None)
193+
]
194+
$ \fileContent posPrefInfo ->
195+
callGetContext (cursorPos posPrefInfo) (prefixText posPrefInfo) fileContent
157196
]
158197
where
159-
callGetContext :: Position -> T.Text -> [T.Text] -> IO Context
198+
callGetContext :: Position -> T.Text -> T.Text -> IO Context
160199
callGetContext pos pref ls = do
161-
runMaybeT (getContext mempty (simpleCabalPrefixInfoFromPos pos pref) (Rope.fromText $ T.unlines ls))
162-
>>= \case
163-
Nothing -> assertFailure "Context must be found"
164-
Just ctx -> pure ctx
200+
case Parse.readCabalFields "not-real" (Text.encodeUtf8 ls) of
201+
Left err -> fail $ show err
202+
Right fields -> do
203+
getContext mempty (simpleCabalPrefixInfoFromPos pos pref) fields
165204

166205
-- ------------------------------------------------------------------------
167206
-- Test Data
168207
-- ------------------------------------------------------------------------
169208

170-
libraryStanzaData :: [T.Text]
171-
libraryStanzaData =
172-
[ "cabal-version: 3.0"
173-
, "name: simple-cabal"
174-
, "library "
175-
, " default-language: Haskell98"
176-
, " build-depends: "
177-
, " "
178-
, "ma "
179-
]
180-
181-
executableStanzaData :: [T.Text]
182-
executableStanzaData =
183-
[ "cabal-version: 3.0"
184-
, "name: simple-cabal"
185-
, "executable exeName"
186-
, " default-language: Haskell2010"
187-
, " hs-source-dirs: test/preprocessor"
188-
]
189-
190-
topLevelData :: [T.Text]
191-
topLevelData =
192-
[ "cabal-version: 3.0"
193-
, "name:"
194-
, ""
195-
, ""
196-
, ""
197-
, " eee"
198-
]
209+
libraryStanzaData :: T.Text
210+
libraryStanzaData = [trimming|
211+
cabal-version: 3.0
212+
name: simple-cabal
213+
library
214+
default-language: Haskell98
215+
build-depends:
216+
217+
ma
218+
|]
219+
220+
executableStanzaData :: T.Text
221+
executableStanzaData = [trimming|
222+
cabal-version: 3.0
223+
name: simple-cabal
224+
executable exeName
225+
default-language: Haskell2010
226+
hs-source-dirs: test/preprocessor
227+
|]
228+
229+
topLevelData :: T.Text
230+
topLevelData = [trimming|
231+
cabal-version: 3.0
232+
name:
233+
234+
235+
236+
eee
237+
|]
238+
239+
multiLineOptsData :: T.Text
240+
multiLineOptsData = [trimming|
241+
cabal-version: 3.0
242+
name:
243+
244+
245+
library
246+
build-depends:
247+
base,
248+
249+
text ,
250+
|]
251+
252+
multiPositionTestData :: T.Text
253+
multiPositionTestData = [trimming|
254+
cabal-version: 3.4
255+
^ ^
256+
category: Development
257+
^
258+
name: haskell-language-server
259+
description:
260+
Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>
261+
^
262+
extra-source-files:
263+
README.md
264+
ChangeLog.md
265+
test/testdata/**/*.project
266+
test/testdata/**/*.cabal
267+
test/testdata/**/*.yaml
268+
test/testdata/**/*.hs
269+
test/testdata/**/*.json
270+
^
271+
-- These globs should only match test/testdata
272+
plugins/**/*.project
273+
274+
source-repository head
275+
^ ^ ^
276+
type: git
277+
^ ^ ^ ^
278+
location: https://github.com/haskell/haskell-language-server
279+
280+
^
281+
|]

0 commit comments

Comments
 (0)
Please sign in to comment.