From 5876ac703cbe7179e457fc79e9dca1bd876c0cba Mon Sep 17 00:00:00 2001 From: rm41339 Date: Thu, 5 Jun 2025 19:56:10 +0100 Subject: [PATCH 1/4] Implement parsing and diagnostics for cabal.project files with the cabal-project plugin. --- .gitignore | 3 + .gitmodules | 4 + cabal.project | 9 + haskell-language-server.cabal | 81 ++++++ hls-plugin-api/src/Ide/Types.hs | 17 +- .../src/Ide/Plugin/Cabal/Diagnostics.hs | 2 + .../src/Ide/Plugin/CabalProject.hs | 271 ++++++++++++++++++ .../Ide/Plugin/CabalProject/Diagnostics.hs | 44 +++ .../src/Ide/Plugin/CabalProject/Parse.hs | 74 +++++ .../src/Ide/Plugin/CabalProject/Types.hs | 30 ++ plugins/hls-cabal-project-plugin/test/Main.hs | 129 +++++++++ .../hls-cabal-project-plugin/test/Utils.hs | 48 ++++ .../test/testdata/cabal.project | 0 .../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 + src/HlsPlugins.hs | 6 + test.cpp | 3 + vendor/cabal | 1 + 21 files changed, 730 insertions(+), 1 deletion(-) create mode 100644 plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.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/Main.hs 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/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 100644 test.cpp create mode 160000 vendor/cabal diff --git a/.gitignore b/.gitignore index 2413a1fcf5..0e23fac134 100644 --- a/.gitignore +++ b/.gitignore @@ -51,3 +51,6 @@ store/ gh-release-artifacts/ .hls/ + +# local cabal package +vendor/parse-cabal-project diff --git a/.gitmodules b/.gitmodules index 7856aaec36..49b0b3c940 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,3 +8,7 @@ # Commit git commit -m "Removed submodule " # Delete the now untracked submodule files # rm -rf path_to_submodule + +[submodule "vendor/cabal"] + path = vendor/cabal + url = https://github.com/rm41339/cabal.git diff --git a/cabal.project b/cabal.project index a795f0126b..0315ff65a8 100644 --- a/cabal.project +++ b/cabal.project @@ -6,7 +6,16 @@ packages: ./ghcide ./hls-plugin-api ./hls-test-utils + ./vendor/cabal/Cabal + ./vendor/cabal/Cabal-syntax + ./vendor/cabal/cabal-install + ./vendor/cabal/cabal-install-solver + ./vendor/cabal/Cabal-described + ./vendor/cabal/Cabal-tree-diff +package cabal-install + tests: False + benchmarks: False index-state: 2025-05-12T13:26:29Z diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 157f5703f2..d85b367ae2 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -317,6 +317,86 @@ test-suite hls-cabal-plugin-tests , text , hls-plugin-api +----------------------------- +-- cabal project plugin +----------------------------- + +flag cabalProject + description: Enable cabalProject plugin + default: True + manual: True + +common cabalProject + if flag(cabalProject) + build-depends: haskell-language-server:hls-cabal-project-plugin + cpp-options: -Dhls_cabal_project + +library hls-cabal-project-plugin + import: defaults, pedantic, warnings + if !flag(cabalProject) + buildable: False + exposed-modules: + Ide.Plugin.CabalProject + Ide.Plugin.CabalProject.Parse + Ide.Plugin.CabalProject.Diagnostics + Ide.Plugin.CabalProject.Types + + build-depends: + , bytestring + , Cabal-syntax >= 3.7 + , containers + , deepseq + , directory + , filepath + , extra >=1.7.4 + , ghcide == 2.11.0.0 + , hashable + , hls-plugin-api == 2.11.0.0 + , hls-graph == 2.11.0.0 + , lens + , lsp ^>=2.7 + , lsp-types ^>=2.3 + , regex-tdfa ^>=1.3.1 + , text + , text-rope + , transformers + , unordered-containers >=0.2.10.0 + , containers + , process + , aeson + , Cabal + , pretty + , cabal-install + , cabal-install-solver + , haskell-language-server:hls-cabal-plugin + , base16-bytestring + , cryptohash-sha1 + + hs-source-dirs: plugins/hls-cabal-project-plugin/src + +test-suite hls-cabal-project-plugin-tests + import: defaults, pedantic, test-defaults, warnings + if !flag(cabalProject) + buildable: False + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-cabal-project-plugin/test + main-is: Main.hs + other-modules: + Utils + build-depends: + , bytestring + , Cabal-syntax >= 3.7 + , extra + , filepath + , ghcide + , haskell-language-server:hls-cabal-project-plugin + , hls-test-utils == 2.11.0.0 + , lens + , lsp-types + , text + , hls-plugin-api + , cabal-install + ----------------------------- -- class plugin ----------------------------- @@ -1830,6 +1910,7 @@ library , pedantic -- plugins , cabal + , cabalProject , callHierarchy , cabalfmt , cabalgild diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 3a06656a77..6e7dd7102f 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -14,7 +14,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} module Ide.Types -( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor +( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor, defaultCabalProjectPluginDescriptor , defaultPluginPriority , describePlugin , IdeCommand(..) @@ -1077,6 +1077,21 @@ defaultCabalPluginDescriptor plId desc = Nothing [".cabal"] +defaultCabalProjectPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState +defaultCabalProjectPluginDescriptor plId desc = + PluginDescriptor + plId + desc + defaultPluginPriority + mempty + mempty + mempty + defaultConfigDescriptor + mempty + mempty + Nothing + [".project"] + newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) instance IsString CommandId where diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs index 5429ac0bb9..3650ac5a25 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -5,6 +5,8 @@ module Ide.Plugin.Cabal.Diagnostics , warningDiagnostic , positionFromCabalPosition , fatalParseErrorDiagnostic +, toBeginningOfNextLine +, mkDiag -- * Re-exports , FileDiagnostic , Diagnostic(..) diff --git a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs new file mode 100644 index 0000000000..3ff1bccb68 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.CabalProject where + +import Control.Concurrent.Strict +import Control.DeepSeq +import Control.Monad.Extra +import Control.Monad.IO.Class +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.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 Development.IDE.Types.Shake (toKey) +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.Types +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import qualified Language.LSP.VFS as VFS + +data Log + = LogModificationTime NormalizedFilePath FileVersion + | LogShake Shake.Log + | LogDocOpened Uri + | LogDocModified Uri + | LogDocSaved Uri + | LogDocClosed Uri + | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) + 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.project files") + { pluginRules = cabalProjectRules 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 + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(opened)" $ + addFileOfInterest recorder ide file Modified{firstOpen = True} + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ + \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file-> do + log' Debug $ LogDocModified _uri + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(changed)" $ + addFileOfInterest recorder ide file Modified{firstOpen = False} + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ + \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocSaved _uri + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(saved)" $ + addFileOfInterest recorder ide file OnDisk + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ + \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocClosed _uri + restartCabalProjectShakeSession (shakeExtras ide) vfs file "(closed)" $ + deleteFileOfInterest recorder ide file + ] + , pluginConfigDescriptor = defaultConfigDescriptor + { configHasDiagnostics = True + } + } + where + log' = logWith recorder + + whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () + whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' + +{- | Helper function to restart the shake session, specifically for modifying cabal.project files. +No special logic, just group up a bunch of functions you need for the base +Notification Handlers. + +To make sure diagnostics are up to date, we need to tell shake that the file was touched and +needs to be re-parsed. That's what we do when we record the dirty key that our parsing +rule depends on. +Then we restart the shake session, so that changes to our virtual files are actually picked up. +-} +restartCabalProjectShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () +restartCabalProjectShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + keys <- actionBetweenSession + return (toKey GetModificationTime file:keys) + + +cabalProjectRules :: Recorder (WithPriority Log) -> PluginId -> Rules () +cabalProjectRules recorder plId = do + -- Make sure we initialise the cabal project files-of-interest. + ofInterestRules recorder + -- Rule to produce diagnostics for cabal project files. + define (cmapWithPrio LogShake recorder) $ \ParseCabalProjectFields file -> do + config <- getPluginConfigAction plId + if not (plcGlobalOn config && plcDiagnosticsOn config) + then pure ([], Nothing) + else do + -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), + -- we rerun this rule because this rule *depends* on GetModificationTime. + (t, mCabalProjectSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalProjectSource of + Just sources -> + pure $ Encoding.encodeUtf8 $ Rope.toText sources + Nothing -> do + liftIO $ BS.readFile $ fromNormalizedFilePath file + + case Parse.readCabalProjectFields file contents of + Left _ -> + pure ([], Nothing) + Right fields -> + pure ([], Just fields) + + define (cmapWithPrio LogShake recorder) $ \ParseCabalProjectFile file -> do + cfg <- getPluginConfigAction plId + if not (plcGlobalOn cfg && plcDiagnosticsOn cfg) + then pure ([], Nothing) + else do + -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), + -- we rerun this rule because this rule *depends* on GetModificationTime. + (t, mCabalProjectSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + + contents <- case mCabalProjectSource of + Just sources -> + pure $ Encoding.encodeUtf8 $ Rope.toText sources + Nothing -> + liftIO $ BS.readFile $ fromNormalizedFilePath file + + (pWarnings, pResult) <- liftIO $ Parse.parseCabalProjectFileContents (fromNormalizedFilePath file) contents + let warnDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings + + case pResult of + Left (_specVer, pErrNE) -> do + let errDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrNE + pure (errDiags ++ warnDiags, Nothing) + + Right projCfg -> do + pure (warnDiags, Just projCfg) + + action $ do + -- Run the cabal project kick. This code always runs when 'shakeRestart' is run. + -- Must be careful to not impede the performance too much. Crucial to + -- a snappy IDE experience. + kick + where + log' = logWith recorder + +{- | This is the kick function for the cabal project plugin. +We run this action, whenever we shake session us run/restarted, which triggers +actions to produce diagnostics for cabal project files. + +It is paramount that this kick-function can be run quickly, since it is a blocking +function invocation. +-} +kick :: Action () +kick = do + files <- HashMap.keys <$> getCabalProjectFilesOfInterestUntracked + Shake.runWithSignal (Proxy @"kick/start/cabal-project") (Proxy @"kick/done/cabal-project") files Types.ParseCabalProjectFile + + +-- ---------------------------------------------------------------- +-- Cabal project file of Interest rules and global variable +-- ---------------------------------------------------------------- + +{- | Cabal project files that are currently open in the lsp-client. +Specific actions happen when these files are saved, closed or modified, +such as generating diagnostics, re-parsing, etc... + +We need to store the open files to parse them again if we restart the shake session. +Restarting of the shake session happens whenever these files are modified. +-} +newtype OfInterestCabalProjectVar = OfInterestCabalProjectVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) + +instance Shake.IsIdeGlobal OfInterestCabalProjectVar + +data IsCabalProjectFileOfInterest = IsCabalProjectFileOfInterest + deriving (Eq, Show, Generic) +instance Hashable IsCabalProjectFileOfInterest +instance NFData IsCabalProjectFileOfInterest + +type instance RuleResult IsCabalProjectFileOfInterest = CabalProjectFileOfInterestResult + +data CabalProjectFileOfInterestResult = NotCabalProjectFOI | IsCabalProjectFOI FileOfInterestStatus + deriving (Eq, Show, Generic) +instance Hashable CabalProjectFileOfInterestResult +instance NFData CabalProjectFileOfInterestResult + +{- | The rule that initialises the files of interest state. + +Needs to be run on start-up. +-} +ofInterestRules :: Recorder (WithPriority Log) -> Rules () +ofInterestRules recorder = do + Shake.addIdeGlobal . OfInterestCabalProjectVar =<< liftIO (newVar HashMap.empty) + Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalProjectFileOfInterest f -> do + alwaysRerun + filesOfInterest <- getCabalProjectFilesOfInterestUntracked + let foi = maybe NotCabalProjectFOI IsCabalProjectFOI $ f `HashMap.lookup` filesOfInterest + fp = summarize foi + res = (Just fp, Just foi) + return res + where + summarize NotCabalProjectFOI = BS.singleton 0 + summarize (IsCabalProjectFOI OnDisk) = BS.singleton 1 + summarize (IsCabalProjectFOI (Modified False)) = BS.singleton 2 + summarize (IsCabalProjectFOI (Modified True)) = BS.singleton 3 + +getCabalProjectFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) +getCabalProjectFilesOfInterestUntracked = do + OfInterestCabalProjectVar var <- Shake.getIdeGlobalAction + liftIO $ readVar var + +addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] +addFileOfInterest recorder state f v = do + OfInterestCabalProjectVar var <- Shake.getIdeGlobalState state + (prev, files) <- modifyVar var $ \dict -> do + let (prev, new) = HashMap.alterF (,Just v) f dict + pure (new, (prev, new)) + if prev /= Just v + then do + log' Debug $ LogFOI files + return [toKey IsCabalProjectFileOfInterest f] + else return [] + where + log' = logWith recorder + +deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] +deleteFileOfInterest recorder state f = do + OfInterestCabalProjectVar var <- Shake.getIdeGlobalState state + files <- modifyVar' var $ HashMap.delete f + log' Debug $ LogFOI files + return [toKey IsFileOfInterest f] + where + log' = logWith recorder 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..8e91db085d --- /dev/null +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject/Types.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.CabalProject.Types where + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import Development.IDE (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/Main.hs b/plugins/hls-cabal-project-plugin/test/Main.hs new file mode 100644 index 0000000000..b1ef14336a --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/Main.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main ( + main, +) where + +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 + ] + +-- ------------------------------------------------------------------------ +-- 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..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/root-directory/cabal.project b/plugins/hls-cabal-project-plugin/test/testdata/root-directory/cabal.project new file mode 100644 index 0000000000..241b892291 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/root-directory/cabal.project @@ -0,0 +1 @@ +import: missing-folder/nonexistent.config diff --git a/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/A.hs b/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/A.hs new file mode 100644 index 0000000000..4eca137b41 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/A.hs @@ -0,0 +1,3 @@ +module A where + +a = undefined diff --git a/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/cabal.project b/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/cabal.project new file mode 100644 index 0000000000..e6fdbadb43 --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/simple-cabal-project/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/plugins/hls-cabal-project-plugin/test/testdata/warning-cabal-project/cabal.project b/plugins/hls-cabal-project-plugin/test/testdata/warning-cabal-project/cabal.project new file mode 100644 index 0000000000..a3cd59d23b --- /dev/null +++ b/plugins/hls-cabal-project-plugin/test/testdata/warning-cabal-project/cabal.project @@ -0,0 +1 @@ +package: . diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 87a1af7392..3b34a06743 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -23,6 +23,9 @@ import qualified Ide.Plugin.CallHierarchy as CallHierarchy #if hls_cabal import qualified Ide.Plugin.Cabal as Cabal #endif +#if hls_cabal_project +import qualified Ide.Plugin.CabalProject as CabalProject +#endif #if hls_class import qualified Ide.Plugin.Class as Class #endif @@ -154,6 +157,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins let pId = "cabal" in Cabal.descriptor (pluginRecorder pId) pId : let caId = "cabalHaskellIntegration" in Cabal.haskellInteractionDescriptor (pluginRecorder caId) caId : #endif +#if hls_cabal_project + let pId = "cabalProject" in CabalProject.descriptor (pluginRecorder pId) pId : +#endif #if hls_pragmas Pragmas.suggestPragmaDescriptor "pragmas-suggest" : Pragmas.completionDescriptor "pragmas-completion" : diff --git a/test.cpp b/test.cpp new file mode 100644 index 0000000000..055115d2e8 --- /dev/null +++ b/test.cpp @@ -0,0 +1,3 @@ +#include +int main() { std::cout << "OK +"; return 0; } diff --git a/vendor/cabal b/vendor/cabal new file mode 160000 index 0000000000..e8e48a6789 --- /dev/null +++ b/vendor/cabal @@ -0,0 +1 @@ +Subproject commit e8e48a6789823e00f392f87d532787a2c7604f88 From 82a08709a67946d160b0aa7f16862730e4f4d073 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Mon, 28 Jul 2025 16:08:36 +0200 Subject: [PATCH 2/4] remove old changes to gitignore --- .gitignore | 3 --- 1 file changed, 3 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 From 0079903b541b0c0d4382c434134f194b3d030835 Mon Sep 17 00:00:00 2001 From: rm41339 Date: Sun, 3 Aug 2025 14:38:47 +0200 Subject: [PATCH 3/4] fix documentation/typos --- .../src/Ide/Plugin/CabalProject.hs | 19 ++++++++----------- plugins/hls-cabal-project-plugin/test/Main.hs | 4 ++-- .../hls-cabal-project-plugin/test/Utils.hs | 8 ++------ test.cpp | 3 --- vendor/cabal | 2 +- 5 files changed, 13 insertions(+), 23 deletions(-) delete mode 100644 test.cpp 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 3ff1bccb68..6c0fdaa67d 100644 --- a/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs +++ b/plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs @@ -65,9 +65,6 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultCabalProjectPluginDescriptor plId "Provides a variety of IDE features in cabal.project files") { pluginRules = cabalProjectRules recorder plId - , pluginHandlers = - mconcat - [] , pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ @@ -123,9 +120,9 @@ restartCabalProjectShakeSession shakeExtras vfs file actionMsg actionBetweenSess cabalProjectRules :: Recorder (WithPriority Log) -> PluginId -> Rules () cabalProjectRules recorder plId = do - -- Make sure we initialise the cabal project files-of-interest. + -- Make sure we initialise the cabal.project files-of-interest. ofInterestRules recorder - -- Rule to produce diagnostics for cabal project 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) @@ -175,16 +172,16 @@ cabalProjectRules recorder plId = do pure (warnDiags, Just projCfg) action $ do - -- Run the cabal project 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 project plugin. -We run this action, whenever we shake session us run/restarted, which triggers -actions to produce diagnostics for cabal project files. +{- | This is the kick function for the cabal.project plugin. +We run this action, whenever a shake session is 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. @@ -196,10 +193,10 @@ kick = do -- ---------------------------------------------------------------- --- Cabal project file of Interest rules and global variable +-- Cabal.project file of Interest rules and global variable -- ---------------------------------------------------------------- -{- | Cabal project 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... diff --git a/plugins/hls-cabal-project-plugin/test/Main.hs b/plugins/hls-cabal-project-plugin/test/Main.hs index b1ef14336a..fe9a2acdb3 100644 --- a/plugins/hls-cabal-project-plugin/test/Main.hs +++ b/plugins/hls-cabal-project-plugin/test/Main.hs @@ -33,7 +33,7 @@ main :: IO () main = do defaultTestRunner $ testGroup - "Cabal Plugin Tests" + "Cabal.project Plugin Tests" [ unitTests , pluginTests ] @@ -52,7 +52,7 @@ unitTests = cabalProjectParserUnitTests :: TestTree cabalProjectParserUnitTests = testGroup - "Parsing Cabal Project" + "Parsing Cabal.project" [ testCase "Simple Parsing works" $ do let fp = testDataDir "cabal.project" bytes <- BS.readFile fp diff --git a/plugins/hls-cabal-project-plugin/test/Utils.hs b/plugins/hls-cabal-project-plugin/test/Utils.hs index 8ab90dd8bd..1543b489e1 100644 --- a/plugins/hls-cabal-project-plugin/test/Utils.hs +++ b/plugins/hls-cabal-project-plugin/test/Utils.hs @@ -31,8 +31,8 @@ runCabalProjectGoldenSession title subdir fp act = goldenWithCabalDoc def cabalP 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 +-- | these functions are used to detect cabal.project kicks +-- and look at diagnostics for cabal.project files -- kicks are run everytime there is a shake session run/restart cabalProjectKickDone :: Session () cabalProjectKickDone = kick (Proxy @"kick/done/cabal-project") >>= guard . not . null @@ -42,7 +42,3 @@ cabalProjectKickStart = kick (Proxy @"kick/start/cabal-project") >>= guard . not 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/test.cpp b/test.cpp deleted file mode 100644 index 055115d2e8..0000000000 --- a/test.cpp +++ /dev/null @@ -1,3 +0,0 @@ -#include -int main() { std::cout << "OK -"; return 0; } diff --git a/vendor/cabal b/vendor/cabal index e8e48a6789..b44fecd12f 160000 --- a/vendor/cabal +++ b/vendor/cabal @@ -1 +1 @@ -Subproject commit e8e48a6789823e00f392f87d532787a2c7604f88 +Subproject commit b44fecd12f3c724b5519e5e6253c380d73704caf From f90d3aa612bd289db97a001392020513a668d9dd Mon Sep 17 00:00:00 2001 From: rm41339 Date: Mon, 4 Aug 2025 12:22:23 +0200 Subject: [PATCH 4/4] fix documentation, tests --- .../Ide/Plugin/CabalProject/Diagnostics.hs | 6 ++-- .../src/Ide/Plugin/CabalProject/Parse.hs | 12 +++---- plugins/hls-cabal-project-plugin/test/Main.hs | 32 ++++--------------- .../hls-cabal-project-plugin/test/Utils.hs | 9 ++---- 4 files changed, 19 insertions(+), 40 deletions(-) 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 8eda8c80aa..c808452e9d 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 @@ -24,19 +24,19 @@ import Language.LSP.Protocol.Types (Diagnostic (..), NormalizedFilePath, fromNormalizedFilePath) --- | Produce a diagnostic for a fatal Cabal Project 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 Project 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 Project 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 674e3887ff..f258c691e9 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 @@ -11,7 +11,6 @@ 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, @@ -31,6 +30,7 @@ import System.Directory.Extra (XdgDirectory (..), import System.FilePath (takeBaseName, takeDirectory, ()) +-- High level parsing of cabal.project file to produce errors, warnings, and ProjectConfigSkeleton parseCabalProjectFileContents :: FilePath -> BS.ByteString @@ -47,21 +47,21 @@ parseCabalProjectFileContents fp bytes = do pure (PR.runParseResult parseRes) +-- Extract fields from cabal.project file readCabalProjectFields :: NormalizedFilePath -> BS.ByteString - -> Either FileDiagnostic [Syntax.Field Syntax.Position] + -> Either [FileDiagnostic] [Syntax.Field Syntax.Position] readCabalProjectFields file contents = case PR.runParseResult (readPreprocessFields contents) of + -- we don't want to double report diagnostics, all diagnostics are produced by 'parseCabalProjectFileContents'. (_warnings, Left (_mbVer, errs)) -> - let perr = NE.head errs - in Left $ - Diagnostics.fatalParseErrorDiagnostic file - ("Failed to parse cabal.project file: " <> T.pack (show perr)) + Left (map (Diagnostics.errorDiagnostic file) (NE.toList errs)) (_warnings, Right fields) -> Right fields +-- Helper for parseCabalProjectFileContents, returns unique cache directory for given cabal.project file getCabalProjectCacheDir :: FilePath -> IO FilePath getCabalProjectCacheDir fp = do getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) diff --git a/plugins/hls-cabal-project-plugin/test/Main.hs b/plugins/hls-cabal-project-plugin/test/Main.hs index fe9a2acdb3..13a34b626d 100644 --- a/plugins/hls-cabal-project-plugin/test/Main.hs +++ b/plugins/hls-cabal-project-plugin/test/Main.hs @@ -6,24 +6,13 @@ module Main ( main, ) where -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 qualified Control.Exception as E +import Control.Lens ((^.)) +import qualified Data.ByteString as BS +import Data.ByteString.Char8 (pack) +import Data.Either (isRight) +import qualified Ide.Plugin.CabalProject.Parse as Lib +import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls import Utils @@ -65,13 +54,6 @@ cabalProjectParserUnitTests = 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 diff --git a/plugins/hls-cabal-project-plugin/test/Utils.hs b/plugins/hls-cabal-project-plugin/test/Utils.hs index 1543b489e1..73205a17a2 100644 --- a/plugins/hls-cabal-project-plugin/test/Utils.hs +++ b/plugins/hls-cabal-project-plugin/test/Utils.hs @@ -4,13 +4,10 @@ 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.Proxy (Proxy (Proxy)) +import Ide.Plugin.CabalProject (descriptor) import qualified Ide.Plugin.CabalProject -import Ide.Plugin.CabalProject.Types import System.FilePath import Test.Hls