Disable hole fit suggestions when running Wingman

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

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

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
   }

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