From e677c9b8388f46bf02321c7da80939542f033ebd Mon Sep 17 00:00:00 2001 From: rm41339 Date: Thu, 5 Jun 2025 19:56:10 +0100 Subject: [PATCH 01/26] Initial cabal-project plugin setup --- haskell-language-server.cabal | 72 ++++++ hls-plugin-api/src/Ide/Types.hs | 17 +- .../src/Ide/Plugin/CabalProject.hs | 218 ++++++++++++++++++ plugins/hls-cabal-project-plugin/test/Main.hs | 3 + src/HlsPlugins.hs | 6 + test.cpp | 3 + 6 files changed, 318 insertions(+), 1 deletion(-) create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs create mode 100644 plugins/hls-cabal-project-plugin/test/Main.hs create mode 100644 test.cpp diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 157f5703f2..d267f5bc13 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -317,6 +317,77 @@ 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(cabal) + buildable: False + exposed-modules: + Ide.Plugin.CabalProject + + + build-depends: + , bytestring + , Cabal-syntax >= 3.7 + , containers + , deepseq + , directory + , filepath + , extra >=1.7.4 + , ghcide == 2.9.0.1 + , hashable + , hls-plugin-api == 2.9.0.1 + , hls-graph == 2.9.0.1 + , 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 + + 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: + build-depends: + , bytestring + , Cabal-syntax >= 3.7 + , extra + , filepath + , ghcide + , haskell-language-server:hls-cabal-project-plugin + , hls-test-utils == 2.9.0.1 + , lens + , lsp-types + , text + , hls-plugin-api + ----------------------------- -- class plugin ----------------------------- @@ -1830,6 +1901,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-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs new file mode 100644 index 0000000000..24ca19945d --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -0,0 +1,218 @@ +{-# 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.Class (lift) +import Control.Monad.Trans.Maybe (runMaybeT) +import qualified Data.ByteString as BS +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import qualified Data.Maybe as Maybe +import Data.Proxy +import qualified Data.Text () +import qualified Data.Text as T +import qualified Data.Text.Encoding as Encoding +import Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE as D +import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.Shake (restartShakeSession) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Graph (Key, + alwaysRerun) +import Development.IDE.LSP.HoverDefinition (foundHover) +import qualified Development.IDE.Plugin.Completions.Logic as Ghcide +import Development.IDE.Types.Shake (toKey) +import qualified Distribution.CabalSpecVersion as Cabal +import qualified Distribution.Fields as Syntax +import Distribution.Package (Dependency) +import Distribution.PackageDescription (allBuildDepends, + depPkgName, + unPackageName) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.Parsec.Error +import qualified Distribution.Parsec.Position as Syntax +import GHC.Generics +import Ide.Plugin.Error +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 +import Text.Regex.TDFA + +data Log + = LogModificationTime NormalizedFilePath FileVersion + | LogShake Shake.Log + | LogDocOpened Uri + | LogDocModified Uri + | LogDocSaved Uri + | LogDocClosed Uri + | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) + 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 + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultCabalProjectPluginDescriptor plId "Provides a variety of IDE features in cabal files") + { pluginRules = cabalRules recorder plId + , pluginHandlers = + mconcat + [] + , pluginNotificationHandlers = + mconcat + [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ + \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocOpened _uri + restartCabalShakeSession (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 + restartCabalShakeSession (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 + restartCabalShakeSession (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 + restartCabalShakeSession (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' + +cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () +cabalRules recorder _ = do + ofInterestRules recorder + +{- | Helper function to restart the shake session, specifically for modifying .cabal 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. +-} +restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () +restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + keys <- actionBetweenSession + return (toKey GetModificationTime file:keys) + +-- ---------------------------------------------------------------- +-- Cabal file of Interest rules and global variable +-- ---------------------------------------------------------------- + +{- | Cabal 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 OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) + +instance Shake.IsIdeGlobal OfInterestCabalVar + +data IsCabalFileOfInterest = IsCabalFileOfInterest + deriving (Eq, Show, Generic) +instance Hashable IsCabalFileOfInterest +instance NFData IsCabalFileOfInterest + +type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult + +data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus + deriving (Eq, Show, Generic) +instance Hashable CabalFileOfInterestResult +instance NFData CabalFileOfInterestResult + +{- | 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 . OfInterestCabalVar =<< liftIO (newVar HashMap.empty) + Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalFileOfInterest f -> do + alwaysRerun + filesOfInterest <- getCabalFilesOfInterestUntracked + let foi = maybe NotCabalFOI IsCabalFOI $ f `HashMap.lookup` filesOfInterest + fp = summarize foi + res = (Just fp, Just foi) + return res + where + summarize NotCabalFOI = BS.singleton 0 + summarize (IsCabalFOI OnDisk) = BS.singleton 1 + summarize (IsCabalFOI (Modified False)) = BS.singleton 2 + summarize (IsCabalFOI (Modified True)) = BS.singleton 3 + +getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) +getCabalFilesOfInterestUntracked = do + OfInterestCabalVar var <- Shake.getIdeGlobalAction + liftIO $ readVar var + +addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] +addFileOfInterest recorder state f v = do + OfInterestCabalVar 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 IsCabalFileOfInterest f] + else return [] + where + log' = logWith recorder + +deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] +deleteFileOfInterest recorder state f = do + OfInterestCabalVar var <- Shake.getIdeGlobalState state + files <- modifyVar' var $ HashMap.delete f + log' Debug $ LogFOI files + return [toKey IsFileOfInterest f] + where + log' = logWith recorder 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..b41c7786b6 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = undefined 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; } From 61e7d95f5d2c1b926d54c9cf0daeff992d7dd7a8 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Fri, 6 Jun 2025 22:12:37 +0100 Subject: [PATCH 02/26] Upgrade to latest Haskell version --- haskell-language-server.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d267f5bc13..f8aa75a492 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -347,10 +347,10 @@ library hls-cabal-project-plugin , directory , filepath , extra >=1.7.4 - , ghcide == 2.9.0.1 + , ghcide == 2.11.0.0 , hashable - , hls-plugin-api == 2.9.0.1 - , hls-graph == 2.9.0.1 + , hls-plugin-api == 2.11.0.0 + , hls-graph == 2.11.0.0 , lens , lsp ^>=2.7 , lsp-types ^>=2.3 @@ -382,7 +382,7 @@ test-suite hls-cabal-project-plugin-tests , filepath , ghcide , haskell-language-server:hls-cabal-project-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.11.0.0 , lens , lsp-types , text From 595efc1961c99982b7bd85b1716610633ef3449c Mon Sep 17 00:00:00 2001 From: rm41339 Date: Mon, 9 Jun 2025 13:03:26 +0100 Subject: [PATCH 03/26] successful parsing of cabal.project file --- haskell-language-server.cabal | 6 +- .../src/Ide/Plugin/CabalProject.hs | 12 ++- .../Ide/Plugin/CabalProject/Diagnostics.hs | 97 +++++++++++++++++++ .../src/Ide/Plugin/CabalProject/Parse.hs | 32 ++++++ 4 files changed, 143 insertions(+), 4 deletions(-) create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index f8aa75a492..17e3089f9d 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -333,11 +333,12 @@ common cabalProject library hls-cabal-project-plugin import: defaults, pedantic, warnings - if !flag(cabal) + if !flag(cabalProject) buildable: False exposed-modules: Ide.Plugin.CabalProject - + Ide.Plugin.CabalProject.Parse + Ide.Plugin.CabalProject.Diagnostics build-depends: , bytestring @@ -364,6 +365,7 @@ library hls-cabal-project-plugin , aeson , Cabal , pretty + , cabal-install-parsers >= 0.6 && < 0.7 hs-source-dirs: plugins/hls-cabal-project-plugin/src diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index 24ca19945d..b9bb351155 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -45,14 +45,17 @@ import Distribution.PackageDescription.Configuration (flattenPackageDe import Distribution.Parsec.Error import qualified Distribution.Parsec.Position as Syntax import GHC.Generics +import Ide.Plugin.CabalProject.Parse (parseCabalProjectContents) import Ide.Plugin.Error 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 +import System.FilePath (takeFileName) import Text.Regex.TDFA + data Log = LogModificationTime NormalizedFilePath FileVersion | LogShake Shake.Log @@ -81,7 +84,7 @@ instance Pretty Log where descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = - (defaultCabalProjectPluginDescriptor plId "Provides a variety of IDE features in cabal files") + (defaultCabalProjectPluginDescriptor plId "Provides a variety of IDE features in cabal.project files") { pluginRules = cabalRules recorder plId , pluginHandlers = mconcat @@ -92,11 +95,15 @@ descriptor recorder plId = \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri + result <- parseCabalProjectContents (fromNormalizedFilePath file) + case result of + Left err -> putStrLn $ "Cabal project parse failed: " ++ err + Right project -> putStrLn $ "Cabal project parsed successfully: " ++ show project restartCabalShakeSession (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 + whenUriFile _uri $ \file-> do log' Debug $ LogDocModified _uri restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $ addFileOfInterest recorder ide file Modified{firstOpen = False} @@ -126,6 +133,7 @@ descriptor recorder plId = cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () cabalRules recorder _ = do ofInterestRules recorder + -- cabalProjectParseRules recorder {- | Helper function to restart the shake session, specifically for modifying .cabal files. No special logic, just group up a bunch of functions you need for the base 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..002932c390 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs @@ -0,0 +1,97 @@ +module Ide.Plugin.CabalProject.Diagnostics where + +diagnostic = undefined + +-- {-# LANGUAGE DuplicateRecordFields #-} +-- {-# LANGUAGE OverloadedStrings #-} +-- module Ide.Plugin.CabalProject.Diagnostics +-- ( errorDiagnostic +-- , warningDiagnostic +-- , positionFromCabaProjectPosition +-- , fatalParseErrorDiagnostic +-- -- * Re-exports +-- , FileDiagnostic +-- , Diagnostic(..) +-- ) +-- where + +-- import Control.Lens ((&), (.~)) +-- import qualified Data.Text as T +-- import Development.IDE (FileDiagnostic) +-- import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, +-- ideErrorWithSource) +-- import Distribution.Fields (showPError, showPWarning) +-- import qualified Distribution.Parsec as Syntax +-- import Ide.PluginUtils (extendNextLine) +-- import Language.LSP.Protocol.Lens (range) +-- import Language.LSP.Protocol.Types (Diagnostic (..), +-- DiagnosticSeverity (..), +-- NormalizedFilePath, +-- Position (Position), +-- 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 -> 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 -> 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 + +-- -- | The Cabal parser does not output a _range_ for a warning/error, +-- -- 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 :: Syntax.Position -> Range +-- toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos +-- where +-- pos = positionFromCabalPosition cabalPos + +-- -- | Convert a 'Lib.Position' from Cabal to a 'Range' that LSP understands. +-- -- +-- -- Prefer this function over hand-rolled unpacking/packing, since LSP is zero-based, +-- -- while Cabal is one-based. +-- -- +-- -- >>> positionFromCabalPosition $ Lib.Position 1 1 +-- -- Position 0 0 +-- positionFromCabalPosition :: Syntax.Position -> Position +-- positionFromCabalPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col') +-- where +-- -- LSP is zero-based, Cabal is one-based +-- -- Cabal can return line 0 for errors in the first line +-- line' = if line <= 0 then 0 else line-1 +-- col' = if column <= 0 then 0 else column-1 + +-- -- | Create a 'FileDiagnostic' +-- mkDiag +-- :: NormalizedFilePath +-- -- ^ Cabal file path +-- -> T.Text +-- -- ^ Where does the diagnostic come from? +-- -> DiagnosticSeverity +-- -- ^ Severity +-- -> Range +-- -- ^ Which source code range should the editor highlight? +-- -> T.Text +-- -- ^ The message displayed by the editor +-- -> FileDiagnostic +-- mkDiag file diagSource sev loc msg = +-- ideErrorWithSource +-- (Just diagSource) +-- (Just sev) +-- file +-- msg +-- Nothing +-- & fdLspDiagnosticL . range .~ loc 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..743012962f --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.CabalProject.Parse + ( parseCabalProjectContents + ) where + +import Data.Void (Void) + +-- cabal-install-parsers 0.6 modules ----------------------------- +import Cabal.Parse (ParseError) +import Cabal.Project (Project, + parseProject) + +-- error type lives in Cabal-syntax +-- import Distribution.Parsec.Error (ParseError) + +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) + +import qualified Data.ByteString as BS +-- import Distribution.Parsec.Project (parseProject) +-- import Distribution.Parsec.Common (ParseError) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (pack) + +parseCabalProjectContents :: FilePath -> IO (Either String (Project Void String String)) +parseCabalProjectContents file = do + contents <- BS.readFile file + case parseProject file contents of + Left parseErr -> + pure $ Left ("Parse error in " ++ file ++ ": " ++ show parseErr) + Right project -> + pure $ Right project From fc7ac76380fbb4f059d78525266760f745802c65 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Fri, 13 Jun 2025 19:38:19 +0100 Subject: [PATCH 04/26] implement basic parsing with parseProject --- .gitignore | 3 + cabal.project | 10 +++ haskell-language-server.cabal | 2 +- .../src/Ide/Plugin/CabalProject.hs | 68 ++++++++++++++++--- .../Ide/Plugin/CabalProject/Diagnostics.hs | 2 + .../src/Ide/Plugin/CabalProject/Parse.hs | 61 ++++++++++------- 6 files changed, 112 insertions(+), 34 deletions(-) diff --git a/.gitignore b/.gitignore index 2413a1fcf5..619ca1e9f1 100644 --- a/.gitignore +++ b/.gitignore @@ -51,3 +51,6 @@ store/ gh-release-artifacts/ .hls/ + +# local cabal package +vendor/ diff --git a/cabal.project b/cabal.project index a795f0126b..ed23c3e958 100644 --- a/cabal.project +++ b/cabal.project @@ -6,6 +6,16 @@ packages: ./ghcide ./hls-plugin-api ./hls-test-utils + ./vendor/parse-cabal-project/cabal/Cabal + ./vendor/parse-cabal-project/cabal/Cabal-syntax + ./vendor/parse-cabal-project/cabal/cabal-install + ./vendor/parse-cabal-project/cabal/cabal-install-solver + ./vendor/parse-cabal-project/cabal/Cabal-described + ./vendor/parse-cabal-project/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 17e3089f9d..1fe853efae 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -365,7 +365,7 @@ library hls-cabal-project-plugin , aeson , Cabal , pretty - , cabal-install-parsers >= 0.6 && < 0.7 + , cabal-install hs-source-dirs: plugins/hls-cabal-project-plugin/src diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index b9bb351155..f213049edb 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -15,7 +15,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (runMaybeT) import qualified Data.ByteString as BS import Data.Hashable -import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict (HashMap, toList) import qualified Data.HashMap.Strict as HashMap import qualified Data.List as List import qualified Data.List.NonEmpty as NE @@ -45,7 +45,7 @@ import Distribution.PackageDescription.Configuration (flattenPackageDe import Distribution.Parsec.Error import qualified Distribution.Parsec.Position as Syntax import GHC.Generics -import Ide.Plugin.CabalProject.Parse (parseCabalProjectContents) +import Ide.Plugin.CabalProject.Parse (parseCabalProjectFileContents) import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as JL @@ -95,16 +95,14 @@ descriptor recorder plId = \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri - result <- parseCabalProjectContents (fromNormalizedFilePath file) - case result of - Left err -> putStrLn $ "Cabal project parse failed: " ++ err - Right project -> putStrLn $ "Cabal project parsed successfully: " ++ show project + parseAndPrint (fromNormalizedFilePath file) restartCabalShakeSession (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 + parseAndPrint (fromNormalizedFilePath file) restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $ addFileOfInterest recorder ide file Modified{firstOpen = False} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ @@ -130,10 +128,20 @@ descriptor recorder plId = whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' -cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () -cabalRules recorder _ = do - ofInterestRules recorder - -- cabalProjectParseRules recorder + parseAndPrint :: FilePath -> IO () + parseAndPrint file = do + (warnings, res) <- parseCabalProjectFileContents file + + mapM_ (putStrLn . ("[Cabal warning] " ++) . show) warnings + + case res of + Left (_mbSpecVer, errs) -> + putStrLn $ + "Cabal project parse failed:\n" ++ unlines (map show (NE.toList errs)) + + Right project -> + putStrLn $ + "Cabal project parsed successfully:\n" ++ show project {- | Helper function to restart the shake session, specifically for modifying .cabal files. No special logic, just group up a bunch of functions you need for the base @@ -150,6 +158,46 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d keys <- actionBetweenSession return (toKey GetModificationTime file:keys) + +cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () +cabalRules recorder _ = do + -- Make sure we initialise the cabal files-of-interest. + ofInterestRules recorder + -- Rule to produce diagnostics for cabal 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, mCabalSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalSource 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) + +{- | This is the kick function for the cabal plugin. +We run this action, whenever we shake session us run/restarted, which triggers +actions to produce diagnostics for cabal 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 <$> getCabalFilesOfInterestUntracked + Shake.runWithSignal (Proxy @"kick/start/cabal-project") (Proxy @"kick/done/cabal-project") files Types.ParseCabalProjectFile + + -- ---------------------------------------------------------------- -- Cabal file of Interest rules and global variable -- ---------------------------------------------------------------- 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 index 002932c390..4356fcbc44 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs @@ -2,6 +2,8 @@ module Ide.Plugin.CabalProject.Diagnostics where diagnostic = undefined +-- can use renderParseError: https://github.com/haskell/cabal/blob/master/cabal-install/src/Distribution/Client/Utils/Parsec.hs + -- {-# LANGUAGE DuplicateRecordFields #-} -- {-# LANGUAGE OverloadedStrings #-} -- module Ide.Plugin.CabalProject.Diagnostics 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 index 743012962f..90c05dfbe3 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs @@ -1,32 +1,47 @@ {-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.CabalProject.Parse - ( parseCabalProjectContents + ( parseCabalProjectFileContents ) where -import Data.Void (Void) +-- base ----------------------------------------------------------------------- +import Control.Monad (unless) +import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty (..)) +import Distribution.Client.HttpUtils (configureTransport) +import Distribution.Client.ProjectConfig.Parsec (ProjectConfigSkeleton, + parseProject) +import Distribution.Client.ProjectConfig.Types (ProjectConfigToParse (..)) +import Distribution.Fields (PError (..), + PWarning (..)) +import Distribution.Fields.ParseResult (ParseResult, + runParseResult) +import Distribution.Types.Version (Version) +import Distribution.Verbosity (normal) +import System.Directory (doesFileExist) +import System.FilePath (takeDirectory) --- cabal-install-parsers 0.6 modules ----------------------------- -import Cabal.Parse (ParseError) -import Cabal.Project (Project, - parseProject) +parseCabalProjectFileContents + :: FilePath + -> IO ([PWarning] + , Either (Maybe Version, NonEmpty PError) ProjectConfigSkeleton) +parseCabalProjectFileContents fp = do + bytes <- BS.readFile fp + let toParse = ProjectConfigToParse bytes + rootDir = takeDirectory fp + verb = normal + httpTransport <- configureTransport verb [fp] Nothing --- error type lives in Cabal-syntax --- import Distribution.Parsec.Error (ParseError) + parseRes :: ParseResult ProjectConfigSkeleton + <- parseProject rootDir fp httpTransport verb toParse -import Distribution.Types.GenericPackageDescription (GenericPackageDescription) + pure (runParseResult parseRes) -import qualified Data.ByteString as BS --- import Distribution.Parsec.Project (parseProject) --- import Distribution.Parsec.Common (ParseError) -import Data.List.NonEmpty (NonEmpty) -import Data.Text (pack) - -parseCabalProjectContents :: FilePath -> IO (Either String (Project Void String String)) -parseCabalProjectContents file = do - contents <- BS.readFile file - case parseProject file contents of - Left parseErr -> - pure $ Left ("Parse error in " ++ file ++ ": " ++ show parseErr) - Right project -> - pure $ Right project +-- parseCabalProjectContents :: FilePath -> IO (Either String (Project Void String String)) +-- parseCabalProjectContents file = do +-- contents <- BS.readFile file +-- case parseProject file contents of +-- Left parseErr -> +-- pure $ Left ("Parse error in " ++ file ++ ": " ++ show parseErr) +-- Right project -> +-- pure $ Right project From 594bba172033b24016c5323c27d63fdf7b69a4fb Mon Sep 17 00:00:00 2001 From: rm41339 Date: Sat, 14 Jun 2025 16:15:15 +0100 Subject: [PATCH 05/26] preliminary, very basic working diagnostics --- haskell-language-server.cabal | 5 +- .../src/Ide/Plugin/CabalProject.hs | 96 +++++++--- .../Ide/Plugin/CabalProject/Diagnostics.hs | 178 +++++++++--------- .../src/Ide/Plugin/CabalProject/Orphans.hs | 42 +++++ .../src/Ide/Plugin/CabalProject/Parse.hs | 36 +++- .../src/Ide/Plugin/CabalProject/Types.hs | 32 ++++ 6 files changed, 264 insertions(+), 125 deletions(-) create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 1fe853efae..caa01095be 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -339,6 +339,8 @@ library hls-cabal-project-plugin Ide.Plugin.CabalProject Ide.Plugin.CabalProject.Parse Ide.Plugin.CabalProject.Diagnostics + Ide.Plugin.CabalProject.Types + Ide.Plugin.CabalProject.Orphans build-depends: , bytestring @@ -365,7 +367,8 @@ library hls-cabal-project-plugin , aeson , Cabal , pretty - , cabal-install + , cabal-install + , cabal-install-solver hs-source-dirs: plugins/hls-cabal-project-plugin/src diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index f213049edb..846ff96665 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} @@ -45,7 +46,10 @@ import Distribution.PackageDescription.Configuration (flattenPackageDe import Distribution.Parsec.Error import qualified Distribution.Parsec.Position as Syntax import GHC.Generics -import Ide.Plugin.CabalProject.Parse (parseCabalProjectFileContents) +import Ide.Plugin.CabalProject.Diagnostics as Diagnostics +import Ide.Plugin.CabalProject.Orphans () +import Ide.Plugin.CabalProject.Parse as Parse +import Ide.Plugin.CabalProject.Types as Types import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as JL @@ -130,7 +134,7 @@ descriptor recorder plId = parseAndPrint :: FilePath -> IO () parseAndPrint file = do - (warnings, res) <- parseCabalProjectFileContents file + (warnings, res) <- Parse.parseCabalProjectFileContents file mapM_ (putStrLn . ("[Cabal warning] " ++) . show) warnings @@ -143,6 +147,11 @@ descriptor recorder plId = putStrLn $ "Cabal project parsed successfully:\n" ++ show project + bs <- BS.readFile file + case Parse.readCabalProjectFields (toNormalizedFilePath' file) bs of + Left diag -> putStrLn $ "readCabalProjectFields error:\n" ++ show diag + Right flds -> putStrLn $ "readCabalProjectFields success:\n" ++ show flds + {- | Helper function to restart the shake session, specifically for modifying .cabal files. No special logic, just group up a bunch of functions you need for the base Notification Handlers. @@ -160,30 +169,64 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () -cabalRules recorder _ = do - -- Make sure we initialise the cabal files-of-interest. - ofInterestRules recorder - -- Rule to produce diagnostics for cabal 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, mCabalSource) <- use_ GetFileContents file - log' Debug $ LogModificationTime file t - contents <- case mCabalSource 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) +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) $ \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, mCabalSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalSource 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 + -- 1. Grab file contents (virtual-file or disk) + (_hash, mRope) <- use_ GetFileContents file + bytes <- case mRope of + Just rope -> pure (Encoding.encodeUtf8 (Rope.toText rope)) + Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath file) + + -- 2. Run Cabal’s parser for cabal.project + (pWarnings, pResult) <- liftIO $ Parse.parseCabalProjectFileContents (fromNormalizedFilePath file) + + -- 3. Convert warnings + let warnDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings + + -- 4. Convert result or errors + 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 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 plugin. We run this action, whenever we shake session us run/restarted, which triggers @@ -195,6 +238,7 @@ function invocation. kick :: Action () kick = do files <- HashMap.keys <$> getCabalFilesOfInterestUntracked +-- let keys = map Types.ParseCabalProjectFile files Shake.runWithSignal (Proxy @"kick/start/cabal-project") (Proxy @"kick/done/cabal-project") files Types.ParseCabalProjectFile 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 index 4356fcbc44..5ba8856eae 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs @@ -1,99 +1,93 @@ -module Ide.Plugin.CabalProject.Diagnostics where +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.CabalProject.Diagnostics +( errorDiagnostic +, warningDiagnostic +, positionFromCabalProjectPosition +, fatalParseErrorDiagnostic + -- * Re-exports +, FileDiagnostic +, Diagnostic(..) +) +where -diagnostic = undefined +import Control.Lens ((&), (.~)) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic) +import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, + ideErrorWithSource) +import Distribution.Fields (showPError, showPWarning) +import qualified Distribution.Parsec as Syntax +import Ide.PluginUtils (extendNextLine) +import Language.LSP.Protocol.Lens (range) +import Language.LSP.Protocol.Types (Diagnostic (..), + DiagnosticSeverity (..), + NormalizedFilePath, + Position (Position), + Range (Range), + fromNormalizedFilePath) --- can use renderParseError: https://github.com/haskell/cabal/blob/master/cabal-install/src/Distribution/Client/Utils/Parsec.hs +-- | 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 --- {-# LANGUAGE DuplicateRecordFields #-} --- {-# LANGUAGE OverloadedStrings #-} --- module Ide.Plugin.CabalProject.Diagnostics --- ( errorDiagnostic --- , warningDiagnostic --- , positionFromCabaProjectPosition --- , fatalParseErrorDiagnostic --- -- * Re-exports --- , FileDiagnostic --- , Diagnostic(..) --- ) --- where +-- | Produce a diagnostic from a Cabal parser error +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 --- import Control.Lens ((&), (.~)) --- import qualified Data.Text as T --- import Development.IDE (FileDiagnostic) --- import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, --- ideErrorWithSource) --- import Distribution.Fields (showPError, showPWarning) --- import qualified Distribution.Parsec as Syntax --- import Ide.PluginUtils (extendNextLine) --- import Language.LSP.Protocol.Lens (range) --- import Language.LSP.Protocol.Types (Diagnostic (..), --- DiagnosticSeverity (..), --- NormalizedFilePath, --- Position (Position), --- Range (Range), --- fromNormalizedFilePath) +-- | Produce a diagnostic from a Cabal parser warning +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 --- -- | 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 +-- | The Cabal parser does not output a _range_ for a warning/error, +-- 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 :: Syntax.Position -> Range +toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos + where + pos = positionFromCabalProjectPosition cabalPos --- -- | Produce a diagnostic from a Cabal parser error --- 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 +-- | Convert a 'Lib.Position' from Cabal to a 'Range' that LSP understands. +-- +-- Prefer this function over hand-rolled unpacking/packing, since LSP is zero-based, +-- while Cabal is one-based. +-- +-- >>> positionFromCabalPosition $ Lib.Position 1 1 +-- Position 0 0 +positionFromCabalProjectPosition :: Syntax.Position -> Position +positionFromCabalProjectPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col') + where + -- LSP is zero-based, Cabal is one-based + -- Cabal can return line 0 for errors in the first line + line' = if line <= 0 then 0 else line-1 + col' = if column <= 0 then 0 else column-1 --- -- | Produce a diagnostic from a Cabal parser warning --- 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 - --- -- | The Cabal parser does not output a _range_ for a warning/error, --- -- 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 :: Syntax.Position -> Range --- toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos --- where --- pos = positionFromCabalPosition cabalPos - --- -- | Convert a 'Lib.Position' from Cabal to a 'Range' that LSP understands. --- -- --- -- Prefer this function over hand-rolled unpacking/packing, since LSP is zero-based, --- -- while Cabal is one-based. --- -- --- -- >>> positionFromCabalPosition $ Lib.Position 1 1 --- -- Position 0 0 --- positionFromCabalPosition :: Syntax.Position -> Position --- positionFromCabalPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col') --- where --- -- LSP is zero-based, Cabal is one-based --- -- Cabal can return line 0 for errors in the first line --- line' = if line <= 0 then 0 else line-1 --- col' = if column <= 0 then 0 else column-1 - --- -- | Create a 'FileDiagnostic' --- mkDiag --- :: NormalizedFilePath --- -- ^ Cabal file path --- -> T.Text --- -- ^ Where does the diagnostic come from? --- -> DiagnosticSeverity --- -- ^ Severity --- -> Range --- -- ^ Which source code range should the editor highlight? --- -> T.Text --- -- ^ The message displayed by the editor --- -> FileDiagnostic --- mkDiag file diagSource sev loc msg = --- ideErrorWithSource --- (Just diagSource) --- (Just sev) --- file --- msg --- Nothing --- & fdLspDiagnosticL . range .~ loc +-- | Create a 'FileDiagnostic' +mkDiag + :: NormalizedFilePath + -- ^ Cabal file path + -> T.Text + -- ^ Where does the diagnostic come from? + -> DiagnosticSeverity + -- ^ Severity + -> Range + -- ^ Which source code range should the editor highlight? + -> T.Text + -- ^ The message displayed by the editor + -> FileDiagnostic +mkDiag file diagSource sev loc msg = + ideErrorWithSource + (Just diagSource) + (Just sev) + file + msg + Nothing + & fdLspDiagnosticL . range .~ loc diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs new file mode 100644 index 0000000000..c11c7b0faf --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ide.Plugin.CabalProject.Orphans where + +import Control.DeepSeq +import Distribution.Fields.Field +import Distribution.Parsec.Position +-- import Control.DeepSeq (NFData) +import qualified Distribution.Solver.Types.ProjectConfigPath as PCPath +import GHC.Generics (Generic) + +import qualified Distribution.Client.ProjectConfig.Types as PC + +-- ---------------------------------------------------------------- +-- 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 + +-- Project Config Orphans + +deriving instance NFData PCPath.ProjectConfigPath + +instance NFData PC.ProjectConfig where + rnf !_ = () + 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 index 90c05dfbe3..4188189c87 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.CabalProject.Parse - ( parseCabalProjectFileContents + ( parseCabalProjectFileContents, + readCabalProjectFields ) where -- base ----------------------------------------------------------------------- @@ -10,14 +11,22 @@ import qualified Data.ByteString as BS import Data.List.NonEmpty (NonEmpty (..)) import Distribution.Client.HttpUtils (configureTransport) import Distribution.Client.ProjectConfig.Parsec (ProjectConfigSkeleton, - parseProject) + parseProject, + readPreprocessFields) import Distribution.Client.ProjectConfig.Types (ProjectConfigToParse (..)) import Distribution.Fields (PError (..), PWarning (..)) -import Distribution.Fields.ParseResult (ParseResult, - runParseResult) +import qualified Distribution.Fields.ParseResult as PR +-- import Distribution.Fields.ParseResult (ParseResult, +-- runParseResult) +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import Development.IDE +import qualified Distribution.Fields.Parser as Syntax +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 (doesFileExist) import System.FilePath (takeDirectory) @@ -32,10 +41,25 @@ parseCabalProjectFileContents fp = do verb = normal httpTransport <- configureTransport verb [fp] Nothing - parseRes :: ParseResult ProjectConfigSkeleton + parseRes :: PR.ParseResult ProjectConfigSkeleton <- parseProject rootDir fp httpTransport verb toParse - pure (runParseResult parseRes) + 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 -- parseCabalProjectContents :: FilePath -> IO (Either String (Project Void String String)) -- parseCabalProjectContents file = do 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..7df6bcd38d --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs @@ -0,0 +1,32 @@ +{-# 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 + From ba5216db0ab143f4964c049fce5a3ce4f4466e04 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Mon, 16 Jun 2025 13:51:25 +0100 Subject: [PATCH 06/26] add parsing and diagnostics tests --- cabal.project | 1 - haskell-language-server.cabal | 1 + .../src/Ide/Plugin/CabalProject.hs | 5 +- .../src/Ide/Plugin/CabalProject/Parse.hs | 20 +--- plugins/hls-cabal-project-plugin/test/Main.hs | 98 ++++++++++++++++++- .../hls-cabal-project-plugin/test/Utils.hs | 48 +++++++++ .../test/testdata/cabal.project | 0 .../invalid-cabal-project/cabal.project | 3 + .../test/testdata/simple-cabal-project/A.hs | 3 + .../simple-cabal-project/cabal.project | 1 + .../warning-cabal-project/cabal.project | 1 + 11 files changed, 160 insertions(+), 21 deletions(-) create mode 100644 plugins/hls-cabal-project-plugin/test/Utils.hs create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/cabal.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/invalid-cabal-project/cabal.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/A.hs create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/cabal.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/warning-cabal-project/cabal.project diff --git a/cabal.project b/cabal.project index ed23c3e958..1bd85d3090 100644 --- a/cabal.project +++ b/cabal.project @@ -17,7 +17,6 @@ package cabal-install tests: False benchmarks: False - index-state: 2025-05-12T13:26:29Z tests: True diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index caa01095be..83dcdb5d1a 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -380,6 +380,7 @@ test-suite hls-cabal-project-plugin-tests hs-source-dirs: plugins/hls-cabal-project-plugin/test main-is: Main.hs other-modules: + Utils build-depends: , bytestring , Cabal-syntax >= 3.7 diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index 846ff96665..efe4c1c38e 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -99,14 +99,14 @@ descriptor recorder plId = \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri - parseAndPrint (fromNormalizedFilePath file) + -- parseAndPrint (fromNormalizedFilePath file) restartCabalShakeSession (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 - parseAndPrint (fromNormalizedFilePath file) + -- parseAndPrint (fromNormalizedFilePath file) restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $ addFileOfInterest recorder ide file Modified{firstOpen = False} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ @@ -132,6 +132,7 @@ descriptor recorder plId = whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' + -- for development/debugging parseAndPrint :: FilePath -> IO () parseAndPrint file = do (warnings, res) <- Parse.parseCabalProjectFileContents file 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 index 4188189c87..004d117c24 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs @@ -5,10 +5,12 @@ module Ide.Plugin.CabalProject.Parse readCabalProjectFields ) where --- base ----------------------------------------------------------------------- import Control.Monad (unless) import qualified Data.ByteString as BS 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, @@ -16,13 +18,8 @@ import Distribution.Client.ProjectConfig.Parsec (ProjectConfigSkeleton import Distribution.Client.ProjectConfig.Types (ProjectConfigToParse (..)) import Distribution.Fields (PError (..), PWarning (..)) -import qualified Distribution.Fields.ParseResult as PR --- import Distribution.Fields.ParseResult (ParseResult, --- runParseResult) -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import Development.IDE 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) @@ -60,12 +57,3 @@ readCabalProjectFields file contents = (_warnings, Right fields) -> Right fields - --- parseCabalProjectContents :: FilePath -> IO (Either String (Project Void String String)) --- parseCabalProjectContents file = do --- contents <- BS.readFile file --- case parseProject file contents of --- Left parseErr -> --- pure $ Left ("Parse error in " ++ file ++ ": " ++ show parseErr) --- Right project -> --- pure $ Right project diff --git a/plugins/hls-cabal-project-plugin/test/Main.hs b/plugins/hls-cabal-project-plugin/test/Main.hs index b41c7786b6..fc004ce892 100644 --- a/plugins/hls-cabal-project-plugin/test/Main.hs +++ b/plugins/hls-cabal-project-plugin/test/Main.hs @@ -1,3 +1,97 @@ -module Main where +{-# LANGUAGE CPP #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} -main = undefined +module Main ( + main, +) where + +import Control.Lens ((^.)) +import Control.Lens.Fold ((^?)) +import Control.Monad (guard) +import qualified Data.ByteString as BS +import Data.Either (isRight) +import Data.List.Extra (nubOrdOn) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +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 + ] + +-- ------------------------------------------------------------------------ +-- Unit Tests +-- ------------------------------------------------------------------------ + +unitTests :: TestTree +unitTests = + testGroup + "Unit Tests" + [ cabalProjectParserUnitTests + ] + +cabalProjectParserUnitTests :: TestTree +cabalProjectParserUnitTests = + testGroup + "Parsing Cabal Project" + [ testCase "Simple Parsing works" $ do + (warnings, pm) <- Lib.parseCabalProjectFileContents (testDataDir "cabal.project") + liftIO $ do + null warnings @? "Found unexpected warnings" + isRight pm @? "Failed to parse base cabal.project file" + ] + +-- ------------------------ ------------------------------------------------ +-- 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..8ab90dd8bd --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/Utils.hs @@ -0,0 +1,48 @@ +{-# 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.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 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/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/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: . From 2164729df5fa79efe118ff78a8cadc42aff7aca2 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Tue, 17 Jun 2025 18:17:26 +0100 Subject: [PATCH 07/26] remove some redundancies between cabal and cabal-project plugin --- haskell-language-server.cabal | 2 + .../src/Ide/Plugin/Cabal/Diagnostics.hs | 2 + .../Ide/Plugin/CabalProject/Diagnostics.hs | 57 +++---------------- .../src/Ide/Plugin/CabalProject/Orphans.hs | 20 +------ 4 files changed, 12 insertions(+), 69 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 83dcdb5d1a..2281ce44f3 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -369,6 +369,8 @@ library hls-cabal-project-plugin , pretty , cabal-install , cabal-install-solver + , haskell-language-server:hls-cabal-plugin + hs-source-dirs: plugins/hls-cabal-project-plugin/src 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-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs index 5ba8856eae..6fa601e16d 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs @@ -3,7 +3,7 @@ module Ide.Plugin.CabalProject.Diagnostics ( errorDiagnostic , warningDiagnostic -, positionFromCabalProjectPosition +, positionFromCabalPosition , fatalParseErrorDiagnostic -- * Re-exports , FileDiagnostic @@ -18,6 +18,9 @@ import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, ideErrorWithSource) import Distribution.Fields (showPError, showPWarning) import qualified Distribution.Parsec as Syntax +import Ide.Plugin.Cabal.Diagnostics (mkDiag, + positionFromCabalPosition, + toBeginningOfNextLine) import Ide.PluginUtils (extendNextLine) import Language.LSP.Protocol.Lens (range) import Language.LSP.Protocol.Types (Diagnostic (..), @@ -30,64 +33,18 @@ import Language.LSP.Protocol.Types (Diagnostic (..), -- | 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 + mkDiag fp "cabal-project" DiagnosticSeverity_Error (toBeginningOfNextLine Syntax.zeroPos) msg -- | Produce a diagnostic from a Cabal parser error errorDiagnostic :: NormalizedFilePath -> Syntax.PError -> FileDiagnostic errorDiagnostic fp err@(Syntax.PError pos _) = - mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg + mkDiag fp "cabal-project" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg where msg = T.pack $ showPError (fromNormalizedFilePath fp) err -- | Produce a diagnostic from a Cabal parser warning warningDiagnostic :: NormalizedFilePath -> Syntax.PWarning -> FileDiagnostic warningDiagnostic fp warning@(Syntax.PWarning _ pos _) = - mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg + mkDiag fp "cabal-project" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg where msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning - --- | The Cabal parser does not output a _range_ for a warning/error, --- 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 :: Syntax.Position -> Range -toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos - where - pos = positionFromCabalProjectPosition cabalPos - --- | Convert a 'Lib.Position' from Cabal to a 'Range' that LSP understands. --- --- Prefer this function over hand-rolled unpacking/packing, since LSP is zero-based, --- while Cabal is one-based. --- --- >>> positionFromCabalPosition $ Lib.Position 1 1 --- Position 0 0 -positionFromCabalProjectPosition :: Syntax.Position -> Position -positionFromCabalProjectPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col') - where - -- LSP is zero-based, Cabal is one-based - -- Cabal can return line 0 for errors in the first line - line' = if line <= 0 then 0 else line-1 - col' = if column <= 0 then 0 else column-1 - --- | Create a 'FileDiagnostic' -mkDiag - :: NormalizedFilePath - -- ^ Cabal file path - -> T.Text - -- ^ Where does the diagnostic come from? - -> DiagnosticSeverity - -- ^ Severity - -> Range - -- ^ Which source code range should the editor highlight? - -> T.Text - -- ^ The message displayed by the editor - -> FileDiagnostic -mkDiag file diagSource sev loc msg = - ideErrorWithSource - (Just diagSource) - (Just sev) - file - msg - Nothing - & fdLspDiagnosticL . range .~ loc diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs index c11c7b0faf..374dd22682 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs @@ -13,25 +13,7 @@ import qualified Distribution.Solver.Types.ProjectConfigPath as PCPath import GHC.Generics (Generic) import qualified Distribution.Client.ProjectConfig.Types as PC - --- ---------------------------------------------------------------- --- 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 +import Ide.Plugin.Cabal.Orphans () -- Project Config Orphans From 7ff873194c1736de032a42cb4daabd9e015e72b8 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Wed, 25 Jun 2025 15:57:08 +0200 Subject: [PATCH 08/26] removed submodule cabal (will replace in correct directory) --- .gitmodules | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitmodules b/.gitmodules index 7856aaec36..e41d57e61d 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,3 +8,4 @@ # Commit git commit -m "Removed submodule " # Delete the now untracked submodule files # rm -rf path_to_submodule + From 2f9f8262f86988f7b3e39a8b8f4f6be7e7a76f3a Mon Sep 17 00:00:00 2001 From: rm41339 Date: Wed, 25 Jun 2025 16:01:37 +0200 Subject: [PATCH 09/26] remove vendor from .gitignore --- .gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 619ca1e9f1..8674ecc3fc 100644 --- a/.gitignore +++ b/.gitignore @@ -53,4 +53,4 @@ gh-release-artifacts/ .hls/ # local cabal package -vendor/ +# vendor/ From 87ecedfcbe32a6389f44a5ea3a47c79dfdadd12d Mon Sep 17 00:00:00 2001 From: rm41339 Date: Wed, 25 Jun 2025 16:03:42 +0200 Subject: [PATCH 10/26] add cabal submodule --- .gitignore | 2 +- .gitmodules | 3 +++ vendor/cabal | 1 + 3 files changed, 5 insertions(+), 1 deletion(-) create mode 160000 vendor/cabal diff --git a/.gitignore b/.gitignore index 8674ecc3fc..0e23fac134 100644 --- a/.gitignore +++ b/.gitignore @@ -53,4 +53,4 @@ gh-release-artifacts/ .hls/ # local cabal package -# vendor/ +vendor/parse-cabal-project diff --git a/.gitmodules b/.gitmodules index e41d57e61d..49b0b3c940 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,3 +9,6 @@ # 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/vendor/cabal b/vendor/cabal new file mode 160000 index 0000000000..369a520d2c --- /dev/null +++ b/vendor/cabal @@ -0,0 +1 @@ +Subproject commit 369a520d2ca162e5967407b68c107c3922204545 From 8adcdd5e34de8f9bb833a066ec3bed59b38a4632 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Wed, 25 Jun 2025 16:11:47 +0200 Subject: [PATCH 11/26] update cabal.project to reflect new submodule location --- cabal.project | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/cabal.project b/cabal.project index 1bd85d3090..0315ff65a8 100644 --- a/cabal.project +++ b/cabal.project @@ -6,12 +6,12 @@ packages: ./ghcide ./hls-plugin-api ./hls-test-utils - ./vendor/parse-cabal-project/cabal/Cabal - ./vendor/parse-cabal-project/cabal/Cabal-syntax - ./vendor/parse-cabal-project/cabal/cabal-install - ./vendor/parse-cabal-project/cabal/cabal-install-solver - ./vendor/parse-cabal-project/cabal/Cabal-described - ./vendor/parse-cabal-project/cabal/Cabal-tree-diff + ./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 From b74bced4f12031bbe17c6831677723cb9406fc85 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Fri, 27 Jun 2025 08:26:23 +0200 Subject: [PATCH 12/26] fix bytes and cache error in parsing --- haskell-language-server.cabal | 2 + .../src/Ide/Plugin/CabalProject.hs | 20 +- .../src/Ide/Plugin/CabalProject/Orphans.hs | 195 ++++++++++++++++++ .../src/Ide/Plugin/CabalProject/Parse.hs | 33 ++- 4 files changed, 235 insertions(+), 15 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 2281ce44f3..c451a781e5 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -370,6 +370,8 @@ library hls-cabal-project-plugin , cabal-install , cabal-install-solver , haskell-language-server:hls-cabal-plugin + , base16-bytestring + , cryptohash-sha1 hs-source-dirs: plugins/hls-cabal-project-plugin/src diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index efe4c1c38e..6f5f65c6ca 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -135,7 +135,8 @@ descriptor recorder plId = -- for development/debugging parseAndPrint :: FilePath -> IO () parseAndPrint file = do - (warnings, res) <- Parse.parseCabalProjectFileContents file + bytes <- BS.readFile file + (warnings, res) <- Parse.parseCabalProjectFileContents file bytes mapM_ (putStrLn . ("[Cabal warning] " ++) . show) warnings @@ -200,19 +201,18 @@ cabalRules recorder plId = do if not (plcGlobalOn cfg && plcDiagnosticsOn cfg) then pure ([], Nothing) else do - -- 1. Grab file contents (virtual-file or disk) - (_hash, mRope) <- use_ GetFileContents file - bytes <- case mRope of - Just rope -> pure (Encoding.encodeUtf8 (Rope.toText rope)) - Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath file) + -- 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, mRope) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t - -- 2. Run Cabal’s parser for cabal.project - (pWarnings, pResult) <- liftIO $ Parse.parseCabalProjectFileContents (fromNormalizedFilePath file) + bytes <- case mRope of + Just sources -> pure (Encoding.encodeUtf8 (Rope.toText sources)) + Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath file) - -- 3. Convert warnings + (pWarnings, pResult) <- liftIO $ Parse.parseCabalProjectFileContents (fromNormalizedFilePath file) bytes let warnDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings - -- 4. Convert result or errors case pResult of Left (_specVer, pErrNE) -> do let errDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrNE diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs index 374dd22682..9f15a5a46c 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs @@ -22,3 +22,198 @@ deriving instance NFData PCPath.ProjectConfigPath instance NFData PC.ProjectConfig where rnf !_ = () +-- {-# OPTIONS_GHC -Wno-orphans #-} +-- {-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE RecordWildCards #-} + +-- module Ide.Plugin.CabalProject.Orphans () where + +-- import Control.DeepSeq ( NFData, rnf ) +-- import Distribution.Compat.Prelude ( genericRnf ) +-- import Distribution.Verbosity (Verbosity) +-- import Distribution.Verbosity.Internal (VerbosityLevel(..), VerbosityFlag(..)) +-- import Ide.Plugin.Cabal.Orphans () + +-- import Distribution.Client.ProjectConfig.Types +-- ( BuildTimeSettings(..) ) +-- import Distribution.Simple.InstallDirs.Internal +-- ( PathComponent(..), PathTemplateVariable(..) +-- ) +-- import Distribution.Simple.InstallDirs +-- ( PathTemplate(..) ) +-- import Control.DeepSeq ( NFData(rnf) ) +-- import Distribution.Client.BuildReports.Types (ReportLevel) + +-- import Distribution.Client.Types.Repo (RemoteRepo, LocalRepo) + +-- -- PathTemplate +-- instance NFData PathTemplate where +-- rnf = genericRnf + +-- instance NFData PathComponent where +-- rnf = genericRnf + +-- instance NFData PathTemplateVariable where +-- rnf = genericRnf + +-- -- Verbosity +-- instance NFData Verbosity where +-- rnf = genericRnf + +-- -- instance NFData VerbosityLevel where +-- -- rnf = genericRnf + +-- -- instance NFData VerbosityFlag where +-- -- rnf = genericRnf + +-- -- ReportLevel +-- instance NFData ReportLevel where +-- rnf = genericRnf + +-- -- RemoteRepo +-- instance NFData RemoteRepo where +-- rnf = genericRnf + +-- instance NFData LocalRepo where +-- rnf = genericRnf + +-- instance NFData BuildTimeSettings where +-- rnf bts = +-- rnf (buildSettingDryRun bts) +-- `seq` rnf (buildSettingOnlyDeps bts) +-- `seq` rnf (buildSettingOnlyDownload bts) +-- `seq` rnf (buildSettingSummaryFile bts) +-- `seq` () +-- `seq` rnf (buildSettingLogVerbosity bts) +-- `seq` rnf (buildSettingBuildReports bts) +-- `seq` rnf (buildSettingReportPlanningFailure bts) +-- `seq` rnf (buildSettingSymlinkBinDir bts) +-- `seq` rnf (buildSettingNumJobs bts) +-- `seq` rnf (buildSettingKeepGoing bts) +-- `seq` rnf (buildSettingOfflineMode bts) +-- `seq` rnf (buildSettingKeepTempFiles bts) +-- `seq` rnf (buildSettingRemoteRepos bts) +-- `seq` rnf (buildSettingLocalNoIndexRepos bts) +-- `seq` rnf (buildSettingCacheDir bts) +-- `seq` rnf (buildSettingHttpTransport bts) +-- `seq` rnf (buildSettingIgnoreExpiry bts) +-- `seq` rnf (buildSettingProgPathExtra bts) +-- `seq` rnf (buildSettingHaddockOpen bts) +-- `seq` () +-- {-# OPTIONS_GHC -Wno-orphans #-} +-- module Ide.Plugin.CabalProject.Orphans () where + +-- import Control.DeepSeq ( NFData, rnf) +-- import Distribution.Compat.Prelude (genericRnf) +-- import Ide.Plugin.Cabal.Orphans () +-- import Distribution.Client.ProjectConfig.Types (BuildTimeSettings(..)) +-- import GHC.Generics ( Generic ) +-- import Control.DeepSeq ( NFData(rnf) ) +-- import Distribution.Simple.InstallDirs ( PathTemplate ) +-- import Distribution.Verbosity ( Verbosity ) +-- import Distribution.Client.BuildReports.Types ( ReportLevel ) +-- import Distribution.Types.ParStrat ( ParStratInstall ) +-- import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo ) + +-- -- 1) Orphan NFData instances for all the “missing” imported types. +-- instance NFData PathTemplate where rnf = genericRnf +-- instance NFData Verbosity where rnf = genericRnf +-- instance NFData ReportLevel where rnf = genericRnf +-- instance NFData ParStratInstall where rnf = genericRnf +-- instance NFData RemoteRepo where rnf = genericRnf +-- instance NFData LocalRepo where rnf = genericRnf + +-- instance NFData BuildTimeSettings where +-- rnf bts = +-- rnf (buildSettingDryRun bts) +-- `seq` rnf (buildSettingOnlyDeps bts) +-- `seq` rnf (buildSettingOnlyDownload bts) +-- `seq` rnf (buildSettingSummaryFile bts) +-- `seq` () +-- `seq` rnf (buildSettingLogVerbosity bts) +-- `seq` rnf (buildSettingBuildReports bts) +-- `seq` rnf (buildSettingReportPlanningFailure bts) +-- `seq` rnf (buildSettingSymlinkBinDir bts) +-- `seq` rnf (buildSettingNumJobs bts) +-- `seq` rnf (buildSettingKeepGoing bts) +-- `seq` rnf (buildSettingOfflineMode bts) +-- `seq` rnf (buildSettingKeepTempFiles bts) +-- `seq` rnf (buildSettingRemoteRepos bts) +-- `seq` rnf (buildSettingLocalNoIndexRepos bts) +-- `seq` rnf (buildSettingCacheDir bts) +-- `seq` rnf (buildSettingHttpTransport bts) +-- `seq` rnf (buildSettingIgnoreExpiry bts) +-- `seq` rnf (buildSettingProgPathExtra bts) +-- `seq` rnf (buildSettingHaddockOpen bts) +-- `seq` () + + +-- import Control.DeepSeq (NFData(rnf)) +-- import qualified Data.Map as Map +-- import qualified Data.Set as Set +-- import Ide.Plugin.Cabal.Orphans () + + +-- import Distribution.Client.ProjectConfig.Types +-- ( ProjectConfig(..) +-- , ProjectConfigBuildOnly +-- , ProjectConfigShared +-- , ProjectConfigProvenance +-- , PackageConfig +-- , MapMappend(getMapMappend) +-- ) +-- import Distribution.Client.Types.SourceRepo +-- ( SourceRepoList ) +-- import Distribution.Types.PackageVersionConstraint +-- ( PackageVersionConstraint ) +-- import Distribution.Types.PackageName +-- ( PackageName ) + +-- -- | The only “deep” NFData: we pattern‐match on all ten fields and +-- -- rnf them. For the Set we convert to a list so we don’t need +-- -- a Set‐instance; for the MapMappend we unwrap to a list of pairs. +-- instance NFData ProjectConfig where +-- rnf (ProjectConfig +-- pkgs +-- pkgsOpt +-- pkgsRepo +-- pkgsNamed +-- buildOnly +-- shared +-- prov +-- allPkgs +-- localPkgs +-- specificM) = +-- rnf pkgs +-- `seq` rnf pkgsOpt +-- `seq` rnf pkgsRepo +-- `seq` rnf pkgsNamed +-- `seq` rnf buildOnly +-- `seq` rnf shared +-- `seq` rnf (Set.toList prov) +-- `seq` rnf allPkgs +-- `seq` rnf localPkgs +-- `seq` rnf (Map.toList (getMapMappend specificM)) + +-- -- Trivial NFData instances for all of the immediate field types +-- -- so that the above rnf calls will compile. + +-- instance NFData SourceRepoList where +-- rnf _ = () + +-- instance NFData ProjectConfigBuildOnly where +-- rnf _ = () + +-- instance NFData ProjectConfigShared where +-- rnf _ = () + +-- instance NFData ProjectConfigProvenance where +-- rnf _ = () + +-- instance NFData PackageConfig where +-- rnf _ = () + + +------------------------------------------------- OLD + + 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 index 004d117c24..d34e6bfaae 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs @@ -6,7 +6,10 @@ module Ide.Plugin.CabalProject.Parse ) where import Control.Monad (unless) +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 @@ -25,21 +28,30 @@ import Distribution.Types.Version (Version) import Distribution.Verbosity (normal) import qualified Ide.Plugin.CabalProject.Diagnostics as Diagnostics import System.Directory (doesFileExist) -import System.FilePath (takeDirectory) +import System.Directory.Extra (XdgDirectory (..), + getXdgDirectory) +import System.FilePath (takeBaseName, + takeDirectory, ()) +-- import System.Directory.Extra as SD + + + parseCabalProjectFileContents :: FilePath + -> BS.ByteString -> IO ([PWarning] , Either (Maybe Version, NonEmpty PError) ProjectConfigSkeleton) -parseCabalProjectFileContents fp = do - bytes <- BS.readFile fp +parseCabalProjectFileContents fp bytes = do + cacheDir <- getCabalProjectCacheDir fp +-- bytes <- BS.readFile fp let toParse = ProjectConfigToParse bytes - rootDir = takeDirectory fp + -- rootDir = takeDirectory fp verb = normal httpTransport <- configureTransport verb [fp] Nothing parseRes :: PR.ParseResult ProjectConfigSkeleton - <- parseProject rootDir fp httpTransport verb toParse + <- parseProject fp cacheDir httpTransport verb toParse pure (PR.runParseResult parseRes) @@ -57,3 +69,14 @@ readCabalProjectFields file contents = (_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" From 72fc5ab817b7bcb06905ec7c51fcce600e91eda6 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Mon, 30 Jun 2025 13:42:48 +0200 Subject: [PATCH 13/26] add NFData instances to cabal --- .../src/Ide/Plugin/CabalProject/Orphans.hs | 15 ++++++++++++--- vendor/cabal | 2 +- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs index 9f15a5a46c..cd55360002 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs @@ -15,12 +15,21 @@ import GHC.Generics (Generic) import qualified Distribution.Client.ProjectConfig.Types as PC import Ide.Plugin.Cabal.Orphans () + +orphans = undefined -- Project Config Orphans -deriving instance NFData PCPath.ProjectConfigPath -instance NFData PC.ProjectConfig where - rnf !_ = () +-- more nfdata instances i need: +-- Distribution.Client.Types.SourceRepo.SourceRepositoryPackage [] +-- NFData (NubList PathTemplate) +-- NFData (InstallDirs (Flag PathTemplate)) +-- NFData (NubList FilePath) + +-- deriving instance NFData PCPath.ProjectConfigPath + +-- instance NFData PC.ProjectConfig where +-- rnf !_ = () -- {-# OPTIONS_GHC -Wno-orphans #-} -- {-# LANGUAGE FlexibleInstances #-} diff --git a/vendor/cabal b/vendor/cabal index 369a520d2c..e67e97fdd6 160000 --- a/vendor/cabal +++ b/vendor/cabal @@ -1 +1 @@ -Subproject commit 369a520d2ca162e5967407b68c107c3922204545 +Subproject commit e67e97fdd60983550bdc963dbf873a0895ceac8d From c05125e32c61be6b972a6f20a301dfbbac8649e4 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Thu, 3 Jul 2025 22:28:19 +0200 Subject: [PATCH 14/26] fix parseCabalProjectFileContents arguments, add test --- haskell-language-server.cabal | 2 + .../src/Ide/Plugin/CabalProject.hs | 14 ++--- .../src/Ide/Plugin/CabalProject/Parse.hs | 4 -- plugins/hls-cabal-project-plugin/test/Main.hs | 54 +++++++++++++++---- .../testdata/root-directory/cabal.project | 1 + vendor/cabal | 2 +- 6 files changed, 55 insertions(+), 22 deletions(-) create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/root-directory/cabal.project diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index c451a781e5..59b4067db6 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -397,6 +397,8 @@ test-suite hls-cabal-project-plugin-tests , lsp-types , text , hls-plugin-api + , cabal-install + ----------------------------- -- class plugin diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index 6f5f65c6ca..c9fb4a4386 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -58,7 +58,7 @@ import Language.LSP.Protocol.Types import qualified Language.LSP.VFS as VFS import System.FilePath (takeFileName) import Text.Regex.TDFA - +-- import Ide.Plugin.Cabal.Orphans () data Log = LogModificationTime NormalizedFilePath FileVersion @@ -203,14 +203,16 @@ cabalRules recorder plId = do 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, mRope) <- use_ GetFileContents file + (t, mCabalSource) <- use_ GetFileContents file log' Debug $ LogModificationTime file t - bytes <- case mRope of - Just sources -> pure (Encoding.encodeUtf8 (Rope.toText sources)) - Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath file) + contents <- case mCabalSource of + Just sources -> + pure $ Encoding.encodeUtf8 $ Rope.toText sources + Nothing -> + liftIO $ BS.readFile $ fromNormalizedFilePath file - (pWarnings, pResult) <- liftIO $ Parse.parseCabalProjectFileContents (fromNormalizedFilePath file) bytes + (pWarnings, pResult) <- liftIO $ Parse.parseCabalProjectFileContents (fromNormalizedFilePath file) contents let warnDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings case pResult of 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 index d34e6bfaae..1eaa2533ce 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs @@ -32,10 +32,6 @@ import System.Directory.Extra (XdgDirectory (..), getXdgDirectory) import System.FilePath (takeBaseName, takeDirectory, ()) --- import System.Directory.Extra as SD - - - parseCabalProjectFileContents :: FilePath diff --git a/plugins/hls-cabal-project-plugin/test/Main.hs b/plugins/hls-cabal-project-plugin/test/Main.hs index fc004ce892..b1ef14336a 100644 --- a/plugins/hls-cabal-project-plugin/test/Main.hs +++ b/plugins/hls-cabal-project-plugin/test/Main.hs @@ -6,20 +6,29 @@ module Main ( main, ) where -import Control.Lens ((^.)) -import Control.Lens.Fold ((^?)) -import Control.Monad (guard) -import qualified Data.ByteString as BS -import Data.Either (isRight) -import Data.List.Extra (nubOrdOn) -import qualified Data.Maybe as Maybe -import qualified Data.Text as T -import qualified Ide.Plugin.CabalProject.Parse as Lib -import qualified Language.LSP.Protocol.Lens as L +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 $ @@ -45,10 +54,33 @@ cabalProjectParserUnitTests = testGroup "Parsing Cabal Project" [ testCase "Simple Parsing works" $ do - (warnings, pm) <- Lib.parseCabalProjectFileContents (testDataDir "cabal.project") + 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" ] -- ------------------------ ------------------------------------------------ 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/vendor/cabal b/vendor/cabal index e67e97fdd6..447964a7b8 160000 --- a/vendor/cabal +++ b/vendor/cabal @@ -1 +1 @@ -Subproject commit e67e97fdd60983550bdc963dbf873a0895ceac8d +Subproject commit 447964a7b8fb430f69dcfd394188c0eafd576413 From 8dc4a545c27b13dffde9de58bca0b2c4a4994865 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Thu, 3 Jul 2025 22:40:47 +0200 Subject: [PATCH 15/26] finish cleaning up diagnostics code --- haskell-language-server.cabal | 1 - .../src/Ide/Plugin/CabalProject.hs | 27 +-- .../src/Ide/Plugin/CabalProject/Orphans.hs | 228 ------------------ 3 files changed, 1 insertion(+), 255 deletions(-) delete mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 59b4067db6..58fb52ecb7 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -340,7 +340,6 @@ library hls-cabal-project-plugin Ide.Plugin.CabalProject.Parse Ide.Plugin.CabalProject.Diagnostics Ide.Plugin.CabalProject.Types - Ide.Plugin.CabalProject.Orphans build-depends: , bytestring diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index c9fb4a4386..1c9ed94fe4 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -46,8 +46,8 @@ import Distribution.PackageDescription.Configuration (flattenPackageDe import Distribution.Parsec.Error import qualified Distribution.Parsec.Position as Syntax import GHC.Generics +import Ide.Plugin.Cabal.Orphans () import Ide.Plugin.CabalProject.Diagnostics as Diagnostics -import Ide.Plugin.CabalProject.Orphans () import Ide.Plugin.CabalProject.Parse as Parse import Ide.Plugin.CabalProject.Types as Types import Ide.Plugin.Error @@ -58,7 +58,6 @@ import Language.LSP.Protocol.Types import qualified Language.LSP.VFS as VFS import System.FilePath (takeFileName) import Text.Regex.TDFA --- import Ide.Plugin.Cabal.Orphans () data Log = LogModificationTime NormalizedFilePath FileVersion @@ -99,14 +98,12 @@ descriptor recorder plId = \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri - -- parseAndPrint (fromNormalizedFilePath file) restartCabalShakeSession (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 - -- parseAndPrint (fromNormalizedFilePath file) restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $ addFileOfInterest recorder ide file Modified{firstOpen = False} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ @@ -132,28 +129,6 @@ descriptor recorder plId = whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' - -- for development/debugging - parseAndPrint :: FilePath -> IO () - parseAndPrint file = do - bytes <- BS.readFile file - (warnings, res) <- Parse.parseCabalProjectFileContents file bytes - - mapM_ (putStrLn . ("[Cabal warning] " ++) . show) warnings - - case res of - Left (_mbSpecVer, errs) -> - putStrLn $ - "Cabal project parse failed:\n" ++ unlines (map show (NE.toList errs)) - - Right project -> - putStrLn $ - "Cabal project parsed successfully:\n" ++ show project - - bs <- BS.readFile file - case Parse.readCabalProjectFields (toNormalizedFilePath' file) bs of - Left diag -> putStrLn $ "readCabalProjectFields error:\n" ++ show diag - Right flds -> putStrLn $ "readCabalProjectFields success:\n" ++ show flds - {- | Helper function to restart the shake session, specifically for modifying .cabal files. No special logic, just group up a bunch of functions you need for the base Notification Handlers. diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs deleted file mode 100644 index cd55360002..0000000000 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Orphans.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Ide.Plugin.CabalProject.Orphans where - -import Control.DeepSeq -import Distribution.Fields.Field -import Distribution.Parsec.Position --- import Control.DeepSeq (NFData) -import qualified Distribution.Solver.Types.ProjectConfigPath as PCPath -import GHC.Generics (Generic) - -import qualified Distribution.Client.ProjectConfig.Types as PC -import Ide.Plugin.Cabal.Orphans () - - -orphans = undefined --- Project Config Orphans - - --- more nfdata instances i need: --- Distribution.Client.Types.SourceRepo.SourceRepositoryPackage [] --- NFData (NubList PathTemplate) --- NFData (InstallDirs (Flag PathTemplate)) --- NFData (NubList FilePath) - --- deriving instance NFData PCPath.ProjectConfigPath - --- instance NFData PC.ProjectConfig where --- rnf !_ = () - --- {-# OPTIONS_GHC -Wno-orphans #-} --- {-# LANGUAGE FlexibleInstances #-} --- {-# LANGUAGE RecordWildCards #-} - --- module Ide.Plugin.CabalProject.Orphans () where - --- import Control.DeepSeq ( NFData, rnf ) --- import Distribution.Compat.Prelude ( genericRnf ) --- import Distribution.Verbosity (Verbosity) --- import Distribution.Verbosity.Internal (VerbosityLevel(..), VerbosityFlag(..)) --- import Ide.Plugin.Cabal.Orphans () - --- import Distribution.Client.ProjectConfig.Types --- ( BuildTimeSettings(..) ) --- import Distribution.Simple.InstallDirs.Internal --- ( PathComponent(..), PathTemplateVariable(..) --- ) --- import Distribution.Simple.InstallDirs --- ( PathTemplate(..) ) --- import Control.DeepSeq ( NFData(rnf) ) --- import Distribution.Client.BuildReports.Types (ReportLevel) - --- import Distribution.Client.Types.Repo (RemoteRepo, LocalRepo) - --- -- PathTemplate --- instance NFData PathTemplate where --- rnf = genericRnf - --- instance NFData PathComponent where --- rnf = genericRnf - --- instance NFData PathTemplateVariable where --- rnf = genericRnf - --- -- Verbosity --- instance NFData Verbosity where --- rnf = genericRnf - --- -- instance NFData VerbosityLevel where --- -- rnf = genericRnf - --- -- instance NFData VerbosityFlag where --- -- rnf = genericRnf - --- -- ReportLevel --- instance NFData ReportLevel where --- rnf = genericRnf - --- -- RemoteRepo --- instance NFData RemoteRepo where --- rnf = genericRnf - --- instance NFData LocalRepo where --- rnf = genericRnf - --- instance NFData BuildTimeSettings where --- rnf bts = --- rnf (buildSettingDryRun bts) --- `seq` rnf (buildSettingOnlyDeps bts) --- `seq` rnf (buildSettingOnlyDownload bts) --- `seq` rnf (buildSettingSummaryFile bts) --- `seq` () --- `seq` rnf (buildSettingLogVerbosity bts) --- `seq` rnf (buildSettingBuildReports bts) --- `seq` rnf (buildSettingReportPlanningFailure bts) --- `seq` rnf (buildSettingSymlinkBinDir bts) --- `seq` rnf (buildSettingNumJobs bts) --- `seq` rnf (buildSettingKeepGoing bts) --- `seq` rnf (buildSettingOfflineMode bts) --- `seq` rnf (buildSettingKeepTempFiles bts) --- `seq` rnf (buildSettingRemoteRepos bts) --- `seq` rnf (buildSettingLocalNoIndexRepos bts) --- `seq` rnf (buildSettingCacheDir bts) --- `seq` rnf (buildSettingHttpTransport bts) --- `seq` rnf (buildSettingIgnoreExpiry bts) --- `seq` rnf (buildSettingProgPathExtra bts) --- `seq` rnf (buildSettingHaddockOpen bts) --- `seq` () --- {-# OPTIONS_GHC -Wno-orphans #-} --- module Ide.Plugin.CabalProject.Orphans () where - --- import Control.DeepSeq ( NFData, rnf) --- import Distribution.Compat.Prelude (genericRnf) --- import Ide.Plugin.Cabal.Orphans () --- import Distribution.Client.ProjectConfig.Types (BuildTimeSettings(..)) --- import GHC.Generics ( Generic ) --- import Control.DeepSeq ( NFData(rnf) ) --- import Distribution.Simple.InstallDirs ( PathTemplate ) --- import Distribution.Verbosity ( Verbosity ) --- import Distribution.Client.BuildReports.Types ( ReportLevel ) --- import Distribution.Types.ParStrat ( ParStratInstall ) --- import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo ) - --- -- 1) Orphan NFData instances for all the “missing” imported types. --- instance NFData PathTemplate where rnf = genericRnf --- instance NFData Verbosity where rnf = genericRnf --- instance NFData ReportLevel where rnf = genericRnf --- instance NFData ParStratInstall where rnf = genericRnf --- instance NFData RemoteRepo where rnf = genericRnf --- instance NFData LocalRepo where rnf = genericRnf - --- instance NFData BuildTimeSettings where --- rnf bts = --- rnf (buildSettingDryRun bts) --- `seq` rnf (buildSettingOnlyDeps bts) --- `seq` rnf (buildSettingOnlyDownload bts) --- `seq` rnf (buildSettingSummaryFile bts) --- `seq` () --- `seq` rnf (buildSettingLogVerbosity bts) --- `seq` rnf (buildSettingBuildReports bts) --- `seq` rnf (buildSettingReportPlanningFailure bts) --- `seq` rnf (buildSettingSymlinkBinDir bts) --- `seq` rnf (buildSettingNumJobs bts) --- `seq` rnf (buildSettingKeepGoing bts) --- `seq` rnf (buildSettingOfflineMode bts) --- `seq` rnf (buildSettingKeepTempFiles bts) --- `seq` rnf (buildSettingRemoteRepos bts) --- `seq` rnf (buildSettingLocalNoIndexRepos bts) --- `seq` rnf (buildSettingCacheDir bts) --- `seq` rnf (buildSettingHttpTransport bts) --- `seq` rnf (buildSettingIgnoreExpiry bts) --- `seq` rnf (buildSettingProgPathExtra bts) --- `seq` rnf (buildSettingHaddockOpen bts) --- `seq` () - - --- import Control.DeepSeq (NFData(rnf)) --- import qualified Data.Map as Map --- import qualified Data.Set as Set --- import Ide.Plugin.Cabal.Orphans () - - --- import Distribution.Client.ProjectConfig.Types --- ( ProjectConfig(..) --- , ProjectConfigBuildOnly --- , ProjectConfigShared --- , ProjectConfigProvenance --- , PackageConfig --- , MapMappend(getMapMappend) --- ) --- import Distribution.Client.Types.SourceRepo --- ( SourceRepoList ) --- import Distribution.Types.PackageVersionConstraint --- ( PackageVersionConstraint ) --- import Distribution.Types.PackageName --- ( PackageName ) - --- -- | The only “deep” NFData: we pattern‐match on all ten fields and --- -- rnf them. For the Set we convert to a list so we don’t need --- -- a Set‐instance; for the MapMappend we unwrap to a list of pairs. --- instance NFData ProjectConfig where --- rnf (ProjectConfig --- pkgs --- pkgsOpt --- pkgsRepo --- pkgsNamed --- buildOnly --- shared --- prov --- allPkgs --- localPkgs --- specificM) = --- rnf pkgs --- `seq` rnf pkgsOpt --- `seq` rnf pkgsRepo --- `seq` rnf pkgsNamed --- `seq` rnf buildOnly --- `seq` rnf shared --- `seq` rnf (Set.toList prov) --- `seq` rnf allPkgs --- `seq` rnf localPkgs --- `seq` rnf (Map.toList (getMapMappend specificM)) - --- -- Trivial NFData instances for all of the immediate field types --- -- so that the above rnf calls will compile. - --- instance NFData SourceRepoList where --- rnf _ = () - --- instance NFData ProjectConfigBuildOnly where --- rnf _ = () - --- instance NFData ProjectConfigShared where --- rnf _ = () - --- instance NFData ProjectConfigProvenance where --- rnf _ = () - --- instance NFData PackageConfig where --- rnf _ = () - - -------------------------------------------------- OLD - - From 09af6a41fbcfcc5fd27ffefdec2b10f238bdaec4 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Fri, 4 Jul 2025 15:01:24 +0200 Subject: [PATCH 16/26] very basic constant completions with formatting --- haskell-language-server.cabal | 6 + .../src/Ide/Plugin/CabalProject.hs | 135 +++++++++---- .../Completion/CabalProjectFields.hs | 7 + .../Completion/Completer/Simple.hs | 3 + .../Completion/Completer/Types.hs | 5 + .../CabalProject/Completion/Completions.hs | 179 ++++++++++++++++++ .../Plugin/CabalProject/Completion/Data.hs | 80 ++++++++ .../src/Ide/Plugin/CabalProject/Types.hs | 1 + 8 files changed, 377 insertions(+), 39 deletions(-) create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/CabalProjectFields.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Simple.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completions.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Data.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 58fb52ecb7..9ede2d5edd 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -340,6 +340,12 @@ library hls-cabal-project-plugin Ide.Plugin.CabalProject.Parse Ide.Plugin.CabalProject.Diagnostics Ide.Plugin.CabalProject.Types + Ide.Plugin.CabalProject.Completion.Completions + Ide.Plugin.CabalProject.Completion.Completer.Simple + Ide.Plugin.CabalProject.Completion.Completer.Types + Ide.Plugin.CabalProject.Completion.CabalProjectFields + Ide.Plugin.CabalProject.Completion.Data + build-depends: , bytestring diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index 1c9ed94fe4..b58d263a07 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -9,56 +9,63 @@ module Ide.Plugin.CabalProject where import Control.Concurrent.Strict import Control.DeepSeq -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Maybe (runMaybeT) -import qualified Data.ByteString as BS +import Control.Monad.Trans.Class (lift) +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 as List -import qualified Data.List.NonEmpty as NE -import qualified Data.Maybe as Maybe +import Data.HashMap.Strict (HashMap, + toList) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import qualified Data.Maybe as Maybe import Data.Proxy -import qualified Data.Text () -import qualified Data.Text as T -import qualified Data.Text.Encoding as Encoding -import Data.Text.Utf16.Rope.Mixed as Rope -import Development.IDE as D -import Development.IDE.Core.FileStore (getVersionedTextDoc) +import qualified Data.Text () +import qualified Data.Text as T +import qualified Data.Text.Encoding as Encoding +import Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE as D +import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils -import Development.IDE.Core.Shake (restartShakeSession) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Graph (Key, - alwaysRerun) -import Development.IDE.LSP.HoverDefinition (foundHover) -import qualified Development.IDE.Plugin.Completions.Logic as Ghcide -import Development.IDE.Types.Shake (toKey) -import qualified Distribution.CabalSpecVersion as Cabal -import qualified Distribution.Fields as Syntax -import Distribution.Package (Dependency) -import Distribution.PackageDescription (allBuildDepends, - depPkgName, - unPackageName) -import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Development.IDE.Core.Shake (restartShakeSession) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Graph (Key, + alwaysRerun) +import Development.IDE.LSP.HoverDefinition (foundHover) +import qualified Development.IDE.Plugin.Completions.Logic as Ghcide +import Development.IDE.Types.Shake (toKey) +import qualified Distribution.CabalSpecVersion as Cabal +import qualified Distribution.Fields as Syntax +import Distribution.Package (Dependency) +import Distribution.PackageDescription (allBuildDepends, + depPkgName, + unPackageName) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.Parsec.Error -import qualified Distribution.Parsec.Position as Syntax +import qualified Distribution.Parsec.Position as Syntax import GHC.Generics -import Ide.Plugin.Cabal.Orphans () -import Ide.Plugin.CabalProject.Diagnostics as Diagnostics -import Ide.Plugin.CabalProject.Parse as Parse -import Ide.Plugin.CabalProject.Types as Types +import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields +import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes +import qualified Ide.Plugin.Cabal.Completion.Data as Data +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.Plugin.Error import Ide.Types -import qualified Language.LSP.Protocol.Lens as JL -import qualified Language.LSP.Protocol.Message as LSP +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 -import System.FilePath (takeFileName) +import qualified Language.LSP.VFS as VFS +import System.FilePath (takeFileName) import Text.Regex.TDFA + data Log = LogModificationTime NormalizedFilePath FileVersion | LogShake Shake.Log @@ -67,6 +74,8 @@ data Log | LogDocSaved Uri | LogDocClosed Uri | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) + | LogCompletionContext CTypes.Context Position + | LogCompletions CTypes.Log deriving (Show) instance Pretty Log where @@ -91,7 +100,9 @@ descriptor recorder plId = { pluginRules = cabalRules recorder plId , pluginHandlers = mconcat - [] + [ + mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder + ] , pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ @@ -294,3 +305,49 @@ deleteFileOfInterest recorder state f = do 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 + -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested. + -- In case it fails, we still will get some completion results instead of an error. + 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 + cabalPrefInfo = Completions.getCabalPrefixInfo path lspPrefInfo + let res = computeCompletionsAt recorder ide cabalPrefInfo 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 ide prefInfo 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 + { + 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/CabalProjectFields.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/CabalProjectFields.hs new file mode 100644 index 0000000000..3a07899144 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/CabalProjectFields.hs @@ -0,0 +1,7 @@ +module Ide.Plugin.CabalProject.Completion.CabalProjectFields where + +import Ide.Plugin.Cabal.Completion.CabalFields (findFieldSection, + findStanzaForColumn, + getAnnotation, + getFieldName, + getOptionalSectionName) diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Simple.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Simple.hs new file mode 100644 index 0000000000..0fcbc66608 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Simple.hs @@ -0,0 +1,3 @@ +module Ide.Plugin.CabalProject.Completion.Completer.Simple where + +import Ide.Plugin.Cabal.Completion.Completer.Simple diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs new file mode 100644 index 0000000000..34ec85351e --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.CabalProject.Completion.Completer.Types where + +import Ide.Plugin.Cabal.Completion.Completer.Types 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..1f0a18ad93 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completions.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.CabalProject.Completion.Completions (contextToCompleter, getContext, getCabalPrefixInfo) 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.Snippet +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 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 packageFields +-- 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 (cabalVersionKeyword <> cabalKeywords) 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. +-- +-- TODO: first line can only have cabal-version: keyword +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 +-- 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. +getCabalPrefixInfo :: FilePath -> Ghcide.PosPrefixInfo -> CabalPrefixInfo +getCabalPrefixInfo 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 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..27571a6b85 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Data.hs @@ -0,0 +1,80 @@ +{-# 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 +-- import Ide.Plugin.Cabal.Completion.Completer.Module +-- import Ide.Plugin.Cabal.Completion.Completer.Paths +import Ide.Plugin.Cabal.Completion.Completer.Simple +import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) +import Ide.Plugin.Cabal.Completion.Types +-- import Ide.Plugin.Cabal.LicenseSuggest (licenseNames) + +-- ---------------------------------------------------------------- +-- Completion Data +-- ---------------------------------------------------------------- + +-- supportedCabalVersions :: [CabalSpecVersion] +-- supportedCabalVersions = [CabalSpecV2_2 .. maxBound] + +-- -- | Keyword for cabal version; required to be the top line in a cabal file +-- cabalVersionKeyword :: Map KeyWordName Completer +-- cabalVersionKeyword = +-- Map.singleton "cabal-version:" $ +-- constantCompleter $ +-- -- We only suggest cabal versions newer than 2.2 +-- -- since we don't recommend using older ones. +-- map (T.pack . showCabalSpecVersion) supportedCabalVersions + +-- | Top level keywords of a cabal 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:", constantCompleter []), + ("optional-packages:", constantCompleter []), + ("extra-packages:", constantCompleter []), + ("verbose:", constantCompleter []), + ("build-summary:", constantCompleter []), + ("build-log:", constantCompleter []), + ("remote-build-reporting:", constantCompleter []), + ("report-planning-failure:", constantCompleter []), + ("symlink-bindir:", constantCompleter []), + ("jobs:", constantCompleter []), + ("semaphore:", constantCompleter []), + ("keep-going:", constantCompleter []), + ("offline:", constantCompleter []), + ("haddock-keep-temp-files:", constantCompleter []), + ("http-transport:", constantCompleter []), + ("ignore-expiry:", constantCompleter []), + ("remote-repo-cache:", constantCompleter []), + ("logs-dir:", constantCompleter []) + -- add projectConfigSharedFieldGrammar, + ] + +packageFields :: Map KeyWordName Completer +packageFields = + Map.fromList + [ ("haddock-all:", constantCompleter []), + ("extra-prog-path:", noopCompleter), + ("flags:", constantCompleter []), + ("library-vanilla:", constantCompleter []), + ("shared:", constantCompleter []) + -- add rest + ] + +-- | Map, containing all stanzas in a cabal file as keys, +-- and lists of their possible nested keywords as values. +stanzaKeywordMap :: Map StanzaType (Map KeyWordName Completer) +stanzaKeywordMap = + Map.fromList + [ ("package", packageFields) + ] 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 index 7df6bcd38d..32d49031f9 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs @@ -10,6 +10,7 @@ import Distribution.Client.ProjectConfig.Parsec (ProjectConfigSkeleton import qualified Distribution.Fields as Syntax import qualified Distribution.Parsec.Position as Syntax import GHC.Generics (Generic) +-- import Ide.Plugin.Cabal.Completion.Types type instance RuleResult ParseCabalProjectFile = ProjectConfigSkeleton From c69973b53c56e8d7c0f7c5da30318734d9f9c00b Mon Sep 17 00:00:00 2001 From: rm41339 Date: Sun, 6 Jul 2025 18:38:49 +0200 Subject: [PATCH 17/26] add basic field constant completions --- haskell-language-server.cabal | 4 ++-- .../hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs | 2 -- .../Ide/Plugin/CabalProject/Completion/Completer/Simple.hs | 3 --- .../Ide/Plugin/CabalProject/Completion/Completer/Types.hs | 5 ----- .../src/Ide/Plugin/CabalProject/Types.hs | 2 -- 5 files changed, 2 insertions(+), 14 deletions(-) delete mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Simple.hs delete mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 9ede2d5edd..08c1fd7aa0 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -341,8 +341,8 @@ library hls-cabal-project-plugin Ide.Plugin.CabalProject.Diagnostics Ide.Plugin.CabalProject.Types Ide.Plugin.CabalProject.Completion.Completions - Ide.Plugin.CabalProject.Completion.Completer.Simple - Ide.Plugin.CabalProject.Completion.Completer.Types + -- Ide.Plugin.CabalProject.Completion.Completer.Simple + -- Ide.Plugin.CabalProject.Completion.Completer.Types Ide.Plugin.CabalProject.Completion.CabalProjectFields Ide.Plugin.CabalProject.Completion.Data diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index b58d263a07..601da89f81 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -317,8 +317,6 @@ completion recorder ide _ complParams = do mContents <- liftIO $ runAction "cabal-project-plugin.getUriContents" ide $ getUriContents $ toNormalizedUri uri case (,) <$> mContents <*> uriToFilePath' uri of Just (cnts, path) -> do - -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested. - -- In case it fails, we still will get some completion results instead of an error. mFields <- liftIO $ runAction "cabal-project-plugin.fields" ide $ useWithStale ParseCabalProjectFields $ toNormalizedFilePath path case mFields of Nothing -> diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Simple.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Simple.hs deleted file mode 100644 index 0fcbc66608..0000000000 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Simple.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Ide.Plugin.CabalProject.Completion.Completer.Simple where - -import Ide.Plugin.Cabal.Completion.Completer.Simple diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs deleted file mode 100644 index 34ec85351e..0000000000 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module Ide.Plugin.CabalProject.Completion.Completer.Types where - -import Ide.Plugin.Cabal.Completion.Completer.Types 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 index 32d49031f9..de161c5aa7 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs @@ -10,8 +10,6 @@ import Distribution.Client.ProjectConfig.Parsec (ProjectConfigSkeleton import qualified Distribution.Fields as Syntax import qualified Distribution.Parsec.Position as Syntax import GHC.Generics (Generic) --- import Ide.Plugin.Cabal.Completion.Types - type instance RuleResult ParseCabalProjectFile = ProjectConfigSkeleton From a812311a14cd500d7e56ddea6066875d1b36bcf3 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Wed, 9 Jul 2025 17:49:52 +0200 Subject: [PATCH 18/26] add noopCompleters for all cabal.project fields in fieldGrammar --- .../Plugin/CabalProject/Completion/Data.hs | 140 +++++++++++++++--- 1 file changed, 116 insertions(+), 24 deletions(-) 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 index 27571a6b85..921c009b27 100644 --- 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 @@ -39,36 +39,128 @@ import Ide.Plugin.Cabal.Completion.Types cabalProjectKeywords :: Map KeyWordName Completer cabalProjectKeywords = Map.fromList - [ ("packages:", constantCompleter []), - ("optional-packages:", constantCompleter []), - ("extra-packages:", constantCompleter []), - ("verbose:", constantCompleter []), - ("build-summary:", constantCompleter []), - ("build-log:", constantCompleter []), - ("remote-build-reporting:", constantCompleter []), - ("report-planning-failure:", constantCompleter []), - ("symlink-bindir:", constantCompleter []), - ("jobs:", constantCompleter []), - ("semaphore:", constantCompleter []), - ("keep-going:", constantCompleter []), - ("offline:", constantCompleter []), - ("haddock-keep-temp-files:", constantCompleter []), - ("http-transport:", constantCompleter []), - ("ignore-expiry:", constantCompleter []), - ("remote-repo-cache:", constantCompleter []), - ("logs-dir:", constantCompleter []) - -- add projectConfigSharedFieldGrammar, + [ -- projectConfigFieldGrammar + ("packages:", noopCompleter), + ("optional-packages:", noopCompleter), + ("extra-packages:", noopCompleter), + -- projectConfigBuildOnlyFieldGrammar + ("verbose:", constantCompleter ["0", "1", "2", "3"]), -- not sure if this works/makes sense? + ("build-summary:", noopCompleter), + ("build-log:", noopCompleter), + ("remote-build-reporting:", noopCompleter), + ("report-planning-failure:", noopCompleter), + ("symlink-bindir:", noopCompleter), + ("jobs:", noopCompleter), + ("semaphore:", noopCompleter), + ("keep-going:", noopCompleter), + ("offline:", noopCompleter), + ("haddock-keep-temp-files:", noopCompleter), + ("http-transport:", noopCompleter), + ("ignore-expiry:", noopCompleter), + ("remote-repo-cache:", noopCompleter), + ("logs-dir:", noopCompleter), + -- projectConfigSharedFieldGrammar + ("builddir:", noopCompleter), + ("project-dir:", noopCompleter), + ("project-file:", noopCompleter), + ("ignore-project:", noopCompleter), + ("compiler:", noopCompleter), + ("with-compiler:", noopCompleter), + ("with-hc-pkg:", noopCompleter), + ("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:", noopCompleter), + ("allow-older:", constantCompleter ["True", "False"]), + ("allow-newer:", constantCompleter ["True", "False"]), + ("write-ghc-environment-files:", noopCompleter), + ("max-backjumps:", noopCompleter), + ("reorder-goals:", noopCompleter), + ("count-conflicts:", noopCompleter), + ("fine-grained-conflicts:", noopCompleter), + ("minimize-conflict-set:", noopCompleter), + ("strong-flags:", noopCompleter), + ("allow-boot-library-installs:", noopCompleter), + ("reject-unconstrained-dependencies:", noopCompleter), + ("per-component:", noopCompleter), + ("independent-goals:", noopCompleter), + ("prefer-oldest:", noopCompleter), + ("extra-prog-path-shared-only:", noopCompleter), + ("multi-repl:", noopCompleter) ] packageFields :: Map KeyWordName Completer packageFields = Map.fromList - [ ("haddock-all:", constantCompleter []), + [ -- packageConfigFieldGrammar + ("haddock-all:", noopCompleter), ("extra-prog-path:", noopCompleter), - ("flags:", constantCompleter []), - ("library-vanilla:", constantCompleter []), - ("shared:", constantCompleter []) - -- add rest + ("flags:", noopCompleter), + ("library-vanilla:", noopCompleter), + ("shared:", noopCompleter), + ("static:", noopCompleter), + ("exectable-dynamic:", noopCompleter), + ("executable-static:", noopCompleter), + ("profiling:", noopCompleter), + ("library-profiling:", noopCompleter), + ("profiling-shared:", noopCompleter), + ("exectable-profiling:", noopCompleter), + ("profiling-detail:", noopCompleter), + ("library-profiling-detail:", noopCompleter), + ("configure-options:", noopCompleter), + ("optimization:", noopCompleter), + ("program-prefix:", noopCompleter), + ("program-suffix:", noopCompleter), + ("extra-lib-dirs:", noopCompleter), + ("extra-lib-dirs-static:", noopCompleter), + ("extra-framework-dirs:", noopCompleter), + ("extra-include-dirs:", noopCompleter), + ("library-for-ghci:", noopCompleter), + ("split-sections:", noopCompleter), + ("split-objs:", noopCompleter), + ("executable-stripping:", noopCompleter), + ("library-stripping:", noopCompleter), + ("tests:", noopCompleter), + ("benchmarks:", noopCompleter), + ("relocatable:", noopCompleter), + ("debug-info:", noopCompleter), + ("build-info:", noopCompleter), + ("run-tests:", noopCompleter), + ("documentation:", noopCompleter), + ("haddock-hoogle:", noopCompleter), + ("haddock-html:", noopCompleter), + ("haddock-html-location:", noopCompleter), + ("haddock-foreign-libraries:", noopCompleter), + ("haddock-executables:", noopCompleter), + ("haddock-tests:", noopCompleter), + ("haddock-benchmarks:", noopCompleter), + ("haddock-internal:", noopCompleter), + ("haddock-css:", noopCompleter), + ("haddock-hyperlink-source:", noopCompleter), + ("haddock-quickjump:", noopCompleter), + ("haddock-hscolour-css:", noopCompleter), + ("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), + -- packageConfigCoverageGrammar + ("coverage:", noopCompleter) ] -- | Map, containing all stanzas in a cabal file as keys, From 3340ec485ed753bb705ee6a5587b22aed78d55b3 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Wed, 9 Jul 2025 17:52:51 +0200 Subject: [PATCH 19/26] update wrong constantCompleter --- .../src/Ide/Plugin/CabalProject/Completion/Data.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 index 921c009b27..3b51cbaee8 100644 --- 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 @@ -76,8 +76,8 @@ cabalProjectKeywords = ("preferences:", noopCompleter), ("cabal-lib-version:", noopCompleter), ("solver:", noopCompleter), - ("allow-older:", constantCompleter ["True", "False"]), - ("allow-newer:", constantCompleter ["True", "False"]), + ("allow-older:", noopCompleter), + ("allow-newer:", noopCompleter), ("write-ghc-environment-files:", noopCompleter), ("max-backjumps:", noopCompleter), ("reorder-goals:", noopCompleter), From d330009fc81506d1ceed070540894139274e595c Mon Sep 17 00:00:00 2001 From: rm41339 Date: Sun, 13 Jul 2025 17:56:48 +0200 Subject: [PATCH 20/26] fill in boolean/enum completion values --- .../src/Ide/Plugin/CabalProject.hs | 6 + .../CabalProject/Completion/Completions.hs | 23 ++- .../Plugin/CabalProject/Completion/Data.hs | 131 ++++++++++++------ 3 files changed, 102 insertions(+), 58 deletions(-) diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index 601da89f81..55dde2d7cb 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -93,6 +93,12 @@ instance Pretty Log where "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 = 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 index 1f0a18ad93..d918fc718f 100644 --- 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 @@ -33,13 +33,13 @@ contextToCompleter :: Context -> Completer -- we can write any top level keywords or a stanza declaration contextToCompleter (TopLevel, None) = constantCompleter $ - Map.keys cabalProjectKeywords ++ Map.keys packageFields + 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 (cabalVersionKeyword <> cabalKeywords) of --- Nothing -> errorNoopCompleter (LogUnknownKeyWordInContextError kw) --- Just l -> l +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) = @@ -47,19 +47,18 @@ contextToCompleter (Stanza s _, None) = 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 +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. -- --- TODO: first line can only have cabal-version: keyword 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 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 index 3b51cbaee8..78ca5bb52f 100644 --- 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 @@ -16,6 +16,13 @@ import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) import Ide.Plugin.Cabal.Completion.Types -- import Ide.Plugin.Cabal.LicenseSuggest (licenseNames) +-- | 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' and 'libExecTestBenchCommons'. +data TopLevelStanza + = Package + | ProgramOptions + -- ---------------------------------------------------------------- -- Completion Data -- ---------------------------------------------------------------- @@ -44,7 +51,7 @@ cabalProjectKeywords = ("optional-packages:", noopCompleter), ("extra-packages:", noopCompleter), -- projectConfigBuildOnlyFieldGrammar - ("verbose:", constantCompleter ["0", "1", "2", "3"]), -- not sure if this works/makes sense? + ("verbose:", constantCompleter ["0", "1", "2", "3"]), ("build-summary:", noopCompleter), ("build-log:", noopCompleter), ("remote-build-reporting:", noopCompleter), @@ -52,11 +59,11 @@ cabalProjectKeywords = ("symlink-bindir:", noopCompleter), ("jobs:", noopCompleter), ("semaphore:", noopCompleter), - ("keep-going:", noopCompleter), + ("keep-going:", constantCompleter ["False", "True"]), ("offline:", noopCompleter), - ("haddock-keep-temp-files:", noopCompleter), - ("http-transport:", noopCompleter), - ("ignore-expiry:", 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), -- projectConfigSharedFieldGrammar @@ -64,7 +71,7 @@ cabalProjectKeywords = ("project-dir:", noopCompleter), ("project-file:", noopCompleter), ("ignore-project:", noopCompleter), - ("compiler:", noopCompleter), + ("compiler:", constantCompleter ["ghc", "ghcjs", "jhc", "lhc", "uhc", "haskell-suite"]), ("with-compiler:", noopCompleter), ("with-hc-pkg:", noopCompleter), ("doc-index-file:", noopCompleter), @@ -75,73 +82,76 @@ cabalProjectKeywords = ("constraints:", noopCompleter), ("preferences:", noopCompleter), ("cabal-lib-version:", noopCompleter), - ("solver:", noopCompleter), + ("solver:", constantCompleter ["modular"]), ("allow-older:", noopCompleter), ("allow-newer:", noopCompleter), - ("write-ghc-environment-files:", noopCompleter), + ("write-ghc-environment-files:", constantCompleter ["never", "always", "ghc8.4.4+"]), ("max-backjumps:", noopCompleter), - ("reorder-goals:", noopCompleter), - ("count-conflicts:", noopCompleter), - ("fine-grained-conflicts:", noopCompleter), - ("minimize-conflict-set:", noopCompleter), - ("strong-flags:", noopCompleter), - ("allow-boot-library-installs:", 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:", noopCompleter), ("per-component:", noopCompleter), ("independent-goals:", noopCompleter), ("prefer-oldest:", noopCompleter), ("extra-prog-path-shared-only:", noopCompleter), - ("multi-repl:", noopCompleter) + ("multi-repl:", noopCompleter), + -- extras + ("benchmarks:", constantCompleter ["False", "True"]) + ] packageFields :: Map KeyWordName Completer packageFields = Map.fromList [ -- packageConfigFieldGrammar - ("haddock-all:", noopCompleter), + ("haddock-all:", constantCompleter ["False", "True"]), ("extra-prog-path:", noopCompleter), ("flags:", noopCompleter), - ("library-vanilla:", noopCompleter), - ("shared:", noopCompleter), - ("static:", noopCompleter), - ("exectable-dynamic:", noopCompleter), - ("executable-static:", noopCompleter), - ("profiling:", noopCompleter), - ("library-profiling:", 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:", noopCompleter), - ("profiling-detail:", noopCompleter), - ("library-profiling-detail:", 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:", noopCompleter), + ("optimization:", constantCompleter ["0", "1", "2", "True", "False"]), ("program-prefix:", noopCompleter), ("program-suffix:", noopCompleter), ("extra-lib-dirs:", noopCompleter), ("extra-lib-dirs-static:", noopCompleter), ("extra-framework-dirs:", noopCompleter), ("extra-include-dirs:", noopCompleter), - ("library-for-ghci:", noopCompleter), - ("split-sections:", noopCompleter), - ("split-objs:", noopCompleter), - ("executable-stripping:", noopCompleter), - ("library-stripping:", noopCompleter), - ("tests:", noopCompleter), - ("benchmarks:", noopCompleter), - ("relocatable:", noopCompleter), + ("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:", noopCompleter), - ("documentation:", noopCompleter), - ("haddock-hoogle:", noopCompleter), - ("haddock-html:", 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:", noopCompleter), - ("haddock-tests:", noopCompleter), - ("haddock-benchmarks:", noopCompleter), - ("haddock-internal:", noopCompleter), + ("haddock-executables:", constantCompleter ["False", "True"]), + ("haddock-tests:", constantCompleter ["False", "True"]), + ("haddock-benchmarks:", constantCompleter ["False", "True"]), + ("haddock-internal:", constantCompleter ["False", "True"]), ("haddock-css:", noopCompleter), - ("haddock-hyperlink-source:", noopCompleter), + ("haddock-hyperlink-source:", constantCompleter ["False", "True"]), ("haddock-quickjump:", noopCompleter), ("haddock-hscolour-css:", noopCompleter), ("haddock-contents-location:", noopCompleter), @@ -160,7 +170,34 @@ packageFields = ("test-options:", noopCompleter), ("benchmark-options:", noopCompleter), -- packageConfigCoverageGrammar - ("coverage:", noopCompleter) + ("coverage:", constantCompleter ["False", "True"]), + -- other + ("ghc-options:", noopCompleter) + ] + +-- just for testing right now, to be filled in later +programOptionsFields :: Map KeyWordName Completer +programOptionsFields = Map.fromList + [ ("ghc-options:", noopCompleter) + ] + +sourceRepoFields :: Map KeyWordName Completer +sourceRepoFields = Map.fromList + [ ("type:", constantCompleter + [ "darcs", + "git", + "svn", + "cvs", + "mercurial", + "hg", + "bazaar", + "bzr", + "arch", + "monotone" + ]), -- just used the one from cabal + ("location:", noopCompleter), + ("tag:", noopCompleter), + ("subdir:", noopCompleter) ] -- | Map, containing all stanzas in a cabal file as keys, @@ -168,5 +205,7 @@ packageFields = stanzaKeywordMap :: Map StanzaType (Map KeyWordName Completer) stanzaKeywordMap = Map.fromList - [ ("package", packageFields) + [ ("package", packageFields), + ("program-options", programOptionsFields), + ("source-repository-package", sourceRepoFields) ] From 0558c8420e61c16f41534e607ff12bb18fe4cfce Mon Sep 17 00:00:00 2001 From: rm41339 Date: Thu, 17 Jul 2025 21:25:08 +0200 Subject: [PATCH 21/26] add completions tests --- haskell-language-server.cabal | 2 + .../test/testdata/completer.cabal | 2 +- .../Plugin/CabalProject/Completion/Data.hs | 48 ++--- .../test/Completer.hs | 178 ++++++++++++++++++ plugins/hls-cabal-project-plugin/test/Main.hs | 2 + .../hls-cabal-project-plugin/test/Utils.hs | 28 ++- .../test/testdata/cabal.completer.project | 6 + .../testdata/filepath-completions/Content.hs | 0 .../filepath-completions/cabal.project | 1 + .../testdata/filepath-completions/dir1/f1.txt | 1 + .../testdata/filepath-completions/dir1/f2.hs | 1 + .../testdata/filepath-completions/test.cabal | 0 .../filepath-completions/textfile.txt | 1 + 13 files changed, 241 insertions(+), 29 deletions(-) create mode 100644 plugins/hls-cabal-project-plugin/test/Completer.hs create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/cabal.completer.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/Content.hs create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/cabal.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f1.txt create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f2.hs create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/test.cabal create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/textfile.txt diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 08c1fd7aa0..708c7c431b 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -389,6 +389,7 @@ test-suite hls-cabal-project-plugin-tests hs-source-dirs: plugins/hls-cabal-project-plugin/test main-is: Main.hs other-modules: + Completer Utils build-depends: , bytestring @@ -403,6 +404,7 @@ test-suite hls-cabal-project-plugin-tests , text , hls-plugin-api , cabal-install + , haskell-language-server:hls-cabal-plugin ----------------------------- 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/Completion/Data.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Data.hs index 78ca5bb52f..96db4a030e 100644 --- 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 @@ -2,17 +2,19 @@ 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 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 -- import Ide.Plugin.Cabal.Completion.Completer.Module -- import Ide.Plugin.Cabal.Completion.Completer.Paths +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.Completer.Types (Completer) import Ide.Plugin.Cabal.Completion.Types -- import Ide.Plugin.Cabal.LicenseSuggest (licenseNames) @@ -47,12 +49,12 @@ cabalProjectKeywords :: Map KeyWordName Completer cabalProjectKeywords = Map.fromList [ -- projectConfigFieldGrammar - ("packages:", noopCompleter), - ("optional-packages:", noopCompleter), - ("extra-packages:", noopCompleter), + ("packages:", filePathCompleter), + ("optional-packages:", filePathCompleter), + ("extra-packages:", filePathCompleter), -- projectConfigBuildOnlyFieldGrammar ("verbose:", constantCompleter ["0", "1", "2", "3"]), - ("build-summary:", noopCompleter), + ("build-summary:", filePathCompleter), ("build-log:", noopCompleter), ("remote-build-reporting:", noopCompleter), ("report-planning-failure:", noopCompleter), @@ -72,8 +74,8 @@ cabalProjectKeywords = ("project-file:", noopCompleter), ("ignore-project:", noopCompleter), ("compiler:", constantCompleter ["ghc", "ghcjs", "jhc", "lhc", "uhc", "haskell-suite"]), - ("with-compiler:", noopCompleter), - ("with-hc-pkg:", noopCompleter), + ("with-compiler:", filePathCompleter), + ("with-hc-pkg:", filePathCompleter), ("doc-index-file:", noopCompleter), ("package-dbs:", noopCompleter), ("active-repositories:", noopCompleter), @@ -93,15 +95,15 @@ cabalProjectKeywords = ("minimize-conflict-set:", constantCompleter ["False", "True"]), ("strong-flags:", constantCompleter ["False", "True"]), ("allow-boot-library-installs:", constantCompleter ["False", "True"]), - ("reject-unconstrained-dependencies:", noopCompleter), + ("reject-unconstrained-dependencies:", constantCompleter ["none", "all"]), ("per-component:", noopCompleter), ("independent-goals:", noopCompleter), ("prefer-oldest:", noopCompleter), ("extra-prog-path-shared-only:", noopCompleter), ("multi-repl:", noopCompleter), -- extras - ("benchmarks:", constantCompleter ["False", "True"]) - + ("benchmarks:", constantCompleter ["False", "True"]), + ("import:", filePathCompleter) ] packageFields :: Map KeyWordName Completer @@ -109,7 +111,7 @@ packageFields = Map.fromList [ -- packageConfigFieldGrammar ("haddock-all:", constantCompleter ["False", "True"]), - ("extra-prog-path:", noopCompleter), + ("extra-prog-path:", filePathCompleter), ("flags:", noopCompleter), ("library-vanilla:", constantCompleter ["True", "False"]), ("shared:", constantCompleter ["False", "True"]), @@ -126,10 +128,10 @@ packageFields = ("optimization:", constantCompleter ["0", "1", "2", "True", "False"]), ("program-prefix:", noopCompleter), ("program-suffix:", noopCompleter), - ("extra-lib-dirs:", noopCompleter), - ("extra-lib-dirs-static:", noopCompleter), - ("extra-framework-dirs:", noopCompleter), - ("extra-include-dirs:", 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"]), @@ -150,10 +152,10 @@ packageFields = ("haddock-tests:", constantCompleter ["False", "True"]), ("haddock-benchmarks:", constantCompleter ["False", "True"]), ("haddock-internal:", constantCompleter ["False", "True"]), - ("haddock-css:", noopCompleter), + ("haddock-css:", filePathCompleter), ("haddock-hyperlink-source:", constantCompleter ["False", "True"]), ("haddock-quickjump:", noopCompleter), - ("haddock-hscolour-css:", noopCompleter), + ("haddock-hscolour-css:", filePathCompleter), ("haddock-contents-location:", noopCompleter), ("haddock-index-location:", noopCompleter), ("haddock-base-url:", noopCompleter), 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 index b1ef14336a..6923ac029c 100644 --- a/plugins/hls-cabal-project-plugin/test/Main.hs +++ b/plugins/hls-cabal-project-plugin/test/Main.hs @@ -6,6 +6,7 @@ module Main ( main, ) where +import Completer (completerTests) import qualified Control.Exception as E import Control.Lens ((^.)) import Control.Lens.Fold ((^?)) @@ -36,6 +37,7 @@ main = do "Cabal Plugin Tests" [ unitTests , pluginTests + , completerTests ] -- ------------------------------------------------------------------------ diff --git a/plugins/hls-cabal-project-plugin/test/Utils.hs b/plugins/hls-cabal-project-plugin/test/Utils.hs index 8ab90dd8bd..9e010cdf55 100644 --- a/plugins/hls-cabal-project-plugin/test/Utils.hs +++ b/plugins/hls-cabal-project-plugin/test/Utils.hs @@ -4,17 +4,19 @@ 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.CabalProject (descriptor) +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" @@ -46,3 +48,19 @@ cabalProjectCaptureKick = captureKickDiagnostics cabalProjectKickStart cabalProj -- | 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/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 From a479a319c036788564f7a2c90661dbb96e889da0 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Tue, 29 Jul 2025 11:35:53 +0200 Subject: [PATCH 22/26] edit Completions/Data documentation --- .../Completion/CabalProjectFields.hs | 7 --- .../CabalProject/Completion/Completions.hs | 3 +- .../Plugin/CabalProject/Completion/Data.hs | 43 +++---------------- vendor/cabal | 2 +- 4 files changed, 9 insertions(+), 46 deletions(-) delete mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/CabalProjectFields.hs diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/CabalProjectFields.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/CabalProjectFields.hs deleted file mode 100644 index 3a07899144..0000000000 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/CabalProjectFields.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Ide.Plugin.CabalProject.Completion.CabalProjectFields where - -import Ide.Plugin.Cabal.Completion.CabalFields (findFieldSection, - findStanzaForColumn, - getAnnotation, - getFieldName, - getOptionalSectionName) 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 index d918fc718f..cff3dd0be6 100644 --- 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 @@ -14,7 +14,6 @@ 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.Snippet import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) import Ide.Plugin.Cabal.Completion.Types import Ide.Plugin.CabalProject.Completion.Data @@ -29,7 +28,7 @@ import System.FilePath (takeBaseName) -- | 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 file and not in a keyword context, +-- 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 $ 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 index 96db4a030e..e9e54a9599 100644 --- 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 @@ -8,19 +8,15 @@ 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 --- import Ide.Plugin.Cabal.Completion.Completer.Module --- import Ide.Plugin.Cabal.Completion.Completer.Paths 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 --- import Ide.Plugin.Cabal.LicenseSuggest (licenseNames) -- | 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' and 'libExecTestBenchCommons'. +-- comparisons in 'stanzaKeywordMap'. data TopLevelStanza = Package | ProgramOptions @@ -29,30 +25,16 @@ data TopLevelStanza -- Completion Data -- ---------------------------------------------------------------- --- supportedCabalVersions :: [CabalSpecVersion] --- supportedCabalVersions = [CabalSpecV2_2 .. maxBound] - --- -- | Keyword for cabal version; required to be the top line in a cabal file --- cabalVersionKeyword :: Map KeyWordName Completer --- cabalVersionKeyword = --- Map.singleton "cabal-version:" $ --- constantCompleter $ --- -- We only suggest cabal versions newer than 2.2 --- -- since we don't recommend using older ones. --- map (T.pack . showCabalSpecVersion) supportedCabalVersions - --- | Top level keywords of a cabal file. +-- | 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 - [ -- projectConfigFieldGrammar - ("packages:", filePathCompleter), + [ ("packages:", filePathCompleter), ("optional-packages:", filePathCompleter), ("extra-packages:", filePathCompleter), - -- projectConfigBuildOnlyFieldGrammar ("verbose:", constantCompleter ["0", "1", "2", "3"]), ("build-summary:", filePathCompleter), ("build-log:", noopCompleter), @@ -68,7 +50,6 @@ cabalProjectKeywords = ("ignore-expiry:", constantCompleter ["False", "True"]), ("remote-repo-cache:", noopCompleter), ("logs-dir:", noopCompleter), - -- projectConfigSharedFieldGrammar ("builddir:", noopCompleter), ("project-dir:", noopCompleter), ("project-file:", noopCompleter), @@ -101,7 +82,6 @@ cabalProjectKeywords = ("prefer-oldest:", noopCompleter), ("extra-prog-path-shared-only:", noopCompleter), ("multi-repl:", noopCompleter), - -- extras ("benchmarks:", constantCompleter ["False", "True"]), ("import:", filePathCompleter) ] @@ -109,8 +89,7 @@ cabalProjectKeywords = packageFields :: Map KeyWordName Completer packageFields = Map.fromList - [ -- packageConfigFieldGrammar - ("haddock-all:", constantCompleter ["False", "True"]), + [ ("haddock-all:", constantCompleter ["False", "True"]), ("extra-prog-path:", filePathCompleter), ("flags:", noopCompleter), ("library-vanilla:", constantCompleter ["True", "False"]), @@ -171,18 +150,10 @@ packageFields = ("test-fail-when-no-test-suites:", noopCompleter), ("test-options:", noopCompleter), ("benchmark-options:", noopCompleter), - -- packageConfigCoverageGrammar ("coverage:", constantCompleter ["False", "True"]), - -- other ("ghc-options:", noopCompleter) ] --- just for testing right now, to be filled in later -programOptionsFields :: Map KeyWordName Completer -programOptionsFields = Map.fromList - [ ("ghc-options:", noopCompleter) - ] - sourceRepoFields :: Map KeyWordName Completer sourceRepoFields = Map.fromList [ ("type:", constantCompleter @@ -196,18 +167,18 @@ sourceRepoFields = Map.fromList "bzr", "arch", "monotone" - ]), -- just used the one from cabal + ]), ("location:", noopCompleter), ("tag:", noopCompleter), ("subdir:", noopCompleter) ] --- | Map, containing all stanzas in a cabal file as keys, +-- | 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", programOptionsFields), + ("program-options", packageFields), ("source-repository-package", sourceRepoFields) ] diff --git a/vendor/cabal b/vendor/cabal index 447964a7b8..b44fecd12f 160000 --- a/vendor/cabal +++ b/vendor/cabal @@ -1 +1 @@ -Subproject commit 447964a7b8fb430f69dcfd394188c0eafd576413 +Subproject commit b44fecd12f3c724b5519e5e6253c380d73704caf From 4da8eb95965a173fde0ef0a0d3fa08024a6fc46e Mon Sep 17 00:00:00 2001 From: rm41339 Date: Wed, 30 Jul 2025 10:51:54 +0200 Subject: [PATCH 23/26] edit documentation and code to reflect cabal.project --- .gitignore | 3 - haskell-language-server.cabal | 6 - .../src/Ide/Plugin/CabalProject.hs | 127 ++++++++---------- .../CabalProject/Completion/Completions.hs | 10 +- .../Ide/Plugin/CabalProject/Diagnostics.hs | 36 +++-- .../src/Ide/Plugin/CabalProject/Parse.hs | 4 - 6 files changed, 76 insertions(+), 110 deletions(-) diff --git a/.gitignore b/.gitignore index 0e23fac134..2413a1fcf5 100644 --- a/.gitignore +++ b/.gitignore @@ -51,6 +51,3 @@ store/ gh-release-artifacts/ .hls/ - -# local cabal package -vendor/parse-cabal-project diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 708c7c431b..e486205f98 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -341,12 +341,8 @@ library hls-cabal-project-plugin Ide.Plugin.CabalProject.Diagnostics Ide.Plugin.CabalProject.Types Ide.Plugin.CabalProject.Completion.Completions - -- Ide.Plugin.CabalProject.Completion.Completer.Simple - -- Ide.Plugin.CabalProject.Completion.Completer.Types - Ide.Plugin.CabalProject.Completion.CabalProjectFields Ide.Plugin.CabalProject.Completion.Data - build-depends: , bytestring , Cabal-syntax >= 3.7 @@ -378,7 +374,6 @@ library hls-cabal-project-plugin , base16-bytestring , cryptohash-sha1 - hs-source-dirs: plugins/hls-cabal-project-plugin/src test-suite hls-cabal-project-plugin-tests @@ -406,7 +401,6 @@ test-suite hls-cabal-project-plugin-tests , cabal-install , haskell-language-server:hls-cabal-plugin - ----------------------------- -- class plugin ----------------------------- diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index 55dde2d7cb..d7d1306955 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -12,59 +12,42 @@ 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.Maybe (runMaybeT) import qualified Data.ByteString as BS import Data.Hashable -import Data.HashMap.Strict (HashMap, - toList) +import Data.HashMap.Strict (HashMap) + -- toList) import qualified Data.HashMap.Strict as HashMap -import qualified Data.List as List import qualified Data.List.NonEmpty as NE -import qualified Data.Maybe as Maybe import Data.Proxy import qualified Data.Text () -import qualified Data.Text as T import qualified Data.Text.Encoding as Encoding import Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE as D -import Development.IDE.Core.FileStore (getVersionedTextDoc) -import Development.IDE.Core.PluginUtils import Development.IDE.Core.Shake (restartShakeSession) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (Key, alwaysRerun) -import Development.IDE.LSP.HoverDefinition (foundHover) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide import Development.IDE.Types.Shake (toKey) -import qualified Distribution.CabalSpecVersion as Cabal import qualified Distribution.Fields as Syntax -import Distribution.Package (Dependency) -import Distribution.PackageDescription (allBuildDepends, - depPkgName, - unPackageName) -import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.Parsec.Error +-- import Distribution.PackageDescription (allBuildDepends, +-- depPkgName, +-- unPackageName) import qualified Distribution.Parsec.Position as Syntax import GHC.Generics -import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes -import qualified Ide.Plugin.Cabal.Completion.Data as Data 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.Plugin.Error 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 -import System.FilePath (takeFileName) -import Text.Regex.TDFA - data Log = LogModificationTime NormalizedFilePath FileVersion @@ -103,7 +86,7 @@ instance Pretty Log where descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultCabalProjectPluginDescriptor plId "Provides a variety of IDE features in cabal.project files") - { pluginRules = cabalRules recorder plId + { pluginRules = cabalProjectRules recorder plId , pluginHandlers = mconcat [ @@ -115,25 +98,25 @@ descriptor recorder plId = \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri - restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" $ + 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 - restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $ + 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 - restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" $ + 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 - restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" $ + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(closed)" $ deleteFileOfInterest recorder ide file ] , pluginConfigDescriptor = defaultConfigDescriptor @@ -146,7 +129,7 @@ descriptor recorder plId = whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' -{- | Helper function to restart the shake session, specifically for modifying .cabal files. +{- | 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. @@ -155,18 +138,18 @@ needs to be re-parsed. That's what we do when we record the dirty key that our p rule depends on. Then we restart the shake session, so that changes to our virtual files are actually picked up. -} -restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () -restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do +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) -cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () -cabalRules recorder plId = do - -- Make sure we initialise the cabal files-of-interest. +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 files. + -- Rule to produce diagnostics for cabal.project files. define (cmapWithPrio LogShake recorder) $ \ParseCabalProjectFields file -> do config <- getPluginConfigAction plId if not (plcGlobalOn config && plcDiagnosticsOn config) @@ -174,9 +157,9 @@ cabalRules recorder plId = do 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 + (t, mCabalProjectSource) <- use_ GetFileContents file log' Debug $ LogModificationTime file t - contents <- case mCabalSource of + contents <- case mCabalProjectSource of Just sources -> pure $ Encoding.encodeUtf8 $ Rope.toText sources Nothing -> do @@ -195,10 +178,10 @@ cabalRules recorder plId = do 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 + (t, mCabalProjectSource) <- use_ GetFileContents file log' Debug $ LogModificationTime file t - contents <- case mCabalSource of + contents <- case mCabalProjectSource of Just sources -> pure $ Encoding.encodeUtf8 $ Rope.toText sources Nothing -> @@ -216,53 +199,53 @@ cabalRules recorder plId = do pure (warnDiags, Just projCfg) action $ do - -- Run the cabal kick. This code always runs when 'shakeRestart' is run. + -- 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 plugin. +{- | 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 files. +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 <$> getCabalFilesOfInterestUntracked + 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 file of Interest rules and global variable +-- Cabal.project file of Interest rules and global variable -- ---------------------------------------------------------------- -{- | Cabal files that are currently open in the lsp-client. +{- | 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 OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) +newtype OfInterestCabalProjectVar = OfInterestCabalProjectVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) -instance Shake.IsIdeGlobal OfInterestCabalVar +instance Shake.IsIdeGlobal OfInterestCabalProjectVar -data IsCabalFileOfInterest = IsCabalFileOfInterest +data IsCabalProjectFileOfInterest = IsCabalProjectFileOfInterest deriving (Eq, Show, Generic) -instance Hashable IsCabalFileOfInterest -instance NFData IsCabalFileOfInterest +instance Hashable IsCabalProjectFileOfInterest +instance NFData IsCabalProjectFileOfInterest -type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult +type instance RuleResult IsCabalProjectFileOfInterest = CabalProjectFileOfInterestResult -data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus +data CabalProjectFileOfInterestResult = NotCabalProjectFOI | IsCabalProjectFOI FileOfInterestStatus deriving (Eq, Show, Generic) -instance Hashable CabalFileOfInterestResult -instance NFData CabalFileOfInterestResult +instance Hashable CabalProjectFileOfInterestResult +instance NFData CabalProjectFileOfInterestResult {- | The rule that initialises the files of interest state. @@ -270,42 +253,42 @@ Needs to be run on start-up. -} ofInterestRules :: Recorder (WithPriority Log) -> Rules () ofInterestRules recorder = do - Shake.addIdeGlobal . OfInterestCabalVar =<< liftIO (newVar HashMap.empty) - Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalFileOfInterest f -> do + Shake.addIdeGlobal . OfInterestCabalProjectVar =<< liftIO (newVar HashMap.empty) + Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalProjectFileOfInterest f -> do alwaysRerun - filesOfInterest <- getCabalFilesOfInterestUntracked - let foi = maybe NotCabalFOI IsCabalFOI $ f `HashMap.lookup` filesOfInterest + filesOfInterest <- getCabalProjectFilesOfInterestUntracked + let foi = maybe NotCabalProjectFOI IsCabalProjectFOI $ f `HashMap.lookup` filesOfInterest fp = summarize foi res = (Just fp, Just foi) return res where - summarize NotCabalFOI = BS.singleton 0 - summarize (IsCabalFOI OnDisk) = BS.singleton 1 - summarize (IsCabalFOI (Modified False)) = BS.singleton 2 - summarize (IsCabalFOI (Modified True)) = BS.singleton 3 - -getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) -getCabalFilesOfInterestUntracked = do - OfInterestCabalVar var <- Shake.getIdeGlobalAction + 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 - OfInterestCabalVar var <- Shake.getIdeGlobalState state + 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 IsCabalFileOfInterest f] + return [toKey IsCabalProjectFileOfInterest f] else return [] where log' = logWith recorder deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest recorder state f = do - OfInterestCabalVar var <- Shake.getIdeGlobalState state + OfInterestCabalProjectVar var <- Shake.getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f log' Debug $ LogFOI files return [toKey IsFileOfInterest f] @@ -329,13 +312,13 @@ completion recorder ide _ complParams = do pure . InR $ InR Null Just (fields, _) -> do let lspPrefInfo = Ghcide.getCompletionPrefixFromRope position cnts - cabalPrefInfo = Completions.getCabalPrefixInfo path lspPrefInfo - let res = computeCompletionsAt recorder ide cabalPrefInfo path fields + cabalProjectPrefInfo = Completions.getCabalPrefixInfo 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 ide prefInfo fp fields = do +computeCompletionsAt recorder _ prefInfo _ fields = do runMaybeT (context fields) >>= \case Nothing -> pure [] Just ctx -> do @@ -343,6 +326,8 @@ computeCompletionsAt recorder ide prefInfo fp fields = do let completer = Completions.contextToCompleter ctx let completerData = CompleterTypes.CompleterData { + getLatestGPD = pure Nothing, + getCabalCommonSections = pure Nothing, cabalPrefixInfo = prefInfo , stanzaName = case fst ctx of 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 index cff3dd0be6..a74b3ebde5 100644 --- 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 @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Ide.Plugin.CabalProject.Completion.Completions (contextToCompleter, getContext, getCabalPrefixInfo) where +module Ide.Plugin.CabalProject.Completion.Completions (contextToCompleter, getContext, getCabalProjectPrefixInfo) where import Control.Lens ((^.)) import Control.Monad.IO.Class (MonadIO) @@ -67,13 +67,13 @@ getContext recorder prefInfo fields = do cursor = lspPositionToCabalPosition (completionCursorPosition prefInfo) -- | Takes information about the current file's file path, --- and the cursor position in the file; and builds a CabalPrefixInfo +-- 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. -getCabalPrefixInfo :: FilePath -> Ghcide.PosPrefixInfo -> CabalPrefixInfo -getCabalPrefixInfo fp prefixInfo = +getCabalProjectPrefixInfo :: FilePath -> Ghcide.PosPrefixInfo -> CabalPrefixInfo +getCabalProjectPrefixInfo fp prefixInfo = CabalPrefixInfo { completionPrefix = completionPrefix', isStringNotation = mkIsStringNotation separator afterCursorText, @@ -148,7 +148,7 @@ findCursorContext cursor parentHistory prefixText fields = -- | 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 files, +-- 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 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 index 6fa601e16d..8eda8c80aa 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs @@ -11,38 +11,32 @@ module Ide.Plugin.CabalProject.Diagnostics ) where -import Control.Lens ((&), (.~)) -import qualified Data.Text as T -import Development.IDE (FileDiagnostic) -import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, - ideErrorWithSource) -import Distribution.Fields (showPError, showPWarning) -import qualified Distribution.Parsec as Syntax -import Ide.Plugin.Cabal.Diagnostics (mkDiag, - positionFromCabalPosition, - toBeginningOfNextLine) -import Ide.PluginUtils (extendNextLine) -import Language.LSP.Protocol.Lens (range) -import Language.LSP.Protocol.Types (Diagnostic (..), - DiagnosticSeverity (..), - NormalizedFilePath, - Position (Position), - Range (Range), - fromNormalizedFilePath) +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 parser error. +-- | 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 parser error +-- | 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 parser warning +-- | 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 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 index 1eaa2533ce..674e3887ff 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs @@ -5,7 +5,6 @@ module Ide.Plugin.CabalProject.Parse readCabalProjectFields ) where -import Control.Monad (unless) import qualified Crypto.Hash.SHA1 as H import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 @@ -27,7 +26,6 @@ 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 (doesFileExist) import System.Directory.Extra (XdgDirectory (..), getXdgDirectory) import System.FilePath (takeBaseName, @@ -40,9 +38,7 @@ parseCabalProjectFileContents , Either (Maybe Version, NonEmpty PError) ProjectConfigSkeleton) parseCabalProjectFileContents fp bytes = do cacheDir <- getCabalProjectCacheDir fp --- bytes <- BS.readFile fp let toParse = ProjectConfigToParse bytes - -- rootDir = takeDirectory fp verb = normal httpTransport <- configureTransport verb [fp] Nothing From 0a6ed298ca4ad82daf8f0b1eecee9ab7f40a1046 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Wed, 30 Jul 2025 13:29:19 +0200 Subject: [PATCH 24/26] fix variable name --- plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index d7d1306955..79854b4ac0 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -312,7 +312,7 @@ completion recorder ide _ complParams = do pure . InR $ InR Null Just (fields, _) -> do let lspPrefInfo = Ghcide.getCompletionPrefixFromRope position cnts - cabalProjectPrefInfo = Completions.getCabalPrefixInfo path lspPrefInfo + cabalProjectPrefInfo = Completions.getCabalProjectPrefixInfo path lspPrefInfo let res = computeCompletionsAt recorder ide cabalProjectPrefInfo path fields liftIO $ fmap InL res Nothing -> pure . InR $ InR Null From b1bced2e65d7076d6e02cbf9fe7bc24633bd7dbb Mon Sep 17 00:00:00 2001 From: rm41339 Date: Thu, 31 Jul 2025 13:46:11 +0200 Subject: [PATCH 25/26] hls-cabal-project-plugin: Add completions suggestions for cabal.project files. --- .gitmodules | 4 + cabal.project | 9 + haskell-language-server.cabal | 25 +- .../src/Ide/Plugin/Cabal/Diagnostics.hs | 2 + .../test/testdata/completer.cabal | 2 +- .../src/Ide/Plugin/CabalProject.hs | 280 +++++++++++++----- .../CabalProject/Completion/Completions.hs | 177 +++++++++++ .../Plugin/CabalProject/Completion/Data.hs | 184 ++++++++++++ .../Ide/Plugin/CabalProject/Diagnostics.hs | 44 +++ .../src/Ide/Plugin/CabalProject/Parse.hs | 74 +++++ .../src/Ide/Plugin/CabalProject/Types.hs | 31 ++ .../test/Completer.hs | 178 +++++++++++ plugins/hls-cabal-project-plugin/test/Main.hs | 132 ++++++++- .../hls-cabal-project-plugin/test/Utils.hs | 66 +++++ .../test/testdata/cabal.completer.project | 6 + .../test/testdata/cabal.project | 0 .../testdata/filepath-completions/Content.hs | 0 .../filepath-completions/cabal.project | 1 + .../testdata/filepath-completions/dir1/f1.txt | 1 + .../testdata/filepath-completions/dir1/f2.hs | 1 + .../testdata/filepath-completions/test.cabal | 0 .../filepath-completions/textfile.txt | 1 + .../invalid-cabal-project/cabal.project | 3 + .../testdata/root-directory/cabal.project | 1 + .../test/testdata/simple-cabal-project/A.hs | 3 + .../simple-cabal-project/cabal.project | 1 + .../warning-cabal-project/cabal.project | 1 + vendor/cabal | 1 + 28 files changed, 1141 insertions(+), 87 deletions(-) create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completions.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Data.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Diagnostics.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Parse.hs create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs create mode 100644 plugins/hls-cabal-project-plugin/test/Completer.hs create mode 100644 plugins/hls-cabal-project-plugin/test/Utils.hs create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/cabal.completer.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/cabal.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/Content.hs create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/cabal.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f1.txt create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/dir1/f2.hs create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/test.cabal create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/filepath-completions/textfile.txt create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/invalid-cabal-project/cabal.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/root-directory/cabal.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/A.hs create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/cabal.project create mode 100644 plugins/hls-cabal-project-plugin/test/testdata/warning-cabal-project/cabal.project create mode 160000 vendor/cabal 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 d267f5bc13..e486205f98 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -333,11 +333,15 @@ common cabalProject library hls-cabal-project-plugin import: defaults, pedantic, warnings - if !flag(cabal) + 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 @@ -347,10 +351,10 @@ library hls-cabal-project-plugin , directory , filepath , extra >=1.7.4 - , ghcide == 2.9.0.1 + , ghcide == 2.11.0.0 , hashable - , hls-plugin-api == 2.9.0.1 - , hls-graph == 2.9.0.1 + , hls-plugin-api == 2.11.0.0 + , hls-graph == 2.11.0.0 , lens , lsp ^>=2.7 , lsp-types ^>=2.3 @@ -364,6 +368,11 @@ library hls-cabal-project-plugin , 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 @@ -375,6 +384,8 @@ test-suite hls-cabal-project-plugin-tests hs-source-dirs: plugins/hls-cabal-project-plugin/test main-is: Main.hs other-modules: + Completer + Utils build-depends: , bytestring , Cabal-syntax >= 3.7 @@ -382,11 +393,13 @@ test-suite hls-cabal-project-plugin-tests , filepath , ghcide , haskell-language-server:hls-cabal-project-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.11.0.0 , lens , lsp-types , text , hls-plugin-api + , cabal-install + , haskell-language-server:hls-cabal-plugin ----------------------------- -- class plugin 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 index 24ca19945d..79854b4ac0 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} @@ -8,50 +9,45 @@ module Ide.Plugin.CabalProject where import Control.Concurrent.Strict import Control.DeepSeq -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Maybe (runMaybeT) -import qualified Data.ByteString as BS +import Control.Monad.Trans.Maybe (runMaybeT) +import qualified Data.ByteString as BS import Data.Hashable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.List as List -import qualified Data.List.NonEmpty as NE -import qualified Data.Maybe as Maybe +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 as T -import qualified Data.Text.Encoding as Encoding -import Data.Text.Utf16.Rope.Mixed as Rope -import Development.IDE as D -import Development.IDE.Core.FileStore (getVersionedTextDoc) -import Development.IDE.Core.PluginUtils -import Development.IDE.Core.Shake (restartShakeSession) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Graph (Key, - alwaysRerun) -import Development.IDE.LSP.HoverDefinition (foundHover) -import qualified Development.IDE.Plugin.Completions.Logic as Ghcide -import Development.IDE.Types.Shake (toKey) -import qualified Distribution.CabalSpecVersion as Cabal -import qualified Distribution.Fields as Syntax -import Distribution.Package (Dependency) -import Distribution.PackageDescription (allBuildDepends, - depPkgName, - unPackageName) -import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.Parsec.Error -import qualified Distribution.Parsec.Position as Syntax +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 Ide.Plugin.Error +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 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 -import Text.Regex.TDFA +import qualified Language.LSP.VFS as VFS data Log = LogModificationTime NormalizedFilePath FileVersion @@ -61,6 +57,8 @@ data Log | LogDocSaved Uri | LogDocClosed Uri | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) + | LogCompletionContext CTypes.Context Position + | LogCompletions CTypes.Log deriving (Show) instance Pretty Log where @@ -78,39 +76,47 @@ instance Pretty Log where "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 files") - { pluginRules = cabalRules 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 - restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" $ + 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 + whenUriFile _uri $ \file-> do log' Debug $ LogDocModified _uri - restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $ + 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 - restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" $ + 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 - restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" $ + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(closed)" $ deleteFileOfInterest recorder ide file ] , pluginConfigDescriptor = defaultConfigDescriptor @@ -123,11 +129,7 @@ descriptor recorder plId = whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' -cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules () -cabalRules recorder _ = do - ofInterestRules recorder - -{- | Helper function to restart the shake session, specifically for modifying .cabal files. +{- | 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. @@ -136,38 +138,114 @@ needs to be re-parsed. That's what we do when we record the dirty key that our p rule depends on. Then we restart the shake session, so that changes to our virtual files are actually picked up. -} -restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () -restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do +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 file of Interest rules and global variable +-- Cabal.project file of Interest rules and global variable -- ---------------------------------------------------------------- -{- | Cabal files that are currently open in the lsp-client. +{- | 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 OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) +newtype OfInterestCabalProjectVar = OfInterestCabalProjectVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) -instance Shake.IsIdeGlobal OfInterestCabalVar +instance Shake.IsIdeGlobal OfInterestCabalProjectVar -data IsCabalFileOfInterest = IsCabalFileOfInterest +data IsCabalProjectFileOfInterest = IsCabalProjectFileOfInterest deriving (Eq, Show, Generic) -instance Hashable IsCabalFileOfInterest -instance NFData IsCabalFileOfInterest +instance Hashable IsCabalProjectFileOfInterest +instance NFData IsCabalProjectFileOfInterest -type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult +type instance RuleResult IsCabalProjectFileOfInterest = CabalProjectFileOfInterestResult -data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus +data CabalProjectFileOfInterestResult = NotCabalProjectFOI | IsCabalProjectFOI FileOfInterestStatus deriving (Eq, Show, Generic) -instance Hashable CabalFileOfInterestResult -instance NFData CabalFileOfInterestResult +instance Hashable CabalProjectFileOfInterestResult +instance NFData CabalProjectFileOfInterestResult {- | The rule that initialises the files of interest state. @@ -175,44 +253,90 @@ Needs to be run on start-up. -} ofInterestRules :: Recorder (WithPriority Log) -> Rules () ofInterestRules recorder = do - Shake.addIdeGlobal . OfInterestCabalVar =<< liftIO (newVar HashMap.empty) - Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalFileOfInterest f -> do + Shake.addIdeGlobal . OfInterestCabalProjectVar =<< liftIO (newVar HashMap.empty) + Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalProjectFileOfInterest f -> do alwaysRerun - filesOfInterest <- getCabalFilesOfInterestUntracked - let foi = maybe NotCabalFOI IsCabalFOI $ f `HashMap.lookup` filesOfInterest + filesOfInterest <- getCabalProjectFilesOfInterestUntracked + let foi = maybe NotCabalProjectFOI IsCabalProjectFOI $ f `HashMap.lookup` filesOfInterest fp = summarize foi res = (Just fp, Just foi) return res where - summarize NotCabalFOI = BS.singleton 0 - summarize (IsCabalFOI OnDisk) = BS.singleton 1 - summarize (IsCabalFOI (Modified False)) = BS.singleton 2 - summarize (IsCabalFOI (Modified True)) = BS.singleton 3 - -getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) -getCabalFilesOfInterestUntracked = do - OfInterestCabalVar var <- Shake.getIdeGlobalAction + 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 - OfInterestCabalVar var <- Shake.getIdeGlobalState state + 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 IsCabalFileOfInterest f] + return [toKey IsCabalProjectFileOfInterest f] else return [] where log' = logWith recorder deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest recorder state f = do - OfInterestCabalVar var <- Shake.getIdeGlobalState state + 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 index b41c7786b6..6923ac029c 100644 --- a/plugins/hls-cabal-project-plugin/test/Main.hs +++ b/plugins/hls-cabal-project-plugin/test/Main.hs @@ -1,3 +1,131 @@ -module Main where +{-# LANGUAGE CPP #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} -main = undefined +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/vendor/cabal b/vendor/cabal new file mode 160000 index 0000000000..b44fecd12f --- /dev/null +++ b/vendor/cabal @@ -0,0 +1 @@ +Subproject commit b44fecd12f3c724b5519e5e6253c380d73704caf From 0293d79607dddc6ff9222075ad7c2fa6c9172f5d Mon Sep 17 00:00:00 2001 From: rm41339 Date: Thu, 7 Aug 2025 14:49:19 +0200 Subject: [PATCH 26/26] generalize Completer for .cabal and cabal.project files --- haskell-language-server.cabal | 1 + .../Cabal/Completion/Completer/FilePath.hs | 10 +-- .../Cabal/Completion/Completer/Module.hs | 2 +- .../Cabal/Completion/Completer/Simple.hs | 14 ++-- .../Cabal/Completion/Completer/Snippet.hs | 2 +- .../Cabal/Completion/Completer/Types.hs | 14 +++- .../Plugin/Cabal/Completion/Completions.hs | 4 +- .../src/Ide/Plugin/Cabal/Completion/Data.hs | 24 +++---- .../src/Ide/Plugin/CabalProject.hs | 64 +++++++++---------- .../Completion/Completer/Types.hs | 22 +++++++ .../CabalProject/Completion/Completions.hs | 36 +++++------ .../Plugin/CabalProject/Completion/Data.hs | 31 +++------ 12 files changed, 122 insertions(+), 102 deletions(-) create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index e486205f98..6903598169 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -342,6 +342,7 @@ library hls-cabal-project-plugin Ide.Plugin.CabalProject.Types Ide.Plugin.CabalProject.Completion.Completions Ide.Plugin.CabalProject.Completion.Data + Ide.Plugin.CabalProject.Completion.Completer.Types build-depends: , bytestring diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/FilePath.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/FilePath.hs index a63777416b..77da07a6b4 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/FilePath.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/FilePath.hs @@ -21,9 +21,9 @@ import qualified Text.Fuzzy.Parallel as Fuzzy -- | Completer to be used when a file path can be completed for a field. -- Completes file paths as well as directories. -filePathCompleter :: Completer +filePathCompleter :: HasPrefixInfo d => Completer d filePathCompleter recorder cData = do - let prefInfo = cabalPrefixInfo cData + let prefInfo = getPrefixInfo cData complInfo = pathCompletionInfoFromCabalPrefixInfo "" prefInfo filePathCompletions <- listFileCompletions recorder complInfo let scored = @@ -40,7 +40,7 @@ filePathCompleter recorder cData = do pure $ mkCompletionItem (completionRange prefInfo) fullFilePath fullFilePath ) -mainIsCompleter :: (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> Completer +mainIsCompleter :: (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> CabalCompleter mainIsCompleter extractionFunction recorder cData = do mGPD <- getLatestGPD cData case mGPD of @@ -74,9 +74,9 @@ mainIsCompleter extractionFunction recorder cData = do -- | Completer to be used when a directory can be completed for the field. -- Only completes directories. -directoryCompleter :: Completer +directoryCompleter :: HasPrefixInfo d => Completer d directoryCompleter recorder cData = do - let prefInfo = cabalPrefixInfo cData + let prefInfo = getPrefixInfo cData complInfo = pathCompletionInfoFromCabalPrefixInfo "" prefInfo directoryCompletions <- listDirectoryCompletions recorder complInfo let scored = diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Module.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Module.hs index 21dfbb9e1f..90300c8595 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Module.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Module.hs @@ -27,7 +27,7 @@ import qualified Text.Fuzzy.Parallel as Fuzzy -- -- Takes an extraction function which extracts the source directories -- to be used by the completer. -modulesCompleter :: (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> Completer +modulesCompleter :: (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> CabalCompleter modulesCompleter extractionFunction recorder cData = do mGPD <- getLatestGPD cData case mGPD of diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs index b097af5cd2..3024c0e2d6 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs @@ -26,21 +26,21 @@ import qualified Text.Fuzzy.Parallel as Fuzzy -- | Completer to be used when no completion suggestions -- are implemented for the field -noopCompleter :: Completer +noopCompleter :: Completer d noopCompleter _ _ = pure [] -- | Completer to be used when no completion suggestions -- are implemented for the field and a log message should be emitted. -errorNoopCompleter :: Log -> Completer +errorNoopCompleter :: Log -> Completer d errorNoopCompleter l recorder _ = do logWith recorder Warning l pure [] -- | Completer to be used when a simple set of values -- can be completed for a field. -constantCompleter :: [T.Text] -> Completer +constantCompleter :: [T.Text] -> HasPrefixInfo d => Completer d constantCompleter completions _ cData = do - let prefInfo = cabalPrefixInfo cData + let prefInfo = getPrefixInfo cData scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) completions range = completionRange prefInfo pure $ map (mkSimpleCompletionItem range . Fuzzy.original) scored @@ -49,7 +49,7 @@ constantCompleter completions _ cData = do -- -- TODO: Does not exclude imports, defined after the current cursor position -- which are not allowed according to the cabal specification -importCompleter :: Completer +importCompleter :: CabalCompleter importCompleter l cData = do cabalCommonsM <- getCabalCommonSections cData case cabalCommonsM of @@ -66,7 +66,7 @@ importCompleter l cData = do -- This is almost always the name of the cabal file. However, -- it is not forbidden by the specification to have a different name, -- it is just forbidden on hackage. -nameCompleter :: Completer +nameCompleter :: CabalCompleter nameCompleter _ cData = do let scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) [completionFileName prefInfo] prefInfo = cabalPrefixInfo cData @@ -80,7 +80,7 @@ nameCompleter _ cData = do -- the value in the completion suggestion. -- -- If the value does not occur in the weighted map its weight is defaulted to zero. -weightedConstantCompleter :: [T.Text] -> Map T.Text Double -> Completer +weightedConstantCompleter :: [T.Text] -> Map T.Text Double -> CabalCompleter weightedConstantCompleter completions weights _ cData = do let scored = if perfectScore > 0 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Snippet.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Snippet.hs index 800a39bfbc..1abcef03a2 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Snippet.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Snippet.hs @@ -18,7 +18,7 @@ import qualified Language.LSP.Protocol.Types as LSP import qualified Text.Fuzzy.Parallel as Fuzzy -- | Maps snippet triggerwords with their completers -snippetCompleter :: Completer +snippetCompleter :: CabalCompleter snippetCompleter recorder cData = do let scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) $ Map.keys snippets mapMaybeM diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs index 968b68919b..bbde24331c 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs @@ -9,9 +9,12 @@ import qualified Distribution.Parsec.Position as Syntax import Ide.Plugin.Cabal.Completion.Types import Language.LSP.Protocol.Types (CompletionItem) --- | Takes information needed to build possible completion items +-- | Takes information and completer type needed to build possible completion items -- and returns the list of possible completion items -type Completer = Recorder (WithPriority Log) -> CompleterData -> IO [CompletionItem] +type Completer d = Recorder (WithPriority Log) -> d -> IO [CompletionItem] + +-- Cabal specific completer +type CabalCompleter = Completer CompleterData -- | Contains information to be used by completers. data CompleterData = CompleterData @@ -26,3 +29,10 @@ data CompleterData = CompleterData -- | The name of the stanza in which the completer is applied stanzaName :: Maybe StanzaName } + +-- Allows CabalCompleter and CabalProjectCompleter to be passed into the same completers +class HasPrefixInfo d where + getPrefixInfo :: d -> CabalPrefixInfo + +instance HasPrefixInfo CompleterData where + getPrefixInfo = cabalPrefixInfo 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 83e809fb0f..953c572160 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 @@ -15,7 +15,7 @@ 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.Snippet -import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) +import Ide.Plugin.Cabal.Completion.Completer.Types (CabalCompleter) import Ide.Plugin.Cabal.Completion.Data import Ide.Plugin.Cabal.Completion.Types import qualified Language.LSP.Protocol.Lens as JL @@ -28,7 +28,7 @@ import System.FilePath (takeBaseName) -- | Takes information about the completion context within the file -- and finds the correct completer to be applied. -contextToCompleter :: Context -> Completer +contextToCompleter :: Context -> CabalCompleter -- if we are in the top level of the cabal file and not in a keyword context, -- we can write any top level keywords or a stanza declaration contextToCompleter (TopLevel, None) = diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs index 03e517eae2..19e1f9e6f8 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs @@ -12,7 +12,7 @@ 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 -import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) +import Ide.Plugin.Cabal.Completion.Completer.Types (CabalCompleter) import Ide.Plugin.Cabal.Completion.Types import Ide.Plugin.Cabal.LicenseSuggest (licenseNames) @@ -35,7 +35,7 @@ supportedCabalVersions :: [CabalSpecVersion] supportedCabalVersions = [CabalSpecV2_2 .. maxBound] -- | Keyword for cabal version; required to be the top line in a cabal file -cabalVersionKeyword :: Map KeyWordName Completer +cabalVersionKeyword :: Map KeyWordName CabalCompleter cabalVersionKeyword = Map.singleton "cabal-version:" $ constantCompleter $ @@ -47,7 +47,7 @@ cabalVersionKeyword = -- -- TODO: we could add descriptions of field values and -- then show them when inside the field's context -cabalKeywords :: Map KeyWordName Completer +cabalKeywords :: Map KeyWordName CabalCompleter cabalKeywords = Map.fromList [ ("name:", nameCompleter), @@ -76,7 +76,7 @@ cabalKeywords = -- | Map, containing all stanzas in a cabal file as keys, -- and lists of their possible nested keywords as values. -stanzaKeywordMap :: Map StanzaType (Map KeyWordName Completer) +stanzaKeywordMap :: Map StanzaType (Map KeyWordName CabalCompleter) stanzaKeywordMap = Map.fromList [ ("library", libraryFields <> libExecTestBenchCommons Library), @@ -90,7 +90,7 @@ stanzaKeywordMap = ("source-repository", sourceRepositoryFields) ] -libraryFields :: Map KeyWordName Completer +libraryFields :: Map KeyWordName CabalCompleter libraryFields = Map.fromList [ ("exposed-modules:", modulesCompleter sourceDirsExtractionLibrary), @@ -102,7 +102,7 @@ libraryFields = ("other-modules:", modulesCompleter sourceDirsExtractionLibrary) ] -executableFields :: Map KeyWordName Completer +executableFields :: Map KeyWordName CabalCompleter executableFields = Map.fromList [ ("main-is:", mainIsCompleter sourceDirsExtractionExecutable), @@ -110,7 +110,7 @@ executableFields = ("other-modules:", modulesCompleter sourceDirsExtractionExecutable) ] -testSuiteFields :: Map KeyWordName Completer +testSuiteFields :: Map KeyWordName CabalCompleter testSuiteFields = Map.fromList [ ("type:", constantCompleter ["exitcode-stdio-1.0", "detailed-0.9"]), @@ -118,7 +118,7 @@ testSuiteFields = ("other-modules:", modulesCompleter sourceDirsExtractionTestSuite) ] -benchmarkFields :: Map KeyWordName Completer +benchmarkFields :: Map KeyWordName CabalCompleter benchmarkFields = Map.fromList [ ("type:", noopCompleter), @@ -126,7 +126,7 @@ benchmarkFields = ("other-modules:", modulesCompleter sourceDirsExtractionBenchmark) ] -foreignLibraryFields :: Map KeyWordName Completer +foreignLibraryFields :: Map KeyWordName CabalCompleter foreignLibraryFields = Map.fromList [ ("type:", constantCompleter ["native-static", "native-shared"]), @@ -136,7 +136,7 @@ foreignLibraryFields = ("lib-version-linux:", noopCompleter) ] -sourceRepositoryFields :: Map KeyWordName Completer +sourceRepositoryFields :: Map KeyWordName CabalCompleter sourceRepositoryFields = Map.fromList [ ( "type:", @@ -160,7 +160,7 @@ sourceRepositoryFields = ("subdir:", directoryCompleter) ] -flagFields :: Map KeyWordName Completer +flagFields :: Map KeyWordName CabalCompleter flagFields = Map.fromList [ ("description:", noopCompleter), @@ -171,7 +171,7 @@ flagFields = ("lib-version-linux:", noopCompleter) ] -libExecTestBenchCommons :: TopLevelStanza -> Map KeyWordName Completer +libExecTestBenchCommons :: TopLevelStanza -> Map KeyWordName CabalCompleter libExecTestBenchCommons st = Map.fromList [ ("import:", importCompleter), diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs index 79854b4ac0..1a30dfb3e7 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -9,45 +9,45 @@ module Ide.Plugin.CabalProject where import Control.Concurrent.Strict import Control.DeepSeq -import Control.Lens ((^.)) +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 Control.Monad.Trans.Maybe (runMaybeT) +import qualified Data.ByteString as BS import Data.Hashable -import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict (HashMap) -- toList) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.List.NonEmpty as NE +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 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 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 qualified Ide.Plugin.Cabal.Completion.Types as CTypes +import Ide.Plugin.Cabal.Orphans () +import qualified Ide.Plugin.CabalProject.Completion.Completer.Types as CPCompleterTypes +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 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 +import qualified Language.LSP.VFS as VFS data Log = LogModificationTime NormalizedFilePath FileVersion @@ -324,12 +324,10 @@ computeCompletionsAt recorder _ prefInfo _ fields = do Just ctx -> do logWith recorder Debug $ LogCompletionContext ctx pos let completer = Completions.contextToCompleter ctx - let completerData = CompleterTypes.CompleterData + let completerData = CPCompleterTypes.CabalProjectCompleterData { - getLatestGPD = pure Nothing, - getCabalCommonSections = pure Nothing, - cabalPrefixInfo = prefInfo - , stanzaName = + cabalProjectPrefixInfo = prefInfo + , cabalProjectStanzaName = case fst ctx of CTypes.Stanza _ name -> name _ -> Nothing diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs new file mode 100644 index 0000000000..0f2db2c1fb --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Completion/Completer/Types.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.CabalProject.Completion.Completer.Types where + +import Ide.Plugin.Cabal.Completion.Completer.Types +import Ide.Plugin.Cabal.Completion.Types + +-- Cabal.project specific completer +type CabalProjectCompleter = Completer CabalProjectCompleterData + +-- | Contains information to be used by completers. +data CabalProjectCompleterData = CabalProjectCompleterData + { + -- | Prefix info to be used for constructing completion items + cabalProjectPrefixInfo :: CabalPrefixInfo, + -- | The name of the stanza in which the completer is applied + cabalProjectStanzaName :: Maybe StanzaName + } + +-- Allows CabalProjectCompleter to be used by Completers +instance HasPrefixInfo CabalProjectCompleterData where + getPrefixInfo = cabalProjectPrefixInfo 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 index a74b3ebde5..cad884e218 100644 --- 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 @@ -2,24 +2,24 @@ 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 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.Completer.Types (CabalProjectCompleter) import Ide.Plugin.CabalProject.Completion.Data -import qualified Language.LSP.Protocol.Lens as JL -import qualified System.FilePath as FP -import System.FilePath (takeBaseName) +import qualified Language.LSP.Protocol.Lens as JL +import qualified System.FilePath as FP +import System.FilePath (takeBaseName) -- ---------------------------------------------------------------- -- Public API for Completions @@ -27,12 +27,12 @@ import System.FilePath (takeBaseName) -- | Takes information about the completion context within the file -- and finds the correct completer to be applied. -contextToCompleter :: Context -> Completer +contextToCompleter :: Context -> CabalProjectCompleter -- 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 + Map.keys cabalProjectKeywords ++ Map.keys cabalProjectStanzaKeywordMap -- 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) = @@ -42,12 +42,12 @@ contextToCompleter (TopLevel, KeyWord kw) = -- 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 + case Map.lookup s cabalProjectStanzaKeywordMap 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 + case Map.lookup s cabalProjectStanzaKeywordMap of Nothing -> errorNoopCompleter (LogUnknownStanzaNameInContextError s) Just m -> case Map.lookup kw m of Nothing -> errorNoopCompleter (LogUnknownKeyWordInContextError kw) 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 index e9e54a9599..3229818db1 100644 --- 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 @@ -2,24 +2,13 @@ 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 Data.Map (Map) +import qualified Data.Map as Map +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 +import Ide.Plugin.CabalProject.Completion.Completer.Types (CabalProjectCompleter) -- ---------------------------------------------------------------- -- Completion Data @@ -29,7 +18,7 @@ data TopLevelStanza -- -- TODO: we could add descriptions of field values and -- then show them when inside the field's context -cabalProjectKeywords :: Map KeyWordName Completer +cabalProjectKeywords :: Map KeyWordName CabalProjectCompleter cabalProjectKeywords = Map.fromList [ ("packages:", filePathCompleter), @@ -86,7 +75,7 @@ cabalProjectKeywords = ("import:", filePathCompleter) ] -packageFields :: Map KeyWordName Completer +packageFields :: Map KeyWordName CabalProjectCompleter packageFields = Map.fromList [ ("haddock-all:", constantCompleter ["False", "True"]), @@ -154,7 +143,7 @@ packageFields = ("ghc-options:", noopCompleter) ] -sourceRepoFields :: Map KeyWordName Completer +sourceRepoFields :: Map KeyWordName CabalProjectCompleter sourceRepoFields = Map.fromList [ ("type:", constantCompleter [ "darcs", @@ -175,8 +164,8 @@ sourceRepoFields = Map.fromList -- | 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 = +cabalProjectStanzaKeywordMap :: Map StanzaType (Map KeyWordName CabalProjectCompleter) +cabalProjectStanzaKeywordMap = Map.fromList [ ("package", packageFields), ("program-options", packageFields),