mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-13 18:23:38 +03:00
a162e81aa3
* TEST: Degrade type error to warning It will be upgraded again later, but for the time being we want to see whether the proposed mechanism for deferring type errors works at all. As it turns out the first, most obvious approach, does not work: this is documented in the next commit. A second approach was found that does work, and appears in the commit after the next. This test is failing until the second approach is implemented. * Defer type errors (first approach: FAILED) The idea is to set the `-fdefer-type-errors` and `-fwarn-deferred-type-errors` flags, by setting options programatically inside the `Ghc` monad. Deferral of type errors was not observed with this approach. The (less obvious) approach used in the next commit seems to be more successful. * Defer type errors (second approach: SUCCESS) This approach modifies the `ParsedModule` which is passed to `GHC.typecheckedModule` by hie-core's `typecheckModule`. Type warning deferral is now observed at run time, and the tests pass. * TEST: Reinstate severity of type errors So far, type errors have been deferred and reported as warnings. The next step is to ensure that the deferred type errors are reported as errors rather than warnings, once again. This test fails until the implementation arrives in the next commit. * Upgrade severity of deferred Type Errors after typecheck ... and make the test pass again. * Hide helper functions in local scopes * Stop setting Opt_WarnDeferredTypeErrors ... and the tests still pass, thereby confirming @hsenag's hypothesis that this flag is not needed. * TEST: Check that typed holes are reported as errors * TEST: Downgrade severity of typed holes Error -> Warning This test fails, thereby falsifying the hypothesis that `Opt_DeferTypeErrors` implies `Opt_DeferTypedHoles`. * Defer typed holes ... and pass the failing test. * TEST: Reinstate severity of typed holes ... failing the test until the implementation catches up in the next commit. * Upgrade severity of deferred Typed Holes after typecheck ... and pass the test once again. * TEST: Degrade variable out of scope from Error to Warning ... test fails until next commit. * Defer out of scope variables ... passing the test which was changed in the last commit. * TEST: Reinstate severity of out of scope variables ... failing the test, and forcing the implementation to catch up. * Upgrade severity of deferred out of scope vars after typecheck ... passing the test once again. * Add explicit tests for deferrals * Add IdeOption for deferral switching * Improve documentation of optDefer * Add IdeDefer newtype
594 lines
22 KiB
Haskell
594 lines
22 KiB
Haskell
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||
-- SPDX-License-Identifier: Apache-2.0
|
||
|
||
{-# LANGUAGE DuplicateRecordFields #-}
|
||
{-# LANGUAGE CPP #-}
|
||
#include "ghc-api-version.h"
|
||
|
||
module Main (main) where
|
||
|
||
import Control.Monad (void)
|
||
import Control.Monad.IO.Class (liftIO)
|
||
import qualified Data.Text as T
|
||
import Development.IDE.Test
|
||
import Development.IDE.Test.Runfiles
|
||
import Language.Haskell.LSP.Test
|
||
import Language.Haskell.LSP.Types
|
||
import Language.Haskell.LSP.Types.Capabilities
|
||
import System.Environment.Blank (setEnv)
|
||
import System.IO.Extra
|
||
import Test.Tasty
|
||
import Test.Tasty.HUnit
|
||
|
||
|
||
main :: IO ()
|
||
main = defaultMain $ testGroup "HIE"
|
||
[ testSession "open close" $ do
|
||
doc <- openDoc' "Testing.hs" "haskell" ""
|
||
void (message :: Session ProgressStartNotification)
|
||
closeDoc doc
|
||
void (message :: Session ProgressDoneNotification)
|
||
, diagnosticTests
|
||
, codeActionTests
|
||
]
|
||
|
||
|
||
diagnosticTests :: TestTree
|
||
diagnosticTests = testGroup "diagnostics"
|
||
[ testSession "fix syntax error" $ do
|
||
let content = T.unlines [ "module Testing wher" ]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
|
||
let change = TextDocumentContentChangeEvent
|
||
{ _range = Just (Range (Position 0 15) (Position 0 19))
|
||
, _rangeLength = Nothing
|
||
, _text = "where"
|
||
}
|
||
changeDoc doc [change]
|
||
expectDiagnostics [("Testing.hs", [])]
|
||
, testSession "introduce syntax error" $ do
|
||
let content = T.unlines [ "module Testing where" ]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
void (message :: Session ProgressStartNotification)
|
||
let change = TextDocumentContentChangeEvent
|
||
{ _range = Just (Range (Position 0 15) (Position 0 18))
|
||
, _rangeLength = Nothing
|
||
, _text = "wher"
|
||
}
|
||
changeDoc doc [change]
|
||
expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
|
||
, testSession "variable not in scope" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "foo :: Int -> Int -> Int"
|
||
, "foo a b = a + ab"
|
||
, "bar :: Int -> Int -> Int"
|
||
, "bar a b = cd + b"
|
||
]
|
||
_ <- openDoc' "Testing.hs" "haskell" content
|
||
expectDiagnostics
|
||
[ ( "Testing.hs"
|
||
, [ (DsError, (2, 14), "Variable not in scope: ab")
|
||
, (DsError, (4, 10), "Variable not in scope: cd")
|
||
]
|
||
)
|
||
]
|
||
, testSession "type error" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "foo :: Int -> String -> Int"
|
||
, "foo a b = a + b"
|
||
]
|
||
_ <- openDoc' "Testing.hs" "haskell" content
|
||
expectDiagnostics
|
||
[ ( "Testing.hs"
|
||
, [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
|
||
)
|
||
]
|
||
, testSession "typed hole" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "foo :: Int -> String"
|
||
, "foo a = _ a"
|
||
]
|
||
_ <- openDoc' "Testing.hs" "haskell" content
|
||
expectDiagnostics
|
||
[ ( "Testing.hs"
|
||
, [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
|
||
)
|
||
]
|
||
|
||
, testGroup "deferral" $
|
||
let sourceA a = T.unlines
|
||
[ "module A where"
|
||
, "a :: Int"
|
||
, "a = " <> a]
|
||
sourceB = T.unlines
|
||
[ "module B where"
|
||
, "import A"
|
||
, "b :: Float"
|
||
, "b = True"]
|
||
bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"
|
||
expectedDs aMessage =
|
||
[ ("A.hs", [(DsError, (2,4), aMessage)])
|
||
, ("B.hs", [(DsError, (3,4), bMessage)])]
|
||
deferralTest title binding message = testSession title $ do
|
||
_ <- openDoc' "A.hs" "haskell" $ sourceA binding
|
||
_ <- openDoc' "B.hs" "haskell" sourceB
|
||
expectDiagnostics $ expectedDs message
|
||
in
|
||
[ deferralTest "type error" "True" "Couldn't match expected type"
|
||
, deferralTest "typed hole" "_" "Found hole"
|
||
, deferralTest "out of scope var" "unbound" "Variable not in scope"
|
||
]
|
||
|
||
, testSession "remove required module" $ do
|
||
let contentA = T.unlines [ "module ModuleA where" ]
|
||
docA <- openDoc' "ModuleA.hs" "haskell" contentA
|
||
let contentB = T.unlines
|
||
[ "module ModuleB where"
|
||
, "import ModuleA"
|
||
]
|
||
_ <- openDoc' "ModuleB.hs" "haskell" contentB
|
||
let change = TextDocumentContentChangeEvent
|
||
{ _range = Just (Range (Position 0 0) (Position 0 20))
|
||
, _rangeLength = Nothing
|
||
, _text = ""
|
||
}
|
||
changeDoc docA [change]
|
||
expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]
|
||
, testSession "add missing module" $ do
|
||
let contentB = T.unlines
|
||
[ "module ModuleB where"
|
||
, "import ModuleA"
|
||
]
|
||
_ <- openDoc' "ModuleB.hs" "haskell" contentB
|
||
expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
|
||
let contentA = T.unlines [ "module ModuleA where" ]
|
||
_ <- openDoc' "ModuleA.hs" "haskell" contentA
|
||
expectDiagnostics [("ModuleB.hs", [])]
|
||
, testSession "cyclic module dependency" $ do
|
||
let contentA = T.unlines
|
||
[ "module ModuleA where"
|
||
, "import ModuleB"
|
||
]
|
||
let contentB = T.unlines
|
||
[ "module ModuleB where"
|
||
, "import ModuleA"
|
||
]
|
||
_ <- openDoc' "ModuleA.hs" "haskell" contentA
|
||
_ <- openDoc' "ModuleB.hs" "haskell" contentB
|
||
expectDiagnostics
|
||
[ ( "ModuleA.hs"
|
||
, [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
|
||
)
|
||
, ( "ModuleB.hs"
|
||
, [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
|
||
)
|
||
]
|
||
, testSession "cyclic module dependency with hs-boot" $ do
|
||
let contentA = T.unlines
|
||
[ "module ModuleA where"
|
||
, "import {-# SOURCE #-} ModuleB"
|
||
]
|
||
let contentB = T.unlines
|
||
[ "module ModuleB where"
|
||
, "import ModuleA"
|
||
]
|
||
let contentBboot = T.unlines
|
||
[ "module ModuleB where"
|
||
]
|
||
_ <- openDoc' "ModuleA.hs" "haskell" contentA
|
||
_ <- openDoc' "ModuleB.hs" "haskell" contentB
|
||
_ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
|
||
expectDiagnostics []
|
||
, testSession "correct reference used with hs-boot" $ do
|
||
let contentB = T.unlines
|
||
[ "module ModuleB where"
|
||
, "import {-# SOURCE #-} ModuleA"
|
||
]
|
||
let contentA = T.unlines
|
||
[ "module ModuleA where"
|
||
, "import ModuleB"
|
||
, "x = 5"
|
||
]
|
||
let contentAboot = T.unlines
|
||
[ "module ModuleA where"
|
||
]
|
||
let contentC = T.unlines
|
||
[ "module ModuleC where"
|
||
, "import ModuleA"
|
||
-- this reference will fail if it gets incorrectly
|
||
-- resolved to the hs-boot file
|
||
, "y = x"
|
||
]
|
||
_ <- openDoc' "ModuleB.hs" "haskell" contentB
|
||
_ <- openDoc' "ModuleA.hs" "haskell" contentA
|
||
_ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
|
||
_ <- openDoc' "ModuleC.hs" "haskell" contentC
|
||
expectDiagnostics []
|
||
, testSession "redundant import" $ do
|
||
let contentA = T.unlines ["module ModuleA where"]
|
||
let contentB = T.unlines
|
||
[ "{-# OPTIONS_GHC -Wunused-imports #-}"
|
||
, "module ModuleB where"
|
||
, "import ModuleA"
|
||
]
|
||
_ <- openDoc' "ModuleA.hs" "haskell" contentA
|
||
_ <- openDoc' "ModuleB.hs" "haskell" contentB
|
||
expectDiagnostics
|
||
[ ( "ModuleB.hs"
|
||
, [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
|
||
)
|
||
]
|
||
, testSession "package imports" $ do
|
||
let thisDataListContent = T.unlines
|
||
[ "module Data.List where"
|
||
, "x = 123"
|
||
]
|
||
let mainContent = T.unlines
|
||
[ "{-# LANGUAGE PackageImports #-}"
|
||
, "module Main where"
|
||
, "import qualified \"this\" Data.List as ThisList"
|
||
, "import qualified \"base\" Data.List as BaseList"
|
||
, "useThis = ThisList.x"
|
||
, "useBase = BaseList.map"
|
||
, "wrong1 = ThisList.map"
|
||
, "wrong2 = BaseList.x"
|
||
]
|
||
_ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
|
||
_ <- openDoc' "Main.hs" "haskell" mainContent
|
||
expectDiagnostics
|
||
[ ( "Main.hs"
|
||
, [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
|
||
,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")
|
||
]
|
||
)
|
||
]
|
||
, testSession "unqualified warnings" $ do
|
||
let fooContent = T.unlines
|
||
[ "{-# OPTIONS_GHC -Wredundant-constraints #-}"
|
||
, "module Foo where"
|
||
, "foo :: Ord a => a -> Int"
|
||
, "foo a = 1"
|
||
]
|
||
_ <- openDoc' "Foo.hs" "haskell" fooContent
|
||
expectDiagnostics
|
||
[ ( "Foo.hs"
|
||
-- The test is to make sure that warnings contain unqualified names
|
||
-- where appropriate. The warning should use an unqualified name 'Ord', not
|
||
-- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to
|
||
-- test this is fairly arbitrary.
|
||
, [(DsWarning, (2, 0), "Redundant constraint: Ord a")
|
||
]
|
||
)
|
||
]
|
||
]
|
||
|
||
codeActionTests :: TestTree
|
||
codeActionTests = testGroup "code actions"
|
||
[ renameActionTests
|
||
, typeWildCardActionTests
|
||
, removeImportTests
|
||
, importRenameActionTests
|
||
, fillTypedHoleTests
|
||
]
|
||
|
||
renameActionTests :: TestTree
|
||
renameActionTests = testGroup "rename actions"
|
||
[ testSession "change to local variable name" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "foo :: Int -> Int"
|
||
, "foo argName = argNme"
|
||
]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
_ <- waitForDiagnostics
|
||
[CACodeAction action@CodeAction { _title = actionTitle }]
|
||
<- getCodeActions doc (Range (Position 2 14) (Position 2 20))
|
||
liftIO $ "Replace with ‘argName’" @=? actionTitle
|
||
executeCodeAction action
|
||
contentAfterAction <- documentContents doc
|
||
let expectedContentAfterAction = T.unlines
|
||
[ "module Testing where"
|
||
, "foo :: Int -> Int"
|
||
, "foo argName = argName"
|
||
]
|
||
liftIO $ expectedContentAfterAction @=? contentAfterAction
|
||
, testSession "change to name of imported function" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "import Data.Maybe (maybeToList)"
|
||
, "foo :: Maybe a -> [a]"
|
||
, "foo = maybToList"
|
||
]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
_ <- waitForDiagnostics
|
||
[CACodeAction action@CodeAction { _title = actionTitle }]
|
||
<- getCodeActions doc (Range (Position 3 6) (Position 3 16))
|
||
liftIO $ "Replace with ‘maybeToList’" @=? actionTitle
|
||
executeCodeAction action
|
||
contentAfterAction <- documentContents doc
|
||
let expectedContentAfterAction = T.unlines
|
||
[ "module Testing where"
|
||
, "import Data.Maybe (maybeToList)"
|
||
, "foo :: Maybe a -> [a]"
|
||
, "foo = maybeToList"
|
||
]
|
||
liftIO $ expectedContentAfterAction @=? contentAfterAction
|
||
, testSession "suggest multiple local variable names" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "foo :: Char -> Char -> Char -> Char"
|
||
, "foo argument1 argument2 argument3 = argumentX"
|
||
]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
_ <- waitForDiagnostics
|
||
actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))
|
||
let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]
|
||
expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
|
||
liftIO $ expectedActionTitles @=? actionTitles
|
||
, testSession "change infix function" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "monus :: Int -> Int"
|
||
, "monus x y = max 0 (x - y)"
|
||
, "foo x y = x `monnus` y"
|
||
]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
_ <- waitForDiagnostics
|
||
actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
|
||
[fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
|
||
executeCodeAction fixTypo
|
||
contentAfterAction <- documentContents doc
|
||
let expectedContentAfterAction = T.unlines
|
||
[ "module Testing where"
|
||
, "monus :: Int -> Int"
|
||
, "monus x y = max 0 (x - y)"
|
||
, "foo x y = x `monus` y"
|
||
]
|
||
liftIO $ expectedContentAfterAction @=? contentAfterAction
|
||
]
|
||
|
||
typeWildCardActionTests :: TestTree
|
||
typeWildCardActionTests = testGroup "type wildcard actions"
|
||
[ testSession "global signature" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "func :: _"
|
||
, "func x = x"
|
||
]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
_ <- waitForDiagnostics
|
||
actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
|
||
let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
|
||
, "Use type signature" `T.isInfixOf` actionTitle
|
||
]
|
||
executeCodeAction addSignature
|
||
contentAfterAction <- documentContents doc
|
||
let expectedContentAfterAction = T.unlines
|
||
[ "module Testing where"
|
||
, "func :: (p -> p)"
|
||
, "func x = x"
|
||
]
|
||
liftIO $ expectedContentAfterAction @=? contentAfterAction
|
||
, testSession "multi-line message" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "func :: _"
|
||
, "func x y = x + y"
|
||
]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
_ <- waitForDiagnostics
|
||
actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
|
||
let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
|
||
, "Use type signature" `T.isInfixOf` actionTitle
|
||
]
|
||
executeCodeAction addSignature
|
||
contentAfterAction <- documentContents doc
|
||
let expectedContentAfterAction = T.unlines
|
||
[ "module Testing where"
|
||
, "func :: (Integer -> Integer -> Integer)"
|
||
, "func x y = x + y"
|
||
]
|
||
liftIO $ expectedContentAfterAction @=? contentAfterAction
|
||
, testSession "local signature" $ do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "func :: Int -> Int"
|
||
, "func x ="
|
||
, " let y :: _"
|
||
, " y = x * 2"
|
||
, " in y"
|
||
]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
_ <- waitForDiagnostics
|
||
actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
|
||
let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
|
||
, "Use type signature" `T.isInfixOf` actionTitle
|
||
]
|
||
executeCodeAction addSignature
|
||
contentAfterAction <- documentContents doc
|
||
let expectedContentAfterAction = T.unlines
|
||
[ "module Testing where"
|
||
, "func :: Int -> Int"
|
||
, "func x ="
|
||
, " let y :: (Int)"
|
||
, " y = x * 2"
|
||
, " in y"
|
||
]
|
||
liftIO $ expectedContentAfterAction @=? contentAfterAction
|
||
]
|
||
|
||
removeImportTests :: TestTree
|
||
removeImportTests = testGroup "remove import actions"
|
||
[ testSession "redundant" $ do
|
||
let contentA = T.unlines
|
||
[ "module ModuleA where"
|
||
]
|
||
_docA <- openDoc' "ModuleA.hs" "haskell" contentA
|
||
let contentB = T.unlines
|
||
[ "{-# OPTIONS_GHC -Wunused-imports #-}"
|
||
, "module ModuleB where"
|
||
, "import ModuleA"
|
||
, "stuffB = 123"
|
||
]
|
||
docB <- openDoc' "ModuleB.hs" "haskell" contentB
|
||
_ <- waitForDiagnostics
|
||
[CACodeAction action@CodeAction { _title = actionTitle }]
|
||
<- getCodeActions docB (Range (Position 2 0) (Position 2 5))
|
||
liftIO $ "Remove import" @=? actionTitle
|
||
executeCodeAction action
|
||
contentAfterAction <- documentContents docB
|
||
let expectedContentAfterAction = T.unlines
|
||
[ "{-# OPTIONS_GHC -Wunused-imports #-}"
|
||
, "module ModuleB where"
|
||
, "stuffB = 123"
|
||
]
|
||
liftIO $ expectedContentAfterAction @=? contentAfterAction
|
||
, testSession "qualified redundant" $ do
|
||
let contentA = T.unlines
|
||
[ "module ModuleA where"
|
||
]
|
||
_docA <- openDoc' "ModuleA.hs" "haskell" contentA
|
||
let contentB = T.unlines
|
||
[ "{-# OPTIONS_GHC -Wunused-imports #-}"
|
||
, "module ModuleB where"
|
||
, "import qualified ModuleA"
|
||
, "stuffB = 123"
|
||
]
|
||
docB <- openDoc' "ModuleB.hs" "haskell" contentB
|
||
_ <- waitForDiagnostics
|
||
[CACodeAction action@CodeAction { _title = actionTitle }]
|
||
<- getCodeActions docB (Range (Position 2 0) (Position 2 5))
|
||
liftIO $ "Remove import" @=? actionTitle
|
||
executeCodeAction action
|
||
contentAfterAction <- documentContents docB
|
||
let expectedContentAfterAction = T.unlines
|
||
[ "{-# OPTIONS_GHC -Wunused-imports #-}"
|
||
, "module ModuleB where"
|
||
, "stuffB = 123"
|
||
]
|
||
liftIO $ expectedContentAfterAction @=? contentAfterAction
|
||
]
|
||
|
||
importRenameActionTests :: TestTree
|
||
importRenameActionTests = testGroup "import rename actions"
|
||
[ testSession "Data.Mape -> Data.Map" $ check "Map"
|
||
, testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where
|
||
check modname = do
|
||
let content = T.unlines
|
||
[ "module Testing where"
|
||
, "import Data.Mape"
|
||
]
|
||
doc <- openDoc' "Testing.hs" "haskell" content
|
||
_ <- waitForDiagnostics
|
||
actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
|
||
let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
|
||
executeCodeAction changeToMap
|
||
contentAfterAction <- documentContents doc
|
||
let expectedContentAfterAction = T.unlines
|
||
[ "module Testing where"
|
||
, "import Data." <> modname
|
||
]
|
||
liftIO $ expectedContentAfterAction @=? contentAfterAction
|
||
|
||
fillTypedHoleTests :: TestTree
|
||
fillTypedHoleTests = let
|
||
|
||
sourceCode :: T.Text -> T.Text -> T.Text -> T.Text
|
||
sourceCode a b c = T.unlines
|
||
[ "module Testing where"
|
||
, ""
|
||
, "globalConvert :: Int -> String"
|
||
, "globalConvert = undefined"
|
||
, ""
|
||
, "globalInt :: Int"
|
||
, "globalInt = 3"
|
||
, ""
|
||
, "bar :: Int -> Int -> String"
|
||
, "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where"
|
||
, " localConvert = (flip replicate) 'x'"
|
||
|
||
]
|
||
|
||
check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree
|
||
check actionTitle
|
||
oldA oldB oldC
|
||
newA newB newC = testSession (T.unpack actionTitle) $ do
|
||
let originalCode = sourceCode oldA oldB oldC
|
||
let expectedCode = sourceCode newA newB newC
|
||
doc <- openDoc' "Testing.hs" "haskell" originalCode
|
||
_ <- waitForDiagnostics
|
||
actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
|
||
let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
|
||
executeCodeAction chosenAction
|
||
modifiedCode <- documentContents doc
|
||
liftIO $ expectedCode @=? modifiedCode
|
||
|
||
pickActionWithTitle title actions = head
|
||
[ action
|
||
| CACodeAction action@CodeAction{ _title = actionTitle } <- actions
|
||
, title == actionTitle ]
|
||
|
||
in
|
||
testGroup "fill typed holes"
|
||
[ check "replace hole `_` with show"
|
||
"_" "n" "n"
|
||
"show" "n" "n"
|
||
|
||
, check "replace hole `_` with globalConvert"
|
||
"_" "n" "n"
|
||
"globalConvert" "n" "n"
|
||
|
||
#if MIN_GHC_API_VERSION(8,6,0)
|
||
, check "replace hole `_convertme` with localConvert"
|
||
"_convertme" "n" "n"
|
||
"localConvert" "n" "n"
|
||
#endif
|
||
|
||
, check "replace hole `_b` with globalInt"
|
||
"_a" "_b" "_c"
|
||
"_a" "globalInt" "_c"
|
||
|
||
, check "replace hole `_c` with globalInt"
|
||
"_a" "_b" "_c"
|
||
"_a" "_b" "globalInt"
|
||
|
||
#if MIN_GHC_API_VERSION(8,6,0)
|
||
, check "replace hole `_c` with parameterInt"
|
||
"_a" "_b" "_c"
|
||
"_a" "_b" "parameterInt"
|
||
#endif
|
||
]
|
||
|
||
----------------------------------------------------------------------
|
||
-- Utils
|
||
|
||
|
||
testSession :: String -> Session () -> TestTree
|
||
testSession name =
|
||
testCase name . run .
|
||
-- Check that any diagnostics produced were already consumed by the test case.
|
||
--
|
||
-- If in future we add test cases where we don't care about checking the diagnostics,
|
||
-- this could move elsewhere.
|
||
--
|
||
-- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
|
||
( >> expectNoMoreDiagnostics 0.5)
|
||
|
||
|
||
run :: Session a -> IO a
|
||
run s = withTempDir $ \dir -> do
|
||
ghcideExe <- locateGhcideExecutable
|
||
let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
|
||
-- HIE calls getXgdDirectory which assumes that HOME is set.
|
||
-- Only sets HOME if it wasn't already set.
|
||
setEnv "HOME" "/homeless-shelter" False
|
||
runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s
|
||
where
|
||
conf = defaultConfig
|
||
-- If you uncomment this you can see all messages
|
||
-- which can be quite useful for debugging.
|
||
-- { logMessages = True, logColor = False, logStdErr = True }
|