diff --git a/.gitmodules b/.gitmodules index 7856aaec36..49b0b3c940 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,3 +8,7 @@ # Commit git commit -m "Removed submodule " # Delete the now untracked submodule files # rm -rf path_to_submodule + +[submodule "vendor/cabal"] + path = vendor/cabal + url = https://github.com/rm41339/cabal.git diff --git a/cabal.project b/cabal.project index a795f0126b..0315ff65a8 100644 --- a/cabal.project +++ b/cabal.project @@ -6,7 +6,16 @@ packages: ./ghcide ./hls-plugin-api ./hls-test-utils + ./vendor/cabal/Cabal + ./vendor/cabal/Cabal-syntax + ./vendor/cabal/cabal-install + ./vendor/cabal/cabal-install-solver + ./vendor/cabal/Cabal-described + ./vendor/cabal/Cabal-tree-diff +package cabal-install + tests: False + benchmarks: False index-state: 2025-05-12T13:26:29Z diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 157f5703f2..e486205f98 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -317,6 +317,90 @@ test-suite hls-cabal-plugin-tests , text , hls-plugin-api +----------------------------- +-- cabal project plugin +----------------------------- + +flag cabalProject + description: Enable cabalProject plugin + default: True + manual: True + +common cabalProject + if flag(cabalProject) + build-depends: haskell-language-server:hls-cabal-project-plugin + cpp-options: -Dhls_cabal_project + +library hls-cabal-project-plugin + import: defaults, pedantic, warnings + if !flag(cabalProject) + buildable: False + exposed-modules: + Ide.Plugin.CabalProject + Ide.Plugin.CabalProject.Parse + Ide.Plugin.CabalProject.Diagnostics + Ide.Plugin.CabalProject.Types + Ide.Plugin.CabalProject.Completion.Completions + Ide.Plugin.CabalProject.Completion.Data + + build-depends: + , bytestring + , Cabal-syntax >= 3.7 + , containers + , deepseq + , directory + , filepath + , extra >=1.7.4 + , ghcide == 2.11.0.0 + , hashable + , hls-plugin-api == 2.11.0.0 + , hls-graph == 2.11.0.0 + , lens + , lsp ^>=2.7 + , lsp-types ^>=2.3 + , regex-tdfa ^>=1.3.1 + , text + , text-rope + , transformers + , unordered-containers >=0.2.10.0 + , containers + , process + , aeson + , Cabal + , pretty + , cabal-install + , cabal-install-solver + , haskell-language-server:hls-cabal-plugin + , base16-bytestring + , cryptohash-sha1 + + hs-source-dirs: plugins/hls-cabal-project-plugin/src + +test-suite hls-cabal-project-plugin-tests + import: defaults, pedantic, test-defaults, warnings + if !flag(cabalProject) + buildable: False + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-cabal-project-plugin/test + main-is: Main.hs + other-modules: + Completer + Utils + build-depends: + , bytestring + , Cabal-syntax >= 3.7 + , extra + , filepath + , ghcide + , haskell-language-server:hls-cabal-project-plugin + , hls-test-utils == 2.11.0.0 + , lens + , lsp-types + , text + , hls-plugin-api + , cabal-install + , haskell-language-server:hls-cabal-plugin + ----------------------------- -- class plugin ----------------------------- @@ -1830,6 +1914,7 @@ library , pedantic -- plugins , cabal + , cabalProject , callHierarchy , cabalfmt , cabalgild diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 3a06656a77..6e7dd7102f 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -14,7 +14,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} module Ide.Types -( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor +( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor, defaultCabalProjectPluginDescriptor , defaultPluginPriority , describePlugin , IdeCommand(..) @@ -1077,6 +1077,21 @@ defaultCabalPluginDescriptor plId desc = Nothing [".cabal"] +defaultCabalProjectPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState +defaultCabalProjectPluginDescriptor plId desc = + PluginDescriptor + plId + desc + defaultPluginPriority + mempty + mempty + mempty + defaultConfigDescriptor + mempty + mempty + Nothing + [".project"] + newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) instance IsString CommandId where 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 5429ac0bb9..3650ac5a25 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -5,6 +5,8 @@ module Ide.Plugin.Cabal.Diagnostics , warningDiagnostic , positionFromCabalPosition , fatalParseErrorDiagnostic +, toBeginningOfNextLine +, mkDiag -- * Re-exports , FileDiagnostic , Diagnostic(..) diff --git a/plugins/hls-cabal-plugin/test/testdata/completer.cabal b/plugins/hls-cabal-plugin/test/testdata/completer.cabal index 141bdd7d2d..f72e1dccb7 100644 --- a/plugins/hls-cabal-plugin/test/testdata/completer.cabal +++ b/plugins/hls-cabal-plugin/test/testdata/completer.cabal @@ -11,4 +11,4 @@ be library lib -co \ No newline at end of file +co diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs new file mode 100644 index 0000000000..79854b4ac0 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.CabalProject where + +import Control.Concurrent.Strict +import Control.DeepSeq +import Control.Lens ((^.)) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe (runMaybeT) +import qualified Data.ByteString as BS +import Data.Hashable +import Data.HashMap.Strict (HashMap) + -- toList) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List.NonEmpty as NE +import Data.Proxy +import qualified Data.Text () +import qualified Data.Text.Encoding as Encoding +import Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE as D +import Development.IDE.Core.Shake (restartShakeSession) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Graph (Key, + alwaysRerun) +import qualified Development.IDE.Plugin.Completions.Logic as Ghcide +import Development.IDE.Types.Shake (toKey) +import qualified Distribution.Fields as Syntax +-- import Distribution.PackageDescription (allBuildDepends, +-- depPkgName, +-- unPackageName) +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.Types as CTypes +import Ide.Plugin.Cabal.Orphans () +import qualified Ide.Plugin.CabalProject.Completion.Completions as Completions +import Ide.Plugin.CabalProject.Diagnostics as Diagnostics +import Ide.Plugin.CabalProject.Parse as Parse +import Ide.Plugin.CabalProject.Types as Types +import Ide.Types +import qualified Language.LSP.Protocol.Lens as JL +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import qualified Language.LSP.VFS as VFS + +data Log + = LogModificationTime NormalizedFilePath FileVersion + | LogShake Shake.Log + | LogDocOpened Uri + | LogDocModified Uri + | LogDocSaved Uri + | LogDocClosed Uri + | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) + | LogCompletionContext CTypes.Context Position + | LogCompletions CTypes.Log + deriving (Show) + +instance Pretty Log where + pretty = \case + LogShake log' -> pretty log' + LogModificationTime nfp modTime -> + "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime) + LogDocOpened uri -> + "Opened text document:" <+> pretty (getUri uri) + LogDocModified uri -> + "Modified text document:" <+> pretty (getUri uri) + LogDocSaved uri -> + "Saved text document:" <+> pretty (getUri uri) + LogDocClosed uri -> + "Closed text document:" <+> pretty (getUri uri) + LogFOI files -> + "Set files of interest to:" <+> viaShow files + LogCompletionContext context position -> + "Determined completion context:" + <+> pretty context + <+> "for cursor position:" + <+> pretty position + LogCompletions logs -> pretty logs + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultCabalProjectPluginDescriptor plId "Provides a variety of IDE features in cabal.project files") + { pluginRules = cabalProjectRules recorder plId + , pluginHandlers = + mconcat + [ + mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder + ] + , pluginNotificationHandlers = + mconcat + [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ + \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocOpened _uri + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(opened)" $ + addFileOfInterest recorder ide file Modified{firstOpen = True} + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ + \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file-> do + log' Debug $ LogDocModified _uri + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(changed)" $ + addFileOfInterest recorder ide file Modified{firstOpen = False} + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ + \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocSaved _uri + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(saved)" $ + addFileOfInterest recorder ide file OnDisk + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ + \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocClosed _uri + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(closed)" $ + deleteFileOfInterest recorder ide file + ] + , pluginConfigDescriptor = defaultConfigDescriptor + { configHasDiagnostics = True + } + } + where + log' = logWith recorder + + whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () + whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' + +{- | Helper function to restart the shake session, specifically for modifying cabal.project files. +No special logic, just group up a bunch of functions you need for the base +Notification Handlers. + +To make sure diagnostics are up to date, we need to tell shake that the file was touched and +needs to be re-parsed. That's what we do when we record the dirty key that our parsing +rule depends on. +Then we restart the shake session, so that changes to our virtual files are actually picked up. +-} +restartCabalProjectShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () +restartCabalProjectShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + keys <- actionBetweenSession + return (toKey GetModificationTime file:keys) + + +cabalProjectRules :: Recorder (WithPriority Log) -> PluginId -> Rules () +cabalProjectRules recorder plId = do + -- Make sure we initialise the cabal.project files-of-interest. + ofInterestRules recorder + -- Rule to produce diagnostics for cabal.project files. + define (cmapWithPrio LogShake recorder) $ \ParseCabalProjectFields 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, mCabalProjectSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalProjectSource of + Just sources -> + pure $ Encoding.encodeUtf8 $ Rope.toText sources + Nothing -> do + liftIO $ BS.readFile $ fromNormalizedFilePath file + + case Parse.readCabalProjectFields file contents of + Left _ -> + pure ([], Nothing) + Right fields -> + pure ([], Just fields) + + define (cmapWithPrio LogShake recorder) $ \ParseCabalProjectFile file -> do + cfg <- getPluginConfigAction plId + if not (plcGlobalOn cfg && plcDiagnosticsOn cfg) + 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, mCabalProjectSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + + contents <- case mCabalProjectSource of + Just sources -> + pure $ Encoding.encodeUtf8 $ Rope.toText sources + Nothing -> + liftIO $ BS.readFile $ fromNormalizedFilePath file + + (pWarnings, pResult) <- liftIO $ Parse.parseCabalProjectFileContents (fromNormalizedFilePath file) contents + let warnDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings + + case pResult of + Left (_specVer, pErrNE) -> do + let errDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrNE + pure (errDiags ++ warnDiags, Nothing) + + Right projCfg -> do + pure (warnDiags, Just projCfg) + + action $ do + -- Run the cabal.project kick. This code always runs when 'shakeRestart' is run. + -- Must be careful to not impede the performance too much. Crucial to + -- a snappy IDE experience. + kick + where + log' = logWith recorder + +{- | This is the kick function for the cabal project plugin. +We run this action, whenever we shake session us run/restarted, which triggers +actions to produce diagnostics for cabal.project files. + +It is paramount that this kick-function can be run quickly, since it is a blocking +function invocation. +-} +kick :: Action () +kick = do + files <- HashMap.keys <$> getCabalProjectFilesOfInterestUntracked +-- let keys = map Types.ParseCabalProjectFile files + Shake.runWithSignal (Proxy @"kick/start/cabal-project") (Proxy @"kick/done/cabal-project") files Types.ParseCabalProjectFile + + +-- ---------------------------------------------------------------- +-- Cabal.project file of Interest rules and global variable +-- ---------------------------------------------------------------- + +{- | Cabal.project files that are currently open in the lsp-client. +Specific actions happen when these files are saved, closed or modified, +such as generating diagnostics, re-parsing, etc... + +We need to store the open files to parse them again if we restart the shake session. +Restarting of the shake session happens whenever these files are modified. +-} +newtype OfInterestCabalProjectVar = OfInterestCabalProjectVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) + +instance Shake.IsIdeGlobal OfInterestCabalProjectVar + +data IsCabalProjectFileOfInterest = IsCabalProjectFileOfInterest + deriving (Eq, Show, Generic) +instance Hashable IsCabalProjectFileOfInterest +instance NFData IsCabalProjectFileOfInterest + +type instance RuleResult IsCabalProjectFileOfInterest = CabalProjectFileOfInterestResult + +data CabalProjectFileOfInterestResult = NotCabalProjectFOI | IsCabalProjectFOI FileOfInterestStatus + deriving (Eq, Show, Generic) +instance Hashable CabalProjectFileOfInterestResult +instance NFData CabalProjectFileOfInterestResult + +{- | The rule that initialises the files of interest state. + +Needs to be run on start-up. +-} +ofInterestRules :: Recorder (WithPriority Log) -> Rules () +ofInterestRules recorder = do + Shake.addIdeGlobal . OfInterestCabalProjectVar =<< liftIO (newVar HashMap.empty) + Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalProjectFileOfInterest f -> do + alwaysRerun + filesOfInterest <- getCabalProjectFilesOfInterestUntracked + let foi = maybe NotCabalProjectFOI IsCabalProjectFOI $ f `HashMap.lookup` filesOfInterest + fp = summarize foi + res = (Just fp, Just foi) + return res + where + summarize NotCabalProjectFOI = BS.singleton 0 + summarize (IsCabalProjectFOI OnDisk) = BS.singleton 1 + summarize (IsCabalProjectFOI (Modified False)) = BS.singleton 2 + summarize (IsCabalProjectFOI (Modified True)) = BS.singleton 3 + +getCabalProjectFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) +getCabalProjectFilesOfInterestUntracked = do + OfInterestCabalProjectVar var <- Shake.getIdeGlobalAction + liftIO $ readVar var + +addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] +addFileOfInterest recorder state f v = do + OfInterestCabalProjectVar var <- Shake.getIdeGlobalState state + (prev, files) <- modifyVar var $ \dict -> do + let (prev, new) = HashMap.alterF (,Just v) f dict + pure (new, (prev, new)) + if prev /= Just v + then do + log' Debug $ LogFOI files + return [toKey IsCabalProjectFileOfInterest f] + else return [] + where + log' = logWith recorder + +deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] +deleteFileOfInterest recorder state f = do + OfInterestCabalProjectVar var <- Shake.getIdeGlobalState state + files <- modifyVar' var $ HashMap.delete f + log' Debug $ LogFOI files + return [toKey IsFileOfInterest f] + where + log' = logWith recorder + +-- ---------------------------------------------------------------- +-- Completion +-- ---------------------------------------------------------------- + +completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion +completion recorder ide _ complParams = do + let TextDocumentIdentifier uri = complParams ^. JL.textDocument + position = complParams ^. JL.position + mContents <- liftIO $ runAction "cabal-project-plugin.getUriContents" ide $ getUriContents $ toNormalizedUri uri + case (,) <$> mContents <*> uriToFilePath' uri of + Just (cnts, path) -> do + mFields <- liftIO $ runAction "cabal-project-plugin.fields" ide $ useWithStale ParseCabalProjectFields $ toNormalizedFilePath path + case mFields of + Nothing -> + pure . InR $ InR Null + Just (fields, _) -> do + let lspPrefInfo = Ghcide.getCompletionPrefixFromRope position cnts + cabalProjectPrefInfo = Completions.getCabalProjectPrefixInfo path lspPrefInfo + let res = computeCompletionsAt recorder ide cabalProjectPrefInfo path fields + liftIO $ fmap InL res + Nothing -> pure . InR $ InR Null + +computeCompletionsAt :: Recorder (WithPriority Log) -> IdeState -> CTypes.CabalPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem] +computeCompletionsAt recorder _ prefInfo _ 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 = pure Nothing, + getCabalCommonSections = pure Nothing, + cabalPrefixInfo = prefInfo + , stanzaName = + case fst ctx of + CTypes.Stanza _ name -> name + _ -> Nothing + } + completions <- completer completerRecorder completerData + pure completions + where + pos = CTypes.completionCursorPosition prefInfo + context fields = Completions.getContext completerRecorder prefInfo fields + completerRecorder = cmapWithPrio LogCompletions recorder diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completions.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completions.hs new file mode 100644 index 0000000000..a74b3ebde5 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completions.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.CabalProject.Completion.Completions (contextToCompleter, getContext, getCabalProjectPrefixInfo) where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class (MonadIO) +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 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.CabalFields +import Ide.Plugin.Cabal.Completion.Completer.Simple +import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) +import Ide.Plugin.Cabal.Completion.Types +import Ide.Plugin.CabalProject.Completion.Data +import qualified Language.LSP.Protocol.Lens as JL +import qualified System.FilePath as FP +import System.FilePath (takeBaseName) + +-- ---------------------------------------------------------------- +-- Public API for Completions +-- ---------------------------------------------------------------- + +-- | Takes information about the completion context within the file +-- and finds the correct completer to be applied. +contextToCompleter :: Context -> Completer +-- if we are in the top level of the cabal.project file and not in a keyword context, +-- we can write any top level keywords or a stanza declaration +contextToCompleter (TopLevel, None) = + constantCompleter $ + Map.keys cabalProjectKeywords ++ Map.keys stanzaKeywordMap +-- if we are in a keyword context in the top level, +-- we look up that keyword in the top level context and can complete its possible values +contextToCompleter (TopLevel, KeyWord kw) = + case Map.lookup kw cabalProjectKeywords of + Nothing -> errorNoopCompleter (LogUnknownKeyWordInContextError kw) + Just l -> l +-- if we are in a stanza and not in a keyword context, +-- we can write any of the stanza's keywords or a stanza declaration +contextToCompleter (Stanza s _, None) = + case Map.lookup s stanzaKeywordMap of + Nothing -> errorNoopCompleter (LogUnknownStanzaNameInContextError s) + Just l -> constantCompleter $ Map.keys l +-- if we are in a stanza's keyword's context we can complete possible values of that keyword +contextToCompleter (Stanza s _, KeyWord kw) = + case Map.lookup s stanzaKeywordMap of + Nothing -> errorNoopCompleter (LogUnknownStanzaNameInContextError s) + Just m -> case Map.lookup kw m of + Nothing -> errorNoopCompleter (LogUnknownKeyWordInContextError kw) + Just l -> l + +-- | Takes prefix info about the previously written text +-- and a rope (representing a file), returns the corresponding context. +-- +-- Can return Nothing if an error occurs. +-- +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 + cursor = lspPositionToCabalPosition (completionCursorPosition prefInfo) + +-- | Takes information about the current file's file path, +-- and the cursor position in the file; and builds a CabalPrefixInfo, reused from hls-cabal-plugin +-- with the prefix up to that cursor position. +-- Checks whether a suffix needs to be completed +-- and calculates the range in the document +-- where the completion action should be applied. +getCabalProjectPrefixInfo :: FilePath -> Ghcide.PosPrefixInfo -> CabalPrefixInfo +getCabalProjectPrefixInfo fp prefixInfo = + CabalPrefixInfo + { completionPrefix = completionPrefix', + isStringNotation = mkIsStringNotation separator afterCursorText, + completionCursorPosition = Ghcide.cursorPos prefixInfo, + completionRange = Range completionStart completionEnd, + completionWorkingDir = FP.takeDirectory fp, + completionFileName = T.pack $ takeBaseName fp + } + where + completionEnd = Ghcide.cursorPos prefixInfo + completionStart = + Position + (_line completionEnd) + (_character completionEnd - (fromIntegral $ T.length completionPrefix')) + (beforeCursorText, afterCursorText) = T.splitAt cursorColumn $ Ghcide.fullLine prefixInfo + completionPrefix' = T.takeWhileEnd (not . (`elem` stopConditionChars)) beforeCursorText + separator = + -- if there is an opening apostrophe before the cursor in the line somewhere, + -- everything after that apostrophe is the completion prefix + if odd $ T.count "\"" beforeCursorText + then '\"' + else ' ' + cursorColumn = fromIntegral $ Ghcide.cursorPos prefixInfo ^. JL.character + stopConditionChars = separator : [',', ':'] + + -- \| Takes the character occurring exactly before, + -- and the text occurring after the item to be completed and + -- returns whether the item is already surrounded by apostrophes. + -- + -- Example: (@|@ indicates the cursor position) + -- + -- @"./src|@ would call @'\"'@ @""@ and result in Just LeftSide + -- + -- @"./src|"@ would call @'\"'@ @'\"'@ and result in Just Surrounded + -- + mkIsStringNotation :: Char -> T.Text -> Maybe Apostrophe + mkIsStringNotation '\"' restLine + | Just ('\"', _) <- T.uncons restLine = Just Surrounded + | otherwise = Just LeftSide + mkIsStringNotation _ _ = Nothing + +-- ---------------------------------------------------------------- +-- Implementation Details +-- ---------------------------------------------------------------- + +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 + | getFieldName section `elem` conditionalKeywords -> findCursorContext cursor parentHistory prefixText sectionFields -- Ignore if conditionals, they are not real sections + | 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 + conditionalKeywords = ["if", "elif", "else"] + +-- | Finds the cursor's context, where the cursor is already found to be in a specific field +-- +-- Due to the way the field context is recognised for incomplete cabal.project 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 + (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) diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Data.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Data.hs new file mode 100644 index 0000000000..e9e54a9599 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Data.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.CabalProject.Completion.Data where + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as T +import Development.IDE.GHC.Compat.Core (flagsForCompletion) +import Distribution.CabalSpecVersion (CabalSpecVersion (CabalSpecV2_2), + showCabalSpecVersion) +import Ide.Plugin.Cabal.Completion.Completer.FilePath (directoryCompleter, + filePathCompleter) +import Ide.Plugin.Cabal.Completion.Completer.Simple +import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) +import Ide.Plugin.Cabal.Completion.Types + +-- | Ad-hoc data type for modelling the available top-level stanzas. +-- Not intended right now for anything else but to avoid string +-- comparisons in 'stanzaKeywordMap'. +data TopLevelStanza + = Package + | ProgramOptions + +-- ---------------------------------------------------------------- +-- Completion Data +-- ---------------------------------------------------------------- + +-- | Top level keywords of a cabal.project file. +-- +-- TODO: we could add descriptions of field values and +-- then show them when inside the field's context +cabalProjectKeywords :: Map KeyWordName Completer +cabalProjectKeywords = + Map.fromList + [ ("packages:", filePathCompleter), + ("optional-packages:", filePathCompleter), + ("extra-packages:", filePathCompleter), + ("verbose:", constantCompleter ["0", "1", "2", "3"]), + ("build-summary:", filePathCompleter), + ("build-log:", noopCompleter), + ("remote-build-reporting:", noopCompleter), + ("report-planning-failure:", noopCompleter), + ("symlink-bindir:", noopCompleter), + ("jobs:", noopCompleter), + ("semaphore:", noopCompleter), + ("keep-going:", constantCompleter ["False", "True"]), + ("offline:", noopCompleter), + ("haddock-keep-temp-files:", constantCompleter ["False", "True"]), + ("http-transport:", constantCompleter ["curl", "wget", "powershell", "plain-http"]), + ("ignore-expiry:", constantCompleter ["False", "True"]), + ("remote-repo-cache:", noopCompleter), + ("logs-dir:", noopCompleter), + ("builddir:", noopCompleter), + ("project-dir:", noopCompleter), + ("project-file:", noopCompleter), + ("ignore-project:", noopCompleter), + ("compiler:", constantCompleter ["ghc", "ghcjs", "jhc", "lhc", "uhc", "haskell-suite"]), + ("with-compiler:", filePathCompleter), + ("with-hc-pkg:", filePathCompleter), + ("doc-index-file:", noopCompleter), + ("package-dbs:", noopCompleter), + ("active-repositories:", noopCompleter), + ("index-state:", noopCompleter), + ("store-dir:", noopCompleter), + ("constraints:", noopCompleter), + ("preferences:", noopCompleter), + ("cabal-lib-version:", noopCompleter), + ("solver:", constantCompleter ["modular"]), + ("allow-older:", noopCompleter), + ("allow-newer:", noopCompleter), + ("write-ghc-environment-files:", constantCompleter ["never", "always", "ghc8.4.4+"]), + ("max-backjumps:", noopCompleter), + ("reorder-goals:", constantCompleter ["False", "True"]), + ("count-conflicts:", constantCompleter ["True", "False"]), + ("fine-grained-conflicts:", constantCompleter ["True", "False"]), + ("minimize-conflict-set:", constantCompleter ["False", "True"]), + ("strong-flags:", constantCompleter ["False", "True"]), + ("allow-boot-library-installs:", constantCompleter ["False", "True"]), + ("reject-unconstrained-dependencies:", constantCompleter ["none", "all"]), + ("per-component:", noopCompleter), + ("independent-goals:", noopCompleter), + ("prefer-oldest:", noopCompleter), + ("extra-prog-path-shared-only:", noopCompleter), + ("multi-repl:", noopCompleter), + ("benchmarks:", constantCompleter ["False", "True"]), + ("import:", filePathCompleter) + ] + +packageFields :: Map KeyWordName Completer +packageFields = + Map.fromList + [ ("haddock-all:", constantCompleter ["False", "True"]), + ("extra-prog-path:", filePathCompleter), + ("flags:", noopCompleter), + ("library-vanilla:", constantCompleter ["True", "False"]), + ("shared:", constantCompleter ["False", "True"]), + ("static:", constantCompleter ["False", "True"]), + ("exectable-dynamic:", constantCompleter ["False", "True"]), + ("executable-static:", constantCompleter ["False", "True"]), + ("profiling:", constantCompleter ["False", "True"]), + ("library-profiling:", constantCompleter ["False", "True"]), + ("profiling-shared:", noopCompleter), + ("exectable-profiling:", constantCompleter ["False", "True"]), + ("profiling-detail:", constantCompleter ["default", "none", "exported-functions", "toplevel-functions", "all-functions"]), + ("library-profiling-detail:", constantCompleter ["default", "none", "exported-functions", "toplevel-functions", "all-functions"]), + ("configure-options:", noopCompleter), + ("optimization:", constantCompleter ["0", "1", "2", "True", "False"]), + ("program-prefix:", noopCompleter), + ("program-suffix:", noopCompleter), + ("extra-lib-dirs:", directoryCompleter), + ("extra-lib-dirs-static:", directoryCompleter), + ("extra-framework-dirs:", directoryCompleter), + ("extra-include-dirs:", directoryCompleter), + ("library-for-ghci:", constantCompleter ["True", "False"]), + ("split-sections:", constantCompleter ["False", "True"]), + ("split-objs:", constantCompleter ["False", "True"]), + ("executable-stripping:", constantCompleter ["True", "False"]), + ("library-stripping:", constantCompleter ["False", "True"]), + ("tests:", constantCompleter ["False", "True"]), + ("benchmarks:", constantCompleter ["False", "True"]), + ("relocatable:", constantCompleter ["False", "True"]), + ("debug-info:", noopCompleter), + ("build-info:", noopCompleter), + ("run-tests:", constantCompleter ["False", "True"]), + ("documentation:", constantCompleter ["False", "True"]), + ("haddock-hoogle:", constantCompleter ["False", "True"]), + ("haddock-html:", constantCompleter ["True", "False"]), + ("haddock-html-location:", noopCompleter), + ("haddock-foreign-libraries:", noopCompleter), + ("haddock-executables:", constantCompleter ["False", "True"]), + ("haddock-tests:", constantCompleter ["False", "True"]), + ("haddock-benchmarks:", constantCompleter ["False", "True"]), + ("haddock-internal:", constantCompleter ["False", "True"]), + ("haddock-css:", filePathCompleter), + ("haddock-hyperlink-source:", constantCompleter ["False", "True"]), + ("haddock-quickjump:", noopCompleter), + ("haddock-hscolour-css:", filePathCompleter), + ("haddock-contents-location:", noopCompleter), + ("haddock-index-location:", noopCompleter), + ("haddock-base-url:", noopCompleter), + ("haddock-resources-dir:", noopCompleter), + ("haddock-output-dir:", noopCompleter), + ("haddock-use-unicode:", noopCompleter), + ("haddock-for-hackage:", noopCompleter), + ("test-log:", noopCompleter), + ("test-machine-log:", noopCompleter), + ("test-show-details:", noopCompleter), + ("test-keep-tix-files:", noopCompleter), + ("test-wrapper:", noopCompleter), + ("test-fail-when-no-test-suites:", noopCompleter), + ("test-options:", noopCompleter), + ("benchmark-options:", noopCompleter), + ("coverage:", constantCompleter ["False", "True"]), + ("ghc-options:", noopCompleter) + ] + +sourceRepoFields :: Map KeyWordName Completer +sourceRepoFields = Map.fromList + [ ("type:", constantCompleter + [ "darcs", + "git", + "svn", + "cvs", + "mercurial", + "hg", + "bazaar", + "bzr", + "arch", + "monotone" + ]), + ("location:", noopCompleter), + ("tag:", noopCompleter), + ("subdir:", noopCompleter) + ] + +-- | Map, containing all stanzas in a cabal.project file as keys, +-- and lists of their possible nested keywords as values. +stanzaKeywordMap :: Map StanzaType (Map KeyWordName Completer) +stanzaKeywordMap = + Map.fromList + [ ("package", packageFields), + ("program-options", packageFields), + ("source-repository-package", sourceRepoFields) + ] diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs new file mode 100644 index 0000000000..8eda8c80aa --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.CabalProject.Diagnostics +( errorDiagnostic +, warningDiagnostic +, positionFromCabalPosition +, fatalParseErrorDiagnostic + -- * Re-exports +, FileDiagnostic +, Diagnostic(..) +) +where + +import qualified Data.Text as T +import Development.IDE (FileDiagnostic) +import qualified Distribution.Parsec as Syntax +import Distribution.Parsec.Error (showPError) +import Distribution.Parsec.Warning (showPWarning) +import Ide.Plugin.Cabal.Diagnostics (mkDiag, + positionFromCabalPosition, + toBeginningOfNextLine) +import Language.LSP.Protocol.Types (Diagnostic (..), + DiagnosticSeverity (..), + NormalizedFilePath, + fromNormalizedFilePath) + +-- | Produce a diagnostic for a fatal Cabal Project parser error. +fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic +fatalParseErrorDiagnostic fp msg = + mkDiag fp "cabal-project" DiagnosticSeverity_Error (toBeginningOfNextLine Syntax.zeroPos) msg + +-- | Produce a diagnostic from a Cabal Project parser error +errorDiagnostic :: NormalizedFilePath -> Syntax.PError -> FileDiagnostic +errorDiagnostic fp err@(Syntax.PError pos _) = + mkDiag fp "cabal-project" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg + where + msg = T.pack $ showPError (fromNormalizedFilePath fp) err + +-- | Produce a diagnostic from a Cabal Project parser warning +warningDiagnostic :: NormalizedFilePath -> Syntax.PWarning -> FileDiagnostic +warningDiagnostic fp warning@(Syntax.PWarning _ pos _) = + mkDiag fp "cabal-project" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg + where + msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs new file mode 100644 index 0000000000..674e3887ff --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.CabalProject.Parse + ( parseCabalProjectFileContents, + readCabalProjectFields + ) where + +import qualified Crypto.Hash.SHA1 as H +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import Development.IDE +import Distribution.Client.HttpUtils (configureTransport) +import Distribution.Client.ProjectConfig.Parsec (ProjectConfigSkeleton, + parseProject, + readPreprocessFields) +import Distribution.Client.ProjectConfig.Types (ProjectConfigToParse (..)) +import Distribution.Fields (PError (..), + PWarning (..)) +import qualified Distribution.Fields.Parser as Syntax +import qualified Distribution.Fields.ParseResult as PR +import qualified Distribution.Parsec.Position as Syntax +import Distribution.Types.Version (Version) +import Distribution.Verbosity (normal) +import qualified Ide.Plugin.CabalProject.Diagnostics as Diagnostics +import System.Directory.Extra (XdgDirectory (..), + getXdgDirectory) +import System.FilePath (takeBaseName, + takeDirectory, ()) + +parseCabalProjectFileContents + :: FilePath + -> BS.ByteString + -> IO ([PWarning] + , Either (Maybe Version, NonEmpty PError) ProjectConfigSkeleton) +parseCabalProjectFileContents fp bytes = do + cacheDir <- getCabalProjectCacheDir fp + let toParse = ProjectConfigToParse bytes + verb = normal + httpTransport <- configureTransport verb [fp] Nothing + + parseRes :: PR.ParseResult ProjectConfigSkeleton + <- parseProject fp cacheDir httpTransport verb toParse + + pure (PR.runParseResult parseRes) + +readCabalProjectFields + :: NormalizedFilePath + -> BS.ByteString + -> Either FileDiagnostic [Syntax.Field Syntax.Position] +readCabalProjectFields file contents = + case PR.runParseResult (readPreprocessFields contents) of + (_warnings, Left (_mbVer, errs)) -> + let perr = NE.head errs + in Left $ + Diagnostics.fatalParseErrorDiagnostic file + ("Failed to parse cabal.project file: " <> T.pack (show perr)) + + (_warnings, Right fields) -> + Right fields + +getCabalProjectCacheDir :: FilePath -> IO FilePath +getCabalProjectCacheDir fp = do + getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) + where + prefix = takeBaseName $ takeDirectory fp + -- Create a unique folder per cabal.project file + opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init [B.pack fp] + +cacheDir :: String +cacheDir = "ghcide" diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs new file mode 100644 index 0000000000..de161c5aa7 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.CabalProject.Types where + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import Development.IDE (NormalizedFilePath, + RuleResult) +import Distribution.Client.ProjectConfig.Parsec (ProjectConfigSkeleton) +import qualified Distribution.Fields as Syntax +import qualified Distribution.Parsec.Position as Syntax +import GHC.Generics (Generic) + +type instance RuleResult ParseCabalProjectFile = ProjectConfigSkeleton + +data ParseCabalProjectFile = ParseCabalProjectFile + deriving (Eq, Show, Generic) + +instance Hashable ParseCabalProjectFile + +instance NFData ParseCabalProjectFile + +type instance RuleResult ParseCabalProjectFields = [Syntax.Field Syntax.Position] + +data ParseCabalProjectFields = ParseCabalProjectFields + deriving (Eq, Show, Generic) + +instance Hashable ParseCabalProjectFields + +instance NFData ParseCabalProjectFields + diff --git a/plugins/hls-cabal-project-plugin/test/Completer.hs b/plugins/hls-cabal-project-plugin/test/Completer.hs new file mode 100644 index 0000000000..4db4025c12 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/Completer.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + + +module Completer where + +import Control.Lens ((^.), (^?)) +import Control.Lens.Prism +import Control.Monad (forM_) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as BS8 +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import qualified Distribution.Fields as Syntax +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) +import qualified Distribution.Parsec.Position as Syntax +import Ide.Plugin.Cabal.Completion.Completer.FilePath +import Ide.Plugin.Cabal.Completion.Completer.Module +import Ide.Plugin.Cabal.Completion.Completer.Paths +import Ide.Plugin.Cabal.Completion.Completer.Simple (importCompleter) +import Ide.Plugin.Cabal.Completion.Completer.Types (CompleterData (..)) +import Ide.Plugin.Cabal.Completion.Types (CabalPrefixInfo (..), + StanzaName) +import Ide.Plugin.CabalProject.Completion.Completions +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath +import Test.Hls +import Utils + +completerTests :: TestTree +completerTests = + testGroup + "Completer Tests" + [ basicCompleterTests, + fileCompleterTests, + filePathCompletionContextTests + -- directoryCompleterTests, + -- completionHelperTests, + -- filePathExposedModulesTests, + -- exposedModuleCompleterTests, + -- importCompleterTests, + -- autogenFieldCompletionTests + ] + +basicCompleterTests :: TestTree +basicCompleterTests = + testGroup + "Basic Completer Tests" + [ runCabalProjectTestCaseSession "In stanza context - stanza should not be suggested" "" $ do + doc <- openDoc "cabal.completer.project" "cabal-project" + compls <- getCompletions doc (Position 1 4) + let complTexts = getTextEditTexts compls + liftIO $ assertBool "does not suggest packages" $ "packages" `notElem` complTexts + liftIO $ assertBool "suggests program-prefix keyword" $ "program-prefix:" `elem` complTexts + , runCabalProjectTestCaseSession "In top level context - stanza should be suggested" "" $ do + doc <- openDoc "cabal.completer.project" "cabal-project" + compls <- getCompletions doc (Position 5 2) + let complTexts = getTextEditTexts compls + liftIO $ assertBool "suggests package" $ "package" `elem` complTexts + , runCabalProjectTestCaseSession "In top level context - stanza should be suggested" "" $ do + doc <- openDoc "cabal.completer.project" "cabal-project" + compls <- getCompletions doc (Position 3 2) + let complTexts = getTextEditTexts compls + liftIO $ assertBool "suggests program-options" $ "program-options" `elem` complTexts + ] + where + getTextEditTexts :: [CompletionItem] -> [T.Text] + getTextEditTexts compls = mapMaybe (^? L.textEdit . _Just . _L . L.newText) compls + +fileCompleterTests :: TestTree +fileCompleterTests = + testGroup + "File Completer Tests" + [ testCase "Current Directory - no leading ./ by default" $ do + completions <- completeFilePath "" filePathComplTestDir + completions @?== ["Content.hs", "dir1/", "dir2/", "textfile.txt", "test.cabal", "cabal.project"], + testCase "Current Directory - alternative writing" $ do + completions <- completeFilePath "./" filePathComplTestDir + completions @?== ["./Content.hs", "./dir1/", "./dir2/", "./textfile.txt", "./test.cabal", "./cabal.project"], + testCase "Current Directory - hidden file start" $ do + completions <- completeFilePath "." filePathComplTestDir + completions @?== ["Content.hs", "textfile.txt", "test.cabal", "cabal.project"], + testCase "Current Directory - incomplete directory path written" $ do + completions <- completeFilePath "di" filePathComplTestDir + completions @?== ["dir1/", "dir2/"], + testCase "Current Directory - incomplete filepath written" $ do + completions <- completeFilePath "te" filePathComplTestDir + completions @?== ["Content.hs", "textfile.txt", "test.cabal"], + testCase "Subdirectory" $ do + completions <- completeFilePath "dir1/" filePathComplTestDir + completions @?== ["dir1/f1.txt", "dir1/f2.hs"], + -- testCase "Subdirectory - incomplete filepath written" $ do + -- completions <- completeFilePath "dir2/dir3/MA" filePathComplTestDir + -- completions @?== ["dir2/dir3/MARKDOWN.md"], + testCase "Nonexistent directory" $ do + completions <- completeFilePath "dir2/dir4/" filePathComplTestDir + completions @?== [] + ] + where + completeFilePath :: T.Text -> TestName -> IO [T.Text] + completeFilePath written dirName = do + completer <- filePathCompleter mempty $ mkCompleterData $ simpleCabalPrefixInfoFromFp written dirName + pure $ fmap extract completer + +filePathCompletionContextTests :: TestTree +filePathCompletionContextTests = + testGroup + "File Path Completion Context Tests" + [ testCase "empty file - start" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "" 0 0) + completionPrefix complContext @?= "", + testCase "only whitespaces" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo " " 0 3) + completionPrefix complContext @?= "", + testCase "simple filepath" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo " src/" 0 7) + completionPrefix complContext @?= "src/", + testCase "simple filepath - starting apostrophe" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo " \"src/" 0 8) + completionPrefix complContext @?= "src/", + testCase "simple filepath - starting apostrophe, already closed" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo " \"src/\"" 0 8) + completionPrefix complContext @?= "src/", + testCase "second filepath - starting apostrophe" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "fp.txt \"src/" 0 12) + completionPrefix complContext @?= "src/", + testCase "middle filepath - starting apostrophe" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "fp.txt \"src/ fp2.txt" 0 12) + completionPrefix complContext @?= "src/", + testCase "middle filepath - starting apostrophe, already closed" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "fp.t xt \"src\" fp2.txt" 0 12) + completionPrefix complContext @?= "src", + testCase "middle filepath - starting apostrophe, already closed" $ do + let complContext = getCabalPrefixInfo "" (simplePosPrefixInfo "\"fp.txt\" \"src fp2.txt" 0 13) + completionPrefix complContext @?= "src", + testCase "Current Directory" $ do + compls <- + listFileCompletions + mempty + PathCompletionInfo + { isStringNotationPath = Nothing, + pathSegment = "", + queryDirectory = "", + workingDirectory = filePathComplTestDir + } + compls @?== ["Content.hs", "dir1/", "dir2/", "textfile.txt", "test.cabal", "cabal.project"], + testCase "In directory" $ do + compls <- + listFileCompletions + mempty + PathCompletionInfo + { isStringNotationPath = Nothing, + pathSegment = "", + queryDirectory = "dir1/", + workingDirectory = filePathComplTestDir + } + compls @?== ["f1.txt", "f2.hs"] + ] + where + simplePosPrefixInfo :: T.Text -> UInt -> UInt -> Ghcide.PosPrefixInfo + simplePosPrefixInfo lineString linePos charPos = + Ghcide.PosPrefixInfo + { Ghcide.fullLine = lineString, + Ghcide.prefixScope = "", + Ghcide.prefixText = "", + Ghcide.cursorPos = Position linePos charPos + } + +mkCompleterData :: CabalPrefixInfo -> CompleterData +mkCompleterData prefInfo = CompleterData {getLatestGPD = undefined, cabalPrefixInfo = prefInfo, stanzaName = Nothing} + +extract :: CompletionItem -> T.Text +extract item = case item ^. L.textEdit of + Just (InL v) -> v ^. L.newText + _ -> error "" diff --git a/plugins/hls-cabal-project-plugin/test/Main.hs b/plugins/hls-cabal-project-plugin/test/Main.hs new file mode 100644 index 0000000000..6923ac029c --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/Main.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main ( + main, +) where + +import Completer (completerTests) +import qualified Control.Exception as E +import Control.Lens ((^.)) +import Control.Lens.Fold ((^?)) +import Control.Monad (guard) +import qualified Data.ByteString as BS +import Data.ByteString.Char8 (pack) +import Data.Either (isRight) +import Data.List.Extra (nubOrdOn) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Distribution.Client.ProjectConfig.Parsec (ProjectConfigSkeleton) +import Distribution.Fields (PError (..), + PWarning (..)) +import Distribution.Types.Version (Version) +import qualified Ide.Plugin.CabalProject.Parse as Lib +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath +import Test.Hls +import Utils + + +main :: IO () +main = do + defaultTestRunner $ + testGroup + "Cabal Plugin Tests" + [ unitTests + , pluginTests + , completerTests + ] + +-- ------------------------------------------------------------------------ +-- Unit Tests +-- ------------------------------------------------------------------------ + +unitTests :: TestTree +unitTests = + testGroup + "Unit Tests" + [ cabalProjectParserUnitTests + ] + +cabalProjectParserUnitTests :: TestTree +cabalProjectParserUnitTests = + testGroup + "Parsing Cabal Project" + [ testCase "Simple Parsing works" $ do + let fp = testDataDir "cabal.project" + bytes <- BS.readFile fp + (warnings, pm) <- Lib.parseCabalProjectFileContents fp bytes + liftIO $ do + null warnings @? "Found unexpected warnings" + isRight pm @? "Failed to parse base cabal.project file" + , testCase "Correct root directory" $ do + let root = testDataDir "root-directory" + let cabalFp = root "cabal.project" + bytes <- BS.readFile cabalFp + result <- E.try @E.IOException (Lib.parseCabalProjectFileContents cabalFp bytes) + :: IO ( Either + E.IOException + ( [PWarning] + , Either (Maybe Version, NonEmpty PError) + ProjectConfigSkeleton + ) + ) + case result of + Left err -> + let errStr = show err + in (pack root `BS.isInfixOf` pack errStr) + @? ("Expected missing file error to mention the test-dir:\n" + ++ " " ++ root ++ "\n" + ++ "but got:\n" ++ errStr) + Right _ -> + False @? "Expected parse to fail (missing import), but it succeeded" + ] + +-- ------------------------ ------------------------------------------------ +-- Integration Tests +-- ------------------------------------------------------------------------ + +pluginTests :: TestTree +pluginTests = + testGroup + "Plugin Tests" + [ testGroup + "Diagnostics" + [ runCabalProjectTestCaseSession "Publishes Diagnostics on Error" "invalid-cabal-project" $ do + _ <- openDoc "cabal.project" "cabal-project" + diags <- cabalProjectCaptureKick + unexpectedErrorDiag <- liftIO $ inspectDiagnostic diags ["unexpected 'f'"] + liftIO $ do + length diags @?= 1 + unexpectedErrorDiag ^. L.range @?= Range (Position 2 6) (Position 3 0) + unexpectedErrorDiag ^. L.severity @?= Just DiagnosticSeverity_Error + , runCabalProjectTestCaseSession "Publishes Diagnostics on misspelled packages as Warning" "warning-cabal-project" $ do + _ <- openDoc "cabal.project" "cabal-project" + diags <- cabalProjectCaptureKick + stanzaWarningDiag <- liftIO $ inspectDiagnosticAny diags ["'\"package\"' is a stanza, not a field. Remove the trailing ':' to parse a stanza."] + liftIO $ do + length diags @?= 1 + stanzaWarningDiag ^. L.range @?= Range (Position 0 0) (Position 1 0) + stanzaWarningDiag ^. L.severity @?= Just DiagnosticSeverity_Warning + , runCabalProjectTestCaseSession "Clears diagnostics" "invalid-cabal-project" $ do + doc <- openDoc "cabal.project" "cabal-project" + diags <- cabalProjectCaptureKick + unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["unexpected 'f'"] + liftIO $ do + length diags @?= 1 + unknownLicenseDiag ^. L.range @?= Range (Position 2 6) (Position 3 0) + unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error + _ <- applyEdit doc $ TextEdit (Range (Position 2 6) (Position 3 0)) " -foo" + newDiags <- cabalProjectCaptureKick + liftIO $ newDiags @?= [] + , runCabalProjectTestCaseSession "No Diagnostics in .hs files from valid cabal.project file" "simple-cabal-project" $ do + hsDoc <- openDoc "A.hs" "haskell" + expectNoMoreDiagnostics 1 hsDoc "typechecking" + cabalDoc <- openDoc "cabal.project" "cabal-project" + expectNoMoreDiagnostics 1 cabalDoc "parsing" + ] + ] diff --git a/plugins/hls-cabal-project-plugin/test/Utils.hs b/plugins/hls-cabal-project-plugin/test/Utils.hs new file mode 100644 index 0000000000..9e010cdf55 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/Utils.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Utils where + +import Control.Monad (guard) +import Data.List (sort) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as T +import Ide.Plugin.Cabal.Completion.Types +import Ide.Plugin.CabalProject (descriptor) +import qualified Ide.Plugin.CabalProject +import Ide.Plugin.CabalProject.Types +import System.FilePath +import Test.Hls + + + +cabalProjectPlugin :: PluginTestDescriptor Ide.Plugin.CabalProject.Log +cabalProjectPlugin = mkPluginTestDescriptor descriptor "cabal-project" + +runCabalProjectTestCaseSession :: TestName -> FilePath -> Session () -> TestTree +runCabalProjectTestCaseSession title subdir = testCase title . runCabalProjectSession subdir + +runCabalProjectSession :: FilePath -> Session a -> IO a +runCabalProjectSession subdir = + failIfSessionTimeout . runSessionWithServer def cabalProjectPlugin (testDataDir subdir) + +runCabalProjectGoldenSession :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +runCabalProjectGoldenSession title subdir fp act = goldenWithCabalDoc def cabalProjectPlugin title testDataDir (subdir fp) "golden" "cabal-project" act + +testDataDir :: FilePath +testDataDir = "plugins" "hls-cabal-project-plugin" "test" "testdata" + +-- | these functions are used to detect cabal kicks +-- and look at diagnostics for cabal files +-- kicks are run everytime there is a shake session run/restart +cabalProjectKickDone :: Session () +cabalProjectKickDone = kick (Proxy @"kick/done/cabal-project") >>= guard . not . null + +cabalProjectKickStart :: Session () +cabalProjectKickStart = kick (Proxy @"kick/start/cabal-project") >>= guard . not . null + +cabalProjectCaptureKick :: Session [Diagnostic] +cabalProjectCaptureKick = captureKickDiagnostics cabalProjectKickStart cabalProjectKickDone + +-- | list comparison where the order in the list is irrelevant +(@?==) :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion +(@?==) l1 l2 = sort l1 @?= sort l2 + +-- potentially add these as imports? +simpleCabalPrefixInfoFromFp :: T.Text -> FilePath -> CabalPrefixInfo +simpleCabalPrefixInfoFromFp prefix fp = + CabalPrefixInfo + { completionPrefix = prefix + , isStringNotation = Nothing + , completionCursorPosition = Position 0 0 + , completionRange = Range (Position 0 0) (Position 0 0) + , completionWorkingDir = fp + , completionFileName = "test" + } + +filePathComplTestDir :: FilePath +filePathComplTestDir = addTrailingPathSeparator $ testDataDir "filepath-completions" + diff --git a/plugins/hls-cabal-project-plugin/test/testdata/cabal.completer.project b/plugins/hls-cabal-project-plugin/test/testdata/cabal.completer.project new file mode 100644 index 0000000000..dfa6984559 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/cabal.completer.project @@ -0,0 +1,6 @@ +package Cabal + pa + +pr + +pa diff --git a/plugins/hls-cabal-project-plugin/test/testdata/cabal.project b/plugins/hls-cabal-project-plugin/test/testdata/cabal.project new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/Content.hs b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/Content.hs new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/cabal.project b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/cabal.project new file mode 100644 index 0000000000..6f920794c8 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/cabal.project @@ -0,0 +1 @@ +packages: ./ diff --git a/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f1.txt b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f1.txt new file mode 100644 index 0000000000..016496005a --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f1.txt @@ -0,0 +1 @@ +test text file diff --git a/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f2.hs b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f2.hs new file mode 100644 index 0000000000..6c5963631f --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f2.hs @@ -0,0 +1 @@ +-- test haskell file diff --git a/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/test.cabal b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/test.cabal new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/textfile.txt b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/textfile.txt new file mode 100644 index 0000000000..016496005a --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/textfile.txt @@ -0,0 +1 @@ +test text file diff --git a/plugins/hls-cabal-project-plugin/test/testdata/invalid-cabal-project/cabal.project b/plugins/hls-cabal-project-plugin/test/testdata/invalid-cabal-project/cabal.project new file mode 100644 index 0000000000..53e4c3b1f6 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/invalid-cabal-project/cabal.project @@ -0,0 +1,3 @@ +packages: . + +flags:foo diff --git a/plugins/hls-cabal-project-plugin/test/testdata/root-directory/cabal.project b/plugins/hls-cabal-project-plugin/test/testdata/root-directory/cabal.project new file mode 100644 index 0000000000..241b892291 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/root-directory/cabal.project @@ -0,0 +1 @@ +import: missing-folder/nonexistent.config diff --git a/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/A.hs b/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/A.hs new file mode 100644 index 0000000000..4eca137b41 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/A.hs @@ -0,0 +1,3 @@ +module A where + +a = undefined diff --git a/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/cabal.project b/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/cabal.project new file mode 100644 index 0000000000..e6fdbadb43 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/plugins/hls-cabal-project-plugin/test/testdata/warning-cabal-project/cabal.project b/plugins/hls-cabal-project-plugin/test/testdata/warning-cabal-project/cabal.project new file mode 100644 index 0000000000..a3cd59d23b --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/warning-cabal-project/cabal.project @@ -0,0 +1 @@ +package: . diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 87a1af7392..3b34a06743 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -23,6 +23,9 @@ import qualified Ide.Plugin.CallHierarchy as CallHierarchy #if hls_cabal import qualified Ide.Plugin.Cabal as Cabal #endif +#if hls_cabal_project +import qualified Ide.Plugin.CabalProject as CabalProject +#endif #if hls_class import qualified Ide.Plugin.Class as Class #endif @@ -154,6 +157,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins let pId = "cabal" in Cabal.descriptor (pluginRecorder pId) pId : let caId = "cabalHaskellIntegration" in Cabal.haskellInteractionDescriptor (pluginRecorder caId) caId : #endif +#if hls_cabal_project + let pId = "cabalProject" in CabalProject.descriptor (pluginRecorder pId) pId : +#endif #if hls_pragmas Pragmas.suggestPragmaDescriptor "pragmas-suggest" : Pragmas.completionDescriptor "pragmas-completion" : diff --git a/test.cpp b/test.cpp new file mode 100644 index 0000000000..055115d2e8 --- /dev/null +++ b/test.cpp @@ -0,0 +1,3 @@ +#include +int main() { std::cout << "OK +"; return 0; } diff --git a/vendor/cabal b/vendor/cabal new file mode 160000 index 0000000000..b44fecd12f --- /dev/null +++ b/vendor/cabal @@ -0,0 +1 @@ +Subproject commit b44fecd12f3c724b5519e5e6253c380d73704caf