From c6d45c430f4f470153a4e844bdd804bddad8315c Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 2 Mar 2024 18:20:11 +0100 Subject: [PATCH 01/10] WIP: Speed up hls-hlint-plugin-tests Move test data to temporary directory. Avoid `waitForDiagnosticsWithSource` as it unconditionally waits for diagnostics. --- ghcide/src/Development/IDE/Core/OfInterest.hs | 1 + ghcide/src/Development/IDE/Core/Shake.hs | 13 +- haskell-language-server.cabal | 2 + hls-test-utils/src/Test/Hls.hs | 24 ++ .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 31 ++- plugins/hls-hlint-plugin/test/Main.hs | 235 +++++++++++++----- 6 files changed, 229 insertions(+), 77 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 950c27bcbb..9e6896f854 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -48,6 +48,7 @@ import Ide.Logger (Pretty (pretty), logDebug) import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP +import qualified Data.Aeson as Aeson data Log = LogShake Shake.Log deriving Show diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 2791dcfc2d..a727a704b6 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1281,9 +1281,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 @@ -1291,19 +1291,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 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 3f38abe391..4b9824c29f 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -691,6 +691,8 @@ library hls-hlint-plugin , unordered-containers , ghc-lib-parser-ex , apply-refact + -- + , lsp-types if flag(ghc-lib) cpp-options: -DGHC_LIB diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 55d579acf1..6470dff904 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -57,6 +58,7 @@ module Test.Hls WithPriority(..), Recorder, Priority(..), + captureKickDiagnostics, ) where @@ -124,6 +126,9 @@ import Test.Tasty.ExpectedFailure import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun +import Language.LSP.Protocol.Lens qualified as L +import Data.Maybe (mapMaybe) +import Control.Lens ((^.)) data Log = LogIDEMain IDEMain.Log @@ -712,6 +717,17 @@ setHlsConfig config = do -- requests! skipManyTill anyMessage (void configurationRequest) +captureKickDiagnostics :: Session [Diagnostic] +captureKickDiagnostics = do + _ <- skipManyTill anyMessage nonTrivialKickStart2 + messages <- manyTill anyMessage nonTrivialKickDone2 + 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 @@ -724,9 +740,17 @@ nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null nonTrivialKickStart :: Session () nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null +nonTrivialKickDone2 :: Session () +nonTrivialKickDone2 = kick (Proxy @"kick/done/hlint") >>= guard . not . null + +nonTrivialKickStart2 :: Session () +nonTrivialKickStart2 = kick (Proxy @"kick/start/hlint") >>= 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 + diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index f88ff77f2d..cb1176709c 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -125,6 +125,11 @@ import System.Environment (setEnv, #endif import Development.IDE.Core.PluginUtils as PluginUtils import Text.Regex.TDFA.Text () +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Server as LSP +import GHC.TypeLits (KnownSymbol) +import qualified Development.IDE.Types.Options as Options + -- --------------------------------------------------------------------- data Log @@ -140,7 +145,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 @@ -189,12 +194,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 @@ -208,8 +213,16 @@ rules recorder plugin = do liftIO $ argsSettings flags action $ do - files <- getFilesOfInterestUntracked - void $ uses GetHlintDiagnostics $ Map.keys files + files <- Map.keys <$> getFilesOfInterestUntracked + Shake.ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- Shake.getShakeExtras + let signal :: KnownSymbol s => Proxy s -> Action () + signal msg = when testing $ liftIO $ Shake.mRunLspT lspEnv $ + LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ + toJSON $ map fromNormalizedFilePath files + + signal (Proxy @"kick/start/hlint") + void $ uses GetHlintDiagnostics files + signal (Proxy @"kick/done/hlint") where diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 5838b22bf3..fb53023dd9 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -18,8 +18,9 @@ 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 Test.Hls +import Test.Hls +import Test.Hls.FileSystem +import System.FilePath ((<.>)) main :: IO () main = defaultTestRunner tests @@ -86,9 +87,10 @@ applyHintTests = testGroup "hlint apply hint tests" suggestionsTests :: TestTree suggestionsTests = testGroup "hlint suggestions" [ - testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do + testCase "provides 3.8 code actions including apply all" $ runHlintSession baseProj $ do doc <- openDoc "Base.hs" "haskell" - diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint" + -- _ <- waitForTypecheck doc + diags@(reduceDiag:_) <- captureKickDiagnostics -- doc liftIO $ do length diags @?= 2 -- "Eta Reduce" and "Redundant Id" @@ -118,10 +120,10 @@ suggestionsTests = contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps def hlintPlugin noLiteralCaps testDir $ do + , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCapsInTmpDir def hlintPlugin noLiteralCaps (mkVirtualFileTree testDir baseProj) $ do doc <- openDoc "Base.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc "hlint" + _ <- captureKickDiagnostics -- doc cars <- getAllCodeActions doc etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"] @@ -131,11 +133,11 @@ suggestionsTests = contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo = id\n" - , testCase ".hlint.yaml fixity rules are applied" $ runHlintSession "fixity" $ do + , testCase ".hlint.yaml fixity rules are applied" $ runHlintSession fixityProject $ do doc <- openDoc "FixityUse.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc - , testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do + , testCase "changing document contents updates hlint diagnostics" $ runHlintSession baseProj $ do doc <- openDoc "Base.hs" "haskell" testHlintDiagnostics doc @@ -143,7 +145,8 @@ suggestionsTests = .+ #rangeLength .== Nothing .+ #text .== "x" 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 $ #range .== Range (Position 1 8) (Position 1 12) .+ #rangeLength .== Nothing @@ -152,62 +155,62 @@ suggestionsTests = changeDoc doc [change'] testHlintDiagnostics doc - , testCase "[#554] hlint diagnostics works with CPP via ghc -XCPP argument" $ runHlintSession "cpp" $ do + , testCase "[#554] hlint diagnostics works with CPP via ghc -XCPP argument" $ runHlintSession cppProj $ do doc <- openDoc "CppCond.hs" "haskell" 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 cppProjPragma $ do doc <- openDoc "CppCond.hs" "haskell" testHlintDiagnostics doc - , testCase "[#554] hlint diagnostics works with CPP via -XCPP argument and flag via #include header" $ runHlintSession "cpp" $ do + , testCase "[#554] hlint diagnostics works with CPP via -XCPP argument and flag via #include header" $ runHlintSession cppProj $ do doc <- openDoc "CppHeader.hs" "haskell" testHlintDiagnostics doc - , testCase "[#590] apply-refact works with -XLambdaCase argument" $ runHlintSession "lambdacase" $ do + , testCase "[#590] apply-refact works with -XLambdaCase argument" $ runHlintSession lambdaCaseProj $ do testRefactor "LambdaCase.hs" "Redundant bracket" expectedLambdaCase - , testCase "[#1242] apply-refact works with -XTypeApplications argument" $ runHlintSession "typeapps" $ do + , testCase "[#1242] apply-refact works with -XTypeApplications argument" $ runHlintSession typeappsProj $ do testRefactor "TypeApplication.hs" "Redundant bracket" expectedTypeApp - , testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do + , testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession lambdaCaseProjPragma $ do testRefactor "LambdaCase.hs" "Redundant bracket" ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase) - , expectFailBecause "apply-refact doesn't work with cpp" $ - testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do + , ignoreTestBecause "apply-refact doesn't work with cpp" $ + testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession cppProj $ do testRefactor "CppCond.hs" "Redundant bracket" expectedCPP - , expectFailBecause "apply-refact doesn't work with cpp" $ - testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do + , ignoreTestBecause "apply-refact doesn't work with cpp" $ + testCase "apply hints works with CPP via language pragma" $ runHlintSession cppProjPragma $ do testRefactor "CppCond.hs" "Redundant bracket" ("{-# LANGUAGE CPP #-}" : expectedCPP) - , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do + , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession ignoreProj $ do doc <- openDoc "CamelCase.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc - , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do + , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession' "IgnoreAnn.hs" $ do doc <- openDoc "IgnoreAnn.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc - , testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do + , testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession' "IgnoreAnnHlint.hs" $ do doc <- openDoc "IgnoreAnnHlint.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc - , testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do + , testCase "apply-refact preserve regular comments" $ runHlintSession' "Comments.hs" $ do testRefactor "Comments.hs" "Redundant bracket" expectedComments - , testCase "[#2290] apply all hints works with a trailing comment" $ runHlintSession "" $ do + , testCase "[#2290] apply all hints works with a trailing comment" $ runHlintSession' "TwoHintsAndComment.hs" $ do testRefactor "TwoHintsAndComment.hs" "Apply all hints" expectedComments2 - , testCase "applyAll is shown only when there is at least one diagnostic in range" $ runHlintSession "" $ do + , testCase "applyAll is shown only when there is at least one diagnostic in range" $ runHlintSession' "TwoHints.hs" $ do doc <- openDoc "TwoHints.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc "hlint" + _ <- captureKickDiagnostics -- doc firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0) secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0) @@ -221,26 +224,26 @@ suggestionsTests = liftIO $ not (hasApplyAll thirdLine) @? "Unexpected apply all code action" liftIO $ hasApplyAll multiLine @? "Missing apply all code action" - , testCase "hlint should warn about unused extensions" $ runHlintSession "unusedext" $ do + , testCase "hlint should warn about unused extensions" $ runHlintSession unusedextProj $ do doc <- openDoc "UnusedExtension.hs" "haskell" - diags@(unusedExt:_) <- waitForDiagnosticsFromSource doc "hlint" + diags@(unusedExt:_) <- captureKickDiagnostics -- doc 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' "PatternKeyword.hs" $ do doc <- openDoc "PatternKeyword.hs" "haskell" - waitForAllProgressDone + -- waitForAllProgressDone -- hlint will report a parse error if PatternSynonyms is enabled - expectNoMoreDiagnostics 3 doc "hlint" - , testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do + testNoHlintDiagnostics doc + , testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession' "StrictData.hs" $ do doc <- openDoc "StrictData.hs" "haskell" - waitForAllProgressDone + -- waitForAllProgressDone - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc ] where testRefactor file caTitle expected = do @@ -286,7 +289,7 @@ suggestionsTests = configTests :: TestTree configTests = testGroup "hlint plugin config" [ - testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do + testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession baseProj $ do setIgnoringConfigurationRequests False enableHlint @@ -295,11 +298,9 @@ configTests = testGroup "hlint plugin config" [ disableHlint - diags' <- waitForDiagnosticsFrom doc + testNoHlintDiagnostics doc - liftIO $ noHlintDiagnostics diags' - - , testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do + , testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession (baseProj <> [ copy "test-hlint-config.yaml"]) $ do setIgnoringConfigurationRequests False enableHlint @@ -309,22 +310,20 @@ 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 + , testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession generaliseProj $ do setIgnoringConfigurationRequests False enableHlint doc <- openDoc "Generalise.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc let config' = hlintConfigWithFlags ["--with-group=generalise"] setHlsConfig config' - diags' <- waitForDiagnosticsFromSource doc "hlint" + diags' <- captureKickDiagnostics -- doc d <- liftIO $ inspectDiagnostic diags' ["Use <>"] liftIO $ do @@ -336,17 +335,34 @@ configTests = testGroup "hlint plugin config" [ testDir :: FilePath testDir = "plugins/hls-hlint-plugin/test/testdata" -runHlintSession :: FilePath -> Session a -> IO a -runHlintSession subdir = failIfSessionTimeout . runSessionWithServerAndCaps def hlintPlugin codeActionNoResolveCaps (testDir subdir) +-- ------------------------------------------------------------------------ +-- Test Helpers +-- ------------------------------------------------------------------------ -noHlintDiagnostics :: [Diagnostic] -> Assertion +noHlintDiagnostics :: HasCallStack => [Diagnostic] -> Assertion noHlintDiagnostics diags = - Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" + all (not . isHlintDiagnostic) diags @? "There are hlint diagnostics" + +isHlintDiagnostic :: Diagnostic -> Bool +isHlintDiagnostic diag = + Just "hlint" == diag ^. L.source -testHlintDiagnostics :: TextDocumentIdentifier -> Session () +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 <- captureKickDiagnostics + if null diags + then captureKickNonEmptyDiagnostics doc + else pure diags + +testNoHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session () +testNoHlintDiagnostics _doc = do + diags <- captureKickDiagnostics + liftIO $ noHlintDiagnostics diags hlintConfigWithFlags :: [T.Text] -> Config hlintConfigWithFlags flags = @@ -372,7 +388,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 { @@ -395,6 +411,22 @@ makeCodeActionNotFoundAtString :: Point -> String makeCodeActionNotFoundAtString Point {..} = "CodeAction not found at line: " <> show line <> ", column: " <> show column +-- ------------------------------------------------------------------------ +-- Test runner helpers +-- ------------------------------------------------------------------------ + +runHlintSession' :: FilePath -> Session a -> IO a +runHlintSession' fp = runHlintSession (directProject fp) + +runHlintSession :: [FileTree] -> Session a -> IO a +runHlintSession tree act = failIfSessionTimeout $ + runSessionWithServerAndCapsInTmpDir + def + hlintPlugin + codeActionNoResolveCaps + (mkVirtualFileTree testDir tree) + act + ignoreHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenTest testCaseName goldenFilename point hintName = goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName) @@ -406,7 +438,7 @@ 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" + _ <- captureKickDiagnostics -- document actions <- getCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> do @@ -417,7 +449,7 @@ goldenTest testCaseName goldenFilename point hintText = setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithHaskellAndCaps def codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithHaskellAndCapsInTmpDir def codeActionNoResolveCaps hlintPlugin testName (mkVirtualFileTree testDir (directProject (path <.> "hs"))) path "expected" "hs" ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = @@ -430,7 +462,7 @@ 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" + _ <- captureKickDiagnostics -- document actions <- getAndResolveCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> executeCodeAction codeAction @@ -438,4 +470,85 @@ goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path = - goldenWithHaskellAndCaps def codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithHaskellAndCapsInTmpDir def codeActionResolveCaps hlintPlugin testName (mkVirtualFileTree testDir (directProject (path <.> "hs"))) path "expected" "hs" + +-- ------------------------------------------------------------------------ +-- Test project setups +-- ------------------------------------------------------------------------ + +baseProj :: [FileTree] +baseProj = directProject "Base.hs" + +generaliseProj :: [FileTree] +generaliseProj = directProject "Generalise.hs" + +cppProj :: [FileTree] +cppProj = + [ copy "cpp/CppCond.hs" + , copy "cpp/CppHeader.hs" + , copy "cpp/test.h" + , directCradle + [ "-XCPP" + , "-DFLAG" + , "CppCond" + , "CppHeader" + ] + ] + +cppProjPragma :: [FileTree] +cppProjPragma = + [ copy "CppCond.hs" + , directCradle + [ "-DFLAG" + , "CppCond" + ] + ] + +lambdaCaseProj :: [FileTree] +lambdaCaseProj = + [ copy "lambdacase/LambdaCase.hs" + , directCradle + [ "LambdaCase" + , "-XLambdaCase" + ] + ] + +lambdaCaseProjPragma :: [FileTree] +lambdaCaseProjPragma = directProject "LambdaCase.hs" + +typeappsProj :: [FileTree] +typeappsProj = + [ copy "typeapps/TypeApplication.hs" + , directCradle + [ "TypeApplication" + , "-XTypeApplications" + ] + ] + +ignoreProj :: [FileTree] +ignoreProj = + [ copy "ignore/CamelCase.hs" + , copy "ignore/.hlint.yaml" + , directCradle + [ "CamelCase" + ] + ] + +fixityProject :: [FileTree] +fixityProject = + [ copy "fixity/FixityDef.hs" + , copy "fixity/FixityUse.hs" + , copy "fixity/.hlint.yaml" + , directCradle + [ "FixityDef" + , "FixityUse" + ] + ] + +unusedextProj :: [FileTree] +unusedextProj = + [ copy "unusedext/UnusedExtension.hs" + , directCradle + [ "UnusedExtension" + ] + ] From 30ec1967388f4d8c1cfdc97260a5a4e0456b0db0 Mon Sep 17 00:00:00 2001 From: komikat Date: Wed, 26 Jun 2024 21:40:45 +0530 Subject: [PATCH 02/10] use captureKickdiagnostics for cabal plugin --- haskell-language-server.cabal | 1 + hls-test-utils/src/Test/Hls.hs | 23 +++++------- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 13 ++++++- plugins/hls-cabal-plugin/test/Main.hs | 18 ++++++---- plugins/hls-cabal-plugin/test/Utils.hs | 12 +++++++ .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 8 ++--- plugins/hls-hlint-plugin/test/Main.hs | 35 ++++++++++++------- 7 files changed, 72 insertions(+), 38 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 4b9824c29f..931ccf9701 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -232,6 +232,7 @@ library hls-cabal-plugin build-depends: + , aeson , base >=4.12 && <5 , bytestring , Cabal-syntax >= 3.7 diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 6470dff904..1be9d50e8a 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -4,7 +4,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedStrings #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -59,6 +58,7 @@ module Test.Hls Recorder, Priority(..), captureKickDiagnostics, + kick ) where @@ -66,6 +66,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) @@ -77,7 +78,7 @@ import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.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 @@ -104,6 +105,7 @@ import Ide.Logger (Doc, Logger (Logger), (<+>)) import Ide.Types import Language.LSP.Protocol.Capabilities +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Test @@ -126,9 +128,6 @@ import Test.Tasty.ExpectedFailure import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun -import Language.LSP.Protocol.Lens qualified as L -import Data.Maybe (mapMaybe) -import Control.Lens ((^.)) data Log = LogIDEMain IDEMain.Log @@ -717,10 +716,10 @@ setHlsConfig config = do -- requests! skipManyTill anyMessage (void configurationRequest) -captureKickDiagnostics :: Session [Diagnostic] -captureKickDiagnostics = do - _ <- skipManyTill anyMessage nonTrivialKickStart2 - messages <- manyTill anyMessage nonTrivialKickDone2 +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] @@ -740,12 +739,6 @@ nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null nonTrivialKickStart :: Session () nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null -nonTrivialKickDone2 :: Session () -nonTrivialKickDone2 = kick (Proxy @"kick/done/hlint") >>= guard . not . null - -nonTrivialKickStart2 :: Session () -nonTrivialKickStart2 = kick (Proxy @"kick/start/hlint") >>= guard . not . null - kick :: KnownSymbol k => Proxy k -> Session [FilePath] kick proxyMsg = do diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 7126dc14b1..7f3c168055 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -5,7 +5,6 @@ {-# LANGUAGE TypeFamilies #-} module Ide.Plugin.Cabal (descriptor, Log (..)) where - import Control.Concurrent.STM import Control.Concurrent.Strict import Control.DeepSeq @@ -14,6 +13,7 @@ import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (runMaybeT) +import Data.Aeson.Types (ToJSON (..)) import qualified Data.ByteString as BS import Data.Hashable import Data.HashMap.Strict (HashMap) @@ -27,7 +27,9 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (alwaysRerun) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import qualified Development.IDE.Types.Options as Options import GHC.Generics +import GHC.TypeLits (KnownSymbol) import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes import qualified Ide.Plugin.Cabal.Completion.Completions as Completions import qualified Ide.Plugin.Cabal.Completion.Types as Types @@ -36,9 +38,11 @@ import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest import qualified Ide.Plugin.Cabal.Parse as Parse import Ide.Types import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Message import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types import Language.LSP.Server (getVirtualFile) +import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS data Log @@ -187,7 +191,14 @@ function invocation. kick :: Action () kick = do files <- HashMap.keys <$> getCabalFilesOfInterestUntracked + Shake.ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- Shake.getShakeExtras + let signal :: KnownSymbol s => Proxy s -> Action () + signal msg = when testing $ liftIO $ Shake.mRunLspT lspEnv $ + LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ + toJSON $ map fromNormalizedFilePath files + signal (Proxy @"kick/start/cabal") void $ uses Types.GetCabalDiagnostics files + signal(Proxy @"kick/done/cabal") -- ---------------------------------------------------------------- -- Code Actions diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 3af77d269b..57c67a3c0d 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -72,6 +72,7 @@ codeActionUnitTests = @?= [("MiT", "MIT"), ("MiT", "MIT-0")] ] + -- ------------------------ ------------------------------------------------ -- Integration Tests -- ------------------------------------------------------------------------ @@ -83,8 +84,9 @@ pluginTests = [ testGroup "Diagnostics" [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do - doc <- openDoc "invalid.cabal" "cabal" - diags <- waitForDiagnosticsFromSource doc "cabal" + _ <- openDoc "invalid.cabal" "cabal" + -- diags <- waitForDiagnosticsFromSource doc "cabal" + diags <- cabalCaptureKick unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do length diags @?= 1 @@ -92,14 +94,16 @@ pluginTests = unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error , runCabalTestCaseSession "Clears diagnostics" "" $ do doc <- openDoc "invalid.cabal" "cabal" - diags <- waitForDiagnosticsFrom doc + -- 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 <- waitForDiagnosticsFrom doc + newDiags <- cabalCaptureKick liftIO $ newDiags @?= [] , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do hsDoc <- openDoc "A.hs" "haskell" @@ -137,7 +141,8 @@ pluginTests = "Code Actions" [ runCabalTestCaseSession "BSD-3" "" $ do doc <- openDoc "licenseCodeAction.cabal" "cabal" - diags <- waitForDiagnosticsFromSource doc "cabal" + -- diags <- waitForDiagnosticsFromSource doc "cabal" + diags <- cabalCaptureKick reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do length diags @?= 1 @@ -160,7 +165,8 @@ pluginTests = ] , runCabalTestCaseSession "Apache-2.0" "" $ do doc <- openDoc "licenseCodeAction2.cabal" "cabal" - diags <- waitForDiagnosticsFromSource doc "cabal" + -- diags <- waitForDiagnosticsFromSource doc "cabal" + diags <- cabalCaptureKick -- test if it supports typos in license name, here 'apahe' reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"] liftIO $ do diff --git a/plugins/hls-cabal-plugin/test/Utils.hs b/plugins/hls-cabal-plugin/test/Utils.hs index cd83ba623e..2a65c828de 100644 --- a/plugins/hls-cabal-plugin/test/Utils.hs +++ b/plugins/hls-cabal-plugin/test/Utils.hs @@ -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 @@ -49,6 +52,15 @@ runCabalSession subdir = testDataDir :: FilePath testDataDir = "plugins" "hls-cabal-plugin" "test" "testdata" +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 diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index cb1176709c..3e7667e75a 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -124,11 +124,11 @@ import System.Environment (setEnv, unsetEnv) #endif import Development.IDE.Core.PluginUtils as PluginUtils +import qualified Development.IDE.Types.Options as Options +import GHC.TypeLits (KnownSymbol) +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Server as LSP import Text.Regex.TDFA.Text () -import qualified Language.LSP.Protocol.Message as LSP -import qualified Language.LSP.Server as LSP -import GHC.TypeLits (KnownSymbol) -import qualified Development.IDE.Types.Options as Options -- --------------------------------------------------------------------- diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index fb53023dd9..56c160e275 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -6,21 +7,22 @@ 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 Data.Row ((.+), (.==)) 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 Test.Hls +import System.FilePath ((<.>)) +import Test.Hls import Test.Hls.FileSystem -import System.FilePath ((<.>)) main :: IO () main = defaultTestRunner tests @@ -90,7 +92,7 @@ suggestionsTests = testCase "provides 3.8 code actions including apply all" $ runHlintSession baseProj $ do doc <- openDoc "Base.hs" "haskell" -- _ <- waitForTypecheck doc - diags@(reduceDiag:_) <- captureKickDiagnostics -- doc + diags@(reduceDiag:_) <- hlintCaptureKick -- doc liftIO $ do length diags @?= 2 -- "Eta Reduce" and "Redundant Id" @@ -123,7 +125,7 @@ suggestionsTests = , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCapsInTmpDir def hlintPlugin noLiteralCaps (mkVirtualFileTree testDir baseProj) $ do doc <- openDoc "Base.hs" "haskell" - _ <- captureKickDiagnostics -- doc + _ <- hlintCaptureKick -- doc cars <- getAllCodeActions doc etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"] @@ -210,7 +212,7 @@ suggestionsTests = , testCase "applyAll is shown only when there is at least one diagnostic in range" $ runHlintSession' "TwoHints.hs" $ do doc <- openDoc "TwoHints.hs" "haskell" - _ <- captureKickDiagnostics -- doc + _ <- hlintCaptureKick -- doc firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0) secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0) @@ -226,7 +228,7 @@ suggestionsTests = , testCase "hlint should warn about unused extensions" $ runHlintSession unusedextProj $ do doc <- openDoc "UnusedExtension.hs" "haskell" - diags@(unusedExt:_) <- captureKickDiagnostics -- doc + diags@(unusedExt:_) <- hlintCaptureKick -- doc liftIO $ do length diags @?= 1 @@ -323,7 +325,7 @@ configTests = testGroup "hlint plugin config" [ let config' = hlintConfigWithFlags ["--with-group=generalise"] setHlsConfig config' - diags' <- captureKickDiagnostics -- doc + diags' <- hlintCaptureKick -- doc d <- liftIO $ inspectDiagnostic diags' ["Use <>"] liftIO $ do @@ -339,6 +341,15 @@ testDir = "plugins/hls-hlint-plugin/test/testdata" -- Test Helpers -- ------------------------------------------------------------------------ +hlintKickDone :: Session () +hlintKickDone = kick (Proxy @"kick/done/hlint") >>= guard . not . null + +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" @@ -354,14 +365,14 @@ testHlintDiagnostics doc = do captureKickNonEmptyDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session [Diagnostic] captureKickNonEmptyDiagnostics doc = do - diags <- captureKickDiagnostics + diags <- hlintCaptureKick if null diags then captureKickNonEmptyDiagnostics doc else pure diags testNoHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session () testNoHlintDiagnostics _doc = do - diags <- captureKickDiagnostics + diags <- hlintCaptureKick liftIO $ noHlintDiagnostics diags hlintConfigWithFlags :: [T.Text] -> Config @@ -438,7 +449,7 @@ applyHintGoldenTest testCaseName goldenFilename point hintName = do goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenTest testCaseName goldenFilename point hintText = setupGoldenHlintTest testCaseName goldenFilename $ \document -> do - _ <- captureKickDiagnostics -- document + _ <- hlintCaptureKick -- document actions <- getCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> do @@ -462,7 +473,7 @@ applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do - _ <- captureKickDiagnostics -- document + _ <- hlintCaptureKick -- document actions <- getAndResolveCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> executeCodeAction codeAction From 1446c192ace056e87722d7b7d055953da2251e65 Mon Sep 17 00:00:00 2001 From: komikat Date: Wed, 10 Jul 2024 06:37:37 +0530 Subject: [PATCH 03/10] fix hlint-plugin resolve tests --- hls-test-utils/src/Test/Hls.hs | 6 +++--- plugins/hls-hlint-plugin/test/Main.hs | 21 ++++++++------------- 2 files changed, 11 insertions(+), 16 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 4a0bea93ad..2ca477d896 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -235,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 diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index aba16bbbc2..63f456227e 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -452,7 +452,7 @@ applyHintGoldenTest testCaseName goldenFilename point hintName = do goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenTest testCaseName goldenFilename point hintText = - setupGoldenHlintTest testCaseName goldenFilename $ \document -> do + setupGoldenHlintTest testCaseName goldenFilename codeActionNoResolveCaps $ \document -> do _ <- hlintCaptureKick -- document actions <- getCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of @@ -463,16 +463,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 = @@ -484,13 +483,9 @@ applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenResolveTest testCaseName goldenFilename point hintText = - setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do + setupGoldenHlintTest testCaseName goldenFilename codeActionResolveCaps $ \document -> do _ <- hlintCaptureKick -- document 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 = - goldenWithHaskellAndCapsInTmpDir def codeActionResolveCaps hlintPlugin testName (mkVirtualFileTree testDir (directProject (path <.> "hs"))) path "expected" "hs" From be84fed82411db779d7d752b9cd7b28c820a7308 Mon Sep 17 00:00:00 2001 From: komikat Date: Wed, 10 Jul 2024 16:20:12 +0530 Subject: [PATCH 04/10] haskell-stylish fix --- ghcide/src/Development/IDE/Core/OfInterest.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 4c658fae36..2a594c1021 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -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 @@ -49,7 +50,6 @@ import Ide.Logger (Pretty (pretty), logWith) import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP -import qualified Data.Aeson as Aeson data Log = LogShake Shake.Log deriving Show From 266e791143886f480613dcf0b3dcbbe86f40f8aa Mon Sep 17 00:00:00 2001 From: komikat Date: Wed, 10 Jul 2024 21:28:02 +0530 Subject: [PATCH 05/10] fix unused imports --- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index fac00ed1a1..8d42f62ba4 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -46,10 +46,8 @@ import Ide.Plugin.Cabal.Orphans () import qualified Ide.Plugin.Cabal.Parse as Parse import Ide.Types import qualified Language.LSP.Protocol.Lens as JL -import Language.LSP.Protocol.Message import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types -import Language.LSP.Server (getVirtualFile) import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS From 2bcbbbbace767fc7306fa034de96d6779b26d3a0 Mon Sep 17 00:00:00 2001 From: komikat Date: Wed, 10 Jul 2024 21:28:02 +0530 Subject: [PATCH 06/10] fix unused imports, unused defs --- plugins/hls-hlint-plugin/test/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 63f456227e..6dbbbc1e71 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -237,7 +237,7 @@ suggestionsTests = liftIO $ hasApplyAll multiLine @? "Missing apply all code action" , testCase "hlint should warn about unused extensions" $ runHlintSession "unusedext" $ do - doc <- openDoc "UnusedExtension.hs" "haskell" + _ <- openDoc "UnusedExtension.hs" "haskell" diags@(unusedExt:_) <- hlintCaptureKick -- doc liftIO $ do From 3311461514206df2a07e8de95e6923ebe1b63982 Mon Sep 17 00:00:00 2001 From: komikat Date: Fri, 19 Jul 2024 21:18:48 +0530 Subject: [PATCH 07/10] resolve conflicts with master with refactor kickSignal --- ghcide/src/Development/IDE/Core/Shake.hs | 15 ++++++++++++- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 11 ++-------- plugins/hls-cabal-plugin/test/Main.hs | 3 --- plugins/hls-cabal-plugin/test/Utils.hs | 3 +++ .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 9 ++------ plugins/hls-hlint-plugin/test/Main.hs | 22 +++++++------------ 6 files changed, 29 insertions(+), 34 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index ce463b12bd..36bd44efb4 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -73,7 +73,8 @@ module Development.IDE.Core.Shake( garbageCollectDirtyKeysOlderThan, Log(..), VFSModified(..), getClientConfigAction, - ThreadQueue(..) + ThreadQueue(..), + kickSignal ) where import Control.Concurrent.Async @@ -123,6 +124,9 @@ import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes +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, @@ -152,6 +156,7 @@ 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 @@ -1443,3 +1448,11 @@ 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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 24bdfe6be0..b25fbbc8ee 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -13,7 +13,6 @@ import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (runMaybeT) -import Data.Aeson.Types (ToJSON (..)) import qualified Data.ByteString as BS import Data.Hashable import Data.HashMap.Strict (HashMap) @@ -34,7 +33,6 @@ import Development.IDE.Types.Shake (toKey) import qualified Distribution.Fields as Syntax import qualified Distribution.Parsec.Position as Syntax import GHC.Generics -import GHC.TypeLits (KnownSymbol) import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes import qualified Ide.Plugin.Cabal.Completion.Completions as Completions import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections), @@ -50,7 +48,6 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as JL import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types -import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS data Log @@ -235,13 +232,9 @@ kick :: Action () kick = do files <- HashMap.keys <$> getCabalFilesOfInterestUntracked Shake.ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- Shake.getShakeExtras - let signal :: KnownSymbol s => Proxy s -> Action () - signal msg = when testing $ liftIO $ Shake.mRunLspT lspEnv $ - LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ - toJSON $ map fromNormalizedFilePath files - signal (Proxy @"kick/start/cabal") + Shake.kickSignal testing lspEnv files (Proxy @"kick/start/cabal") void $ uses Types.ParseCabalFile files - signal(Proxy @"kick/done/cabal") + Shake.kickSignal testing lspEnv files (Proxy @"kick/done/cabal") -- ---------------------------------------------------------------- -- Code Actions diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index c921f654fa..51b1f357f5 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -96,7 +96,6 @@ pluginTests = "Diagnostics" [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do _ <- openDoc "invalid.cabal" "cabal" - -- diags <- waitForDiagnosticsFromSource doc "cabal" diags <- cabalCaptureKick unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do @@ -105,7 +104,6 @@ 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 @@ -113,7 +111,6 @@ pluginTests = 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 diff --git a/plugins/hls-cabal-plugin/test/Utils.hs b/plugins/hls-cabal-plugin/test/Utils.hs index f66ae34034..bcafa01fac 100644 --- a/plugins/hls-cabal-plugin/test/Utils.hs +++ b/plugins/hls-cabal-plugin/test/Utils.hs @@ -55,6 +55,9 @@ 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 diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 17fa1090f1..3207ea842f 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -209,14 +209,9 @@ rules recorder plugin = do action $ do files <- Map.keys <$> getFilesOfInterestUntracked Shake.ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- Shake.getShakeExtras - let signal :: KnownSymbol s => Proxy s -> Action () - signal msg = when testing $ liftIO $ Shake.mRunLspT lspEnv $ - LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ - toJSON $ map fromNormalizedFilePath files - - signal (Proxy @"kick/start/hlint") + Shake.kickSignal testing lspEnv files (Proxy @"kick/start/hlint") void $ uses GetHlintDiagnostics files - signal (Proxy @"kick/done/hlint") + Shake.kickSignal testing lspEnv files (Proxy @"kick/done/hlint") where diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 6dbbbc1e71..5db5d485a4 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -90,8 +90,7 @@ suggestionsTests = testGroup "hlint suggestions" [ testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do doc <- openDoc "Base.hs" "haskell" - -- _ <- waitForTypecheck doc - diags@(reduceDiag:_) <- hlintCaptureKick -- doc + diags@(reduceDiag:_) <- hlintCaptureKick liftIO $ do length diags @?= 2 -- "Eta Reduce" and "Redundant Id" @@ -129,7 +128,7 @@ suggestionsTests = , testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" - _ <- hlintCaptureKick -- doc + _ <- hlintCaptureKick cars <- getAllCodeActions doc etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"] @@ -222,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" - _ <- hlintCaptureKick -- doc + _ <- hlintCaptureKick firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0) secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0) @@ -238,7 +237,7 @@ suggestionsTests = , testCase "hlint should warn about unused extensions" $ runHlintSession "unusedext" $ do _ <- openDoc "UnusedExtension.hs" "haskell" - diags@(unusedExt:_) <- hlintCaptureKick -- doc + diags@(unusedExt:_) <- hlintCaptureKick liftIO $ do length diags @?= 1 @@ -246,15 +245,10 @@ suggestionsTests = , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do doc <- openDoc "PatternKeyword.hs" "haskell" - - -- waitForAllProgressDone -- hlint will report a parse error if PatternSynonyms is enabled testNoHlintDiagnostics doc , testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do doc <- openDoc "StrictData.hs" "haskell" - - -- waitForAllProgressDone - testNoHlintDiagnostics doc ] where @@ -335,7 +329,7 @@ configTests = testGroup "hlint plugin config" [ let config' = hlintConfigWithFlags ["--with-group=generalise"] setHlsConfig config' - diags' <- hlintCaptureKick -- doc + diags' <- hlintCaptureKick d <- liftIO $ inspectDiagnostic diags' ["Use <>"] liftIO $ do @@ -453,7 +447,7 @@ applyHintGoldenTest testCaseName goldenFilename point hintName = do goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenTest testCaseName goldenFilename point hintText = setupGoldenHlintTest testCaseName goldenFilename codeActionNoResolveCaps $ \document -> do - _ <- hlintCaptureKick -- document + _ <- hlintCaptureKick actions <- getCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> do @@ -471,7 +465,7 @@ setupGoldenHlintTest testName path config = , testPluginDescriptor = hlintPlugin , testDirLocation = Right tree } testName tree path "expected" "hs" - where tree = (mkVirtualFileTree testDir (directProject (path <.> "hs"))) + where tree = mkVirtualFileTree testDir (directProject (path <.> "hs")) ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = @@ -484,7 +478,7 @@ applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintTest testCaseName goldenFilename codeActionResolveCaps $ \document -> do - _ <- hlintCaptureKick -- document + _ <- hlintCaptureKick actions <- getAndResolveCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> executeCodeAction codeAction From 674908de5f1a55d1f82f9db75b0a027ae4cb5d59 Mon Sep 17 00:00:00 2001 From: komikat Date: Fri, 19 Jul 2024 21:22:22 +0530 Subject: [PATCH 08/10] remove redundant imports --- haskell-language-server.cabal | 1 - plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 1 - 2 files changed, 2 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 6157c5aba4..ef2eff4cc2 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -249,7 +249,6 @@ library hls-cabal-plugin build-depends: - , aeson , base >=4.12 && <5 , bytestring , Cabal-syntax >= 3.7 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index b25fbbc8ee..62ffeae8ed 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -27,7 +27,6 @@ import Development.IDE.Core.Shake (restartShakeSessio import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (Key, alwaysRerun) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide -import qualified Development.IDE.Plugin.Completions.Types as Ghcide import qualified Development.IDE.Types.Options as Options import Development.IDE.Types.Shake (toKey) import qualified Distribution.Fields as Syntax From 85c13dcc39b0a722fc0ef09e44be884b78b8b49a Mon Sep 17 00:00:00 2001 From: komikat Date: Fri, 19 Jul 2024 21:27:22 +0530 Subject: [PATCH 09/10] remove more redundant imports --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 3207ea842f..d2fdaf52bd 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -119,9 +119,6 @@ import System.Environment (setEnv, #endif import Development.IDE.Core.PluginUtils as PluginUtils import qualified Development.IDE.Types.Options as Options -import GHC.TypeLits (KnownSymbol) -import qualified Language.LSP.Protocol.Message as LSP -import qualified Language.LSP.Server as LSP import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- From faec0ab2de7eddd6120243a571961aff423f3e6a Mon Sep 17 00:00:00 2001 From: komikat Date: Thu, 1 Aug 2024 20:29:40 +0530 Subject: [PATCH 10/10] refactor kicks to use runWithsignal --- ghcide/src/Development/IDE/Core/Shake.hs | 13 ++++++++++--- haskell-language-server.cabal | 1 - plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 6 +----- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 7 +------ 4 files changed, 12 insertions(+), 15 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 36bd44efb4..e37c3741c7 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -74,7 +74,7 @@ module Development.IDE.Core.Shake( Log(..), VFSModified(..), getClientConfigAction, ThreadQueue(..), - kickSignal + runWithSignal ) where import Control.Concurrent.Async @@ -124,6 +124,7 @@ 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 @@ -151,7 +152,6 @@ 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 @@ -170,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) @@ -1456,3 +1455,11 @@ kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [Norm 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 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index ef2eff4cc2..b183ea5fa7 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -714,7 +714,6 @@ library hls-hlint-plugin , hlint >= 3.5 && < 3.9 , hls-plugin-api == 2.9.0.1 , lens - , lsp , mtl , refact , regex-tdfa diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 62ffeae8ed..bb274938f8 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -27,7 +27,6 @@ import Development.IDE.Core.Shake (restartShakeSessio import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (Key, alwaysRerun) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide -import qualified Development.IDE.Types.Options as Options import Development.IDE.Types.Shake (toKey) import qualified Distribution.Fields as Syntax import qualified Distribution.Parsec.Position as Syntax @@ -230,10 +229,7 @@ function invocation. kick :: Action () kick = do files <- HashMap.keys <$> getCabalFilesOfInterestUntracked - Shake.ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- Shake.getShakeExtras - Shake.kickSignal testing lspEnv files (Proxy @"kick/start/cabal") - void $ uses Types.ParseCabalFile files - Shake.kickSignal testing lspEnv files (Proxy @"kick/done/cabal") + Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile -- ---------------------------------------------------------------- -- Code Actions diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index d2fdaf52bd..23a5683c29 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -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)) @@ -118,7 +117,6 @@ import System.Environment (setEnv, unsetEnv) #endif import Development.IDE.Core.PluginUtils as PluginUtils -import qualified Development.IDE.Types.Options as Options import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -205,10 +203,7 @@ rules recorder plugin = do action $ do files <- Map.keys <$> getFilesOfInterestUntracked - Shake.ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- Shake.getShakeExtras - Shake.kickSignal testing lspEnv files (Proxy @"kick/start/hlint") - void $ uses GetHlintDiagnostics files - Shake.kickSignal testing lspEnv files (Proxy @"kick/done/hlint") + Shake.runWithSignal (Proxy @"kick/start/hlint") (Proxy @"kick/done/hlint") files GetHlintDiagnostics where