haskell-language-server-2.10.0.0: plugins/hls-cabal-plugin/test/Main.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (
main,
) where
import CabalAdd (cabalAddTests)
import Completer (completerTests)
import Context (contextTests)
import Control.Lens ((^.))
import Control.Lens.Fold ((^?))
import Control.Monad (guard)
import qualified Data.ByteString as BS
import Data.Either (isRight)
import Data.List.Extra (nubOrdOn)
import qualified Data.Maybe as Maybe
import qualified Data.Text as T
import Definition (gotoDefinitionTests)
import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion)
import qualified Ide.Plugin.Cabal.Parse as Lib
import qualified Language.LSP.Protocol.Lens as L
import Outline (outlineTests)
import System.FilePath
import Test.Hls
import Utils
main :: IO ()
main = do
defaultTestRunner $
testGroup
"Cabal Plugin Tests"
[ unitTests
, pluginTests
, completerTests
, contextTests
, outlineTests
, codeActionTests
, gotoDefinitionTests
, hoverTests
]
-- ------------------------------------------------------------------------
-- 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 maxCompletions "Unknown license identifier: 'BSD3' Do you mean BSD-3-Clause?" @?= []
, testCase "BSD-3-Clause" $ do
take 2 (licenseErrorSuggestion maxCompletions "Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?")
@?=
-- Cabal-syntax 3.12.0.0 added bunch of new licenses, so now more licenses match "BSD3" pattern
#if MIN_VERSION_Cabal_syntax(3,12,0)
[("BSD3", "BSD-4.3RENO"), ("BSD3", "BSD-3-Clause")]
#else
[("BSD3", "BSD-3-Clause"), ("BSD3", "BSD-3-Clause-LBNL")]
#endif
, testCase "MiT" $ do
-- contains no suggestion
take 2 (licenseErrorSuggestion maxCompletions "Unknown SPDX license identifier: 'MiT'")
@?= [("MiT", "MIT"), ("MiT", "MIT-0")]
]
where
maxCompletions = 100
-- ------------------------ ------------------------------------------------
-- Integration Tests
-- ------------------------------------------------------------------------
pluginTests :: TestTree
pluginTests =
testGroup
"Plugin Tests"
[ testGroup
"Diagnostics"
[ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do
_ <- openDoc "invalid.cabal" "cabal"
diags <- cabalCaptureKick
unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]
liftIO $ do
length diags @?= 1
unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)
unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error
, runCabalTestCaseSession "Publishes Diagnostics on unsupported cabal version as Warning" "" $ do
_ <- openDoc "unsupportedVersion.cabal" "cabal"
diags <- cabalCaptureKick
unknownVersionDiag <- liftIO $ inspectDiagnosticAny diags ["Unsupported cabal-version 99999.0", "Unsupported cabal format version in cabal-version field: 99999.0"]
liftIO $ do
length diags @?= 1
unknownVersionDiag ^. L.range @?= Range (Position 0 0) (Position 1 0)
unknownVersionDiag ^. L.severity @?= Just DiagnosticSeverity_Warning
, runCabalTestCaseSession "Clears diagnostics" "" $ do
doc <- openDoc "invalid.cabal" "cabal"
diags <- cabalCaptureKick
unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]
liftIO $ do
length diags @?= 1
unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)
unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error
_ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n"
newDiags <- cabalCaptureKick
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"
, 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 $
InL TextDocumentContentChangePartial
{ _range = theRange
, _rangeLength = Nothing
, _text = "MIT3"
}
]
cabalDiags <- waitForDiagnosticsFrom cabalDoc
unknownLicenseDiag <- liftIO $ inspectDiagnostic cabalDiags ["Unknown SPDX license identifier: 'MIT3'"]
expectNoMoreDiagnostics 1 hsDoc "typechecking"
liftIO $ do
length cabalDiags @?= 1
unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)
unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error
]
]
-- ----------------------------------------------------------------------------
-- Code Action Tests
-- ----------------------------------------------------------------------------
codeActionTests :: TestTree
codeActionTests = 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 ^. L.range @?= Range (Position 3 24) (Position 4 0)
reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error
[codeAction] <- getLicenseAction "BSD-3-Clause" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0))
executeCodeAction codeAction
contents <- documentContents doc
liftIO $
contents
@?= T.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 ^. L.range @?= Range (Position 3 25) (Position 4 0)
reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error
[codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0))
executeCodeAction codeAction
contents <- documentContents doc
liftIO $
contents
@?= T.unlines
[ "cabal-version: 3.0"
, "name: licenseCodeAction2"
, "version: 0.1.0.0"
, "license: Apache-2.0"
, ""
, "library"
, " build-depends: base"
, " default-language: Haskell2010"
]
, runCabalGoldenSession "Code Actions - Can fix field names" "code-actions" "FieldSuggestions" $ \doc -> do
_ <- waitForDiagnosticsFrom doc
cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions doc
-- Filter out the code actions we want to invoke.
-- We only want to invoke Code Actions with certain titles, and
-- we want to invoke them only once, not once for each cursor request.
-- 'getAllCodeActions' iterates over each cursor position and requests code actions.
let selectedCas = nubOrdOn (^. L.title) $ filter
(\ca -> (ca ^. L.title) `elem`
[ "Replace with license"
, "Replace with build-type"
, "Replace with extra-doc-files"
, "Replace with ghc-options"
, "Replace with location"
, "Replace with default-language"
, "Replace with import"
, "Replace with build-depends"
, "Replace with main-is"
, "Replace with hs-source-dirs"
]) cas
mapM_ executeCodeAction selectedCas
pure ()
, cabalAddTests
]
where
getLicenseAction :: T.Text -> [Command |? CodeAction] -> [CodeAction]
getLicenseAction license codeActions = do
InR action@CodeAction{_title} <- codeActions
guard (_title == "Replace with " <> license)
pure action
-- ----------------------------------------------------------------------------
-- Hover Tests
-- ----------------------------------------------------------------------------
hoverTests :: TestTree
hoverTests = testGroup "Hover"
[ hoverOnDependencyTests
]
hoverOnDependencyTests :: TestTree
hoverOnDependencyTests = testGroup "Hover Dependency"
[ hoverContainsTest "base with separated version" "hover-deps.cabal" (Position 6 25) "[Documentation](https://hackage.haskell.org/package/base)"
, hoverContainsTest "aeson with not separated version " "hover-deps.cabal" (Position 7 25) "[Documentation](https://hackage.haskell.org/package/aeson)"
, hoverContainsTest "lens no version" "hover-deps.cabal" (Position 7 42) "[Documentation](https://hackage.haskell.org/package/lens)"
, hoverIsNullTest "name has no documentation" "hover-deps.cabal" (Position 1 25)
, hoverIsNullTest "exposed-modules has no documentation" "hover-deps.cabal" (Position 5 25)
, hoverIsNullTest "hs-source-dirs has no documentation" "hover-deps.cabal" (Position 8 25)
]
where
hoverContainsTest :: TestName -> FilePath -> Position -> T.Text -> TestTree
hoverContainsTest testName cabalFile pos containedText =
runCabalTestCaseSession testName "hover" $ do
doc <- openDoc cabalFile "cabal"
h <- getHover doc pos
case h of
Nothing -> liftIO $ assertFailure "No hover"
Just (Hover contents _) -> case contents of
InL (MarkupContent _ txt) -> do
liftIO
$ assertBool ("Failed to find `" <> T.unpack containedText <> "` in hover message: " <> T.unpack txt)
$ containedText `T.isInfixOf` txt
_ -> liftIO $ assertFailure "Unexpected content type"
closeDoc doc
hoverIsNullTest :: TestName -> FilePath -> Position -> TestTree
hoverIsNullTest testName cabalFile pos =
runCabalTestCaseSession testName "hover" $ do
doc <- openDoc cabalFile "cabal"
h <- getHover doc pos
liftIO $ assertBool ("Found hover `" <> show h <> "`") $ Maybe.isNothing h
closeDoc doc