futhark-0.28.2: src-testing/Futhark/LspTests.hs
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Futhark.LspTests (tests, main) where
import Colog.Core (LogAction (LogAction))
import Control.Applicative ((<|>))
import Control.Concurrent (forkIO)
import Control.Lens ((^.))
import Control.Monad (zipWithM_)
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (for_)
import Data.Functor (void)
import Data.List (sortOn)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Futhark.CLI.LSP (serverDefinition)
import Futhark.Fmt.Printer (fmtToText)
import Language.Futhark.Parser.Monad (SyntaxError (..))
import Language.LSP.Protocol.Lens (uri, version)
import Language.LSP.Protocol.Message
( SMethod (SMethod_TextDocumentFormatting, SMethod_TextDocumentPublishDiagnostics, SMethod_WindowShowMessage, SMethod_WorkspaceApplyEdit),
TNotificationMessage (TNotificationMessage),
TResponseError (TResponseError),
TResponseMessage (TResponseMessage),
)
import Language.LSP.Protocol.Types
( CodeAction (..),
CodeLens (CodeLens),
Definition (Definition),
Diagnostic (..),
DiagnosticSeverity (DiagnosticSeverity_Error, DiagnosticSeverity_Warning),
DocumentFormattingParams (DocumentFormattingParams),
FormattingOptions (FormattingOptions),
Hover (Hover),
InlayHint (..),
InlayHintKind (InlayHintKind_Type),
LSPErrorCodes (LSPErrorCodes_RequestFailed),
LanguageKind (LanguageKind_Custom),
Location (..),
MarkupContent (..),
MarkupKind (MarkupKind_PlainText),
MessageType (MessageType_Error),
Position (..),
PublishDiagnosticsParams (..),
Range (..),
SemanticTokens (..),
ShowMessageParams (ShowMessageParams),
TextDocumentContentChangeEvent (..),
TextDocumentContentChangeWholeDocument (..),
TextDocumentIdentifier,
type (|?) (..),
)
import Language.LSP.Server (runServerWithHandles)
import Language.LSP.Test
( Session,
SessionConfig (..),
anyMessage,
changeDoc,
createDoc,
defaultConfig,
documentContents,
executeCodeAction,
executeCommand,
formatDoc,
fullLatestClientCaps,
getAndResolveCodeLenses,
getAndResolveInlayHints,
getCodeActions,
getDefinitions,
getHover,
getSemanticTokens,
getVersionedDoc,
message,
request,
runSessionWithHandles,
waitForDiagnostics,
)
import NeatInterpolation (text)
import System.IO (hClose)
import System.Process (createPipe)
import Test.Tasty (TestName, TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))
runServerSessionPair :: Session a -> IO a
runServerSessionPair = runServerSessionPairWith defaultConfig
runServerSessionPairWith :: SessionConfig -> Session a -> IO a
runServerSessionPairWith config session = do
(serverIn, clientOut) <- createPipe
(clientIn, serverOut) <- createPipe
futharkServer <- serverDefinition
let ignoreLog :: (Applicative m) => LogAction m msg
ignoreLog = LogAction . const $ pure ()
_serverTid <-
forkIO . void $
runServerWithHandles ignoreLog ignoreLog serverIn serverOut futharkServer
result <- runSessionWithHandles clientOut clientIn config fullLatestClientCaps "." session
for_ [serverIn, clientOut, clientIn, serverOut] hClose
pure result
createMainDoc :: Text -> Session TextDocumentIdentifier
createMainDoc = createDoc "main.fut" futharkLanguage
where
futharkLanguage :: LanguageKind
futharkLanguage = LanguageKind_Custom "Futhark"
serverTestCase :: TestName -> Session () -> TestTree
serverTestCase testName = testCase testName . runServerSessionPair
testDiagnosticsOnOpen :: TestTree
testDiagnosticsOnOpen = serverTestCase "Diagnostics on open" $ do
_ <- createMainDoc "def main = 1i32 + true"
diags <- waitForDiagnostics
liftIO $ map severityAndRange diags @?= [(Just DiagnosticSeverity_Error, expectedRange)]
where
expectedRange =
Range
{ _start = Position {_line = 0, _character = 18},
_end = Position {_line = 0, _character = 22}
}
severityAndRange Diagnostic {..} = (_severity, _range)
testWarningsWithErrors :: TestTree
testWarningsWithErrors = serverTestCase "Warnings with errors" $ do
_ <- createMainDoc "def f (x: i32) = let y = x in x\ndef g (x: i32) = x + true"
diags <- waitForDiagnostics
liftIO $
sortOn fst (map lineAndSeverity diags)
@?= [(0, Just DiagnosticSeverity_Warning), (1, Just DiagnosticSeverity_Error)]
where
lineAndSeverity Diagnostic {..} = (_line (_start _range), _severity)
-- The clearing of fixed diagnostics must carry the current document
-- version, or clients may discard it as stale. A client that has
-- since changed the document discards it anyway, so every
-- compilation must also publish for every open document.
testDiagnosticsClearedOnFix :: TestTree
testDiagnosticsClearedOnFix = serverTestCase "Diagnostics cleared on fix" $ do
docIdent <- createMainDoc "def main = 1i32 + true"
_ <- waitForDiagnostics
changeTo docIdent "def main = 1i32 + 2"
expectCleared docIdent
changeTo docIdent "def main = 1i32 + 3"
expectCleared docIdent
where
changeTo docIdent s =
changeDoc docIdent [TextDocumentContentChangeEvent $ InR $ TextDocumentContentChangeWholeDocument s]
expectCleared docIdent = do
TNotificationMessage _ _ (PublishDiagnosticsParams _ diags_version diags) <- publishedDiagnostics
doc <- getVersionedDoc docIdent
liftIO $ (diags_version, diags) @?= (Just (doc ^. version), [])
publishedDiagnostics =
message SMethod_TextDocumentPublishDiagnostics <|> (anyMessage *> publishedDiagnostics)
testUnlocatedError :: TestTree
testUnlocatedError = testCase "Error without location" . runServerSessionPairWith config $ do
_ <- createDoc "main.txt" (LanguageKind_Custom "Futhark") "def main = 0i32"
TNotificationMessage _ _ (ShowMessageParams message_type msg) <- showMessage
liftIO $ message_type @?= MessageType_Error
liftIO $ assertBool "Mentions extension" $ ".fut extension" `T.isInfixOf` msg
where
-- By default, lsp-test discards window/showMessage.
config = defaultConfig {ignoreLogNotifications = False}
showMessage = message SMethod_WindowShowMessage <|> (anyMessage *> showMessage)
testHoverInformation :: TestTree
testHoverInformation = serverTestCase "Hover" $ do
docIdent <- createMainDoc "def main = let xyz = 42i32 in xyz"
hoverInfo <- getHover docIdent $ Position {_character = 31, _line = 0}
case hoverInfo of
Nothing -> liftIO $ assertFailure "Did not receive any hover information"
Just (Hover content range) -> do
liftIO $ range @?= Just expectedRange
liftIO $ content @?= InL expectedMarkup
where
expectedMarkup =
MarkupContent
{ _value = "i32",
_kind = MarkupKind_PlainText
}
expectedRange =
Range
{ _start = Position {_line = 0, _character = 30},
_end = Position {_line = 0, _character = 33}
}
testDefinition :: TestTree
testDefinition = serverTestCase "Go To Definition" $ do
docIdent <- createMainDoc mainContents
definition <- getDefinitions docIdent fooBodyPosition
let expectedDefinition =
Definition $
InL $
Location
{ _uri = docIdent ^. uri,
_range =
Range
{ _end = Position 0 14,
_start = Position 0 0
}
}
liftIO $ definition @?= InL expectedDefinition
where
mainContents =
[text|
def foo = 0i32
def bar = foo
|]
fooBodyPosition :: Position
fooBodyPosition =
Position
{ _line = 1,
_character = 12
}
testSemanticTokens :: TestTree
testSemanticTokens = serverTestCase "Semantic tokens" $ do
docIdent <- createMainDoc "def main = 0i32"
tokens <- getSemanticTokens docIdent
liftIO $ tokens @?= InL (SemanticTokens Nothing [])
testFormatting :: TestTree
testFormatting = serverTestCase "Formatting" $ do
docIdent <- createMainDoc mainContents
formatDoc docIdent formattingOptions
lspFormattedDoc <- documentContents docIdent
formattedDoc <- case fmtToText "main.fut" mainContents of
Left (SyntaxError loc msg) ->
liftIO . assertFailure $
"Formatting failed: " <> show loc <> ".\n" <> show msg
Right d -> pure d
liftIO $ lspFormattedDoc @?= formattedDoc
where
-- these are ignored by the formatter anyway
formattingOptions = FormattingOptions 0 False Nothing Nothing Nothing
mainContents =
[text|
-- this is where all the lines start
def main =
0i32
|]
testFormattingSyntaxError :: TestTree
testFormattingSyntaxError = serverTestCase "Formatting syntax error" $ do
docIdent <- createMainDoc "def main = ("
TResponseMessage _ _ result <-
request SMethod_TextDocumentFormatting $
DocumentFormattingParams Nothing docIdent formattingOptions
liftIO $ case result of
Left (TResponseError code msg _) -> do
code @?= InL LSPErrorCodes_RequestFailed
assertBool ("Unexpected message: " <> T.unpack msg) $
"main.fut:" `T.isInfixOf` msg
Right edits ->
assertFailure $ "Expected an error, got: " <> show edits
where
formattingOptions = FormattingOptions 0 False Nothing Nothing Nothing
main :: IO ()
main = defaultMain testEvaluationComment
-- | Evaluate the single evaluation comment in the document.
evaluateComment :: TextDocumentIdentifier -> Session ()
evaluateComment docIdent = do
lensCommand <-
getAndResolveCodeLenses docIdent >>= \case
[CodeLens _ (Just command) _] -> pure command
bad -> liftIO $ assertFailure $ "Unexpected Code Lenses: " <> show bad
executeCommand lensCommand
-- this is important, it crashes with an IOError otherwise
void $ message SMethod_WorkspaceApplyEdit
testEvaluationComment :: TestTree
testEvaluationComment = serverTestCase "Evaluation Comment" $ do
docIdent <- createMainDoc mainContents
evaluateComment docIdent
newContents <- documentContents docIdent
liftIO $ newContents @?= expectedContents
where
expectedContents =
mainContents
<> "-- 47\n"
mainContents =
[text|
def x = 42i32
-- >>> x + 5
|]
testEvaluationCommentReplacesResult :: TestTree
testEvaluationCommentReplacesResult =
serverTestCase "Evaluation Comment replaces result" $ do
docIdent <- createMainDoc mainContents
evaluateComment docIdent
evaluateComment docIdent
newContents <- documentContents docIdent
liftIO $ newContents @?= expectedContents
where
mainContents = "def x = 42i32\n-- >>> x + 5\ndef y = x\n"
expectedContents = "def x = 42i32\n-- >>> x + 5\n-- 47\ndef y = x\n"
fullRange :: Range
fullRange =
Range
{ _start = Position minBound minBound,
_end = Position maxBound maxBound
}
testInlayTypeHint :: TestTree
testInlayTypeHint =
testGroup
"Inlay type hint"
[ defParamHint,
letHint,
noSizeHint,
loopHint,
defReturnHint,
defConstantReturnHint,
lambdaArgHint,
typeArgHint,
defNestedHint
]
where
expectHint InlayHint {..} l p = do
_position @?= p
_label @?= InL l
_kind @?= Just InlayHintKind_Type
hintTestCase name mainDoc expectedHints = serverTestCase name $ do
docIdent <- createMainDoc mainDoc
hints <- getAndResolveInlayHints docIdent fullRange
liftIO $
if length hints /= length expectedHints
then assertFailure $ "Unexpected inlay hints: " ++ show hints
else zipWithM_ (\h (p, l) -> expectHint h l p) hints expectedHints
typeArgHint =
hintTestCase
"type argument hint"
"def identity = let f 'a (x: a): a = x in f"
[(Position 0 12, " 'a\8320"), (Position 0 12, " : (x: a\8320) -> a\8320")]
lambdaArgHint =
hintTestCase
"lambda argument hint"
"def lambda : i32 -> i32 = \\ x -> x + 0i32"
[(Position 0 28, "("), (Position 0 29, ": i32)")]
defConstantReturnHint =
hintTestCase
"def constant hint"
"def pi = 3"
[(Position 0 6, " : i32")]
defReturnHint =
hintTestCase
"def return hint"
"def twice (x: i32) = x + x"
[(Position 0 18, " : i32")]
loopHint =
hintTestCase
"loop hint"
"def factorial (n: i32) : i32 = loop result = 1 for i < n do result * (i + 1)"
[(Position 0 36, "("), (Position 0 42, ": i32)")]
-- this is on purpose, all sizes have type i64
noSizeHint =
hintTestCase
"no size hint"
"def sz [n] 'a (_: [n]a) : i64 = n"
[]
letHint =
hintTestCase
"let hint"
"def foo : bool = let f = false in true && f"
[(Position 0 22, ": bool")]
defParamHint =
hintTestCase
"def param hint"
"def plus5 x : i32 = x + 5i32"
[(Position 0 10, "("), (Position 0 11, ": i32)")]
defNestedHint =
hintTestCase
"def nested hint"
"def bar 'a (f: a -> a -> a) (x : a, y) : a = f x y"
[(Position 0 37, ": a")]
testTypeCompletionCodeAction :: TestTree
testTypeCompletionCodeAction =
testGroup
"Type completion code action"
[ testDefReturn,
testDefParam,
testDefParamTypeArg,
testNestedTypeArg,
testLetType,
testLetArg,
testDefDim,
testDefConstantReturnPosition
]
where
-- Retrieves code actions, selects the one containing the title phrase
-- and checks that the new document looks like expected
actionTestCase name contents actionTitleLike newContents =
serverTestCase name $ do
docIdent <- createMainDoc contents
actions <- getCodeActions docIdent fullRange
let filterAction = \case
InL _ -> Nothing
InR c@(CodeAction {..})
| actionTitleLike `T.isInfixOf` _title -> Just c
| otherwise -> Nothing
selectedAction <- liftIO $ case mapMaybe filterAction actions of
[a] -> pure a
rest -> assertFailure $ "No single action found: " ++ show rest
executeCodeAction selectedAction
documentContents docIdent >>= liftIO . (@?= newContents)
testDefReturn =
actionTestCase
"def return"
"def pi = 3i32"
"return type"
"def pi : i32 = 3i32"
testDefParam =
actionTestCase
"param type"
"def identity 'a x : a = x"
"Insert type"
"def identity 'a (x: a) : a = x"
testDefParamTypeArg =
actionTestCase
"param type arg"
"def identity x = x"
"Insert type"
"def identity '^t0 (x: t0) = x"
testNestedTypeArg =
actionTestCase
"nested type arg"
"def identity x = let y = x in y"
"Insert type: `y"
"def identity '^t0 x = let y: t0 = x in y"
testLetType =
actionTestCase
"let type"
"def inc x = let y = x + 1i32 in y"
"Insert type: `y"
"def inc x = let y: i32 = x + 1i32 in y"
testLetArg =
actionTestCase
"let arg"
"def inc x = let f y = y + 1i32 in f x"
"Insert type: `(y"
"def inc x = let f (y: i32) = y + 1i32 in f x"
testDefDim =
actionTestCase
"def dim"
"def id'arr 'a (xs: []a) = xs"
"return type"
"def id'arr [d0] 'a (xs: []a) : [d0]a = xs"
testDefConstantReturnPosition =
actionTestCase
"def constant return position"
"def it '^t = \\(x: t) -> x"
"return type"
"def it '^t : (x: t) -> t = \\(x: t) -> x"
tests :: TestTree
tests =
testGroup
"Futhark.LspTests"
[ testDiagnosticsOnOpen,
testWarningsWithErrors,
testDiagnosticsClearedOnFix,
testUnlocatedError,
testHoverInformation,
testDefinition,
testSemanticTokens,
testFormatting,
testFormattingSyntaxError,
testEvaluationComment,
testEvaluationCommentReplacesResult,
testInlayTypeHint,
testTypeCompletionCodeAction
]