diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/hls-cabal-plugin.cabal b/hls-cabal-plugin.cabal new file mode 100644 --- /dev/null +++ b/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.9 + , hashable + , hls-plugin-api ^>=1.6 + , hls-graph ^>=1.9 + , 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.5 + , lens + , lsp-types + , tasty-hunit + , text diff --git a/src/Ide/Plugin/Cabal.hs b/src/Ide/Plugin/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Cabal.hs @@ -0,0 +1,257 @@ +{-# 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 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 $ diags >>= (fmap InR . (LicenseSuggest.licenseErrorAction uri)) + +-- ---------------------------------------------------------------- +-- 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/src/Ide/Plugin/Cabal/Diagnostics.hs b/src/Ide/Plugin/Cabal/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/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/src/Ide/Plugin/Cabal/LicenseSuggest.hs b/src/Ide/Plugin/Cabal/LicenseSuggest.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Cabal/LicenseSuggest.hs @@ -0,0 +1,88 @@ +{-# 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 + +import qualified Data.List as List +import Distribution.SPDX.LicenseId (licenseId) +import qualified Text.Fuzzy.Parallel as Fuzzy + +-- | 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' + -> [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 + +-- | License name of every license supported by cabal +licenseNames :: [T.Text] +licenseNames = map (T.pack . licenseId) [minBound .. maxBound] + +-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiagnostic', +-- provide possible corrections for SPDX license identifiers +-- based on the list specified in Cabal. +-- Results are sorted by best fit, and prefer solutions that have smaller +-- length distance to the original word. +-- +-- >>> take 2 $ licenseErrorSuggestion (T.pack "Unknown SPDX license identifier: 'BSD3'") +-- [("BSD3","BSD-3-Clause"),("BSD3","BSD-3-Clause-LBNL")] +licenseErrorSuggestion :: + T.Text + -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + -> [(T.Text, T.Text)] + -- ^ (Original (incorrect) license identifier, suggested replacement) +licenseErrorSuggestion msg = + (getMatch <$> msg =~~ regex) >>= \case + [original] -> + let matches = map Fuzzy.original $ Fuzzy.simpleFilter 1000 10 original licenseNames + in [(original,candidate) | candidate <- List.sortBy (lengthDistance original) matches] + _ -> [] + where + regex :: T.Text + regex = "Unknown SPDX license identifier: '(.*)'" + getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [T.Text] + getMatch (_, _, _, results) = results + lengthDistance original x1 x2 = abs (T.length original - T.length x1) `compare` abs (T.length original - T.length x2) diff --git a/src/Ide/Plugin/Cabal/Parse.hs b/src/Ide/Plugin/Cabal/Parse.hs new file mode 100644 --- /dev/null +++ b/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/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} +module Main + ( main + ) where + +import Control.Lens ((^.)) +import Control.Monad (guard) +import qualified Data.ByteString as BS +import Data.Either (isRight) +import qualified Data.Text as Text +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 :: PluginTestDescriptor Log +cabalPlugin = mkPluginTestDescriptor descriptor "cabal" + +main :: IO () +main = do + defaultTestRunner $ + testGroup "Cabal Plugin Tests" + [ unitTests + , pluginTests + ] + +-- ------------------------------------------------------------------------ +-- 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?" @?= [], + + testCase "BSD-3-Clause" $ do + take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?") + @?= [("BSD3","BSD-3-Clause"),("BSD3","BSD-3-Clause-LBNL")], + + testCase "MiT" $ do + -- contains no suggestion + take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'MiT'") + @?= [("MiT","MIT"),("MiT","MIT-0")] + ] + +-- ------------------------------------------------------------------------ +-- Integration Tests +-- ------------------------------------------------------------------------ + +pluginTests :: TestTree +pluginTests = testGroup "Plugin Tests" + [ testGroup "Diagnostics" + [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ 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" "" $ 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" "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.5). See #3333 for details." $ do + runCabalTestCaseSession "Diagnostics in .hs files from invalid .cabal file" "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" "" $ 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 + [codeAction] <- getLicenseAction "BSD-3-Clause" <$> 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" + ] + , runCabalTestCaseSession "Apache-2.0" "" $ do + doc <- openDoc "licenseCodeAction2.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + -- test if it supports typos in license name, here 'apahe' + reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"] + liftIO $ do + length diags @?= 1 + reduceDiag ^. J.range @?= Range (Position 3 25) (Position 4 0) + reduceDiag ^. J.severity @?= Just DsError + [codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) + executeCodeAction codeAction + contents <- documentContents doc + liftIO $ contents @?= Text.unlines + [ "cabal-version: 3.0" + , "name: licenseCodeAction2" + , "version: 0.1.0.0" + , "license: Apache-2.0" + , "" + , "library" + , " build-depends: base" + , " default-language: Haskell2010" + ] + ] + ] + where + getLicenseAction :: Text.Text -> [Command |? CodeAction] -> [CodeAction] + getLicenseAction license codeActions = do + InR action@CodeAction{_title} <- codeActions + guard (_title=="Replace with " <> license) + pure action + +-- ------------------------------------------------------------------------ +-- Runner utils +-- ------------------------------------------------------------------------ + +runCabalTestCaseSession :: TestName -> FilePath -> Session () -> TestTree +runCabalTestCaseSession title subdir = testCase title . runCabalSession subdir + +runCabalSession :: FilePath -> Session a -> IO a +runCabalSession subdir = + failIfSessionTimeout . runSessionWithServer cabalPlugin (testDataDir subdir) + +testDataDir :: FilePath +testDataDir = "test" "testdata" diff --git a/test/testdata/invalid.cabal b/test/testdata/invalid.cabal new file mode 100644 --- /dev/null +++ b/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/test/testdata/licenseCodeAction.cabal b/test/testdata/licenseCodeAction.cabal new file mode 100644 --- /dev/null +++ b/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/test/testdata/licenseCodeAction2.cabal b/test/testdata/licenseCodeAction2.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/licenseCodeAction2.cabal @@ -0,0 +1,8 @@ +cabal-version: 3.0 +name: licenseCodeAction2 +version: 0.1.0.0 +license: APAHE + +library + build-depends: base + default-language: Haskell2010 diff --git a/test/testdata/simple-cabal/A.hs b/test/testdata/simple-cabal/A.hs new file mode 100644 --- /dev/null +++ b/test/testdata/simple-cabal/A.hs @@ -0,0 +1,4 @@ +module A where + +-- definitions don't matter here. +foo = 1 diff --git a/test/testdata/simple-cabal/cabal.project b/test/testdata/simple-cabal/cabal.project new file mode 100644 --- /dev/null +++ b/test/testdata/simple-cabal/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/test/testdata/simple-cabal/hie.yaml b/test/testdata/simple-cabal/hie.yaml new file mode 100644 --- /dev/null +++ b/test/testdata/simple-cabal/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/test/testdata/simple-cabal/simple-cabal.cabal b/test/testdata/simple-cabal/simple-cabal.cabal new file mode 100644 --- /dev/null +++ b/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/test/testdata/simple.cabal b/test/testdata/simple.cabal new file mode 100644 --- /dev/null +++ b/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