1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DuplicateRecordFields #-} 3{-# LANGUAGE OverloadedStrings #-} 4 5module FunctionalCodeAction (tests) where 6 7import Control.Lens hiding (List) 8import Control.Monad 9import Data.Aeson 10import qualified Data.HashMap.Strict as HM 11import Data.List 12import qualified Data.Map as M 13import Data.Maybe 14import qualified Data.Text as T 15import Ide.Plugin.Config 16import Language.LSP.Test as Test 17import qualified Language.LSP.Types.Capabilities as C 18import qualified Language.LSP.Types.Lens as L 19import Test.Hls 20import Test.Hspec.Expectations 21 22import System.FilePath ((</>)) 23import Test.Hls.Command 24 25{-# ANN module ("HLint: ignore Reduce duplication"::String) #-} 26 27tests :: TestTree 28tests = testGroup "code actions" [ 29 hlintTests 30 , importTests 31 , packageTests 32 , redundantImportTests 33 , renameTests 34 , signatureTests 35 , typedHoleTests 36 , unusedTermTests 37 ] 38 39 40hlintTests :: TestTree 41hlintTests = testGroup "hlint suggestions" [ 42 testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do 43 doc <- openDoc "ApplyRefact2.hs" "haskell" 44 diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint" 45 46 liftIO $ do 47 length diags @?= 2 -- "Eta Reduce" and "Redundant Id" 48 reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12) 49 reduceDiag ^. L.severity @?= Just DsInfo 50 reduceDiag ^. L.code @?= Just (InR "refact:Eta reduce") 51 reduceDiag ^. L.source @?= Just "hlint" 52 53 cas <- map fromAction <$> getAllCodeActions doc 54 55 let applyAll = find (\ca -> "Apply all hints" `T.isSuffixOf` (ca ^. L.title)) cas 56 let redId = find (\ca -> "Redundant id" `T.isSuffixOf` (ca ^. L.title)) cas 57 let redEta = find (\ca -> "Eta reduce" `T.isSuffixOf` (ca ^. L.title)) cas 58 59 liftIO $ isJust applyAll @? "There is 'Apply all hints' code action" 60 liftIO $ isJust redId @? "There is 'Redundant id' code action" 61 liftIO $ isJust redEta @? "There is 'Eta reduce' code action" 62 63 executeCodeAction (fromJust redId) 64 65 contents <- skipManyTill anyMessage $ getDocumentEdit doc 66 liftIO $ contents @?= "main = undefined\nfoo x = x\n" 67 68 , testCase "falls back to pre 3.8 code actions" $ runSession hlsCommand noLiteralCaps "test/testdata/hlint" $ do 69 doc <- openDoc "ApplyRefact2.hs" "haskell" 70 71 _ <- waitForDiagnosticsFromSource doc "hlint" 72 73 cars <- getAllCodeActions doc 74 etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"] 75 76 executeCommand etaReduce 77 78 contents <- skipManyTill anyMessage $ getDocumentEdit doc 79 liftIO $ contents @?= "main = undefined\nfoo = id\n" 80 81 , testCase "changing configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do 82 let config = def { hlintOn = True } 83 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) 84 85 doc <- openDoc "ApplyRefact2.hs" "haskell" 86 testHlintDiagnostics doc 87 88 let config' = def { hlintOn = False } 89 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) 90 91 diags' <- waitForDiagnosticsFrom doc 92 93 liftIO $ noHlintDiagnostics diags' 94 95 , testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do 96 doc <- openDoc "ApplyRefact2.hs" "haskell" 97 testHlintDiagnostics doc 98 99 let change = TextDocumentContentChangeEvent 100 (Just (Range (Position 1 8) (Position 1 12))) 101 Nothing "x" 102 changeDoc doc [change] 103 expectNoMoreDiagnostics 3 doc "hlint" 104 105 let change' = TextDocumentContentChangeEvent 106 (Just (Range (Position 1 8) (Position 1 12))) 107 Nothing "id x" 108 changeDoc doc [change'] 109 testHlintDiagnostics doc 110 111 , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $ 112 testCase "hlint diagnostics works with CPP via ghc -XCPP argument (#554)" $ runHlintSession "cpp" $ do 113 doc <- openDoc "ApplyRefact3.hs" "haskell" 114 testHlintDiagnostics doc 115 116 , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $ 117 testCase "hlint diagnostics works with CPP via language pragma (#554)" $ runHlintSession "" $ do 118 doc <- openDoc "ApplyRefact3.hs" "haskell" 119 testHlintDiagnostics doc 120 121 , testCase "hlint diagnostics works with CPP via -XCPP argument and flag via #include header (#554)" $ runHlintSession "cpp" $ do 122 doc <- openDoc "ApplyRefact2.hs" "haskell" 123 testHlintDiagnostics doc 124 125 , testCase "apply-refact works with -XLambdaCase argument (#590)" $ runHlintSession "lambdacase" $ do 126 testRefactor "ApplyRefact1.hs" "Redundant bracket" 127 expectedLambdaCase 128 129 , testCase "apply-refact works with -XTypeApplications argument (#1242)" $ runHlintSession "typeapps" $ do 130 testRefactor "ApplyRefact1.hs" "Redundant bracket" 131 expectedTypeApp 132 133 , testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do 134 testRefactor "ApplyRefact1.hs" "Redundant bracket" 135 ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase) 136 137 , expectFailBecause "apply-refact doesn't work with cpp" $ 138 testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do 139 testRefactor "ApplyRefact3.hs" "Redundant bracket" 140 expectedCPP 141 142 , expectFailBecause "apply-refact doesn't work with cpp" $ 143 testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do 144 testRefactor "ApplyRefact3.hs" "Redundant bracket" 145 ("{-# LANGUAGE CPP #-}" : expectedCPP) 146 147 , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do 148 doc <- openDoc "ApplyRefact.hs" "haskell" 149 expectNoMoreDiagnostics 3 doc "hlint" 150 151 , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do 152 doc <- openDoc "ApplyRefact4.hs" "haskell" 153 expectNoMoreDiagnostics 3 doc "hlint" 154 155 , knownBrokenForGhcVersions [GHC810, GHC90] "hlint plugin doesn't honour HLINT annotations (#838)" $ 156 testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do 157 doc <- openDoc "ApplyRefact5.hs" "haskell" 158 expectNoMoreDiagnostics 3 doc "hlint" 159 160 , testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do 161 testRefactor "ApplyRefact6.hs" "Redundant bracket" expectedComments 162 163 , testCase "applyAll is shown only when there is at least one diagnostic in range" $ runHlintSession "" $ do 164 doc <- openDoc "ApplyRefact8.hs" "haskell" 165 _ <- waitForDiagnosticsFromSource doc "hlint" 166 167 firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0) 168 secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0) 169 thirdLine <- map fromAction <$> getCodeActions doc (mkRange 2 0 2 0) 170 multiLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 2 0) 171 172 let hasApplyAll = isJust . find (\ca -> "Apply all hints" `T.isSuffixOf` (ca ^. L.title)) 173 174 liftIO $ hasApplyAll firstLine @? "Missing apply all code action" 175 liftIO $ hasApplyAll secondLine @? "Missing apply all code action" 176 liftIO $ not (hasApplyAll thirdLine) @? "Unexpected apply all code action" 177 liftIO $ hasApplyAll multiLine @? "Missing apply all code action" 178 ] 179 where 180 runHlintSession :: FilePath -> Session a -> IO a 181 runHlintSession subdir = 182 failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" </> subdir) 183 184 noHlintDiagnostics :: [Diagnostic] -> Assertion 185 noHlintDiagnostics diags = 186 Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" 187 188 testHlintDiagnostics doc = do 189 diags <- waitForDiagnosticsFromSource doc "hlint" 190 liftIO $ length diags > 0 @? "There are hlint diagnostics" 191 192 testRefactor file caTitle expected = do 193 doc <- openDoc file "haskell" 194 testHlintDiagnostics doc 195 196 cas <- map fromAction <$> getAllCodeActions doc 197 let ca = find (\ca -> caTitle `T.isSuffixOf` (ca ^. L.title)) cas 198 liftIO $ isJust ca @? ("There is '" ++ T.unpack caTitle ++"' code action") 199 200 executeCodeAction (fromJust ca) 201 202 contents <- skipManyTill anyMessage $ getDocumentEdit doc 203 liftIO $ contents @?= T.unlines expected 204 205 expectedLambdaCase = [ "module ApplyRefact1 where", "" 206 , "f = \\case \"true\" -> True" 207 , " _ -> False" 208 ] 209 expectedCPP = [ "module ApplyRefact3 where", "" 210 , "#ifdef FLAG" 211 , "f = 1" 212 , "#else" 213 , "g = 2" 214 , "#endif", "" 215 ] 216 expectedComments = [ "-- comment before header" 217 , "module ApplyRefact6 where", "" 218 , "{-# standalone annotation #-}", "" 219 , "-- standalone comment", "" 220 , "-- | haddock comment" 221 , "f = {- inline comment -}{- inline comment inside refactored code -} 1 -- ending comment", "" 222 , "-- final comment" 223 ] 224 expectedTypeApp = [ "module ApplyRefact1 where", "" 225 , "a = id @Int 1" 226 ] 227renameTests :: TestTree 228renameTests = testGroup "rename suggestions" [ 229 testCase "works" $ runSession hlsCommand noLiteralCaps "test/testdata" $ do 230 doc <- openDoc "CodeActionRename.hs" "haskell" 231 232 _ <- waitForDiagnosticsFromSource doc "typecheck" 233 234 cars <- getAllCodeActions doc 235 replaceButStrLn <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] 236 executeCommand replaceButStrLn 237 _ <- anyRequest 238 239 x:_ <- T.lines <$> documentContents doc 240 liftIO $ x @?= "main = putStrLn \"hello\"" 241 242 , testCase "doesn't give both documentChanges and changes" 243 $ runSession hlsCommand noLiteralCaps "test/testdata" $ do 244 doc <- openDoc "CodeActionRename.hs" "haskell" 245 246 _ <- waitForDiagnosticsFromSource doc "typecheck" 247 248 cars <- getAllCodeActions doc 249 cmd <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] 250 let Just (List [Object args]) = cmd ^. L.arguments 251 Object editParams = args HM.! "fallbackWorkspaceEdit" 252 liftIO $ do 253 "changes" `HM.member` editParams @? "Contains changes" 254 not ("documentChanges" `HM.member` editParams) @? "Doesn't contain documentChanges" 255 256 executeCommand cmd 257 _ <- anyRequest 258 259 x1:x2:_ <- T.lines <$> documentContents doc 260 liftIO $ 261 x1 == "main = putStrLn \"hello\"" 262 || x2 == "foo = putStrLn \"world\"" 263 @? "One of the typos got fixed" 264 ] 265 266importTests :: TestTree 267importTests = testGroup "import suggestions" [ 268 testCase "works with 3.8 code action kinds" $ runSession hlsCommand fullCaps "test/testdata" $ do 269 doc <- openDoc "CodeActionImport.hs" "haskell" 270 -- No Formatting: 271 let config = def { formattingProvider = "none" } 272 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) 273 274 (diag:_) <- waitForDiagnosticsFrom doc 275 liftIO $ diag ^. L.message @?= "Variable not in scope: when :: Bool -> IO () -> IO ()" 276 277 actionsOrCommands <- getAllCodeActions doc 278 let actns = map fromAction actionsOrCommands 279 280 importControlMonad <- liftIO $ inspectCodeAction actionsOrCommands ["import Control.Monad"] 281 liftIO $ do 282 expectCodeAction actionsOrCommands ["import Control.Monad (when)"] 283 length actns >= 10 @? "There are some actions" 284 285 executeCodeAction importControlMonad 286 287 contents <- documentContents doc 288 liftIO $ contents @?= "import Control.Monad\nmain :: IO ()\nmain = when True $ putStrLn \"hello\"" 289 ] 290 291packageTests :: TestTree 292packageTests = testGroup "add package suggestions" [ 293 ignoreTestBecause "no support for adding dependent packages via code action" $ testCase "adds to .cabal files" $ do 294 flushStackEnvironment 295 runSession hlsCommand fullCaps "test/testdata/addPackageTest/cabal-exe" $ do 296 doc <- openDoc "AddPackage.hs" "haskell" 297 298 -- ignore the first empty hlint diagnostic publish 299 [_,diag:_] <- count 2 $ waitForDiagnosticsFrom doc 300 301 let prefixes = [ "Could not load module `Data.Text'" -- Windows && GHC >= 8.6 302 , "Could not find module `Data.Text'" -- Windows 303 , "Could not load module ‘Data.Text’" -- GHC >= 8.6 304 , "Could not find module ‘Data.Text’" 305 ] 306 in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Contains prefix" 307 308 acts <- getAllCodeActions doc 309 let (InR action:_) = acts 310 311 liftIO $ do 312 action ^. L.title @?= "Add text as a dependency" 313 action ^. L.kind @?= Just CodeActionQuickFix 314 "package:add" `T.isSuffixOf` (action ^. L.command . _Just . L.command) @? "Command contains package:add" 315 316 executeCodeAction action 317 318 contents <- skipManyTill anyMessage $ getDocumentEdit . TextDocumentIdentifier =<< getDocUri "add-package-test.cabal" 319 liftIO $ 320 any (\l -> "text -any" `T.isSuffixOf` l || "text : {} -any" `T.isSuffixOf` l) (T.lines contents) @? "Contains text package" 321 322 , ignoreTestBecause "no support for adding dependent packages via code action" $ testCase "adds to hpack package.yaml files" $ 323 runSession hlsCommand fullCaps "test/testdata/addPackageTest/hpack-exe" $ do 324 doc <- openDoc "app/Asdf.hs" "haskell" 325 326 -- ignore the first empty hlint diagnostic publish 327 [_,_:diag:_] <- count 2 $ waitForDiagnosticsFrom doc 328 329 let prefixes = [ "Could not load module `Codec.Compression.GZip'" -- Windows && GHC >= 8.6 330 , "Could not find module `Codec.Compression.GZip'" -- Windows 331 , "Could not load module ‘Codec.Compression.GZip’" -- GHC >= 8.6 332 , "Could not find module ‘Codec.Compression.GZip’" 333 ] 334 in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Diagnostic contains message" 335 336 mActions <- getAllCodeActions doc 337 let allActions = map fromAction mActions 338 action = head allActions 339 340 liftIO $ do 341 action ^. L.title @?= "Add zlib as a dependency" 342 forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionQuickFix 343 forM_ allActions $ \a -> "package:add" `T.isSuffixOf` (a ^. L.command . _Just . L.command) @? "Command contains package:add" 344 345 executeCodeAction action 346 347 contents <- skipManyTill anyMessage $ getDocumentEdit . TextDocumentIdentifier =<< getDocUri "package.yaml" 348 liftIO $ do 349 "zlib" `T.isSuffixOf` (T.lines contents !! 3) @? "Contains zlib" 350 "zlib" `T.isSuffixOf` (T.lines contents !! 21) @? "Does not contain zlib in unrelated component" 351 ] 352 353redundantImportTests :: TestTree 354redundantImportTests = testGroup "redundant import code actions" [ 355 testCase "remove solitary redundant imports" $ 356 runSession hlsCommand fullCaps "test/testdata/redundantImportTest/" $ do 357 doc <- openDoc "src/CodeActionRedundant.hs" "haskell" 358 359 diags <- waitForDiagnosticsFromSource doc "typecheck" 360 liftIO $ expectDiagnostic diags ["The import of", "Data.List", "is redundant"] 361 362 mActions <- getAllCodeActions doc 363 364 let allActions = map fromAction mActions 365 actionTitles = map (view L.title) allActions 366 367 liftIO $ actionTitles `shouldContain` ["Remove import", "Remove all redundant imports"] 368 369 let Just removeAction = find (\x -> x ^. L.title == "Remove import") allActions 370 371 liftIO $ do 372 forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionQuickFix 373 forM_ allActions $ \a -> a ^. L.command @?= Nothing 374 forM_ allActions $ \a -> isJust (a ^. L.edit) @? "Has edit" 375 376 executeCodeAction removeAction 377 378 -- No command/applyworkspaceedit should be here, since action 379 -- provides workspace edit property which skips round trip to 380 -- the server 381 contents <- documentContents doc 382 liftIO $ contents @?= "{-# OPTIONS_GHC -Wunused-imports #-}\nmodule CodeActionRedundant where\nmain :: IO ()\nmain = putStrLn \"hello\"\n" 383 384 , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do 385 doc <- openDoc "src/MultipleImports.hs" "haskell" 386 _ <- waitForDiagnosticsFromSource doc "typecheck" 387 cas <- getAllCodeActions doc 388 cmd <- liftIO $ inspectCommand cas ["redundant import"] 389 executeCommand cmd 390 _ <- anyRequest 391 contents <- documentContents doc 392 liftIO $ T.lines contents @?= 393 [ "{-# OPTIONS_GHC -Wunused-imports #-}" 394 , "module MultipleImports where" 395 , "import Data.Maybe" 396 , "foo :: Int" 397 , "foo = fromJust (Just 3)" 398 ] 399 ] 400 401 402typedHoleTests :: TestTree 403typedHoleTests = testGroup "typed hole code actions" [ 404 testCase "works" $ 405 runSession hlsCommand fullCaps "test/testdata" $ do 406 disableWingman 407 doc <- openDoc "TypedHoles.hs" "haskell" 408 _ <- waitForDiagnosticsFromSource doc "typecheck" 409 cas <- getAllCodeActions doc 410 liftIO $ do 411 expectCodeAction cas ["replace _ with minBound"] 412 expectCodeAction cas ["replace _ with foo _"] 413 replaceWithMaxBound <- liftIO $ inspectCodeAction cas ["replace _ with maxBound"] 414 415 executeCodeAction replaceWithMaxBound 416 417 contents <- documentContents doc 418 419 liftIO $ contents @?= T.concat 420 [ "module TypedHoles where\n" 421 , "foo :: [Int] -> Int\n" 422 , "foo x = maxBound" 423 ] 424 425 , expectFailIfGhc9 "The wingman plugin doesn't yet compile in GHC9" $ 426 testCase "doesn't work when wingman is active" $ 427 runSession hlsCommand fullCaps "test/testdata" $ do 428 doc <- openDoc "TypedHoles.hs" "haskell" 429 _ <- waitForDiagnosticsFromSource doc "typecheck" 430 cas <- getAllCodeActions doc 431 liftIO $ do 432 dontExpectCodeAction cas ["replace _ with minBound"] 433 dontExpectCodeAction cas ["replace _ with foo _"] 434 435 , testCase "shows more suggestions" $ 436 runSession hlsCommand fullCaps "test/testdata" $ do 437 disableWingman 438 doc <- openDoc "TypedHoles2.hs" "haskell" 439 _ <- waitForDiagnosticsFromSource doc "typecheck" 440 cas <- getAllCodeActions doc 441 442 liftIO $ do 443 expectCodeAction cas ["replace _ with foo2 _"] 444 expectCodeAction cas ["replace _ with A _"] 445 replaceWithStuff <- liftIO $ inspectCodeAction cas ["replace _ with stuff _"] 446 447 executeCodeAction replaceWithStuff 448 449 contents <- documentContents doc 450 451 liftIO $ T.lines contents @?= 452 [ "module TypedHoles2 (foo2) where" 453 , "newtype A = A Int" 454 , "foo2 :: [A] -> A" 455 , "foo2 x = (stuff _)" 456 , " where" 457 , " stuff (A a) = A (a + 1)" 458 ] 459 460 , expectFailIfGhc9 "The wingman plugin doesn't yet compile in GHC9" $ 461 testCase "doesnt show more suggestions when wingman is active" $ 462 runSession hlsCommand fullCaps "test/testdata" $ do 463 doc <- openDoc "TypedHoles2.hs" "haskell" 464 _ <- waitForDiagnosticsFromSource doc "typecheck" 465 cas <- getAllCodeActions doc 466 467 liftIO $ do 468 dontExpectCodeAction cas ["replace _ with foo2 _"] 469 dontExpectCodeAction cas ["replace _ with A _"] 470 ] 471 472signatureTests :: TestTree 473signatureTests = testGroup "missing top level signature code actions" [ 474 testCase "Adds top level signature" $ 475 runSession hlsCommand fullCaps "test/testdata/" $ do 476 doc <- openDoc "TopLevelSignature.hs" "haskell" 477 478 _ <- waitForDiagnosticsFromSource doc "typecheck" 479 cas <- getAllCodeActions doc 480 481 liftIO $ expectCodeAction cas ["add signature: main :: IO ()"] 482 483 replaceWithStuff <- liftIO $ inspectCodeAction cas ["add signature"] 484 executeCodeAction replaceWithStuff 485 486 contents <- documentContents doc 487 488 let expected = [ "{-# OPTIONS_GHC -Wall #-}" 489 , "module TopLevelSignature where" 490 , "main :: IO ()" 491 , "main = do" 492 , " putStrLn \"Hello\"" 493 , " return ()" 494 ] 495 496 liftIO $ T.lines contents @?= expected 497 ] 498 499unusedTermTests :: TestTree 500unusedTermTests = testGroup "unused term code actions" [ 501 ignoreTestBecause "no support for prefixing unused names with _" $ testCase "Prefixes with '_'" $ 502 runSession hlsCommand fullCaps "test/testdata/" $ do 503 doc <- openDoc "UnusedTerm.hs" "haskell" 504 505 _ <- waitForDiagnosticsFromSource doc "typecheck" 506 cars <- getAllCodeActions doc 507 prefixImUnused <- liftIO $ inspectCodeAction cars ["Prefix imUnused with _"] 508 509 executeCodeAction prefixImUnused 510 511 edit <- skipManyTill anyMessage $ getDocumentEdit doc 512 513 let expected = [ "{-# OPTIONS_GHC -Wall #-}" 514 , "module UnusedTerm () where" 515 , "_imUnused :: Int -> Int" 516 , "_imUnused 1 = 1" 517 , "_imUnused 2 = 2" 518 , "_imUnused _ = 3" 519 ] 520 521 liftIO $ edit @?= T.unlines expected 522 523 -- See https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#textDocument_codeAction 524 -- `CodeActionContext` 525 , testCase "respect 'only' parameter" $ runSession hlsCommand fullCaps "test/testdata" $ do 526 doc <- openDoc "CodeActionOnly.hs" "haskell" 527 _ <- waitForDiagnosticsFrom doc 528 diags <- getCurrentDiagnostics doc 529 let params = CodeActionParams Nothing Nothing doc (Range (Position 1 0) (Position 4 0)) caContext 530 caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactor])) 531 caContextAllActions = CodeActionContext (List diags) Nothing 532 -- Verify that we get code actions of at least two different kinds. 533 ResponseMessage _ _ (Right (List res)) 534 <- request STextDocumentCodeAction (params & L.context .~ caContextAllActions) 535 liftIO $ do 536 let cas = map fromAction res 537 kinds = map (^. L.kind) cas 538 nub kinds @?= [Just CodeActionRefactorInline, Just CodeActionRefactorExtract, Just CodeActionQuickFix] 539 -- Verify that that when we set the only parameter, we only get actions 540 -- of the right kind. 541 ResponseMessage _ _ (Right (List res)) <- request STextDocumentCodeAction params 542 liftIO $ do 543 let cas = map fromAction res 544 kinds = map (^. L.kind) cas 545 nub kinds @?= nub [Just CodeActionRefactorInline, Just CodeActionRefactorExtract] 546 ] 547 548expectFailIfGhc9 :: String -> TestTree -> TestTree 549expectFailIfGhc9 reason = 550 case ghcVersion of 551 GHC90 -> expectFailBecause reason 552 _ -> id 553 554disableWingman :: Session () 555disableWingman = 556 sendConfigurationChanged $ def 557 { plugins = M.fromList [ ("tactics", def { plcGlobalOn = False }) ] 558 } 559 560 561sendConfigurationChanged :: Config -> Session () 562sendConfigurationChanged config = 563 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) 564 565noLiteralCaps :: C.ClientCapabilities 566noLiteralCaps = def { C._textDocument = Just textDocumentCaps } 567 where 568 textDocumentCaps = def { C._codeAction = Just codeActionCaps } 569 codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing 570