From f024d2a0dbbff12efd51a1f89e0abedbdc2542c2 Mon Sep 17 00:00:00 2001 From: Fendor Date: Mon, 27 May 2024 21:41:49 +0200 Subject: [PATCH 1/2] hls-test-utils: Add parameterised cursor test utils Add utils that allows to define parameterised tests for files that require cursor positions. This enables us to define run the same tests for multiple inputs efficiently, and with readable error messages. The main advantage is the improved specification of the test cases, as we allow to specify the cursor position directly in the source of the test files. --- .../IDE/Plugin/Completions/Logic.hs | 6 +- hls-test-utils/hls-test-utils.cabal | 2 + hls-test-utils/src/Test/Hls.hs | 163 ++++++++++++------ hls-test-utils/src/Test/Hls/Util.hs | 163 ++++++++++++++++-- 4 files changed, 261 insertions(+), 73 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 145e9a2b37..867c47719a 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -11,6 +11,7 @@ module Development.IDE.Plugin.Completions.Logic ( , getCompletions , fromIdentInfo , getCompletionPrefix +, getCompletionPrefixFromRope ) where import Control.Applicative @@ -897,7 +898,10 @@ mergeListsBy cmp all_lists = merge_lists all_lists -- |From the given cursor position, gets the prefix module or record for autocompletion getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo -getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) = +getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext + +getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo +getCompletionPrefixFromRope pos@(Position l c) ropetext = fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad let headMaybe = listToMaybe lastMaybe = headMaybe . reverse diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index f284f8088d..252eb51799 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -49,6 +49,7 @@ library , lsp , lsp-test ^>=0.17 , lsp-types ^>=2.2 + , neat-interpolation , safe-exceptions , tasty , tasty-expected-failure @@ -57,6 +58,7 @@ library , tasty-rerun , temporary , text + , text-rope ghc-options: -Wall diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 342677d872..15f41e3b2b 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -34,6 +34,8 @@ module Test.Hls runSessionWithServer, runSessionWithServerInTmpDir, runSessionWithTestConfig, + -- * Running parameterised tests for a set of test configurations + parameterisedCursorTest, -- * Helpful re-exports PluginDescriptor, IdeState, @@ -64,74 +66,76 @@ module Test.Hls where import Control.Applicative.Combinators -import Control.Concurrent.Async (async, cancel, wait) +import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Safe -import Control.Lens.Extras (is) -import Control.Monad (guard, unless, void) -import Control.Monad.Extra (forM) +import Control.Lens.Extras (is) +import Control.Monad (guard, unless, void) +import Control.Monad.Extra (forM) import Control.Monad.IO.Class -import Data.Aeson (Result (Success), - Value (Null), fromJSON, - toJSON) -import qualified Data.Aeson as A -import Data.ByteString.Lazy (ByteString) -import Data.Default (Default, def) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (Proxy)) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import Development.IDE (IdeState, - LoggingColumn (ThreadIdColumn), - defaultLayoutOptions, - layoutPretty, renderStrict) -import qualified Development.IDE.LSP.Notifications as Notifications -import Development.IDE.Main hiding (Log) -import qualified Development.IDE.Main as IDEMain -import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), - WaitForIdeRuleResult (ideResultSuccess)) -import qualified Development.IDE.Plugin.Test as Test +import Data.Aeson (Result (Success), + Value (Null), + fromJSON, toJSON) +import qualified Data.Aeson as A +import Data.ByteString.Lazy (ByteString) +import Data.Default (Default, def) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Development.IDE (IdeState, + LoggingColumn (ThreadIdColumn), + defaultLayoutOptions, + layoutPretty, + renderStrict) +import Development.IDE.Main hiding (Log) +import qualified Development.IDE.Main as IDEMain +import Development.IDE.Plugin.Completions.Types (PosPrefixInfo) +import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), + WaitForIdeRuleResult (ideResultSuccess)) +import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import GHC.IO.Handle import GHC.TypeLits -import Ide.Logger (Pretty (pretty), - Priority (..), Recorder, - WithPriority (WithPriority, priority), - cfilter, cmapWithPrio, - defaultLoggingColumns, - logWith, - makeDefaultStderrRecorder, - (<+>)) -import qualified Ide.Logger as Logger -import Ide.Plugin.Properties ((&)) -import Ide.PluginUtils (idePluginsToPluginDesc, - pluginDescToIdePlugins) +import Ide.Logger (Pretty (pretty), + Priority (..), + Recorder, + WithPriority (WithPriority, priority), + cfilter, + cmapWithPrio, + defaultLoggingColumns, + logWith, + makeDefaultStderrRecorder, + (<+>)) +import qualified Ide.Logger as Logger +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Message -import qualified Language.LSP.Protocol.Message as LSP -import Language.LSP.Protocol.Types hiding (Null) -import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types hiding (Null) +import qualified Language.LSP.Server as LSP import Language.LSP.Test -import Prelude hiding (log) -import System.Directory (canonicalizePath, - createDirectoryIfMissing, - getCurrentDirectory, - getTemporaryDirectory, - makeAbsolute, - setCurrentDirectory) -import System.Environment (lookupEnv, setEnv) +import Prelude hiding (log) +import System.Directory (canonicalizePath, + createDirectoryIfMissing, + getCurrentDirectory, + getTemporaryDirectory, + makeAbsolute, + setCurrentDirectory) +import System.Environment (lookupEnv, setEnv) import System.FilePath -import System.IO.Extra (newTempDirWithin) -import System.IO.Unsafe (unsafePerformIO) -import System.Process.Extra (createPipe) +import System.IO.Extra (newTempDirWithin) +import System.IO.Unsafe (unsafePerformIO) +import System.Process.Extra (createPipe) import System.Time.Extra -import qualified Test.Hls.FileSystem as FS +import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem import Test.Hls.Util -import Test.Tasty hiding (Timeout) +import Test.Tasty hiding (Timeout) import Test.Tasty.ExpectedFailure import Test.Tasty.Golden import Test.Tasty.HUnit @@ -328,6 +332,56 @@ goldenWithDocInTmpDir languageKind config plugin title tree path desc ext act = act doc documentContents doc +-- | A parameterised test is similar to a normal test case but allows to run +-- the same test case multiple times with different inputs. +-- A 'parameterisedCursorTest' allows to define a test case based on an input file +-- that specifies one or many cursor positions via the identification value '^'. +-- +-- For example: +-- +-- @ +-- parameterisedCursorTest "Cursor Test" [trimming| +-- foo = 2 +-- ^ +-- bar = 3 +-- baz = foo + bar +-- ^ +-- |] +-- ["foo", "baz"] +-- (\input cursor -> findFunctionNameUnderCursor input cursor) +-- @ +-- +-- Assuming a fitting implementation for 'findFunctionNameUnderCursor'. +-- +-- This test definition will run the test case 'findFunctionNameUnderCursor' for +-- each cursor position, each in its own isolated 'testCase'. +-- Cursor positions are identified via the character '^', which points to the +-- above line as the actual cursor position. +-- Lines containing '^' characters, are removed from the final text, that is +-- passed to the testing function. +-- +-- TODO: Many Haskell and Cabal source may contain '^' characters for good reasons. +-- We likely need a way to change the character for certain test cases in the future. +-- +-- The quasi quoter 'trimming' is very helpful to define such tests, as it additionally +-- allows to interpolate haskell values and functions. We reexport this quasi quoter +-- for easier usage. +parameterisedCursorTest :: (Show a, Eq a) => String -> T.Text -> [a] -> (T.Text -> PosPrefixInfo -> IO a) -> TestTree +parameterisedCursorTest title content expectations act + | lenPrefs /= lenExpected = error $ "parameterisedCursorTest: Expected " <> show lenExpected <> " cursors but found: " <> show lenPrefs + | otherwise = testGroup title $ + map singleTest testCaseSpec + where + lenPrefs = length prefInfos + lenExpected = length expectations + (cleanText, prefInfos) = extractCursorPositions content + + testCaseSpec = zip [1 ::Int ..] (zip expectations prefInfos) + + singleTest (n, (expected, info)) = testCase (title <> " " <> show n) $ do + actual <- act cleanText info + assertEqual (mkParameterisedLabel info) expected actual + -- ------------------------------------------------------------ -- Helper function for initialising plugins under test -- ------------------------------------------------------------ @@ -429,6 +483,7 @@ initializeTestRecorder envVars = do -- ------------------------------------------------------------ -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ + runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a runSessionWithServerInTmpDir config plugin tree act = runSessionWithTestConfig def diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 92bada04f7..64c976fd8e 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -42,37 +42,48 @@ module Test.Hls.Util , withCurrentDirectoryInTmp , withCurrentDirectoryInTmp' , withCanonicalTempDir + -- * Extract positions from input file. + , extractCursorPositions + , mkParameterisedLabel + , trimming ) where -import Control.Applicative.Combinators (skipManyTill, (<|>)) -import Control.Exception (catch, throwIO) -import Control.Lens (_Just, (&), (.~), (?~), (^.)) +import Control.Applicative.Combinators (skipManyTill, (<|>)) +import Control.Exception (catch, throwIO) +import Control.Lens (_Just, (&), (.~), + (?~), (^.)) import Control.Monad import Control.Monad.IO.Class -import qualified Data.Aeson as A -import Data.Bool (bool) +import qualified Data.Aeson as A +import Data.Bool (bool) import Data.Default -import Data.List.Extra (find) +import Data.List.Extra (find) import Data.Proxy -import qualified Data.Set as Set -import qualified Data.Text as T -import Development.IDE (GhcVersion (..), ghcVersion) -import qualified Language.LSP.Protocol.Lens as L +import qualified Data.Text as T +import Development.IDE (GhcVersion (..), + ghcVersion) +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import qualified Language.LSP.Test as Test +import qualified Language.LSP.Test as Test import System.Directory import System.FilePath -import System.Info.Extra (isMac, isWindows) +import System.Info.Extra (isMac, isWindows) import qualified System.IO.Extra import System.IO.Temp -import System.Time.Extra (Seconds, sleep) -import Test.Tasty (TestTree) -import Test.Tasty.ExpectedFailure (expectFailBecause, - ignoreTestBecause) -import Test.Tasty.HUnit (Assertion, assertFailure, - (@?=)) +import System.Time.Extra (Seconds, sleep) +import Test.Tasty (TestTree) +import Test.Tasty.ExpectedFailure (expectFailBecause, + ignoreTestBecause) +import Test.Tasty.HUnit (assertFailure) + +import qualified Data.List as List +import qualified Data.Text.Internal.Search as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope) +import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..)) +import NeatInterpolation (trimming) noLiteralCaps :: ClientCapabilities noLiteralCaps = def & L.textDocument ?~ textDocumentCaps @@ -327,3 +338,119 @@ withCanonicalTempDir :: (FilePath -> IO a) -> IO a withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do dir' <- canonicalizePath dir f dir' + +-- ---------------------------------------------------------------------------- +-- Extract Position data from the source file itself. +-- ---------------------------------------------------------------------------- + +-- | Pretty labelling for tests that use the parameterised test helpers. +mkParameterisedLabel :: PosPrefixInfo -> String +mkParameterisedLabel posPrefixInfo = unlines + [ "Full Line: \"" <> T.unpack (fullLine posPrefixInfo) <> "\"" + , "Cursor Column: \"" <> replicate (fromIntegral $ cursorPos posPrefixInfo ^. L.character) ' ' ++ "^" <> "\"" + , "Prefix Text: \"" <> T.unpack (prefixText posPrefixInfo) <> "\"" + ] + +-- | Given a in-memory representation of a file, where a user can specify the +-- current cursor position using a '^' in the next line. +-- +-- This function allows to generate multiple tests for a single input file, without +-- the hassle of calculating by hand where there cursor is supposed to be. +-- +-- Example (line number has been added for readability): +-- +-- @ +-- 0: foo = 2 +-- 1: ^ +-- 2: bar = +-- 3: ^ +-- @ +-- +-- This example input file contains two cursor positions (y, x), at +-- +-- * (1, 1), and +-- * (3, 5). +-- +-- 'extractCursorPositions' will search for '^' characters, and determine there are +-- two cursor positions in the text. +-- First, it will normalise the text to: +-- +-- @ +-- 0: foo = 2 +-- 1: bar = +-- @ +-- +-- stripping away the '^' characters. Then, the actual cursor positions are: +-- +-- * (0, 1) and +-- * (2, 5). +-- +extractCursorPositions :: T.Text -> (T.Text, [PosPrefixInfo]) +extractCursorPositions t = + let + textLines = T.lines t + foldState = List.foldl' go emptyFoldState textLines + finalText = foldStateToText foldState + reconstructCompletionPrefix pos = getCompletionPrefixFromRope pos (Rope.fromText finalText) + cursorPositions = reverse . fmap reconstructCompletionPrefix $ foldStatePositions foldState + in + (finalText, cursorPositions) + + where + go foldState l = case T.indices "^" l of + [] -> addTextLine foldState l + xs -> List.foldl' addTextCursor foldState xs + +-- | 'FoldState' is an implementation detail used to parse some file contents, +-- extracting the cursor positions identified by '^' and producing a cleaned +-- representation of the file contents. +data FoldState = FoldState + { foldStateRows :: !Int + -- ^ The row index of the cleaned file contents. + -- + -- For example, the file contents + -- + -- @ + -- 0: foo + -- 1: ^ + -- 2: bar + -- @ + -- will report that 'bar' is actually occurring in line '1', as '^' is + -- a cursor position. + -- Lines containing cursor positions are removed. + , foldStatePositions :: ![Position] + -- ^ List of cursors positions found in the file contents. + -- + -- List is stored in reverse for efficient 'cons'ing + , foldStateFinalText :: ![T.Text] + -- ^ Final file contents with all lines containing cursor positions removed. + -- + -- List is stored in reverse for efficient 'cons'ing + } + +emptyFoldState :: FoldState +emptyFoldState = FoldState + { foldStateRows = 0 + , foldStatePositions = [] + , foldStateFinalText = [] + } + +-- | Produce the final file contents, without any lines containing cursor positions. +foldStateToText :: FoldState -> T.Text +foldStateToText state = T.unlines $ reverse $ foldStateFinalText state + +-- | We found a '^' at some location! Add it to the list of known cursor positions. +-- +-- If the row index is '0', we throw an error, as there can't be a cursor position above the first line. +addTextCursor :: FoldState -> Int -> FoldState +addTextCursor state col + | foldStateRows state <= 0 = error $ "addTextCursor: Invalid '^' found at: " <> show (col, foldStateRows state) + | otherwise = state + { foldStatePositions = Position (fromIntegral (foldStateRows state) - 1) (fromIntegral col) : foldStatePositions state + } + +addTextLine :: FoldState -> T.Text -> FoldState +addTextLine state l = state + { foldStateFinalText = l : foldStateFinalText state + , foldStateRows = foldStateRows state + 1 + } From 6e09f48e3ee32b0341ffdb308afa15b5fde0dbdb Mon Sep 17 00:00:00 2001 From: Fendor Date: Mon, 27 May 2024 21:42:30 +0200 Subject: [PATCH 2/2] 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. Further, we extend the known rules for the cabal plugin, to avoid expensive reparsing using `readFields`. Co-authored-by: VeryMilkyJoe --- haskell-language-server.cabal | 1 + .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 112 ++++++--- .../Plugin/Cabal/Completion/Completions.hs | 224 +++++++++--------- .../src/Ide/Plugin/Cabal/Completion/Types.hs | 52 +++- .../src/Ide/Plugin/Cabal/Diagnostics.hs | 22 +- .../src/Ide/Plugin/Cabal/Orphans.hs | 24 ++ .../src/Ide/Plugin/Cabal/Parse.hs | 31 ++- plugins/hls-cabal-plugin/test/Completer.hs | 2 +- plugins/hls-cabal-plugin/test/Context.hs | 187 ++++++++++----- 9 files changed, 427 insertions(+), 228 deletions(-) create mode 100644 plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 8d58d70a81..d2ecf58cab 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -241,6 +241,7 @@ library hls-cabal-plugin Ide.Plugin.Cabal.Completion.Data Ide.Plugin.Cabal.Completion.Types Ide.Plugin.Cabal.LicenseSuggest + Ide.Plugin.Cabal.Orphans Ide.Plugin.Cabal.Parse diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index c13ce9fe4a..c483ddc1d5 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -11,7 +11,7 @@ import Control.DeepSeq import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (runMaybeT) import qualified Data.ByteString as BS import Data.Hashable @@ -27,12 +27,17 @@ import Development.IDE.Graph (Key, alwaysRerun) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide import qualified Development.IDE.Plugin.Completions.Types as Ghcide import Development.IDE.Types.Shake (toKey) +import qualified Distribution.Fields as Syntax +import qualified Distribution.Parsec.Position as Syntax import GHC.Generics import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes import qualified Ide.Plugin.Cabal.Completion.Completions as Completions +import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..), + ParseCabalFile (..)) import qualified Ide.Plugin.Cabal.Completion.Types as Types import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest +import Ide.Plugin.Cabal.Orphans () import qualified Ide.Plugin.Cabal.Parse as Parse import Ide.Types import qualified Language.LSP.Protocol.Lens as JL @@ -70,7 +75,7 @@ instance Pretty Log where "Set files of interest to:" <+> viaShow files LogCompletionContext context position -> "Determined completion context:" - <+> viaShow context + <+> pretty context <+> "for cursor position:" <+> pretty position LogCompletions logs -> pretty logs @@ -145,30 +150,55 @@ cabalRules recorder plId = do -- Make sure we initialise the cabal files-of-interest. ofInterestRules recorder -- Rule to produce diagnostics for cabal files. - define (cmapWithPrio LogShake recorder) $ \Types.GetCabalDiagnostics file -> do + define (cmapWithPrio LogShake recorder) $ \ParseCabalFields file -> do config <- getPluginConfigAction plId if not (plcGlobalOn config && plcDiagnosticsOn config) - then pure ([], Nothing) - else do - -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), - -- we rerun this rule because this rule *depends* on GetModificationTime. - (t, mCabalSource) <- use_ GetFileContents file - log' Debug $ LogModificationTime file t - contents <- case mCabalSource of - Just sources -> - pure $ Encoding.encodeUtf8 sources - Nothing -> do - liftIO $ BS.readFile $ fromNormalizedFilePath file - - (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents - let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings - case pm of - Left (_cabalVersion, pErrorNE) -> do - let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE - allDiags = errorDiags <> warningDiags - pure (allDiags, Nothing) - Right gpd -> do - pure (warningDiags, Just gpd) + then pure ([], Nothing) + else do + -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), + -- we rerun this rule because this rule *depends* on GetModificationTime. + (t, mCabalSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalSource of + Just sources -> + pure $ Encoding.encodeUtf8 sources + Nothing -> do + liftIO $ BS.readFile $ fromNormalizedFilePath file + + case Parse.readCabalFields file contents of + Left _ -> + pure ([], Nothing) + Right fields -> + pure ([], Just fields) + + define (cmapWithPrio LogShake recorder) $ \ParseCabalFile file -> do + config <- getPluginConfigAction plId + if not (plcGlobalOn config && plcDiagnosticsOn config) + then pure ([], Nothing) + else do + -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), + -- we rerun this rule because this rule *depends* on GetModificationTime. + (t, mCabalSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalSource of + Just sources -> + pure $ Encoding.encodeUtf8 sources + Nothing -> do + liftIO $ BS.readFile $ fromNormalizedFilePath file + + -- Instead of fully reparsing the sources to get a 'GenericPackageDescription', + -- we would much rather re-use the already parsed results of 'ParseCabalFields'. + -- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription'' + -- which allows us to resume the parsing pipeline with '[Field Position]'. + (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents + let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings + case pm of + Left (_cabalVersion, pErrorNE) -> do + let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE + allDiags = errorDiags <> warningDiags + pure (allDiags, Nothing) + Right gpd -> do + pure (warningDiags, Just gpd) action $ do -- Run the cabal kick. This code always runs when 'shakeRestart' is run. @@ -188,7 +218,7 @@ function invocation. kick :: Action () kick = do files <- HashMap.keys <$> getCabalFilesOfInterestUntracked - void $ uses Types.GetCabalDiagnostics files + void $ uses Types.ParseCabalFile files -- ---------------------------------------------------------------- -- Code Actions @@ -281,24 +311,31 @@ completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.M completion recorder ide _ complParams = do let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument position = complParams ^. JL.position - contents <- lift $ getVirtualFile $ toNormalizedUri uri - case (contents, uriToFilePath' uri) of - (Just cnts, Just path) -> do - let pref = Ghcide.getCompletionPrefix position cnts - let res = result pref path cnts - liftIO $ fmap InL res - _ -> pure . InR $ InR Null + mVf <- lift $ getVirtualFile $ toNormalizedUri uri + case (,) <$> mVf <*> uriToFilePath' uri of + Just (cnts, path) -> do + mFields <- liftIO $ runIdeAction "cabal-plugin.fields" (shakeExtras ide) $ useWithStaleFast ParseCabalFields $ toNormalizedFilePath path + case mFields of + Nothing -> + pure . InR $ InR Null + Just (fields, _) -> do + let pref = Ghcide.getCompletionPrefix position cnts + let res = produceCompletions pref path fields + liftIO $ fmap InL res + Nothing -> pure . InR $ InR Null where - result :: Ghcide.PosPrefixInfo -> FilePath -> VFS.VirtualFile -> IO [CompletionItem] - result prefix fp cnts = do - runMaybeT context >>= \case + completerRecorder = cmapWithPrio LogCompletions recorder + + produceCompletions :: Ghcide.PosPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem] + produceCompletions prefix fp fields = do + runMaybeT (context fields) >>= \case Nothing -> pure [] Just ctx -> do logWith recorder Debug $ LogCompletionContext ctx pos let completer = Completions.contextToCompleter ctx let completerData = CompleterTypes.CompleterData { getLatestGPD = do - mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast Types.GetCabalDiagnostics $ toNormalizedFilePath fp + mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast ParseCabalFile $ toNormalizedFilePath fp pure $ fmap fst mGPD , cabalPrefixInfo = prefInfo , stanzaName = @@ -309,7 +346,6 @@ completion recorder ide _ complParams = do completions <- completer completerRecorder completerData pure completions where - completerRecorder = cmapWithPrio LogCompletions recorder pos = Ghcide.cursorPos prefix - context = Completions.getContext completerRecorder prefInfo (cnts ^. VFS.file_text) + context fields = Completions.getContext completerRecorder prefInfo fields prefInfo = Completions.getCabalPrefixInfo fp prefix diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs index 5bf0ef8838..6b3f3c9e45 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs @@ -4,17 +4,15 @@ module Ide.Plugin.Cabal.Completion.Completions (contextToCompleter, getContext, import Control.Lens ((^.)) import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Maybe -import Data.Foldable (asum) -import qualified Data.List as List -import Data.Map (Map) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Text as T -import qualified Data.Text.Utf16.Lines as Rope (Position (..)) -import Data.Text.Utf16.Rope.Mixed (Rope) -import qualified Data.Text.Utf16.Rope.Mixed as Rope +import qualified Data.Text.Encoding as T import Development.IDE as D import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import qualified Distribution.Fields as Syntax +import qualified Distribution.Parsec.Position as Syntax import Ide.Plugin.Cabal.Completion.Completer.Simple import Ide.Plugin.Cabal.Completion.Completer.Snippet import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) @@ -64,32 +62,13 @@ contextToCompleter (Stanza s _, KeyWord kw) = -- Can return Nothing if an error occurs. -- -- TODO: first line can only have cabal-version: keyword -getContext :: (MonadIO m) => Recorder (WithPriority Log) -> CabalPrefixInfo -> Rope -> MaybeT m Context -getContext recorder prefInfo ls = - case prevLinesM of - Just prevLines -> do - let lvlContext = - if completionIndentation prefInfo == 0 - then TopLevel - else currentLevel prevLines - case lvlContext of - TopLevel -> do - kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines (cabalVersionKeyword <> cabalKeywords) - pure (TopLevel, kwContext) - Stanza s n -> - case Map.lookup s stanzaKeywordMap of - Nothing -> do - pure (Stanza s n, None) - Just m -> do - kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines m - pure (Stanza s n, kwContext) - Nothing -> do - logWith recorder Warning $ LogFileSplitError pos - -- basically returns nothing - fail "Abort computation" +getContext :: (MonadIO m) => Recorder (WithPriority Log) -> CabalPrefixInfo -> [Syntax.Field Syntax.Position] -> m Context +getContext recorder prefInfo fields = do + let ctx = findCursorContext cursor (NE.singleton (0, TopLevel)) (completionPrefix prefInfo) fields + logWith recorder Debug $ LogCompletionContext ctx + pure ctx where - pos = completionCursorPosition prefInfo - prevLinesM = splitAtPosition pos ls + cursor = lspPositionToCabalPosition (completionCursorPosition prefInfo) -- | Takes information about the current file's file path, -- and the cursor position in the file; and builds a CabalPrefixInfo @@ -144,84 +123,111 @@ getCabalPrefixInfo fp prefixInfo = -- Implementation Details -- ---------------------------------------------------------------- --- | Takes prefix info about the previously written text, --- a list of lines (representing a file) and a map of --- keywords and returns a keyword context if the --- previously written keyword matches one in the map. +findCursorContext :: + Syntax.Position -> + -- ^ The cursor position we look for in the fields + NonEmpty (Int, StanzaContext) -> + -- ^ A stack of current stanza contexts and their starting line numbers + T.Text -> + -- ^ The cursor's prefix text + [Syntax.Field Syntax.Position] -> + -- ^ The fields to traverse + Context +findCursorContext cursor parentHistory prefixText fields = + case findFieldSection cursor fields of + Nothing -> (snd $ NE.head parentHistory, None) + -- We found the most likely section. Now, are we starting a new section or are we completing an existing one? + Just field@(Syntax.Field _ _) -> classifyFieldContext parentHistory cursor field + Just section@(Syntax.Section _ args sectionFields) + | inSameLineAsSectionName section -> (stanzaCtx, None) -- TODO: test whether keyword in same line is parsed correctly + | otherwise -> + findCursorContext cursor + (NE.cons (Syntax.positionCol (getAnnotation section) + 1, Stanza (getFieldName section) (getOptionalSectionName args)) parentHistory) + prefixText sectionFields + where + inSameLineAsSectionName section = Syntax.positionRow (getAnnotation section) == Syntax.positionRow cursor + stanzaCtx = snd $ NE.head parentHistory + +-- | Finds the cursor's context, where the cursor is already found to be in a specific field -- --- From a cursor position, we traverse the cabal file upwards to --- find the latest written keyword if there is any. --- Values may be written on subsequent lines, --- in order to allow for this we take the indentation of the current --- word to be completed into account to find the correct keyword context. -getKeyWordContext :: CabalPrefixInfo -> [T.Text] -> Map KeyWordName a -> Maybe FieldContext -getKeyWordContext prefInfo ls keywords = do - case lastNonEmptyLineM of - Nothing -> Just None - Just lastLine' -> do - let (whiteSpaces, lastLine) = T.span (== ' ') lastLine' - let keywordIndentation = T.length whiteSpaces - let cursorIndentation = completionIndentation prefInfo - -- in order to be in a keyword context the cursor needs - -- to be indented more than the keyword - if cursorIndentation > keywordIndentation - then -- if the last thing written was a keyword without a value - case List.find (`T.isPrefixOf` lastLine) (Map.keys keywords) of - Nothing -> Just None - Just kw -> Just $ KeyWord kw - else Just None +-- Due to the way the field context is recognised for incomplete cabal files, +-- an incomplete keyword is also recognised as a field, therefore we need to determine +-- the specific context as we could still be in a stanza context in this case. +classifyFieldContext :: NonEmpty (Int, StanzaContext) -> Syntax.Position -> Syntax.Field Syntax.Position -> Context +classifyFieldContext ctx cursor field + -- the cursor is not indented enough to be within the field + -- but still indented enough to be within the stanza + | cursorColumn <= fieldColumn && minIndent <= cursorColumn = (stanzaCtx, None) + -- the cursor is not in the current stanza's context as it is not indented enough + | cursorColumn < minIndent = findStanzaForColumn cursorColumn ctx + | cursorIsInFieldName = (stanzaCtx, None) + | cursorIsBeforeFieldName = (stanzaCtx, None) + | otherwise = (stanzaCtx, KeyWord (getFieldName field <> ":")) where - lastNonEmptyLineM :: Maybe T.Text - lastNonEmptyLineM = do - (curLine, rest) <- List.uncons ls - -- represents the current line while disregarding the - -- currently written text we want to complete - let cur = stripPartiallyWritten curLine - List.find (not . T.null . T.stripEnd) $ - cur : rest - --- | Traverse the given lines (starting before current cursor position --- up to the start of the file) to find the nearest stanza declaration, --- if none is found we are in the top level context. + (minIndent, stanzaCtx) = NE.head ctx + + cursorIsInFieldName = inSameLineAsFieldName && + fieldColumn <= cursorColumn && + cursorColumn <= fieldColumn + T.length (getFieldName field) + + cursorIsBeforeFieldName = inSameLineAsFieldName && + cursorColumn < fieldColumn + + inSameLineAsFieldName = Syntax.positionRow (getAnnotation field) == Syntax.positionRow cursor + + cursorColumn = Syntax.positionCol cursor + fieldColumn = Syntax.positionCol (getAnnotation field) + +-- ---------------------------------------------------------------- +-- Cabal-syntax utilities I don't really want to write myself +-- ---------------------------------------------------------------- + +-- | Determine the context of a cursor position within a stack of stanza contexts -- --- TODO: this could be merged with getKeyWordContext in order to increase --- performance by reducing the number of times we have to traverse the cabal file. -currentLevel :: [T.Text] -> StanzaContext -currentLevel [] = TopLevel -currentLevel (cur : xs) - | Just (s, n) <- stanza = Stanza s n - | otherwise = currentLevel xs - where - stanza = asum $ map checkStanza (Map.keys stanzaKeywordMap) - checkStanza :: StanzaType -> Maybe (StanzaType, Maybe StanzaName) - checkStanza t = - case T.stripPrefix t (T.strip cur) of - Just n - | T.null n -> Just (t, Nothing) - | otherwise -> Just (t, Just $ T.strip n) - Nothing -> Nothing - --- | Get all lines before the given cursor position in the given file --- and reverse their order to traverse backwards starting from the given position. -splitAtPosition :: Position -> Rope -> Maybe [T.Text] -splitAtPosition pos ls = do - split <- splitFile - pure $ reverse $ Rope.lines $ fst split - where - splitFile = Rope.utf16SplitAtPosition ropePos ls - ropePos = - Rope.Position - { Rope.posLine = fromIntegral $ pos ^. JL.line, - Rope.posColumn = fromIntegral $ pos ^. JL.character - } - --- | Takes a line of text and removes the last partially --- written word to be completed. -stripPartiallyWritten :: T.Text -> T.Text -stripPartiallyWritten = T.dropWhileEnd (\y -> (y /= ' ') && (y /= ':')) - --- | Calculates how many spaces the currently completed item is indented. -completionIndentation :: CabalPrefixInfo -> Int -completionIndentation prefInfo = fromIntegral (pos ^. JL.character) - (T.length $ completionPrefix prefInfo) +-- If the cursor is indented more than one of the stanzas in the stack +-- the respective stanza is returned if this is never the case, the toplevel stanza +-- in the stack is returned. +findStanzaForColumn :: Int -> NonEmpty (Int, StanzaContext) -> (StanzaContext, FieldContext) +findStanzaForColumn col ctx = case NE.uncons ctx of + ((_, stanza), Nothing) -> (stanza, None) + ((indentation, stanza), Just res) + | col < indentation -> findStanzaForColumn col res + | otherwise -> (stanza, None) + +-- | Determine the field the cursor is currently a part 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. +-- +-- TODO: we do not handle braces correctly. Add more tests! +findFieldSection :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe (Syntax.Field Syntax.Position) +findFieldSection _cursor [] = Nothing +findFieldSection _cursor [x] = + -- Last field. We decide later, whether we are starting + -- a new section. + Just x +findFieldSection cursor (x:y:ys) + | Syntax.positionRow (getAnnotation x) <= cursorLine && cursorLine < Syntax.positionRow (getAnnotation y) + = Just x + | otherwise = findFieldSection cursor (y:ys) where - pos = completionCursorPosition prefInfo + cursorLine = Syntax.positionRow cursor + +type FieldName = T.Text + +getAnnotation :: Syntax.Field ann -> ann +getAnnotation (Syntax.Field (Syntax.Name ann _) _) = ann +getAnnotation (Syntax.Section (Syntax.Name ann _) _ _) = ann + +getFieldName :: Syntax.Field ann -> FieldName +getFieldName (Syntax.Field (Syntax.Name _ fn) _) = T.decodeUtf8 fn +getFieldName (Syntax.Section (Syntax.Name _ fn) _ _) = T.decodeUtf8 fn + +getOptionalSectionName :: [Syntax.SectionArg ann] -> Maybe T.Text +getOptionalSectionName [] = Nothing +getOptionalSectionName (x:xs) = case x of + Syntax.SecArgName _ name -> Just (T.decodeUtf8 name) + _ -> getOptionalSectionName xs diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs index ecb50f9ae3..c39362e826 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs @@ -4,13 +4,17 @@ module Ide.Plugin.Cabal.Completion.Types where -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) +import Control.Lens ((^.)) import Data.Hashable -import qualified Data.Text as T +import qualified Data.Text as T import Data.Typeable -import Development.IDE as D +import Development.IDE as D +import qualified Distribution.Fields as Syntax +import qualified Distribution.PackageDescription as PD +import qualified Distribution.Parsec.Position as Syntax import GHC.Generics -import qualified Ide.Plugin.Cabal.Parse as Parse +import qualified Language.LSP.Protocol.Lens as JL data Log = LogFileSplitError Position @@ -21,6 +25,7 @@ data Log | LogFilePathCompleterIOError FilePath IOError | LogUseWithStaleFastNoResult | LogMapLookUpOfKnownKeyFailed T.Text + | LogCompletionContext Context deriving (Show) instance Pretty Log where @@ -34,15 +39,25 @@ instance Pretty Log where "When trying to complete the file path:" <+> pretty fp <+> "the following unexpected IO error occurred" <+> viaShow ioErr LogUseWithStaleFastNoResult -> "Package description couldn't be read" LogMapLookUpOfKnownKeyFailed key -> "Lookup of key in map failed even though it should exist" <+> pretty key + LogCompletionContext ctx -> "Completion context is:" <+> pretty ctx -type instance RuleResult GetCabalDiagnostics = Parse.GenericPackageDescription +type instance RuleResult ParseCabalFile = PD.GenericPackageDescription -data GetCabalDiagnostics = GetCabalDiagnostics +data ParseCabalFile = ParseCabalFile deriving (Eq, Show, Typeable, Generic) -instance Hashable GetCabalDiagnostics +instance Hashable ParseCabalFile -instance NFData GetCabalDiagnostics +instance NFData ParseCabalFile + +type instance RuleResult ParseCabalFields = [Syntax.Field Syntax.Position] + +data ParseCabalFields = ParseCabalFields + deriving (Eq, Show, Typeable, Generic) + +instance Hashable ParseCabalFields + +instance NFData ParseCabalFields -- | The context a cursor can be in within a cabal file. -- @@ -61,9 +76,13 @@ data StanzaContext -- Stanzas have their own fields which differ from top-level fields. -- Each stanza must be named, such as 'executable exe', -- except for the main library. - Stanza StanzaType (Maybe StanzaName) + Stanza !StanzaType !(Maybe StanzaName) deriving (Eq, Show, Read) +instance Pretty StanzaContext where + pretty TopLevel = "TopLevel" + pretty (Stanza t ms) = "Stanza" <+> pretty t <+> (maybe mempty pretty ms) + -- | Keyword context in a cabal file. -- -- Used to decide whether to suggest values or keywords. @@ -71,12 +90,16 @@ data FieldContext = -- | Key word context, where a keyword -- occurs right before the current word -- to be completed - KeyWord KeyWordName + KeyWord !KeyWordName | -- | Keyword context where no keyword occurs -- right before the current word to be completed None deriving (Eq, Show, Read) +instance Pretty FieldContext where + pretty (KeyWord kw) = "KeyWord" <+> pretty kw + pretty None = "No Keyword" + type KeyWordName = T.Text type StanzaName = T.Text @@ -139,3 +162,12 @@ applyStringNotation (Just LeftSide) compl = compl <> "\"" applyStringNotation Nothing compl | Just _ <- T.find (== ' ') compl = "\"" <> compl <> "\"" | otherwise = compl + +-- | Convert an LSP 'Position' to a 'Syntax.Position'. +-- +-- Cabal Positions start their indexing at 1 while LSP starts at 0. +-- This helper makes sure, the translation is done properly. +lspPositionToCabalPosition :: Position -> Syntax.Position +lspPositionToCabalPosition pos = Syntax.Position + (fromIntegral (pos ^. JL.line) + 1) + (fromIntegral (pos ^. JL.character) + 1) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs index 00033747db..26156c5131 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -4,6 +4,7 @@ module Ide.Plugin.Cabal.Diagnostics ( errorDiagnostic , warningDiagnostic , positionFromCabalPosition +, fatalParseErrorDiagnostic -- * Re-exports , FileDiagnostic , Diagnostic(..) @@ -14,7 +15,7 @@ import qualified Data.Text as T import Development.IDE (FileDiagnostic, ShowDiagnostic (ShowDiag)) import Distribution.Fields (showPError, showPWarning) -import qualified Ide.Plugin.Cabal.Parse as Lib +import qualified Distribution.Parsec as Syntax import Ide.PluginUtils (extendNextLine) import Language.LSP.Protocol.Types (Diagnostic (..), DiagnosticSeverity (..), @@ -23,16 +24,21 @@ import Language.LSP.Protocol.Types (Diagnostic (..), Range (Range), fromNormalizedFilePath) +-- | Produce a diagnostic for a fatal Cabal parser error. +fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic +fatalParseErrorDiagnostic fp msg = + mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine Syntax.zeroPos) msg + -- | Produce a diagnostic from a Cabal parser error -errorDiagnostic :: NormalizedFilePath -> Lib.PError -> FileDiagnostic -errorDiagnostic fp err@(Lib.PError pos _) = +errorDiagnostic :: NormalizedFilePath -> Syntax.PError -> FileDiagnostic +errorDiagnostic fp err@(Syntax.PError pos _) = mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg where msg = T.pack $ showPError (fromNormalizedFilePath fp) err -- | Produce a diagnostic from a Cabal parser warning -warningDiagnostic :: NormalizedFilePath -> Lib.PWarning -> FileDiagnostic -warningDiagnostic fp warning@(Lib.PWarning _ pos _) = +warningDiagnostic :: NormalizedFilePath -> Syntax.PWarning -> FileDiagnostic +warningDiagnostic fp warning@(Syntax.PWarning _ pos _) = mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg where msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning @@ -41,7 +47,7 @@ warningDiagnostic fp warning@(Lib.PWarning _ pos _) = -- only a single source code 'Lib.Position'. -- We define the range to be _from_ this position -- _to_ the first column of the next line. -toBeginningOfNextLine :: Lib.Position -> Range +toBeginningOfNextLine :: Syntax.Position -> Range toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos where pos = positionFromCabalPosition cabalPos @@ -53,8 +59,8 @@ toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos -- -- >>> positionFromCabalPosition $ Lib.Position 1 1 -- Position 0 0 -positionFromCabalPosition :: Lib.Position -> Position -positionFromCabalPosition (Lib.Position line column) = Position (fromIntegral line') (fromIntegral col') +positionFromCabalPosition :: Syntax.Position -> Position +positionFromCabalPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col') where -- LSP is zero-based, Cabal is one-based line' = line-1 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs new file mode 100644 index 0000000000..2264d5390f --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Ide.Plugin.Cabal.Orphans where +import Control.DeepSeq +import Distribution.Fields.Field +import Distribution.Parsec.Position + +-- ---------------------------------------------------------------- +-- Cabal-syntax orphan instances we need sometimes +-- ---------------------------------------------------------------- + +instance NFData (Field Position) where + rnf (Field name fieldLines) = rnf name `seq` rnf fieldLines + rnf (Section name sectionArgs fields) = rnf name `seq` rnf sectionArgs `seq` rnf fields + +instance NFData (Name Position) where + rnf (Name ann fName) = rnf ann `seq` rnf fName + +instance NFData (FieldLine Position) where + rnf (FieldLine ann bs) = rnf ann `seq` rnf bs + +instance NFData (SectionArg Position) where + rnf (SecArgName ann bs) = rnf ann `seq` rnf bs + rnf (SecArgStr ann bs) = rnf ann `seq` rnf bs + rnf (SecArgOther ann bs) = rnf ann `seq` rnf bs diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs index 28700c5104..e949af1b1d 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs @@ -1,13 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Cabal.Parse ( parseCabalFileContents - -- * Re-exports -, FilePath -, NonEmpty(..) -, PWarning(..) -, Version -, PError(..) -, Position(..) -, GenericPackageDescription(..) +, readCabalFields ) where import qualified Data.ByteString as BS @@ -16,12 +10,31 @@ import Distribution.Fields (PError (..), PWarning (..)) import Distribution.Fields.ParseResult (runParseResult) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) -import Distribution.Parsec.Position (Position (..)) import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..)) import Distribution.Types.Version (Version) +import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics + +import qualified Data.Text as T +import Development.IDE +import qualified Distribution.Fields.Parser as Syntax +import qualified Distribution.Parsec.Position as Syntax + parseCabalFileContents :: BS.ByteString -- ^ UTF-8 encoded bytestring -> IO ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription) parseCabalFileContents bs = pure $ runParseResult (parseGenericPackageDescription bs) + +readCabalFields :: + NormalizedFilePath -> + BS.ByteString -> + Either FileDiagnostic [Syntax.Field Syntax.Position] +readCabalFields file contents = do + case Syntax.readFields' contents of + Left parseError -> + Left $ Diagnostics.fatalParseErrorDiagnostic file + $ "Failed to parse cabal file: " <> T.pack (show parseError) + Right (fields, _warnings) -> do + -- we don't want to double report diagnostics, all diagnostics are produced by 'ParseCabalFile'. + Right fields diff --git a/plugins/hls-cabal-plugin/test/Completer.hs b/plugins/hls-cabal-plugin/test/Completer.hs index 80da8c53e6..4d87bae01d 100644 --- a/plugins/hls-cabal-plugin/test/Completer.hs +++ b/plugins/hls-cabal-plugin/test/Completer.hs @@ -9,6 +9,7 @@ import qualified Data.ByteString as ByteString import Data.Maybe (mapMaybe) import qualified Data.Text as T import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) import Ide.Plugin.Cabal.Completion.Completer.FilePath import Ide.Plugin.Cabal.Completion.Completer.Module @@ -17,7 +18,6 @@ import Ide.Plugin.Cabal.Completion.Completer.Types (CompleterData ( import Ide.Plugin.Cabal.Completion.Completions import Ide.Plugin.Cabal.Completion.Types (CabalPrefixInfo (..), StanzaName) -import Ide.Plugin.Cabal.Parse (GenericPackageDescription) import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls diff --git a/plugins/hls-cabal-plugin/test/Context.hs b/plugins/hls-cabal-plugin/test/Context.hs index badc9263c0..e9e090c310 100644 --- a/plugins/hls-cabal-plugin/test/Context.hs +++ b/plugins/hls-cabal-plugin/test/Context.hs @@ -1,18 +1,20 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Context where -import Control.Monad.Trans.Maybe (runMaybeT) import qualified Data.Text as T -import qualified Data.Text.Utf16.Rope.Mixed as Rope +import qualified Data.Text.Encoding as Text +import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..)) import Ide.Plugin.Cabal import Ide.Plugin.Cabal.Completion.Completer.Paths import Ide.Plugin.Cabal.Completion.Completions import Ide.Plugin.Cabal.Completion.Types (Context, FieldContext (KeyWord, None), StanzaContext (Stanza, TopLevel)) +import qualified Ide.Plugin.Cabal.Parse as Parse import Test.Hls import Utils as T @@ -22,7 +24,7 @@ cabalPlugin = mkPluginTestDescriptor descriptor "cabal context" contextTests :: TestTree contextTests = testGroup - "Context Tests " + "Context Tests" [ pathCompletionInfoFromCompletionContextTests , getContextTests ] @@ -58,39 +60,39 @@ pathCompletionInfoFromCompletionContextTests = getContextTests :: TestTree getContextTests = testGroup - "Context Tests" + "Context Tests Real" [ testCase "Empty File - Start" $ do -- for a completely empty file, the context needs to -- be top level without a specified keyword - ctx <- callGetContext (Position 0 0) "" [""] + ctx <- callGetContext (Position 0 0) "" "" ctx @?= (TopLevel, None) , testCase "Cabal version keyword - no value, no space after :" $ do -- on a file, where the keyword is already written -- the context should still be toplevel but the keyword should be recognized - ctx <- callGetContext (Position 0 14) "" ["cabal-version:"] + ctx <- callGetContext (Position 0 14) "" "cabal-version:\n" ctx @?= (TopLevel, KeyWord "cabal-version:") , testCase "Cabal version keyword - cursor in keyword" $ do -- on a file, where the keyword is already written -- but the cursor is in the middle of the keyword, -- we are not in a keyword context - ctx <- callGetContext (Position 0 5) "cabal" ["cabal-version:"] + ctx <- callGetContext (Position 0 5) "cabal" "cabal-version:\n" ctx @?= (TopLevel, None) , testCase "Cabal version keyword - no value, many spaces" $ do -- on a file, where the "cabal-version:" keyword is already written -- the context should still be top level but the keyword should be recognized - ctx <- callGetContext (Position 0 45) "" ["cabal-version:" <> T.replicate 50 " "] + ctx <- callGetContext (Position 0 45) "" ("cabal-version:" <> T.replicate 50 " " <> "\n") ctx @?= (TopLevel, KeyWord "cabal-version:") , testCase "Cabal version keyword - keyword partly written" $ do -- in the first line of the file, if the keyword -- has not been written completely, the keyword context -- should still be None - ctx <- callGetContext (Position 0 5) "cabal" ["cabal"] + ctx <- callGetContext (Position 0 5) "cabal" "cabal" ctx @?= (TopLevel, None) , testCase "Cabal version keyword - value partly written" $ do -- in the first line of the file, if the keyword -- has not been written completely, the keyword context -- should still be None - ctx <- callGetContext (Position 0 17) "1." ["cabal-version: 1."] + ctx <- callGetContext (Position 0 17) "1." "cabal-version: 1." ctx @?= (TopLevel, KeyWord "cabal-version:") , testCase "Inside Stanza - no keyword" $ do -- on a file, where the library stanza has been defined @@ -102,14 +104,15 @@ getContextTests = -- has been defined, the keyword and stanza should be recognized ctx <- callGetContext (Position 4 21) "" libraryStanzaData ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:") - , expectFailBecause "While not valid, it is not that important to make the code more complicated for this" $ - testCase "Cabal version keyword - no value, next line" $ do - -- if the cabal version keyword has been written but without a value, - -- in the next line we still should be in top level context with no keyword - -- since the cabal version keyword and value pair need to be in the same line - ctx <- callGetContext (Position 1 2) "" ["cabal-version:", ""] - ctx @?= (TopLevel, None) - , testCase "Non-cabal-version keyword - no value, next line indentented position" $ do + , testCase "Cabal version keyword - no value, next line" $ do + -- if the cabal version keyword has been written but without a value, + -- in the next line we still should be in top level context with no keyword + -- since the cabal version keyword and value pair need to be in the same line. + -- However, that's too much work to implement for virtually no benefit, so we + -- test here the status-quo is satisfied. + ctx <- callGetContext (Position 1 2) "" "cabal-version:\n\n" + ctx @?= (TopLevel, KeyWord "cabal-version:") + , testCase "Non-cabal-version keyword - no value, next line indented position" $ do -- if a keyword, other than the cabal version keyword has been written -- with no value, in the next line we still should be in top level keyword context -- of the keyword with no value, since its value may be written in the next line @@ -153,46 +156,124 @@ getContextTests = ctx @?= (TopLevel, KeyWord "name:") , testCase "Named Stanza" $ do ctx <- callGetContext (Position 2 18) "" executableStanzaData - ctx @?= (Stanza "executable" (Just "exeName"), None) + ctx @?= (TopLevel, None) + , testCase "Multi line, finds context in same line" $ do + ctx <- callGetContext (Position 5 18) "" multiLineOptsData + ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:") + , testCase "Multi line, in the middle of option" $ do + ctx <- callGetContext (Position 6 11) "" multiLineOptsData + ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:") + , testCase "Multi line, finds context in between lines" $ do + ctx <- callGetContext (Position 7 8) "" multiLineOptsData + ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:") + , testCase "Multi line, finds context in between lines, start if line" $ do + ctx <- callGetContext (Position 7 0) "" multiLineOptsData + ctx @?= (TopLevel, None) + , testCase "Multi line, end of option" $ do + ctx <- callGetContext (Position 8 14) "" multiLineOptsData + ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:") + , parameterisedCursorTest "Contexts in large testfile" multiPositionTestData + [ (TopLevel, None) + , (TopLevel, KeyWord "cabal-version:") + , (TopLevel, None) + , (TopLevel, KeyWord "description:") + , (TopLevel, KeyWord "extra-source-files:") + , (TopLevel, None) + -- this might not be what we want, maybe add another Context + , (TopLevel, None) + -- this might not be what we want, maybe add another Context + , (TopLevel, None) + , (Stanza "source-repository" (Just "head"), None) + , (Stanza "source-repository" (Just "head"), KeyWord "type:") + , (Stanza "source-repository" (Just "head"), KeyWord "type:") + , (Stanza "source-repository" (Just "head"), KeyWord "type:") + , (Stanza "source-repository" (Just "head"), None) + ] + $ \fileContent posPrefInfo -> + callGetContext (cursorPos posPrefInfo) (prefixText posPrefInfo) fileContent ] where - callGetContext :: Position -> T.Text -> [T.Text] -> IO Context + callGetContext :: Position -> T.Text -> T.Text -> IO Context callGetContext pos pref ls = do - runMaybeT (getContext mempty (simpleCabalPrefixInfoFromPos pos pref) (Rope.fromText $ T.unlines ls)) - >>= \case - Nothing -> assertFailure "Context must be found" - Just ctx -> pure ctx + case Parse.readCabalFields "not-real" (Text.encodeUtf8 ls) of + Left err -> fail $ show err + Right fields -> do + getContext mempty (simpleCabalPrefixInfoFromPos pos pref) fields -- ------------------------------------------------------------------------ -- Test Data -- ------------------------------------------------------------------------ -libraryStanzaData :: [T.Text] -libraryStanzaData = - [ "cabal-version: 3.0" - , "name: simple-cabal" - , "library " - , " default-language: Haskell98" - , " build-depends: " - , " " - , "ma " - ] - -executableStanzaData :: [T.Text] -executableStanzaData = - [ "cabal-version: 3.0" - , "name: simple-cabal" - , "executable exeName" - , " default-language: Haskell2010" - , " hs-source-dirs: test/preprocessor" - ] - -topLevelData :: [T.Text] -topLevelData = - [ "cabal-version: 3.0" - , "name:" - , "" - , "" - , "" - , " eee" - ] +libraryStanzaData :: T.Text +libraryStanzaData = [trimming| +cabal-version: 3.0 +name: simple-cabal +library + default-language: Haskell98 + build-depends: + +ma +|] + +executableStanzaData :: T.Text +executableStanzaData = [trimming| +cabal-version: 3.0 +name: simple-cabal +executable exeName + default-language: Haskell2010 + hs-source-dirs: test/preprocessor +|] + +topLevelData :: T.Text +topLevelData = [trimming| +cabal-version: 3.0 +name: + + + + eee +|] + +multiLineOptsData :: T.Text +multiLineOptsData = [trimming| +cabal-version: 3.0 +name: + + +library + build-depends: + base, + + text , +|] + +multiPositionTestData :: T.Text +multiPositionTestData = [trimming| +cabal-version: 3.4 + ^ ^ +category: Development +^ +name: haskell-language-server +description: + Please see the README on GitHub at + ^ +extra-source-files: + README.md + ChangeLog.md + test/testdata/**/*.project + test/testdata/**/*.cabal + test/testdata/**/*.yaml + test/testdata/**/*.hs + test/testdata/**/*.json + ^ + -- These globs should only match test/testdata + plugins/**/*.project + +source-repository head + ^ ^ ^ + type: git + ^ ^ ^ ^ + location: https://github.com/haskell/haskell-language-server + + ^ +|]