diff --git a/.github/workflows/hackage.yml b/.github/workflows/hackage.yml index f909ef6fb9..34e6b8b62b 100644 --- a/.github/workflows/hackage.yml +++ b/.github/workflows/hackage.yml @@ -28,6 +28,7 @@ jobs: matrix: package: ["hie-compat", "hls-graph", "shake-bench", "hls-plugin-api", "ghcide", "hls-test-utils", + "hls-cabal-plugin", "hls-brittany-plugin", "hls-floskell-plugin", "hls-fourmolu-plugin", "hls-ormolu-plugin", "hls-stylish-haskell-plugin", "hls-class-plugin", "hls-eval-plugin", "hls-explicit-imports-plugin", diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 3a79cf13d1..fb9022e113 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -259,6 +259,10 @@ jobs: name: Test hls-cabal-fmt-plugin test suite run: cabal test hls-cabal-fmt-plugin --flag=isolateTests --test-options="$TEST_OPTS" || cabal test hls-cabal-fmt-plugin --flag=isolateTests --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-cabal-fmt-plugin --flag=isolateTests --test-options="$TEST_OPTS" + - if: matrix.test + name: Test hls-cabal-plugin test suite + run: cabal test hls-cabal-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-cabal-plugin --test-options="$TEST_OPTS" + test_post_job: if: always() runs-on: ubuntu-latest diff --git a/CODEOWNERS b/CODEOWNERS index 268f136ff9..dbe8495fbc 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -9,6 +9,7 @@ # Plugins /plugins/hls-alternate-number-format-plugin @drsooch /plugins/hls-brittany-plugin @fendor +/plugins/hls-cabal-plugin @fendor /plugins/hls-cabal-fmt-plugin @VeryMilkyJoe @fendor /plugins/hls-call-hierarchy-plugin @July541 /plugins/hls-class-plugin @Ailrun diff --git a/cabal.project b/cabal.project index 4dee7fc198..6536f26465 100644 --- a/cabal.project +++ b/cabal.project @@ -8,6 +8,7 @@ packages: ./ghcide/test ./hls-plugin-api ./hls-test-utils + ./plugins/hls-cabal-plugin ./plugins/hls-cabal-fmt-plugin ./plugins/hls-tactics-plugin ./plugins/hls-brittany-plugin diff --git a/docs/features.md b/docs/features.md index 5b025a82aa..c032848abb 100644 --- a/docs/features.md +++ b/docs/features.md @@ -44,6 +44,12 @@ Provided by: `hls-stan-plugin` Provides Stan hints as diagnostics. +### Cabal parse errors and warnings + +Provided by: `hls-cabal-plugin` + +Provides errors and warnings from Cabal as diagnostics + ## Hovers Provided by: `ghcide` @@ -308,6 +314,14 @@ Expand record wildcards, explicitly listing all record fields as field puns. ![Explicit Wildcard Demo](../plugins/hls-explicit-record-fields-plugin/wildcard.gif) +### Unknown SPDX License suggestion + +Provided by: `hls-cabal-plugin` + +Code action kind: `quickfix` + +Correct common misspelling of SPDX Licenses such as `BSD-3-Clause`. + ## Code lenses ### Add type signature diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index cc69eed3a1..6926f53318 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -63,6 +63,12 @@ flag ignore-plugins-ghc-bounds default: False manual: True + +flag cabal + description: Enable cabal plugin + default: True + manual: True + flag class description: Enable class plugin default: True @@ -215,6 +221,11 @@ common cabalfmt build-depends: hls-cabal-fmt-plugin ^>= 0.1.0.0 cpp-options: -Dhls_cabalfmt +common cabal + if flag(cabal) + build-depends: hls-cabal-plugin ^>= 0.1 + cpp-options: -Dhls_cabal + common class if flag(class) build-depends: hls-class-plugin ^>= 1.1 @@ -358,6 +369,7 @@ library , warnings , pedantic -- plugins + , cabal , callHierarchy , cabalfmt , changeTypeSignature diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 3203cbcf8a..3b1fbb7ac2 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -2,9 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Ide.PluginUtils - ( WithDeletions(..), - getProcessID, + ( -- * LSP Range manipulation functions normalize, + extendNextLine, + extendLineStart, + WithDeletions(..), + getProcessID, makeDiffTextEdit, makeDiffTextEditAdditive, diffText, @@ -67,9 +70,27 @@ import qualified Text.Megaparsec.Char.Lexer as P -- --------------------------------------------------------------------- -- | Extend to the line below and above to replace newline character. +-- +-- >>> normalize (Range (Position 5 5) (Position 5 10)) +-- Range (Position 5 0) (Position 6 0) normalize :: Range -> Range -normalize (Range (Position sl _) (Position el _)) = - Range (Position sl 0) (Position (el + 1) 0) +normalize = extendLineStart . extendNextLine + +-- | Extend 'Range' to the start of the next line. +-- +-- >>> extendNextLine (Range (Position 5 5) (Position 5 10)) +-- Range (Position 5 5) (Position 6 0) +extendNextLine :: Range -> Range +extendNextLine (Range s (Position el _)) = + Range s (Position (el + 1) 0) + +-- | Extend 'Range' to the start of the current line. +-- +-- >>> extendLineStart (Range (Position 5 5) (Position 5 10)) +-- Range (Position 5 0) (Position 5 10) +extendLineStart :: Range -> Range +extendLineStart (Range (Position sl _) e) = + Range (Position sl 0) e -- --------------------------------------------------------------------- diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 7f61f66ae6..a9d3a595f3 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -16,6 +16,7 @@ module Test.Hls defaultTestRunner, goldenGitDiff, goldenWithHaskellDoc, + goldenWithCabalDoc, goldenWithHaskellDocFormatter, goldenWithCabalDocFormatter, def, @@ -124,12 +125,35 @@ goldenWithHaskellDoc -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithHaskellDoc plugin title testDataDir path desc ext act = +goldenWithHaskellDoc = goldenWithDoc "haskell" + +goldenWithCabalDoc + :: PluginDescriptor IdeState + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithCabalDoc = goldenWithDoc "cabal" + +goldenWithDoc + :: T.Text + -> PluginDescriptor IdeState + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithDoc fileType plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) $ runSessionWithServer plugin testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do - doc <- openDoc (path <.> ext) "haskell" + doc <- openDoc (path <.> ext) fileType void waitForBuildQueue act doc documentContents doc diff --git a/plugins/hls-cabal-plugin/CHANGELOG.md b/plugins/hls-cabal-plugin/CHANGELOG.md new file mode 100644 index 0000000000..809439f0a8 --- /dev/null +++ b/plugins/hls-cabal-plugin/CHANGELOG.md @@ -0,0 +1,6 @@ +# Revision history for hls-cabal-plugin + +## 0.1.0.0 -- YYYY-mm-dd + +* Provide Diagnostics on parse errors and warnings for .cabal files +* Provide CodeAction for the common SPDX License mistake "BSD3" instead of "BSD-3-Clause" diff --git a/plugins/hls-cabal-plugin/LICENSE b/plugins/hls-cabal-plugin/LICENSE new file mode 100644 index 0000000000..6d34465ea5 --- /dev/null +++ b/plugins/hls-cabal-plugin/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2022 Fendor + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal b/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal new file mode 100644 index 0000000000..67170c10ab --- /dev/null +++ b/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal @@ -0,0 +1,81 @@ +cabal-version: 3.0 +name: hls-cabal-plugin +version: 0.1.0.0 +synopsis: Cabal integration plugin with Haskell Language Server +description: + Please see the README on GitHub at + +homepage: +license: MIT +license-file: LICENSE +author: Fendor +maintainer: fendor@posteo.de +category: Development +extra-source-files: + CHANGELOG.md + test/testdata/*.cabal + test/testdata/simple-cabal/A.hs + test/testdata/simple-cabal/cabal.project + test/testdata/simple-cabal/hie.yaml + test/testdata/simple-cabal/simple-cabal.cabal + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: + Ide.Plugin.Cabal + Ide.Plugin.Cabal.Diagnostics + Ide.Plugin.Cabal.LicenseSuggest + Ide.Plugin.Cabal.Parse + + build-depends: + , base >=4.12 && <5 + , bytestring + -- Ideally, we only want to support a single Cabal version, supporting + -- older versions is completely pointless since Cabal is backwards compatible, + -- the latest Cabal version can parse all versions of the Cabal file format. + -- + -- However, stack is making this difficult, if we change the version of Cabal, + -- we essentially need to make sure all other packages in the snapshot have their + -- Cabal dependency version relaxed. + -- Most packages have a Hackage revision, but stack won't pick these up (for sensible reasons) + -- automatically, forcing us to manually update the packages revision id. + -- This is a lot of work for almost zero benefit, so we just allow more versions here + -- and we eventually completely drop support for building HLS with stack. + , Cabal ^>=3.2 || ^>=3.4 || ^>=3.6 || ^>= 3.8 + , deepseq + , directory + , extra >=1.7.4 + , ghcide ^>= 1.8 + , hashable + , hls-plugin-api ^>=1.5 + , hls-graph ^>=1.8 + , lsp ^>=1.6.0.0 + , lsp-types ^>=1.6.0.0 + , regex-tdfa ^>=1.3.1 + , stm + , text + , unordered-containers >=0.2.10.0 + + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , base + , bytestring + , filepath + , ghcide + , hls-cabal-plugin + , hls-test-utils ^>=1.4 + , lens + , lsp-types + , tasty-hunit + , text diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs new file mode 100644 index 0000000000..72a16c8ea6 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Cabal (descriptor, Log(..)) where + +import Control.Concurrent.STM +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.Maybe (mapMaybe) +import qualified Data.Text.Encoding as Encoding +import Data.Typeable +import Development.IDE as D +import Development.IDE.Core.Shake (restartShakeSession) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Graph (alwaysRerun) +import GHC.Generics +import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics +import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest +import qualified Ide.Plugin.Cabal.Parse as Parse +import Ide.Plugin.Config (Config) +import Ide.Types +import Language.LSP.Server (LspM) +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +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 = (defaultCabalPluginDescriptor plId) + { pluginRules = cabalRules recorder + , pluginHandlers = mkPluginHandler STextDocumentCodeAction licenseSuggestCodeAction + , pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ + \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocOpened _uri + addFileOfInterest recorder ide file Modified{firstOpen=True} + restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" + + , mkPluginNotificationHandler LSP.STextDocumentDidChange $ + \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocModified _uri + addFileOfInterest recorder ide file Modified{firstOpen=False} + restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" + + , mkPluginNotificationHandler LSP.STextDocumentDidSave $ + \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocSaved _uri + addFileOfInterest recorder ide file OnDisk + restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" + + , mkPluginNotificationHandler LSP.STextDocumentDidClose $ + \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do + whenUriFile _uri $ \file -> do + log' Debug $ LogDocClosed _uri + deleteFileOfInterest recorder ide file + restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" + ] + } + where + log' = logWith recorder + + whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () + whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' + +-- | 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 () +restartCabalShakeSession shakeExtras vfs file actionMsg = do + join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] + +-- ---------------------------------------------------------------- +-- Plugin Rules +-- ---------------------------------------------------------------- + +data ParseCabal = ParseCabal + deriving (Eq, Show, Typeable, Generic) +instance Hashable ParseCabal +instance NFData ParseCabal + +type instance RuleResult ParseCabal = () + +cabalRules :: Recorder (WithPriority Log) -> 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) $ \ParseCabal file -> do + -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), + -- we rerun this rule because this rule *depends* on GetModificationTime. + (t, mCabalSource) <- use_ GetFileContents file + log' Debug $ LogModificationTime file t + contents <- case mCabalSource of + Just sources -> pure $ Encoding.encodeUtf8 sources + Nothing -> do + liftIO $ BS.readFile $ fromNormalizedFilePath file + + (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents + let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings + case pm of + Left (_cabalVersion, pErrorNE) -> do + let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE + allDiags = errorDiags <> warningDiags + pure (allDiags, Nothing) + Right _ -> do + pure (warningDiags, Just ()) + + 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 +-- 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 + void $ uses ParseCabal files + +-- ---------------------------------------------------------------- +-- Code Actions +-- ---------------------------------------------------------------- + +licenseSuggestCodeAction + :: IdeState + -> PluginId + -> CodeActionParams + -> LspM Config (Either ResponseError (ResponseResult 'TextDocumentCodeAction)) +licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List diags}) = + pure $ Right $ List $ mapMaybe (fmap InR . LicenseSuggest.licenseErrorAction uri) diags + +-- ---------------------------------------------------------------- +-- 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, Typeable, Generic) +instance Hashable IsCabalFileOfInterest +instance NFData IsCabalFileOfInterest + +type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult + +data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus + deriving (Eq, Show, Typeable, 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 () +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)) + when (prev /= Just v) $ do + join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + log' Debug $ LogFOI files + where + log' = logWith recorder + +deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO () +deleteFileOfInterest recorder state f = do + OfInterestCabalVar var <- Shake.getIdeGlobalState state + files <- modifyVar' var $ HashMap.delete f + join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + log' Debug $ LogFOI files + where + log' = logWith recorder diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs new file mode 100644 index 0000000000..2b077cfaf1 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module Ide.Plugin.Cabal.Diagnostics +( errorDiagnostic +, warningDiagnostic +, positionFromCabalPosition + -- * Re-exports +, FileDiagnostic +, Diagnostic(..) +) +where + +import qualified Data.Text as T +import Development.IDE (FileDiagnostic, + ShowDiagnostic (ShowDiag)) +import Distribution.Fields (showPError, showPWarning) +import qualified Ide.Plugin.Cabal.Parse as Lib +import Ide.PluginUtils (extendNextLine) +import Language.LSP.Types (Diagnostic (..), + DiagnosticSeverity (..), + DiagnosticSource, NormalizedFilePath, + Position (Position), Range (Range), + fromNormalizedFilePath) + +-- | Produce a diagnostic from a Cabal parser error +errorDiagnostic :: NormalizedFilePath -> Lib.PError -> FileDiagnostic +errorDiagnostic fp err@(Lib.PError pos _) = + mkDiag fp "cabal" DsError (toBeginningOfNextLine pos) msg + where + msg = T.pack $ showPError (fromNormalizedFilePath fp) err + +-- | Produce a diagnostic from a Cabal parser warning +warningDiagnostic :: NormalizedFilePath -> Lib.PWarning -> FileDiagnostic +warningDiagnostic fp warning@(Lib.PWarning _ pos _) = + mkDiag fp "cabal" DsWarning (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 :: Lib.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 :: Lib.Position -> Position +positionFromCabalPosition (Lib.Position line column) = Position (fromIntegral line') (fromIntegral col') + where + -- LSP is zero-based, Cabal is one-based + line' = line-1 + col' = column-1 + +-- | Create a 'FileDiagnostic' +mkDiag + :: NormalizedFilePath + -- ^ Cabal file path + -> DiagnosticSource + -- ^ 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 = (file, ShowDiag,) + Diagnostic + { _range = loc + , _severity = Just sev + , _source = Just diagSource + , _message = msg + , _code = Nothing + , _tags = Nothing + , _relatedInformation = Nothing + } diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs new file mode 100644 index 0000000000..2381286c95 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.Cabal.LicenseSuggest +( licenseErrorSuggestion +, licenseErrorAction + -- * Re-exports +, T.Text +, Diagnostic(..) +) +where + +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as T +import Language.LSP.Types (CodeAction (CodeAction), + CodeActionKind (CodeActionQuickFix), + Diagnostic (..), List (List), + Position (Position), Range (Range), + TextEdit (TextEdit), Uri, + WorkspaceEdit (WorkspaceEdit)) +import Text.Regex.TDFA + +-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiagnostic', +-- if it represents an "Unknown SPDX license identifier"-error along +-- with a suggestion, then return a 'CodeAction' for replacing the +-- the incorrect license identifier with the suggestion. +licenseErrorAction + :: Uri + -- ^ File for which the diagnostic was generated + -> Diagnostic + -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + -> Maybe CodeAction +licenseErrorAction uri diag = + mkCodeAction <$> licenseErrorSuggestion (_message diag) + where + mkCodeAction (original, suggestion) = + let + -- The Cabal parser does not output the _range_ of the incorrect license identifier, + -- only a single source code position. Consequently, in 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + -- we define the range to be from the returned position the first column of the next line. + -- Since the "replace" code action replaces this range, we need to modify the range to + -- start at the first character of the invalid license identifier. We achieve this by + -- subtracting the length of the identifier from the beginning of the range. + adjustRange (Range (Position line col) rangeTo) = + Range (Position line (col - fromIntegral (T.length original))) rangeTo + title = "Replace with " <> suggestion + -- We must also add a newline character to the replacement since the range returned by + -- 'Ide.Plugin.Cabal.Diag.errorDiagnostic' ends at the beginning of the following line. + tedit = [TextEdit (adjustRange $ _range diag) (suggestion <> "\n")] + edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing + in CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing Nothing + +-- | Given an error message returned by 'Ide.Plugin.Cabal.Diag.errorDiagnostic', +-- if it represents an "Unknown SPDX license identifier"-error along +-- with a suggestion then return the suggestion (after the "Do you mean"-text) +-- along with the incorrect identifier. +licenseErrorSuggestion + :: T.Text + -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + -> Maybe (T.Text, T.Text) + -- ^ (Original (incorrect) license identifier, suggested replacement) +licenseErrorSuggestion message = + mSuggestion message >>= \case + [original, suggestion] -> Just (original, suggestion) + _ -> Nothing + where + regex :: T.Text + regex = "Unknown SPDX license identifier: '(.*)' Do you mean (.*)\\?" + mSuggestion msg = getMatch <$> (msg :: T.Text) =~~ regex + getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [T.Text] + getMatch (_, _, _, results) = results diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs new file mode 100644 index 0000000000..28700c5104 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs @@ -0,0 +1,27 @@ +module Ide.Plugin.Cabal.Parse +( parseCabalFileContents + -- * Re-exports +, FilePath +, NonEmpty(..) +, PWarning(..) +, Version +, PError(..) +, Position(..) +, GenericPackageDescription(..) +) where + +import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty (..)) +import Distribution.Fields (PError (..), + PWarning (..)) +import Distribution.Fields.ParseResult (runParseResult) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.Parsec.Position (Position (..)) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..)) +import Distribution.Types.Version (Version) + +parseCabalFileContents + :: BS.ByteString -- ^ UTF-8 encoded bytestring + -> IO ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription) +parseCabalFileContents bs = + pure $ runParseResult (parseGenericPackageDescription bs) diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs new file mode 100644 index 0000000000..b2db2f4315 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE NamedFieldPuns #-} +module Main + ( main + ) where + +import Control.Lens ((^.)) +import qualified Data.ByteString as BS +import Data.Either (isRight) +import Data.Function +import qualified Data.Text as Text +import Development.IDE.Types.Logger +import Ide.Plugin.Cabal +import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion) +import qualified Ide.Plugin.Cabal.Parse as Lib +import qualified Language.LSP.Types.Lens as J +import System.FilePath +import Test.Hls + + +cabalPlugin :: Recorder (WithPriority Log) -> PluginDescriptor IdeState +cabalPlugin recorder = descriptor recorder "cabal" + +main :: IO () +main = do + recorder <- initialiseRecorder True + defaultTestRunner $ + testGroup "Cabal Plugin Tests" + [ unitTests + , pluginTests recorder + ] + +-- | @initialiseRecorder silent@ +-- +-- If @'silent' == True@, then don't log anything, otherwise +-- the recorder is the standard recorder of HLS. Useful for debugging. +initialiseRecorder :: Bool -> IO (Recorder (WithPriority Log)) +initialiseRecorder True = pure mempty +initialiseRecorder False = do + docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug + + let docWithFilteredPriorityRecorder = + docWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= Debug) + pure $ docWithFilteredPriorityRecorder + & cmapWithPrio pretty + +-- ------------------------------------------------------------------------ +-- Unit Tests +-- ------------------------------------------------------------------------ + +unitTests :: TestTree +unitTests = + testGroup "Unit Tests" + [ cabalParserUnitTests, + codeActionUnitTests + ] + +cabalParserUnitTests :: TestTree +cabalParserUnitTests = testGroup "Parsing Cabal" + [ testCase "Simple Parsing works" $ do + (warnings, pm) <- Lib.parseCabalFileContents =<< BS.readFile (testDataDir "simple.cabal") + liftIO $ do + null warnings @? "Found unexpected warnings" + isRight pm @? "Failed to parse GenericPackageDescription" + ] + +codeActionUnitTests :: TestTree +codeActionUnitTests = testGroup "Code Action Tests" + [ testCase "Unknown format" $ do + -- the message has the wrong format + licenseErrorSuggestion "Unknown license identifier: 'BSD3' Do you mean BSD-3-Clause?" @?= Nothing, + + testCase "BSD-3-Clause" $ do + licenseErrorSuggestion "Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?" @?= Just ("BSD3", "BSD-3-Clause"), + + testCase "MIT" $ do + -- contains no suggestion + licenseErrorSuggestion "Unknown SPDX license identifier: 'MIT3'" @?= Nothing + ] + +-- ------------------------------------------------------------------------ +-- Integration Tests +-- ------------------------------------------------------------------------ + +pluginTests :: Recorder (WithPriority Log) -> TestTree +pluginTests recorder = testGroup "Plugin Tests" + [ testGroup "Diagnostics" + [ runCabalTestCaseSession "Publishes Diagnostics on Error" recorder "" $ do + doc <- openDoc "invalid.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] + liftIO $ do + length diags @?= 1 + unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. J.severity @?= Just DsError + , runCabalTestCaseSession "Clears diagnostics" recorder "" $ do + doc <- openDoc "invalid.cabal" "cabal" + diags <- waitForDiagnosticsFrom doc + unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] + liftIO $ do + length diags @?= 1 + unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. J.severity @?= Just DsError + _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n" + newDiags <- waitForDiagnosticsFrom doc + liftIO $ newDiags @?= [] + , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" recorder "simple-cabal" $ do + hsDoc <- openDoc "A.hs" "haskell" + expectNoMoreDiagnostics 1 hsDoc "typechecking" + cabalDoc <- openDoc "simple-cabal.cabal" "cabal" + expectNoMoreDiagnostics 1 cabalDoc "parsing" + , ignoreTestBecause "Testcase is flaky for certain GHC versions (e.g. 9.2.4). See #3333 for details." $ do + runCabalTestCaseSession "Diagnostics in .hs files from invalid .cabal file" recorder "simple-cabal" $ do + hsDoc <- openDoc "A.hs" "haskell" + expectNoMoreDiagnostics 1 hsDoc "typechecking" + cabalDoc <- openDoc "simple-cabal.cabal" "cabal" + expectNoMoreDiagnostics 1 cabalDoc "parsing" + let theRange = Range (Position 3 20) (Position 3 23) + -- Invalid license + changeDoc cabalDoc [TextDocumentContentChangeEvent (Just theRange) Nothing "MIT3"] + cabalDiags <- waitForDiagnosticsFrom cabalDoc + unknownLicenseDiag <- liftIO $ inspectDiagnostic cabalDiags ["Unknown SPDX license identifier: 'MIT3'"] + expectNoMoreDiagnostics 1 hsDoc "typechecking" + liftIO $ do + length cabalDiags @?= 1 + unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. J.severity @?= Just DsError + ] + , testGroup "Code Actions" + [ runCabalTestCaseSession "BSD-3" recorder "" $ do + doc <- openDoc "licenseCodeAction.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] + liftIO $ do + length diags @?= 1 + reduceDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) + reduceDiag ^. J.severity @?= Just DsError + [InR codeAction] <- getCodeActions doc (Range (Position 3 24) (Position 4 0)) + executeCodeAction codeAction + contents <- documentContents doc + liftIO $ contents @?= Text.unlines + [ "cabal-version: 3.0" + , "name: licenseCodeAction" + , "version: 0.1.0.0" + , "license: BSD-3-Clause" + , "" + , "library" + , " build-depends: base" + , " default-language: Haskell2010" + ] + ] + ] + +-- ------------------------------------------------------------------------ +-- Runner utils +-- ------------------------------------------------------------------------ + +runCabalTestCaseSession :: TestName -> Recorder (WithPriority Log) -> FilePath -> Session () -> TestTree +runCabalTestCaseSession title recorder subdir act = testCase title $ runCabalSession recorder subdir act + +runCabalSession :: Recorder (WithPriority Log) -> FilePath -> Session a -> IO a +runCabalSession recorder subdir = + failIfSessionTimeout . runSessionWithServer (cabalPlugin recorder) (testDataDir subdir) + +testDataDir :: FilePath +testDataDir = "test" "testdata" diff --git a/plugins/hls-cabal-plugin/test/testdata/invalid.cabal b/plugins/hls-cabal-plugin/test/testdata/invalid.cabal new file mode 100644 index 0000000000..26f9b8f2d6 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/invalid.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: invalid +version: 0.1.0.0 +license: BSD3 + +library + build-depends: base + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/licenseCodeAction.cabal b/plugins/hls-cabal-plugin/test/testdata/licenseCodeAction.cabal new file mode 100644 index 0000000000..d1bbf8b5c2 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/licenseCodeAction.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: licenseCodeAction +version: 0.1.0.0 +license: BSD3 + +library + build-depends: base + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-cabal/A.hs b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/A.hs new file mode 100644 index 0000000000..c72a91d81a --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/A.hs @@ -0,0 +1,4 @@ +module A where + +-- definitions don't matter here. +foo = 1 diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-cabal/cabal.project b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/cabal.project new file mode 100644 index 0000000000..e6fdbadb43 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-cabal/hie.yaml b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-cabal/simple-cabal.cabal b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/simple-cabal.cabal new file mode 100644 index 0000000000..48ac100d3d --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-cabal/simple-cabal.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: simple-cabal +version: 0.1.0.0 +license: MIT + +library + build-depends: base + hs-source-dirs: . + exposed-modules: A + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/simple.cabal b/plugins/hls-cabal-plugin/test/testdata/simple.cabal new file mode 100644 index 0000000000..1adb3b2795 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple.cabal @@ -0,0 +1,24 @@ +cabal-version: 3.0 +name: hls-cabal-plugin +version: 0.1.0.0 +synopsis: +homepage: +license: MIT +license-file: LICENSE +author: Fendor +maintainer: fendor@posteo.de +category: Development +extra-source-files: CHANGELOG.md + +library + exposed-modules: IDE.Plugin.Cabal + build-depends: base ^>=4.14.3.0 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite hls-cabal-plugin-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base ^>=4.14.3.0 diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index b471fa65cb..6fe2e4ef24 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -21,7 +21,9 @@ import qualified Ide.Plugin.QualifyImportedNames as QualifyImportedNames #if hls_callHierarchy import qualified Ide.Plugin.CallHierarchy as CallHierarchy #endif - +#if hls_cabal +import qualified Ide.Plugin.Cabal as Cabal +#endif #if hls_class import qualified Ide.Plugin.Class as Class #endif @@ -146,6 +148,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins pluginRecorder :: forall log. (Pretty log) => PluginId -> Recorder (WithPriority log) pluginRecorder pluginId = cmapWithPrio (Log pluginId) recorder allPlugins = +#if hls_cabal + let pId = "cabal" in Cabal.descriptor (pluginRecorder pId) pId : +#endif #if hls_pragmas Pragmas.descriptor "pragmas" : #endif diff --git a/stack-lts19.yaml b/stack-lts19.yaml index 4e33bd28f8..74d90c3361 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -9,6 +9,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench + - ./plugins/hls-cabal-plugin - ./plugins/hls-cabal-fmt-plugin - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin diff --git a/stack.yaml b/stack.yaml index ca2f39b5cf..b92448278e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,6 +9,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils - ./shake-bench +- ./plugins/hls-cabal-plugin - ./plugins/hls-cabal-fmt-plugin - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin