{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
module Language.Haskell.LSP.Test
(
Session
, runSession
, runSessionWithConfig
, SessionConfig(..)
, defaultConfig
, C.fullCaps
, module Language.Haskell.LSP.Test.Exceptions
, withTimeout
, request
, request_
, sendRequest
, sendNotification
, sendResponse
, module Language.Haskell.LSP.Test.Parsing
, initializeResponse
, openDoc
, openDoc'
, closeDoc
, changeDoc
, documentContents
, getDocumentEdit
, getDocUri
, getVersionedDoc
, getDocumentSymbols
, waitForDiagnostics
, waitForDiagnosticsSource
, noDiagnostics
, getCurrentDiagnostics
, executeCommand
, getCodeActions
, getAllCodeActions
, executeCodeAction
, getCompletions
, getReferences
, getDefinitions
, getTypeDefinitions
, rename
, getHover
, getHighlights
, formatDoc
, formatRange
, applyEdit
, getCodeLenses
) where
import Control.Applicative.Combinators
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Exception
import Control.Lens hiding ((.=), List)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Aeson
import Data.Default
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Data.Maybe
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Lens hiding
(id, capabilities, message, executeCommand, applyEdit, rename)
import qualified Language.Haskell.LSP.Types.Lens as LSP
import qualified Language.Haskell.LSP.Types.Capabilities as C
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.VFS
import Language.Haskell.LSP.Test.Compat
import Language.Haskell.LSP.Test.Decoding
import Language.Haskell.LSP.Test.Exceptions
import Language.Haskell.LSP.Test.Parsing
import Language.Haskell.LSP.Test.Session
import Language.Haskell.LSP.Test.Server
import System.Environment
import System.IO
import System.Directory
import System.FilePath
runSession :: String
-> C.ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSession = runSessionWithConfig def
runSessionWithConfig :: SessionConfig
-> String
-> C.ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithConfig config' serverExe caps rootDir session = do
pid <- getCurrentProcessID
absRootDir <- canonicalizePath rootDir
config <- envOverrideConfig config'
let initializeParams = InitializeParams (Just pid)
(Just $ T.pack absRootDir)
(Just $ filePathToUri absRootDir)
Nothing
caps
(Just TraceOff)
Nothing
withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
initReqId <- sendRequest Initialize initializeParams
(inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId)
liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
initRspVar <- initRsp <$> ask
liftIO $ putMVar initRspVar initRspMsg
sendNotification Initialized InitializedParams
case lspConfig config of
Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
Nothing -> return ()
forM_ inBetween checkLegalBetweenMessage
msgChan <- asks messageChan
liftIO $ writeList2Chan msgChan (ServerMessage <$> inBetween)
session
where
exitServer :: Session ()
exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
listenServer :: Handle -> SessionContext -> IO ()
listenServer serverOut context = do
msgBytes <- getNextMessage serverOut
reqMap <- readMVar $ requestMap context
let msg = decodeFromServerMsg reqMap msgBytes
writeChan (messageChan context) (ServerMessage msg)
case msg of
(RspShutdown _) -> return ()
_ -> listenServer serverOut context
checkLegalBetweenMessage :: FromServerMessage -> Session ()
checkLegalBetweenMessage (NotShowMessage _) = pure ()
checkLegalBetweenMessage (NotLogMessage _) = pure ()
checkLegalBetweenMessage (NotTelemetry _) = pure ()
checkLegalBetweenMessage (ReqShowMessage _) = pure ()
checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg)
envOverrideConfig :: SessionConfig -> IO SessionConfig
envOverrideConfig cfg = do
logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES"
logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"
return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }
where checkEnv :: String -> IO (Maybe Bool)
checkEnv s = fmap convertVal <$> lookupEnv s
convertVal "0" = False
convertVal _ = True
documentContents :: TextDocumentIdentifier -> Session T.Text
documentContents doc = do
vfs <- vfs <$> get
let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
return (virtualFileText file)
getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
getDocumentEdit doc = do
req <- message :: Session ApplyWorkspaceEditRequest
unless (checkDocumentChanges req || checkChanges req) $
liftIO $ throw (IncorrectApplyEditRequest (show req))
documentContents doc
where
checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
checkDocumentChanges req =
let changes = req ^. params . edit . documentChanges
maybeDocs = fmap (fmap (^. textDocument . uri)) changes
in case maybeDocs of
Just docs -> (doc ^. uri) `elem` docs
Nothing -> False
checkChanges :: ApplyWorkspaceEditRequest -> Bool
checkChanges req =
let mMap = req ^. params . edit . changes
in maybe False (HashMap.member (doc ^. uri)) mMap
request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
request m = sendRequest m >=> skipManyTill anyMessage . responseForId
request_ :: ToJSON params => ClientMethod -> params -> Session ()
request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
sendRequest
:: ToJSON params
=> ClientMethod
-> params
-> Session LspId
sendRequest method params = do
id <- curReqId <$> get
modify $ \c -> c { curReqId = nextId id }
let req = RequestMessage' "2.0" id method params
reqMap <- requestMap <$> ask
liftIO $ modifyMVar_ reqMap $
\r -> return $ updateRequestMap r id method
sendMessage req
return id
where nextId (IdInt i) = IdInt (i + 1)
nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
instance ToJSON a => ToJSON (RequestMessage' a) where
toJSON (RequestMessage' rpc id method params) =
object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
sendNotification :: ToJSON a
=> ClientMethod
-> a
-> Session ()
sendNotification TextDocumentDidOpen params = do
let params' = fromJust $ decode $ encode params
n :: DidOpenTextDocumentNotification
n = NotificationMessage "2.0" TextDocumentDidOpen params'
oldVFS <- vfs <$> get
let (newVFS,_) = openVFS oldVFS n
modify (\s -> s { vfs = newVFS })
sendMessage n
sendNotification TextDocumentDidClose params = do
let params' = fromJust $ decode $ encode params
n :: DidCloseTextDocumentNotification
n = NotificationMessage "2.0" TextDocumentDidClose params'
oldVFS <- vfs <$> get
let (newVFS,_) = closeVFS oldVFS n
modify (\s -> s { vfs = newVFS })
sendMessage n
sendNotification TextDocumentDidChange params = do
let params' = fromJust $ decode $ encode params
n :: DidChangeTextDocumentNotification
n = NotificationMessage "2.0" TextDocumentDidChange params'
oldVFS <- vfs <$> get
let (newVFS,_) = changeFromClientVFS oldVFS n
modify (\s -> s { vfs = newVFS })
sendMessage n
sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
sendResponse :: ToJSON a => ResponseMessage a -> Session ()
sendResponse = sendMessage
initializeResponse :: Session InitializeResponse
initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
openDoc :: FilePath -> String -> Session TextDocumentIdentifier
openDoc file languageId = do
context <- ask
let fp = rootDir context </> file
contents <- liftIO $ T.readFile fp
openDoc' file languageId contents
openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
openDoc' file languageId contents = do
context <- ask
let fp = rootDir context </> file
uri = filePathToUri fp
item = TextDocumentItem uri (T.pack languageId) 0 contents
sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
pure $ TextDocumentIdentifier uri
closeDoc :: TextDocumentIdentifier -> Session ()
closeDoc docId = do
let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
sendNotification TextDocumentDidClose params
changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
changeDoc docId changes = do
verDoc <- getVersionedDoc docId
let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
sendNotification TextDocumentDidChange params
getDocUri :: FilePath -> Session Uri
getDocUri file = do
context <- ask
let fp = rootDir context </> file
return $ filePathToUri fp
waitForDiagnostics :: Session [Diagnostic]
waitForDiagnostics = do
diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
let (List diags) = diagsNot ^. params . LSP.diagnostics
return diags
waitForDiagnosticsSource :: String -> Session [Diagnostic]
waitForDiagnosticsSource src = do
diags <- waitForDiagnostics
let res = filter matches diags
if null res
then waitForDiagnosticsSource src
else return res
where
matches :: Diagnostic -> Bool
matches d = d ^. source == Just (T.pack src)
noDiagnostics :: Session ()
noDiagnostics = do
diagsNot <- message :: Session PublishDiagnosticsNotification
when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
getDocumentSymbols doc = do
ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
case mRes of
Just (DSDocumentSymbols (List xs)) -> return (Left xs)
Just (DSSymbolInformation (List xs)) -> return (Right xs)
Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
getCodeActions doc range = do
ctx <- getCodeActionContext doc
rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
case rsp ^. result of
Just (List xs) -> return xs
_ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
getAllCodeActions doc = do
ctx <- getCodeActionContext doc
foldM (go ctx) [] =<< getCurrentDiagnostics doc
where
go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
go ctx acc diag = do
ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
case mErr of
Just e -> throw (UnexpectedResponseError rspLid e)
Nothing ->
let Just (List cmdOrCAs) = mRes
in return (acc ++ cmdOrCAs)
getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
getCodeActionContext doc = do
curDiags <- getCurrentDiagnostics doc
return $ CodeActionContext (List curDiags) Nothing
getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
executeCommand :: Command -> Session ()
executeCommand cmd = do
let args = decode $ encode $ fromJust $ cmd ^. arguments
execParams = ExecuteCommandParams (cmd ^. command) args Nothing
request_ WorkspaceExecuteCommand execParams
executeCodeAction :: CodeAction -> Session ()
executeCodeAction action = do
maybe (return ()) handleEdit $ action ^. edit
maybe (return ()) executeCommand $ action ^. command
where handleEdit :: WorkspaceEdit -> Session ()
handleEdit e =
let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
in updateState (ReqApplyWorkspaceEdit req)
getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
getVersionedDoc (TextDocumentIdentifier uri) = do
fs <- vfsMap . vfs <$> get
let ver =
case fs Map.!? toNormalizedUri uri of
Just vf -> Just (virtualFileVersion vf)
_ -> Nothing
return (VersionedTextDocumentIdentifier uri ver)
applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
applyEdit doc edit = do
verDoc <- getVersionedDoc doc
caps <- asks sessionCapabilities
let supportsDocChanges = fromMaybe False $ do
let mWorkspace = C._workspace caps
C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
mDocChanges
let wEdit = if supportsDocChanges
then
let docEdit = TextDocumentEdit verDoc (List [edit])
in WorkspaceEdit Nothing (Just (List [docEdit]))
else
let changes = HashMap.singleton (doc ^. uri) (List [edit])
in WorkspaceEdit (Just changes) Nothing
let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
updateState (ReqApplyWorkspaceEdit req)
getVersionedDoc doc
getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions doc pos = do
rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
case getResponseResult rsp of
Completions (List items) -> return items
CompletionList (CompletionListType _ (List items)) -> return items
getReferences :: TextDocumentIdentifier
-> Position
-> Bool
-> Session [Location]
getReferences doc pos inclDecl =
let ctx = ReferenceContext inclDecl
params = ReferenceParams doc pos ctx Nothing
in getResponseResult <$> request TextDocumentReferences params
getDefinitions :: TextDocumentIdentifier
-> Position
-> Session [Location]
getDefinitions doc pos = do
let params = TextDocumentPositionParams doc pos Nothing
rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
case getResponseResult rsp of
SingleLoc loc -> pure [loc]
MultiLoc locs -> pure locs
getTypeDefinitions :: TextDocumentIdentifier
-> Position
-> Session [Location]
getTypeDefinitions doc pos =
let params = TextDocumentPositionParams doc pos Nothing
in getResponseResult <$> request TextDocumentTypeDefinition params
rename :: TextDocumentIdentifier -> Position -> String -> Session ()
rename doc pos newName = do
let params = RenameParams doc pos (T.pack newName) Nothing
rsp <- request TextDocumentRename params :: Session RenameResponse
let wEdit = getResponseResult rsp
req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
updateState (ReqApplyWorkspaceEdit req)
getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover doc pos =
let params = TextDocumentPositionParams doc pos Nothing
in getResponseResult <$> request TextDocumentHover params
getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
getHighlights doc pos =
let params = TextDocumentPositionParams doc pos Nothing
in getResponseResult <$> request TextDocumentDocumentHighlight params
getResponseResult :: ResponseMessage a -> a
getResponseResult rsp = fromMaybe exc (rsp ^. result)
where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
(fromJust $ rsp ^. LSP.error)
formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
formatDoc doc opts = do
let params = DocumentFormattingParams doc opts Nothing
edits <- getResponseResult <$> request TextDocumentFormatting params
applyTextEdits doc edits
formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
formatRange doc opts range = do
let params = DocumentRangeFormattingParams doc range opts Nothing
edits <- getResponseResult <$> request TextDocumentRangeFormatting params
applyTextEdits doc edits
applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
applyTextEdits doc edits =
let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
in updateState (ReqApplyWorkspaceEdit req)
getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
getCodeLenses tId = do
rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
case getResponseResult rsp of
List res -> pure res