mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-13 18:23:38 +03:00
852 lines
34 KiB
Haskell
852 lines
34 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.Applicative.Combinators
|
||
import Control.Monad
|
||
import Control.Monad.IO.Class (liftIO)
|
||
import Data.Char (toLower)
|
||
import Data.Foldable
|
||
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.FilePath
|
||
import System.IO.Extra
|
||
import System.Directory
|
||
import Test.Tasty
|
||
import Test.Tasty.HUnit
|
||
import Test.Tasty.ExpectedFailure
|
||
import Data.Maybe
|
||
|
||
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)
|
||
, initializeResponseTests
|
||
, diagnosticTests
|
||
, codeActionTests
|
||
, findDefinitionTests
|
||
]
|
||
|
||
initializeResponseTests :: TestTree
|
||
initializeResponseTests = withResource acquire release tests where
|
||
|
||
-- these tests document and monitor the evolution of the
|
||
-- capabilities announced by the server in the initialize
|
||
-- response. Currently the server advertises almost no capabilities
|
||
-- at all, in some cases failing to announce capabilities that it
|
||
-- actually does provide! Hopefully this will change ...
|
||
tests :: IO InitializeResponse -> TestTree
|
||
tests getInitializeResponse =
|
||
testGroup "initialize response capabilities"
|
||
[ chk " text doc sync" _textDocumentSync tds
|
||
, chk " hover" _hoverProvider (Just True)
|
||
, chk "NO completion" _completionProvider Nothing
|
||
, chk "NO signature help" _signatureHelpProvider Nothing
|
||
, chk " goto definition" _definitionProvider (Just True)
|
||
, chk "NO goto type definition" _typeDefinitionProvider Nothing
|
||
, chk "NO goto implementation" _implementationProvider Nothing
|
||
, chk "NO find references" _referencesProvider Nothing
|
||
, chk "NO doc highlight" _documentHighlightProvider Nothing
|
||
, chk "NO doc symbol" _documentSymbolProvider Nothing
|
||
, chk "NO workspace symbol" _workspaceSymbolProvider Nothing
|
||
, chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
|
||
, chk "NO code lens" _codeLensProvider Nothing
|
||
, chk "NO doc formatting" _documentFormattingProvider Nothing
|
||
, chk "NO doc range formatting"
|
||
_documentRangeFormattingProvider Nothing
|
||
, chk "NO doc formatting on typing"
|
||
_documentOnTypeFormattingProvider Nothing
|
||
, chk "NO renaming" _renameProvider Nothing
|
||
, chk "NO doc link" _documentLinkProvider Nothing
|
||
, chk "NO color" _colorProvider Nothing
|
||
, chk "NO folding range" _foldingRangeProvider Nothing
|
||
, chk "NO execute command" _executeCommandProvider Nothing
|
||
, chk "NO workspace" _workspace nothingWorkspace
|
||
, chk "NO experimental" _experimental Nothing
|
||
] where
|
||
|
||
tds = Just (TDSOptions (TextDocumentSyncOptions
|
||
{ _openClose = Just True
|
||
, _change = Just TdSyncIncremental
|
||
, _willSave = Nothing
|
||
, _willSaveWaitUntil = Nothing
|
||
, _save = Just (SaveOptions {_includeText = Nothing})}))
|
||
|
||
nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})
|
||
|
||
chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
|
||
chk title getActual expected =
|
||
testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
|
||
|
||
innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
|
||
innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
|
||
innerCaps _ = error "this test only expects inner capabilities"
|
||
|
||
acquire :: IO InitializeResponse
|
||
acquire = run initializeResponse
|
||
|
||
release :: InitializeResponse -> IO ()
|
||
release = const $ pure ()
|
||
|
||
|
||
diagnosticTests :: TestTree
|
||
diagnosticTests = testGroup "diagnostics"
|
||
[ testSessionWait "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", [])]
|
||
, testSessionWait "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")])]
|
||
, testSessionWait "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")
|
||
]
|
||
)
|
||
]
|
||
, testSessionWait "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'")]
|
||
)
|
||
]
|
||
, testSessionWait "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 msg = testSessionWait title $ do
|
||
_ <- openDoc' "A.hs" "haskell" $ sourceA binding
|
||
_ <- openDoc' "B.hs" "haskell" sourceB
|
||
expectDiagnostics $ expectedDs msg
|
||
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"
|
||
, deferralTest "message shows error" "True" "A.hs:3:5: error:"
|
||
]
|
||
|
||
, testSessionWait "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")])]
|
||
, testSessionWait "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", [])]
|
||
, testSessionWait "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")]
|
||
)
|
||
]
|
||
, testSessionWait "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 []
|
||
, testSessionWait "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 []
|
||
, testSessionWait "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")]
|
||
)
|
||
]
|
||
, testSessionWait "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")
|
||
]
|
||
)
|
||
]
|
||
, testSessionWait "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")
|
||
]
|
||
)
|
||
]
|
||
, testSessionWait "lower-case drive" $ do
|
||
let aContent = T.unlines
|
||
[ "module A.A where"
|
||
, "import A.B ()"
|
||
]
|
||
bContent = T.unlines
|
||
[ "{-# OPTIONS_GHC -Wall #-}"
|
||
, "module A.B where"
|
||
, "import Data.List"
|
||
]
|
||
uriB <- getDocUri "A/B.hs"
|
||
Just pathB <- pure $ uriToFilePath uriB
|
||
uriB <- pure $
|
||
let (drive, suffix) = splitDrive pathB
|
||
in filePathToUri (joinDrive (map toLower drive ) suffix)
|
||
liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
|
||
liftIO $ writeFileUTF8 pathB $ T.unpack bContent
|
||
uriA <- getDocUri "A/A.hs"
|
||
Just pathA <- pure $ uriToFilePath uriA
|
||
uriA <- pure $
|
||
let (drive, suffix) = splitDrive pathA
|
||
in filePathToUri (joinDrive (map toLower drive ) suffix)
|
||
let itemA = TextDocumentItem uriA "haskell" 0 aContent
|
||
let a = TextDocumentIdentifier uriA
|
||
sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
|
||
diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
|
||
let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
|
||
-- Check that if we put a lower-case drive in for A.A
|
||
-- the diagnostics for A.B will also be lower-case.
|
||
liftIO $ fileUri @?= uriB
|
||
let msg = _message (head (toList diags) :: Diagnostic)
|
||
liftIO $ unless ("redundant" `T.isInfixOf` msg) $
|
||
assertFailure ("Expected redundant import but got " <> T.unpack msg)
|
||
closeDoc a
|
||
]
|
||
|
||
codeActionTests :: TestTree
|
||
codeActionTests = testGroup "code actions"
|
||
[ renameActionTests
|
||
, typeWildCardActionTests
|
||
, removeImportTests
|
||
, importRenameActionTests
|
||
, fillTypedHoleTests
|
||
, addSigActionTests
|
||
]
|
||
|
||
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
|
||
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
|
||
]
|
||
|
||
addSigActionTests :: TestTree
|
||
addSigActionTests = let
|
||
header = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
|
||
, "module Sigs where"]
|
||
before def = T.unlines [header, def]
|
||
after' def sig = T.unlines [header, sig, def]
|
||
|
||
def >:: sig = testSession (T.unpack def) $ do
|
||
let originalCode = before def
|
||
let expectedCode = after' def sig
|
||
doc <- openDoc' "Sigs.hs" "haskell" originalCode
|
||
_ <- waitForDiagnostics
|
||
actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
|
||
let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
|
||
executeCodeAction chosenAction
|
||
modifiedCode <- documentContents doc
|
||
liftIO $ expectedCode @=? modifiedCode
|
||
in
|
||
testGroup "add signature"
|
||
[ "abc = True" >:: "abc :: Bool"
|
||
, "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
|
||
, "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
|
||
, "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
|
||
, "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
|
||
, "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
|
||
]
|
||
|
||
findDefinitionTests :: TestTree
|
||
findDefinitionTests = let
|
||
|
||
tst (get, check) pos targetRange title = testSession title $ do
|
||
doc <- openDoc' "Testing.hs" "haskell" source
|
||
found <- get doc pos
|
||
check found targetRange
|
||
|
||
checkDefs defs expected = do
|
||
|
||
let ndef = length defs
|
||
if ndef /= 1
|
||
then let dfound n = "definitions found: " <> show n in
|
||
liftIO $ dfound (1 :: Int) @=? dfound (length defs)
|
||
else do
|
||
let [Location{_range = foundRange}] = defs
|
||
liftIO $ expected @=? foundRange
|
||
|
||
checkHover hover expected =
|
||
case hover of
|
||
Nothing -> liftIO $ "hover found" @=? ("no hover found" :: T.Text)
|
||
Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
|
||
,_range = mRange } ->
|
||
let
|
||
extractLineColFromMsg =
|
||
T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn "Testing.hs:"
|
||
lineCol = extractLineColFromMsg msg
|
||
|
||
-- looks like hovers use 1-based numbering while definitions use 0-based
|
||
-- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
|
||
adjust Position{_line = l, _character = c} =
|
||
Position{_line = l + 1, _character = c + 1}
|
||
in
|
||
case lineCol of
|
||
[_,_] -> liftIO $ (adjust $ _start expected) @=? Position l c where [l,c] = map (read . T.unpack) lineCol
|
||
_ -> liftIO $ ("[...]Testing.hs:<LINE>:<COL>**[...]", mRange) @=? (msg, Just expected)
|
||
_ -> error "test not expecting this kind of hover info"
|
||
|
||
mkFindTests tests = testGroup "get"
|
||
[ testGroup "definition" $ mapMaybe fst tests
|
||
, testGroup "hover" $ mapMaybe snd tests ]
|
||
|
||
test runDef runHover look bind title =
|
||
( runDef $ tst def look bind title
|
||
, runHover $ tst hover look bind title ) where
|
||
def = (getDefinitions, checkDefs)
|
||
hover = (getHover , checkHover)
|
||
--type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
|
||
-- test run control
|
||
yes, broken :: (TestTree -> Maybe TestTree)
|
||
yes = Just -- test should run and pass
|
||
broken = Just . (`xfail` "known broken")
|
||
cant = Just . (`xfail` "cannot be made to work")
|
||
-- no = const Nothing -- don't run this test at all
|
||
|
||
source = T.unlines
|
||
-- 0123456789 123456789 123456789 123456789
|
||
[ "{-# OPTIONS_GHC -Wmissing-signatures #-}" -- 0
|
||
, "module Testing where" -- 1
|
||
, "import Data.Text (Text)" -- 2
|
||
, "data TypeConstructor = DataConstructor" -- 3
|
||
, " { fff :: Text" -- 4
|
||
, " , ggg :: Int }" -- 5
|
||
, "aaa :: TypeConstructor" -- 6
|
||
, "aaa = DataConstructor" -- 7
|
||
, " { fff = \"\"" -- 8
|
||
, " , ggg = 0" -- 9
|
||
-- 0123456789 123456789 123456789 123456789
|
||
, " }" -- 10
|
||
, "bbb :: TypeConstructor" -- 11
|
||
, "bbb = DataConstructor \"\" 0" -- 12
|
||
, "ccc :: (Text, Int)" -- 13
|
||
, "ccc = (fff bbb, ggg aaa)" -- 14
|
||
, "ddd :: Num a => a -> a -> a" -- 15
|
||
, "ddd vv ww = vv +! ww" -- 16
|
||
, "a +! b = a - b" -- 17
|
||
, "hhh (Just a) (><) = a >< a" -- 18
|
||
, "iii a b = a `b` a" -- 19
|
||
-- 0123456789 123456789 123456789 123456789
|
||
]
|
||
|
||
-- search locations definition locations
|
||
fffL4 = _start fff ; fff = mkRange 4 4 4 7
|
||
fffL8 = Position 8 4 ;
|
||
fffL14 = Position 14 7 ;
|
||
aaaL14 = Position 14 20 ; aaa = mkRange 7 0 7 3
|
||
dcL7 = Position 7 11 ; tcDC = mkRange 3 23 5 16
|
||
dcL12 = Position 12 11 ;
|
||
xtcL5 = Position 5 11 ; xtc = undefined -- not clear what it should do
|
||
tcL6 = Position 6 11 ; tcData = mkRange 3 0 5 16
|
||
vvL16 = Position 16 12 ; vv = mkRange 16 4 16 6
|
||
opL16 = Position 16 15 ; op = mkRange 17 2 17 4
|
||
opL18 = Position 18 22 ; opp = mkRange 18 13 18 17
|
||
aL18 = Position 18 20 ; apmp = mkRange 18 10 18 11
|
||
b'L19 = Position 19 13 ; bp = mkRange 19 6 19 7
|
||
|
||
in
|
||
mkFindTests
|
||
-- def hover look bind
|
||
[ test yes yes fffL4 fff "field in record definition"
|
||
, test broken broken fffL8 fff "field in record construction"
|
||
, test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
|
||
, test yes yes aaaL14 aaa "top-level name" -- 120
|
||
, test broken broken dcL7 tcDC "record data constructor"
|
||
, test yes yes dcL12 tcDC "plain data constructor" -- 121
|
||
, test yes broken tcL6 tcData "type constructor" -- 147
|
||
, test cant broken xtcL5 xtc "type constructor from other package"
|
||
, test yes yes vvL16 vv "plain parameter"
|
||
, test yes yes aL18 apmp "pattern match name"
|
||
, test yes yes opL16 op "top-level operator" -- 123
|
||
, test yes yes opL18 opp "parameter operator"
|
||
, test yes yes b'L19 bp "name in backticks"
|
||
]
|
||
|
||
xfail :: TestTree -> String -> TestTree
|
||
xfail = flip expectFailBecause
|
||
|
||
----------------------------------------------------------------------
|
||
-- Utils
|
||
|
||
|
||
testSession :: String -> Session () -> TestTree
|
||
testSession name = testCase name . run
|
||
|
||
testSessionWait :: String -> Session () -> TestTree
|
||
testSessionWait name = testSession name .
|
||
-- 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)
|
||
|
||
pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction
|
||
pickActionWithTitle title actions = head
|
||
[ action
|
||
| CACodeAction action@CodeAction{ _title = actionTitle } <- actions
|
||
, title == actionTitle ]
|
||
|
||
mkRange :: Int -> Int -> Int -> Int -> Range
|
||
mkRange a b c d = Range (Position a b) (Position c d)
|
||
|
||
run :: Session a -> IO a
|
||
run s = withTempDir $ \dir -> do
|
||
ghcideExe <- locateGhcideExecutable
|
||
|
||
-- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
|
||
-- since the package import test creates "Data/List.hs", which otherwise has no physical home
|
||
createDirectoryIfMissing True $ dir ++ "/Data"
|
||
|
||
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 }
|