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/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/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 + } 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 + + ^ +|]