From 190218eb781fffb463a4766769f3fc375b3fffdf Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 28 May 2021 10:24:54 -0700 Subject: [PATCH 01/13] Disable hole fit suggestions for EXTREME SPEED --- plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs index 868a040570..03140cfeef 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs @@ -19,9 +19,16 @@ staticPlugin :: DynFlagsModifications staticPlugin = mempty { dynFlagsModifyGlobal = \df -> allowEmptyCaseButWithWarning + $ flip gopt_unset Opt_SortBySubsumHoleFits $ 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 } From 0f6251c4db19bb7210d0e58c8f686547a65bf8dc Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 28 May 2021 11:50:52 -0700 Subject: [PATCH 02/13] Note the new behavior in the README --- plugins/hls-tactics-plugin/README.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/plugins/hls-tactics-plugin/README.md b/plugins/hls-tactics-plugin/README.md index b8102a952a..08035c3411 100644 --- a/plugins/hls-tactics-plugin/README.md +++ b/plugins/hls-tactics-plugin/README.md @@ -34,6 +34,19 @@ 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. They are mostly subsumed by +Wingman, and usually make extremely unhelpful suggestions, such as `replace _ +with id _`. If you'd prefer to use these actions, you can get them back by +disabling Wingman. + + ## Editor Configuration ### Enabling Jump to Hole From 180b29c4f2012fab68ae845593e65ca7ac641605 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 4 Jun 2021 15:27:25 -0700 Subject: [PATCH 03/13] Disable the tests --- test/functional/FunctionalCodeAction.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 13dd7eca67..4bf18e6a4e 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -397,8 +397,10 @@ redundantImportTests = testGroup "redundant import code actions" [ ] ] + typedHoleTests :: TestTree typedHoleTests = testGroup "typed hole code actions" [ + ignoreTestBecause "Wingman changes the result of this test and I don't know how to disable Wingman" $ testCase "works" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "TypedHoles.hs" "haskell" @@ -419,7 +421,8 @@ typedHoleTests = testGroup "typed hole code actions" [ , "foo x = maxBound" ] - , testCase "shows more suggestions" $ + , ignoreTestBecause "Wingman changes the result of this test and I don't know how to disable Wingman" $ + testCase "shows more suggestions" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "TypedHoles2.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" From c57ccf0e0d2532a0bb0613bbb5e43a0c25666183 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sat, 12 Jun 2021 10:28:17 -0700 Subject: [PATCH 04/13] Update documentation --- plugins/hls-tactics-plugin/README.md | 6 ++---- test/functional/FunctionalCodeAction.hs | 4 ++-- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/plugins/hls-tactics-plugin/README.md b/plugins/hls-tactics-plugin/README.md index 08035c3411..306ca69168 100644 --- a/plugins/hls-tactics-plugin/README.md +++ b/plugins/hls-tactics-plugin/README.md @@ -41,10 +41,8 @@ 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. They are mostly subsumed by -Wingman, and usually make extremely unhelpful suggestions, such as `replace _ -with id _`. If you'd prefer to use these actions, you can get them back by -disabling Wingman. +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 diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 4bf18e6a4e..d482abf51d 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -400,7 +400,7 @@ redundantImportTests = testGroup "redundant import code actions" [ typedHoleTests :: TestTree typedHoleTests = testGroup "typed hole code actions" [ - ignoreTestBecause "Wingman changes the result of this test and I don't know how to disable Wingman" $ + ignoreTestBecause "Wingman changes the result of this test when enabled" $ testCase "works" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "TypedHoles.hs" "haskell" @@ -421,7 +421,7 @@ typedHoleTests = testGroup "typed hole code actions" [ , "foo x = maxBound" ] - , ignoreTestBecause "Wingman changes the result of this test and I don't know how to disable Wingman" $ + , ignoreTestBecause "Wingman changes the result of this test when enabled" $ testCase "shows more suggestions" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "TypedHoles2.hs" "haskell" From efe14bcaadde04cfdf1c4517aafd46d636438033 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 20 Jul 2021 09:45:21 -0700 Subject: [PATCH 05/13] Fix tests properly --- test/functional/FunctionalCodeAction.hs | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 551f1fb7cc..f7ea929e00 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 @@ -400,9 +401,9 @@ redundantImportTests = testGroup "redundant import code actions" [ typedHoleTests :: TestTree typedHoleTests = testGroup "typed hole code actions" [ - ignoreTestBecause "Wingman changes the result of this test when enabled" $ testCase "works" $ runSession hlsCommand fullCaps "test/testdata" $ do + disableWingman doc <- openDoc "TypedHoles.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" cas <- getAllCodeActions doc @@ -421,9 +422,9 @@ typedHoleTests = testGroup "typed hole code actions" [ , "foo x = maxBound" ] - , ignoreTestBecause "Wingman changes the result of this test when enabled" $ - testCase "shows more suggestions" $ + , testCase "shows more suggestions" $ runSession hlsCommand fullCaps "test/testdata" $ do + disableWingman doc <- openDoc "TypedHoles2.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" cas <- getAllCodeActions doc @@ -525,6 +526,17 @@ unusedTermTests = testGroup "unused term code actions" [ all (Just CodeActionRefactorInline ==) kinds @? "All CodeActionRefactorInline" ] +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 From 73c55f8f6dadd1949c96a76d112c013bab7fd995 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 20 Jul 2021 22:44:46 -0700 Subject: [PATCH 06/13] Tests that code actions don't appear when Wingman is enabled --- hls-test-utils/src/Test/Hls/Util.hs | 14 ++++++++++++++ test/functional/FunctionalCodeAction.hs | 19 +++++++++++++++++++ 2 files changed, 33 insertions(+) diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index b2785cf7bc..60b916a1ff 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 = "expected code action matching '" ++ show s ++ "' but did not find one" + + 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/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index f7ea929e00..ddc0b314bc 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -422,6 +422,15 @@ typedHoleTests = testGroup "typed hole code actions" [ , "foo x = maxBound" ] + , 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 @@ -446,6 +455,16 @@ typedHoleTests = testGroup "typed hole code actions" [ , " where" , " stuff (A a) = A (a + 1)" ] + + , 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 From 940c535ab957c82b8ac3d1121f46304116079774 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 20 Jul 2021 22:48:49 -0700 Subject: [PATCH 07/13] Unset dynflags rather than change their values --- plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs index 03140cfeef..b2600906a1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs @@ -20,15 +20,11 @@ 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 + { staticPlugins = staticPlugins df <> [metaprogrammingPlugin] } -#if __GLASGOW_HASKELL__ >= 808 , dynFlagsModifyParser = enableQuasiQuotes #endif } From a5746ffbaca2ce68697d2dc491eb0a9e7135ff6f Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 20 Jul 2021 23:39:05 -0700 Subject: [PATCH 08/13] Fix error message --- hls-test-utils/src/Test/Hls/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 60b916a1ff..05e06b7d64 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -342,7 +342,7 @@ dontExpectCodeAction cars s = noMatch cars predicate err where predicate (InR ca) = all (`T.isInfixOf` (ca ^. L.title)) s predicate _ = False - err = "expected code action matching '" ++ show s ++ "' but did not find one" + err = "didn't expected code action matching '" ++ show s ++ "' but found one anyway" inspectCommand :: [Command |? CodeAction] -> [T.Text] -> IO Command From 97a8a4dcc2af1a5199f50d3e12839c1a32ddc048 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 22 Jul 2021 17:40:00 -0700 Subject: [PATCH 09/13] Revert "Unset dynflags rather than change their values" This reverts commit 940c535ab957c82b8ac3d1121f46304116079774. --- plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs index b2600906a1..03140cfeef 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs @@ -20,11 +20,15 @@ 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] + , staticPlugins = staticPlugins df <> [metaprogrammingPlugin] +#endif } +#if __GLASGOW_HASKELL__ >= 808 , dynFlagsModifyParser = enableQuasiQuotes #endif } From d35de9443c0efa62044d32fd7e91b05d3879d9f3 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 22 Jul 2021 22:35:05 -0700 Subject: [PATCH 10/13] Maybe try unsetting it too? --- plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs index 03140cfeef..635fa463a5 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs @@ -20,6 +20,7 @@ staticPlugin = mempty { dynFlagsModifyGlobal = \df -> allowEmptyCaseButWithWarning $ flip gopt_unset Opt_SortBySubsumHoleFits + $ flip gopt_unset Opt_ShowValidHoleFits $ df { refLevelHoleFits = Just 0 , maxRefHoleFits = Just 0 From 6c5b8356a37de4f6b65da2c90fbde41a126c7ff6 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 22 Jul 2021 22:45:09 -0700 Subject: [PATCH 11/13] Maybe this will elucidate the error --- hls-test-utils/src/Test/Hls/Util.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 05e06b7d64..dd97cc242c 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -317,9 +317,9 @@ 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 :: Show a => [a] -> (a -> Bool) -> String -> IO () noMatch [] _ _ = pure () -noMatch as predicate err = bool (pure ()) (fail err) (any predicate as) +noMatch as predicate err = bool (pure ()) (fail $ (show as) <> err) (any predicate as) inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.message)) s) err From 010cce208eedaad7a0e37ed30fec2d0e280b6782 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 23 Jul 2021 00:07:17 -0700 Subject: [PATCH 12/13] Disable tests on GHC9 because tactics doesn't build on GHC9 --- test/functional/FunctionalCodeAction.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index ddc0b314bc..85264583ff 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -422,7 +422,8 @@ typedHoleTests = testGroup "typed hole code actions" [ , "foo x = maxBound" ] - , testCase "doesn't work when wingman is active" $ + , 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" @@ -456,7 +457,8 @@ typedHoleTests = testGroup "typed hole code actions" [ , " stuff (A a) = A (a + 1)" ] - , testCase "doesnt show more suggestions when wingman is active" $ + , 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" @@ -545,6 +547,12 @@ 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 From b381251821f348c6571c6fa55b2e2ca0245b6416 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 23 Jul 2021 00:12:02 -0700 Subject: [PATCH 13/13] Revert "Maybe this will elucidate the error" This reverts commit 6c5b8356a37de4f6b65da2c90fbde41a126c7ff6. --- hls-test-utils/src/Test/Hls/Util.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index dd97cc242c..05e06b7d64 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -317,9 +317,9 @@ fromCommand _ = error "Not a command" onMatch :: [a] -> (a -> Bool) -> String -> IO a onMatch as predicate err = maybe (fail err) return (find predicate as) -noMatch :: Show a => [a] -> (a -> Bool) -> String -> IO () +noMatch :: [a] -> (a -> Bool) -> String -> IO () noMatch [] _ _ = pure () -noMatch as predicate err = bool (pure ()) (fail $ (show as) <> err) (any predicate as) +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