mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
Using captureKicksDiagnostics to speed up multiple plugin tests (#4339)
* WIP: Speed up hls-hlint-plugin-tests Move test data to temporary directory. Avoid `waitForDiagnosticsWithSource` as it unconditionally waits for diagnostics. * use captureKickdiagnostics for cabal plugin * fix hlint-plugin resolve tests * haskell-stylish fix * fix unused imports * fix unused imports, unused defs * resolve conflicts with master with refactor kickSignal * remove redundant imports * remove more redundant imports * refactor kicks to use runWithsignal --------- Co-authored-by: Fendor <power.walross@gmail.com>
This commit is contained in:
komikat
GitHub
parent
0bf3348f0d
commit
9565d0b2d0
@ -29,6 +29,7 @@ import Development.IDE.Graph
|
||||
import Control.Concurrent.STM.Stats (atomically,
|
||||
modifyTVar')
|
||||
import Data.Aeson (toJSON)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Maybe (catMaybes)
|
||||
import Development.IDE.Core.ProgressReporting
|
||||
|
||||
@ -73,7 +73,8 @@ module Development.IDE.Core.Shake(
|
||||
garbageCollectDirtyKeysOlderThan,
|
||||
Log(..),
|
||||
VFSModified(..), getClientConfigAction,
|
||||
ThreadQueue(..)
|
||||
ThreadQueue(..),
|
||||
runWithSignal
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Async
|
||||
@ -123,6 +124,10 @@ import Development.IDE.Core.FileUtils (getModTime)
|
||||
import Development.IDE.Core.PositionMapping
|
||||
import Development.IDE.Core.ProgressReporting
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Types.Options as Options
|
||||
import qualified Language.LSP.Protocol.Message as LSP
|
||||
import qualified Language.LSP.Server as LSP
|
||||
|
||||
import Development.IDE.Core.Tracing
|
||||
import Development.IDE.Core.WorkerThread
|
||||
import Development.IDE.GHC.Compat (NameCache,
|
||||
@ -147,11 +152,11 @@ import qualified Development.IDE.Types.Exports as ExportsMap
|
||||
import Development.IDE.Types.KnownTargets
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Types.Monitoring (Monitoring (..))
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.Types.Shake
|
||||
import qualified Focus
|
||||
import GHC.Fingerprint
|
||||
import GHC.Stack (HasCallStack)
|
||||
import GHC.TypeLits (KnownSymbol)
|
||||
import HieDb.Types
|
||||
import Ide.Logger hiding (Priority)
|
||||
import qualified Ide.Logger as Logger
|
||||
@ -165,7 +170,6 @@ import qualified Language.LSP.Protocol.Lens as L
|
||||
import Language.LSP.Protocol.Message
|
||||
import Language.LSP.Protocol.Types
|
||||
import qualified Language.LSP.Protocol.Types as LSP
|
||||
import qualified Language.LSP.Server as LSP
|
||||
import Language.LSP.VFS hiding (start)
|
||||
import qualified "list-t" ListT
|
||||
import OpenTelemetry.Eventlog hiding (addEvent)
|
||||
@ -1350,9 +1354,9 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
|
||||
let uri' = filePathToUri' fp
|
||||
let delay = if null newDiags then 0.1 else 0
|
||||
registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do
|
||||
join $ mask_ $ do
|
||||
lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics
|
||||
let action = when (lastPublish /= newDiags) $ case lspEnv of
|
||||
join $ mask_ $ do
|
||||
lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics
|
||||
let action = when (lastPublish /= newDiags) $ case lspEnv of
|
||||
Nothing -> -- Print an LSP event.
|
||||
logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags)
|
||||
Just env -> LSP.runLspT env $ do
|
||||
@ -1360,19 +1364,18 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
|
||||
liftIO $ tag "key" (show k)
|
||||
LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $
|
||||
LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) newDiags
|
||||
return action
|
||||
return action
|
||||
where
|
||||
diagsFromRule :: Diagnostic -> Diagnostic
|
||||
diagsFromRule c@Diagnostic{_range}
|
||||
| coerce ideTesting = c & L.relatedInformation ?~
|
||||
[
|
||||
DiagnosticRelatedInformation
|
||||
[ DiagnosticRelatedInformation
|
||||
(Location
|
||||
(filePathToUri $ fromNormalizedFilePath fp)
|
||||
_range
|
||||
)
|
||||
(T.pack $ show k)
|
||||
]
|
||||
]
|
||||
| otherwise = c
|
||||
|
||||
|
||||
@ -1444,3 +1447,19 @@ updatePositionMappingHelper ver changes mappingForUri = snd $
|
||||
EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc)))
|
||||
zeroMapping
|
||||
(EM.insert ver (mkDelta changes, zeroMapping) mappingForUri)
|
||||
|
||||
-- | sends a signal whenever shake session is run/restarted
|
||||
-- being used in cabal and hlint plugin tests to know when its time
|
||||
-- to look for file diagnostics
|
||||
kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [NormalizedFilePath] -> Proxy s -> Action ()
|
||||
kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $
|
||||
LSP.sendNotification (LSP.SMethod_CustomMethod msg) $
|
||||
toJSON $ map fromNormalizedFilePath files
|
||||
|
||||
-- | Add kick start/done signal to rule
|
||||
runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedFilePath] -> k -> Action ()
|
||||
runWithSignal msgStart msgEnd files rule = do
|
||||
ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras
|
||||
kickSignal testing lspEnv files msgStart
|
||||
void $ uses rule files
|
||||
kickSignal testing lspEnv files msgEnd
|
||||
|
||||
@ -716,7 +716,6 @@ library hls-hlint-plugin
|
||||
, hlint >= 3.5 && < 3.9
|
||||
, hls-plugin-api == 2.9.0.1
|
||||
, lens
|
||||
, lsp
|
||||
, mtl
|
||||
, refact
|
||||
, regex-tdfa
|
||||
@ -727,6 +726,8 @@ library hls-hlint-plugin
|
||||
, unordered-containers
|
||||
, ghc-lib-parser-ex
|
||||
, apply-refact
|
||||
--
|
||||
, lsp-types
|
||||
|
||||
if flag(ghc-lib)
|
||||
cpp-options: -DGHC_LIB
|
||||
|
||||
@ -61,7 +61,9 @@ module Test.Hls
|
||||
WithPriority(..),
|
||||
Recorder,
|
||||
Priority(..),
|
||||
TestConfig(..),
|
||||
captureKickDiagnostics,
|
||||
kick,
|
||||
TestConfig(..)
|
||||
)
|
||||
where
|
||||
|
||||
@ -69,6 +71,7 @@ import Control.Applicative.Combinators
|
||||
import Control.Concurrent.Async (async, cancel, wait)
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Exception.Safe
|
||||
import Control.Lens ((^.))
|
||||
import Control.Lens.Extras (is)
|
||||
import Control.Monad (guard, unless, void)
|
||||
import Control.Monad.Extra (forM)
|
||||
@ -80,7 +83,7 @@ import qualified Data.Aeson as A
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Default (Default, def)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
@ -114,6 +117,7 @@ import Ide.PluginUtils (idePluginsToPluginDes
|
||||
pluginDescToIdePlugins)
|
||||
import Ide.Types
|
||||
import Language.LSP.Protocol.Capabilities
|
||||
import qualified Language.LSP.Protocol.Lens as L
|
||||
import Language.LSP.Protocol.Message
|
||||
import qualified Language.LSP.Protocol.Message as LSP
|
||||
import Language.LSP.Protocol.Types hiding (Null)
|
||||
@ -231,14 +235,14 @@ goldenWithTestConfig
|
||||
:: Pretty b
|
||||
=> TestConfig b
|
||||
-> TestName
|
||||
-> FilePath
|
||||
-> VirtualFileTree
|
||||
-> FilePath
|
||||
-> FilePath
|
||||
-> FilePath
|
||||
-> (TextDocumentIdentifier -> Session ())
|
||||
-> TestTree
|
||||
goldenWithTestConfig config title testDataDir path desc ext act =
|
||||
goldenGitDiff title (testDataDir </> path <.> desc <.> ext)
|
||||
goldenWithTestConfig config title tree path desc ext act =
|
||||
goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)
|
||||
$ runSessionWithTestConfig config $ const
|
||||
$ TL.encodeUtf8 . TL.fromStrict
|
||||
<$> do
|
||||
@ -869,6 +873,17 @@ setHlsConfig config = do
|
||||
-- requests!
|
||||
skipManyTill anyMessage (void configurationRequest)
|
||||
|
||||
captureKickDiagnostics :: Session () -> Session () -> Session [Diagnostic]
|
||||
captureKickDiagnostics start done = do
|
||||
_ <- skipManyTill anyMessage start
|
||||
messages <- manyTill anyMessage done
|
||||
pure $ concat $ mapMaybe diagnostics messages
|
||||
where
|
||||
diagnostics :: FromServerMessage' a -> Maybe [Diagnostic]
|
||||
diagnostics = \msg -> case msg of
|
||||
FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just (diags ^. L.params . L.diagnostics)
|
||||
_ -> Nothing
|
||||
|
||||
waitForKickDone :: Session ()
|
||||
waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone
|
||||
|
||||
@ -881,9 +896,11 @@ nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null
|
||||
nonTrivialKickStart :: Session ()
|
||||
nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null
|
||||
|
||||
|
||||
kick :: KnownSymbol k => Proxy k -> Session [FilePath]
|
||||
kick proxyMsg = do
|
||||
NotMess TNotificationMessage{_params} <- customNotification proxyMsg
|
||||
case fromJSON _params of
|
||||
Success x -> return x
|
||||
other -> error $ "Failed to parse kick/done details: " <> show other
|
||||
|
||||
|
||||
@ -231,7 +231,7 @@ function invocation.
|
||||
kick :: Action ()
|
||||
kick = do
|
||||
files <- HashMap.keys <$> getCabalFilesOfInterestUntracked
|
||||
void $ uses Types.ParseCabalFile files
|
||||
Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
-- Code Actions
|
||||
|
||||
@ -85,6 +85,7 @@ codeActionUnitTests =
|
||||
where
|
||||
maxCompletions = 100
|
||||
|
||||
|
||||
-- ------------------------ ------------------------------------------------
|
||||
-- Integration Tests
|
||||
-- ------------------------------------------------------------------------
|
||||
@ -96,8 +97,8 @@ pluginTests =
|
||||
[ testGroup
|
||||
"Diagnostics"
|
||||
[ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do
|
||||
doc <- openDoc "invalid.cabal" "cabal"
|
||||
diags <- waitForDiagnosticsFromSource doc "cabal"
|
||||
_ <- openDoc "invalid.cabal" "cabal"
|
||||
diags <- cabalCaptureKick
|
||||
unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]
|
||||
liftIO $ do
|
||||
length diags @?= 1
|
||||
@ -105,14 +106,14 @@ pluginTests =
|
||||
unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error
|
||||
, runCabalTestCaseSession "Clears diagnostics" "" $ do
|
||||
doc <- openDoc "invalid.cabal" "cabal"
|
||||
diags <- waitForDiagnosticsFrom doc
|
||||
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 <- waitForDiagnosticsFrom doc
|
||||
newDiags <- cabalCaptureKick
|
||||
liftIO $ newDiags @?= []
|
||||
, runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do
|
||||
hsDoc <- openDoc "A.hs" "haskell"
|
||||
|
||||
@ -1,9 +1,12 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Utils where
|
||||
|
||||
import Control.Monad (guard)
|
||||
import Data.List (sort)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import qualified Data.Text as T
|
||||
import Ide.Plugin.Cabal (descriptor)
|
||||
import qualified Ide.Plugin.Cabal
|
||||
@ -52,6 +55,18 @@ runCabalGoldenSession title subdir fp act = goldenWithCabalDoc def cabalPlugin t
|
||||
testDataDir :: FilePath
|
||||
testDataDir = "plugins" </> "hls-cabal-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
|
||||
cabalKickDone :: Session ()
|
||||
cabalKickDone = kick (Proxy @"kick/done/cabal") >>= guard . not . null
|
||||
|
||||
cabalKickStart :: Session ()
|
||||
cabalKickStart = kick (Proxy @"kick/start/cabal") >>= guard . not . null
|
||||
|
||||
cabalCaptureKick :: Session [Diagnostic]
|
||||
cabalCaptureKick = captureKickDiagnostics cabalKickStart cabalKickDone
|
||||
|
||||
-- | list comparison where the order in the list is irrelevant
|
||||
(@?==) :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion
|
||||
(@?==) l1 l2 = sort l1 @?= sort l2
|
||||
|
||||
@ -29,7 +29,6 @@ import Control.Concurrent.STM
|
||||
import Control.DeepSeq
|
||||
import Control.Exception
|
||||
import Control.Lens ((?~), (^.))
|
||||
import Control.Monad
|
||||
import Control.Monad.Error.Class (MonadError (throwError))
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Trans.Class (MonadTrans (lift))
|
||||
@ -119,6 +118,7 @@ import System.Environment (setEnv,
|
||||
#endif
|
||||
import Development.IDE.Core.PluginUtils as PluginUtils
|
||||
import Text.Regex.TDFA.Text ()
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
data Log
|
||||
@ -134,7 +134,7 @@ instance Pretty Log where
|
||||
LogShake log -> pretty log
|
||||
LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res
|
||||
LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas
|
||||
LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts
|
||||
LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <> line <> indent 4 (pretty exts)
|
||||
LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp
|
||||
LogResolve msg -> pretty msg
|
||||
|
||||
@ -183,12 +183,12 @@ instance NFData GetHlintDiagnostics
|
||||
type instance RuleResult GetHlintDiagnostics = ()
|
||||
|
||||
-- | Hlint rules to generate file diagnostics based on hlint hints
|
||||
-- | This rule is recomputed when:
|
||||
-- | - A file has been edited via
|
||||
-- | - `getIdeas` -> `getParsedModule` in any case
|
||||
-- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc
|
||||
-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`
|
||||
-- | - The hlint specific settings have changed, via `getHlintSettingsRule`
|
||||
-- This rule is recomputed when:
|
||||
-- - A file has been edited via
|
||||
-- - `getIdeas` -> `getParsedModule` in any case
|
||||
-- - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc
|
||||
-- - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`
|
||||
-- - The hlint specific settings have changed, via `getHlintSettingsRule`
|
||||
rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
|
||||
rules recorder plugin = do
|
||||
define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do
|
||||
@ -202,8 +202,8 @@ rules recorder plugin = do
|
||||
liftIO $ argsSettings flags
|
||||
|
||||
action $ do
|
||||
files <- getFilesOfInterestUntracked
|
||||
void $ uses GetHlintDiagnostics $ Map.keys files
|
||||
files <- Map.keys <$> getFilesOfInterestUntracked
|
||||
Shake.runWithSignal (Proxy @"kick/start/hlint") (Proxy @"kick/done/hlint") files GetHlintDiagnostics
|
||||
|
||||
where
|
||||
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Main
|
||||
@ -5,19 +7,21 @@ module Main
|
||||
) where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad (when)
|
||||
import Control.Monad (guard, when)
|
||||
import Data.Aeson (Value (..), object, (.=))
|
||||
import Data.Functor (void)
|
||||
import Data.List (find)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromJust, isJust)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import qualified Data.Text as T
|
||||
import Ide.Plugin.Config (Config (..))
|
||||
import qualified Ide.Plugin.Config as Plugin
|
||||
import qualified Ide.Plugin.Hlint as HLint
|
||||
import qualified Language.LSP.Protocol.Lens as L
|
||||
import System.FilePath ((</>))
|
||||
import System.FilePath ((<.>), (</>))
|
||||
import Test.Hls
|
||||
import Test.Hls.FileSystem
|
||||
|
||||
main :: IO ()
|
||||
main = defaultTestRunner tests
|
||||
@ -86,7 +90,7 @@ suggestionsTests =
|
||||
testGroup "hlint suggestions" [
|
||||
testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do
|
||||
doc <- openDoc "Base.hs" "haskell"
|
||||
diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint"
|
||||
diags@(reduceDiag:_) <- hlintCaptureKick
|
||||
|
||||
liftIO $ do
|
||||
length diags @?= 2 -- "Eta Reduce" and "Redundant Id"
|
||||
@ -124,7 +128,7 @@ suggestionsTests =
|
||||
, testShiftRoot = True} $ const $ do
|
||||
doc <- openDoc "Base.hs" "haskell"
|
||||
|
||||
_ <- waitForDiagnosticsFromSource doc "hlint"
|
||||
_ <- hlintCaptureKick
|
||||
|
||||
cars <- getAllCodeActions doc
|
||||
etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"]
|
||||
@ -136,7 +140,7 @@ suggestionsTests =
|
||||
|
||||
, testCase ".hlint.yaml fixity rules are applied" $ runHlintSession "fixity" $ do
|
||||
doc <- openDoc "FixityUse.hs" "haskell"
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
testNoHlintDiagnostics doc
|
||||
|
||||
, testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do
|
||||
doc <- openDoc "Base.hs" "haskell"
|
||||
@ -150,7 +154,8 @@ suggestionsTests =
|
||||
}
|
||||
|
||||
changeDoc doc [change]
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
-- We need to wait until hlint has been rerun and clears the diagnostic
|
||||
[] <- waitForDiagnosticsFrom doc
|
||||
|
||||
let change' = TextDocumentContentChangeEvent $ InL
|
||||
TextDocumentContentChangePartial
|
||||
@ -166,7 +171,7 @@ suggestionsTests =
|
||||
testHlintDiagnostics doc
|
||||
|
||||
, knownBrokenForHlintOnGhcLib "hlint doesn't take in account cpp flag as ghc -D argument" $
|
||||
testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "" $ do
|
||||
testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "cpp" $ do
|
||||
doc <- openDoc "CppCond.hs" "haskell"
|
||||
testHlintDiagnostics doc
|
||||
|
||||
@ -186,27 +191,27 @@ suggestionsTests =
|
||||
testRefactor "LambdaCase.hs" "Redundant bracket"
|
||||
("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase)
|
||||
|
||||
, expectFailBecause "apply-refact doesn't work with cpp" $
|
||||
, ignoreTestBecause "apply-refact doesn't work with cpp" $
|
||||
testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do
|
||||
testRefactor "CppCond.hs" "Redundant bracket"
|
||||
expectedCPP
|
||||
|
||||
, expectFailBecause "apply-refact doesn't work with cpp" $
|
||||
, ignoreTestBecause "apply-refact doesn't work with cpp" $
|
||||
testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do
|
||||
testRefactor "CppCond.hs" "Redundant bracket"
|
||||
("{-# LANGUAGE CPP #-}" : expectedCPP)
|
||||
|
||||
, testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do
|
||||
doc <- openDoc "CamelCase.hs" "haskell"
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
testNoHlintDiagnostics doc
|
||||
|
||||
, testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do
|
||||
doc <- openDoc "IgnoreAnn.hs" "haskell"
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
testNoHlintDiagnostics doc
|
||||
|
||||
, testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do
|
||||
doc <- openDoc "IgnoreAnnHlint.hs" "haskell"
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
testNoHlintDiagnostics doc
|
||||
|
||||
, testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do
|
||||
testRefactor "Comments.hs" "Redundant bracket" expectedComments
|
||||
@ -216,7 +221,7 @@ suggestionsTests =
|
||||
|
||||
, testCase "applyAll is shown only when there is at least one diagnostic in range" $ runHlintSession "" $ do
|
||||
doc <- openDoc "TwoHints.hs" "haskell"
|
||||
_ <- waitForDiagnosticsFromSource doc "hlint"
|
||||
_ <- hlintCaptureKick
|
||||
|
||||
firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0)
|
||||
secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0)
|
||||
@ -231,22 +236,20 @@ suggestionsTests =
|
||||
liftIO $ hasApplyAll multiLine @? "Missing apply all code action"
|
||||
|
||||
, testCase "hlint should warn about unused extensions" $ runHlintSession "unusedext" $ do
|
||||
doc <- openDoc "UnusedExtension.hs" "haskell"
|
||||
diags@(unusedExt:_) <- waitForDiagnosticsFromSource doc "hlint"
|
||||
_ <- openDoc "UnusedExtension.hs" "haskell"
|
||||
diags@(unusedExt:_) <- hlintCaptureKick
|
||||
|
||||
liftIO $ do
|
||||
length diags @?= 1
|
||||
unusedExt ^. L.code @?= Just (InR "refact:Unused LANGUAGE pragma")
|
||||
|
||||
, testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do
|
||||
, testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do
|
||||
doc <- openDoc "PatternKeyword.hs" "haskell"
|
||||
|
||||
-- hlint will report a parse error if PatternSynonyms is enabled
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
testNoHlintDiagnostics doc
|
||||
, testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do
|
||||
doc <- openDoc "StrictData.hs" "haskell"
|
||||
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
testNoHlintDiagnostics doc
|
||||
]
|
||||
where
|
||||
testRefactor file caTitle expected = do
|
||||
@ -301,9 +304,7 @@ configTests = testGroup "hlint plugin config" [
|
||||
|
||||
disableHlint
|
||||
|
||||
diags' <- waitForDiagnosticsFrom doc
|
||||
|
||||
liftIO $ noHlintDiagnostics diags'
|
||||
testNoHlintDiagnostics doc
|
||||
|
||||
, testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do
|
||||
setIgnoringConfigurationRequests False
|
||||
@ -315,9 +316,7 @@ configTests = testGroup "hlint plugin config" [
|
||||
let config' = hlintConfigWithFlags ["--ignore=Redundant id", "--hint=test-hlint-config.yaml"]
|
||||
setHlsConfig config'
|
||||
|
||||
diags' <- waitForDiagnosticsFrom doc
|
||||
|
||||
liftIO $ noHlintDiagnostics diags'
|
||||
testNoHlintDiagnostics doc
|
||||
|
||||
, testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession "" $ do
|
||||
setIgnoringConfigurationRequests False
|
||||
@ -325,12 +324,12 @@ configTests = testGroup "hlint plugin config" [
|
||||
|
||||
doc <- openDoc "Generalise.hs" "haskell"
|
||||
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
testNoHlintDiagnostics doc
|
||||
|
||||
let config' = hlintConfigWithFlags ["--with-group=generalise"]
|
||||
setHlsConfig config'
|
||||
|
||||
diags' <- waitForDiagnosticsFromSource doc "hlint"
|
||||
diags' <- hlintCaptureKick
|
||||
d <- liftIO $ inspectDiagnostic diags' ["Use <>"]
|
||||
|
||||
liftIO $ do
|
||||
@ -352,14 +351,39 @@ runHlintSession subdir = failIfSessionTimeout .
|
||||
}
|
||||
. const
|
||||
|
||||
noHlintDiagnostics :: [Diagnostic] -> Assertion
|
||||
noHlintDiagnostics diags =
|
||||
Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics"
|
||||
hlintKickDone :: Session ()
|
||||
hlintKickDone = kick (Proxy @"kick/done/hlint") >>= guard . not . null
|
||||
|
||||
testHlintDiagnostics :: TextDocumentIdentifier -> Session ()
|
||||
hlintKickStart :: Session ()
|
||||
hlintKickStart = kick (Proxy @"kick/start/hlint") >>= guard . not . null
|
||||
|
||||
hlintCaptureKick :: Session [Diagnostic]
|
||||
hlintCaptureKick = captureKickDiagnostics hlintKickStart hlintKickDone
|
||||
|
||||
noHlintDiagnostics :: HasCallStack => [Diagnostic] -> Assertion
|
||||
noHlintDiagnostics diags =
|
||||
all (not . isHlintDiagnostic) diags @? "There are hlint diagnostics"
|
||||
|
||||
isHlintDiagnostic :: Diagnostic -> Bool
|
||||
isHlintDiagnostic diag =
|
||||
Just "hlint" == diag ^. L.source
|
||||
|
||||
testHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session ()
|
||||
testHlintDiagnostics doc = do
|
||||
diags <- waitForDiagnosticsFromSource doc "hlint"
|
||||
liftIO $ length diags > 0 @? "There are hlint diagnostics"
|
||||
diags <- captureKickNonEmptyDiagnostics doc
|
||||
liftIO $ length diags > 0 @? "There are no hlint diagnostics"
|
||||
|
||||
captureKickNonEmptyDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session [Diagnostic]
|
||||
captureKickNonEmptyDiagnostics doc = do
|
||||
diags <- hlintCaptureKick
|
||||
if null diags
|
||||
then captureKickNonEmptyDiagnostics doc
|
||||
else pure diags
|
||||
|
||||
testNoHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session ()
|
||||
testNoHlintDiagnostics _doc = do
|
||||
diags <- hlintCaptureKick
|
||||
liftIO $ noHlintDiagnostics diags
|
||||
|
||||
hlintConfigWithFlags :: [T.Text] -> Config
|
||||
hlintConfigWithFlags flags =
|
||||
@ -385,7 +409,7 @@ disableHlint = setHlsConfig $ def { Plugin.plugins = Map.fromList [ ("hlint", de
|
||||
-- Although a given hlint version supports one direct ghc, we could use several versions of hlint
|
||||
-- each one supporting a different ghc version. It should be a temporary situation though.
|
||||
knownBrokenForHlintOnGhcLib :: String -> TestTree -> TestTree
|
||||
knownBrokenForHlintOnGhcLib = expectFailBecause
|
||||
knownBrokenForHlintOnGhcLib = ignoreTestBecause
|
||||
|
||||
-- 1's based
|
||||
data Point = Point {
|
||||
@ -408,6 +432,10 @@ makeCodeActionNotFoundAtString :: Point -> String
|
||||
makeCodeActionNotFoundAtString Point {..} =
|
||||
"CodeAction not found at line: " <> show line <> ", column: " <> show column
|
||||
|
||||
-- ------------------------------------------------------------------------
|
||||
-- Test runner helpers
|
||||
-- ------------------------------------------------------------------------
|
||||
|
||||
ignoreHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree
|
||||
ignoreHintGoldenTest testCaseName goldenFilename point hintName =
|
||||
goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName)
|
||||
@ -418,8 +446,8 @@ applyHintGoldenTest testCaseName goldenFilename point hintName = do
|
||||
|
||||
goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree
|
||||
goldenTest testCaseName goldenFilename point hintText =
|
||||
setupGoldenHlintTest testCaseName goldenFilename $ \document -> do
|
||||
_ <- waitForDiagnosticsFromSource document "hlint"
|
||||
setupGoldenHlintTest testCaseName goldenFilename codeActionNoResolveCaps $ \document -> do
|
||||
_ <- hlintCaptureKick
|
||||
actions <- getCodeActions document $ pointToRange point
|
||||
case find ((== Just hintText) . getCodeActionTitle) actions of
|
||||
Just (InR codeAction) -> do
|
||||
@ -429,16 +457,15 @@ goldenTest testCaseName goldenFilename point hintText =
|
||||
_ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point
|
||||
|
||||
|
||||
setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
|
||||
setupGoldenHlintTest testName path =
|
||||
setupGoldenHlintTest :: TestName -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree
|
||||
setupGoldenHlintTest testName path config =
|
||||
goldenWithTestConfig def
|
||||
{ testConfigCaps = codeActionNoResolveCaps
|
||||
{ testConfigCaps = config
|
||||
, testShiftRoot = True
|
||||
, testPluginDescriptor = hlintPlugin
|
||||
, testDirLocation = Left testDir
|
||||
}
|
||||
testName testDir path "expected" "hs"
|
||||
|
||||
, testDirLocation = Right tree
|
||||
} testName tree path "expected" "hs"
|
||||
where tree = mkVirtualFileTree testDir (directProject (path <.> "hs"))
|
||||
|
||||
ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree
|
||||
ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName =
|
||||
@ -450,19 +477,9 @@ applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do
|
||||
|
||||
goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree
|
||||
goldenResolveTest testCaseName goldenFilename point hintText =
|
||||
setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do
|
||||
_ <- waitForDiagnosticsFromSource document "hlint"
|
||||
setupGoldenHlintTest testCaseName goldenFilename codeActionResolveCaps $ \document -> do
|
||||
_ <- hlintCaptureKick
|
||||
actions <- getAndResolveCodeActions document $ pointToRange point
|
||||
case find ((== Just hintText) . getCodeActionTitle) actions of
|
||||
Just (InR codeAction) -> executeCodeAction codeAction
|
||||
_ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point
|
||||
|
||||
setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
|
||||
setupGoldenHlintResolveTest testName path =
|
||||
goldenWithTestConfig def
|
||||
{ testConfigCaps = codeActionResolveCaps
|
||||
, testShiftRoot = True
|
||||
, testPluginDescriptor = hlintPlugin
|
||||
, testDirLocation = Left testDir
|
||||
}
|
||||
testName testDir path "expected" "hs"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user