diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index b2785cf7bc..05e06b7d64 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -10,6 +10,7 @@ module Test.Hls.Util ( codeActionSupportCaps , expectCodeAction + , dontExpectCodeAction , expectDiagnostic , expectNoMoreDiagnostics , expectSameLocations @@ -45,6 +46,7 @@ import Control.Lens ((^.)) import Control.Monad import Control.Monad.IO.Class import qualified Data.Aeson as A +import Data.Bool (bool) import Data.Default import Data.List (intercalate) import Data.List.Extra (find) @@ -315,6 +317,10 @@ fromCommand _ = error "Not a command" onMatch :: [a] -> (a -> Bool) -> String -> IO a onMatch as predicate err = maybe (fail err) return (find predicate as) +noMatch :: [a] -> (a -> Bool) -> String -> IO () +noMatch [] _ _ = pure () +noMatch as predicate err = bool (pure ()) (fail err) (any predicate as) + inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.message)) s) err where err = "expected diagnostic matching '" ++ show s ++ "' but did not find one" @@ -331,6 +337,14 @@ inspectCodeAction cars s = fromAction <$> onMatch cars predicate err expectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO () expectCodeAction cars s = void $ inspectCodeAction cars s +dontExpectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO () +dontExpectCodeAction cars s = + noMatch cars predicate err + where predicate (InR ca) = all (`T.isInfixOf` (ca ^. L.title)) s + predicate _ = False + err = "didn't expected code action matching '" ++ show s ++ "' but found one anyway" + + inspectCommand :: [Command |? CodeAction] -> [T.Text] -> IO Command inspectCommand cars s = fromCommand <$> onMatch cars predicate err where predicate (InL command) = all (`T.isInfixOf` (command ^. L.title)) s diff --git a/plugins/hls-tactics-plugin/README.md b/plugins/hls-tactics-plugin/README.md index 8ef702b956..6f4171196c 100644 --- a/plugins/hls-tactics-plugin/README.md +++ b/plugins/hls-tactics-plugin/README.md @@ -34,6 +34,17 @@ fill hole" code action, *et voila!* [hls]: https://github.com/haskell/haskell-language-server/releases +## Usage + +When enabled, Wingman for Haskell will remove HLS support for hole-fit code +actions. These code actions are provided by GHC and make typechecking extremely +slow in the presence of typed holes. Because Wingman relies so heavily on typed +holes, these features are in great tension. + +The solution: we just remove the hole-fit actions. If you'd prefer to use these +actions, you can get them back by compiling HLS without the Wingman plugin. + + ## Editor Configuration ### Enabling Jump to Hole diff --git a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs index 868a040570..635fa463a5 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs @@ -19,9 +19,17 @@ staticPlugin :: DynFlagsModifications staticPlugin = mempty { dynFlagsModifyGlobal = \df -> allowEmptyCaseButWithWarning + $ flip gopt_unset Opt_SortBySubsumHoleFits + $ flip gopt_unset Opt_ShowValidHoleFits $ df + { refLevelHoleFits = Just 0 + , maxRefHoleFits = Just 0 + , maxValidHoleFits = Just 0 +#if __GLASGOW_HASKELL__ >= 808 + , staticPlugins = staticPlugins df <> [metaprogrammingPlugin] +#endif + } #if __GLASGOW_HASKELL__ >= 808 - { staticPlugins = staticPlugins df <> [metaprogrammingPlugin] } , dynFlagsModifyParser = enableQuasiQuotes #endif } diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index f598cf5ddd..85264583ff 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -9,6 +9,7 @@ import Control.Monad import Data.Aeson import qualified Data.HashMap.Strict as HM import Data.List +import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import Ide.Plugin.Config @@ -397,10 +398,12 @@ redundantImportTests = testGroup "redundant import code actions" [ ] ] + typedHoleTests :: TestTree typedHoleTests = testGroup "typed hole code actions" [ testCase "works" $ runSession hlsCommand fullCaps "test/testdata" $ do + disableWingman doc <- openDoc "TypedHoles.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" cas <- getAllCodeActions doc @@ -419,8 +422,19 @@ typedHoleTests = testGroup "typed hole code actions" [ , "foo x = maxBound" ] + , expectFailIfGhc9 "The wingman plugin doesn't yet compile in GHC9" $ + testCase "doesn't work when wingman is active" $ + runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "TypedHoles.hs" "haskell" + _ <- waitForDiagnosticsFromSource doc "typecheck" + cas <- getAllCodeActions doc + liftIO $ do + dontExpectCodeAction cas ["replace _ with minBound"] + dontExpectCodeAction cas ["replace _ with foo _"] + , testCase "shows more suggestions" $ runSession hlsCommand fullCaps "test/testdata" $ do + disableWingman doc <- openDoc "TypedHoles2.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" cas <- getAllCodeActions doc @@ -442,6 +456,17 @@ typedHoleTests = testGroup "typed hole code actions" [ , " where" , " stuff (A a) = A (a + 1)" ] + + , expectFailIfGhc9 "The wingman plugin doesn't yet compile in GHC9" $ + testCase "doesnt show more suggestions when wingman is active" $ + runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "TypedHoles2.hs" "haskell" + _ <- waitForDiagnosticsFromSource doc "typecheck" + cas <- getAllCodeActions doc + + liftIO $ do + dontExpectCodeAction cas ["replace _ with foo2 _"] + dontExpectCodeAction cas ["replace _ with A _"] ] signatureTests :: TestTree @@ -522,6 +547,23 @@ unusedTermTests = testGroup "unused term code actions" [ all (Just CodeActionRefactorInline ==) kinds @? "All CodeActionRefactorInline" ] +expectFailIfGhc9 :: String -> TestTree -> TestTree +expectFailIfGhc9 reason = + case ghcVersion of + GHC90 -> expectFailBecause reason + _ -> id + +disableWingman :: Session () +disableWingman = + sendConfigurationChanged $ def + { plugins = M.fromList [ ("tactics", def { plcGlobalOn = False }) ] + } + + +sendConfigurationChanged :: Config -> Session () +sendConfigurationChanged config = + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + noLiteralCaps :: C.ClientCapabilities noLiteralCaps = def { C._textDocument = Just textDocumentCaps } where