{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE NamedFieldPuns           #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE PolyKinds                #-}
module Test.Hls
  ( module Test.Tasty.HUnit,
    module Test.Tasty,
    module Test.Tasty.ExpectedFailure,
    module Test.Hls.Util,
    module Language.LSP.Types,
    module Language.LSP.Test,
    module Control.Monad.IO.Class,
    module Control.Applicative.Combinators,
    defaultTestRunner,
    goldenGitDiff,
    goldenWithHaskellDoc,
    goldenWithHaskellDocFormatter,
    def,
    runSessionWithServer,
    runSessionWithServerFormatter,
    runSessionWithServer',
    waitForProgressDone,
    waitForAllProgressDone,
    PluginDescriptor,
    IdeState,
    waitForBuildQueue,
    waitForTypecheck,
    waitForAction,
    sendConfigurationChanged,
    getLastBuildKeys,
    waitForKickDone,
    waitForKickStart,
    )
where

import           Control.Applicative.Combinators
import           Control.Concurrent.Async        (async, cancel, wait)
import           Control.Concurrent.Extra
import           Control.Exception.Base
import           Control.Monad                   (guard, unless, void)
import           Control.Monad.IO.Class
import           Data.Aeson                      (Result (Success),
                                                  Value (Null), fromJSON,
                                                  toJSON)
import qualified Data.Aeson                      as A
import           Data.ByteString.Lazy            (ByteString)
import           Data.Default                    (def)
import qualified Data.Map                        as M
import           Data.Maybe                      (fromMaybe)
import qualified Data.Text                       as T
import qualified Data.Text.Lazy                  as TL
import qualified Data.Text.Lazy.Encoding         as TL
import           Development.IDE                 (IdeState)
import           Development.IDE.Main            hiding (Log)
import qualified Development.IDE.Main            as Ghcide
import qualified Development.IDE.Main            as IDEMain
import           Development.IDE.Plugin.Test     (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
                                                  WaitForIdeRuleResult (ideResultSuccess))
import qualified Development.IDE.Plugin.Test     as Test
import           Development.IDE.Types.Logger    (Logger (Logger),
                                                  Pretty (pretty),
                                                  Priority (Debug),
                                                  Recorder (Recorder, logger_),
                                                  WithPriority (WithPriority, priority),
                                                  cfilter, cmapWithPrio,
                                                  makeDefaultStderrRecorder)
import           Development.IDE.Types.Options
import           GHC.IO.Handle
import           GHC.Stack                       (emptyCallStack)
import           Ide.Plugin.Config               (Config, PluginConfig,
                                                  formattingProvider, plugins)
import           Ide.PluginUtils                 (idePluginsToPluginDesc,
                                                  pluginDescToIdePlugins)
import           Ide.Types
import           Language.LSP.Test
import           Language.LSP.Types              hiding
                                                 (SemanticTokenAbsolute (length, line),
                                                  SemanticTokenRelative (length),
                                                  SemanticTokensEdit (_start))
import           Language.LSP.Types.Capabilities (ClientCapabilities)
import           Prelude                         hiding (log)
import           System.Directory                (getCurrentDirectory,
                                                  setCurrentDirectory)
import           System.Environment              (lookupEnv)
import           System.FilePath
import           System.IO.Unsafe                (unsafePerformIO)
import           System.Process.Extra            (createPipe)
import           System.Time.Extra
import           Test.Hls.Util
import           Test.Tasty                      hiding (Timeout)
import           Test.Tasty.ExpectedFailure
import           Test.Tasty.Golden
import           Test.Tasty.HUnit
import           Test.Tasty.Ingredients.Rerun

newtype Log = LogIDEMain IDEMain.Log

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogIDEMain Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log

-- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner = TestTree -> IO ()
defaultMainWithRerun forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Integer -> Timeout
mkTimeout Integer
600000000)

gitDiff :: FilePath -> FilePath -> [String]
gitDiff :: FilePath -> FilePath -> [FilePath]
gitDiff FilePath
fRef FilePath
fNew = [FilePath
"git", FilePath
"-c", FilePath
"core.fileMode=false", FilePath
"diff", FilePath
"--no-index", FilePath
"--text", FilePath
"--exit-code", FilePath
fRef, FilePath
fNew]

goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree
goldenGitDiff :: FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
name = FilePath
-> (FilePath -> FilePath -> [FilePath])
-> FilePath
-> IO ByteString
-> TestTree
goldenVsStringDiff FilePath
name FilePath -> FilePath -> [FilePath]
gitDiff

goldenWithHaskellDoc
  :: PluginDescriptor IdeState
  -> TestName
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithHaskellDoc :: PluginDescriptor IdeState
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDoc PluginDescriptor IdeState
plugin FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
  FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
  forall a b. (a -> b) -> a -> b
$ forall a.
PluginDescriptor IdeState -> FilePath -> Session a -> IO a
runSessionWithServer PluginDescriptor IdeState
plugin FilePath
testDataDir
  forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
"haskell"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

goldenWithHaskellDocFormatter
  :: PluginDescriptor IdeState
  -> String
  -> PluginConfig
  -> TestName
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithHaskellDocFormatter :: PluginDescriptor IdeState
-> FilePath
-> PluginConfig
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter PluginDescriptor IdeState
plugin FilePath
formatter PluginConfig
conf FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
  FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
  forall a b. (a -> b) -> a -> b
$ forall a.
PluginDescriptor IdeState
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginDescriptor IdeState
plugin FilePath
formatter PluginConfig
conf FilePath
testDataDir
  forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
"haskell"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
    TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
    TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc

runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a
runSessionWithServer :: forall a.
PluginDescriptor IdeState -> FilePath -> Session a -> IO a
runSessionWithServer PluginDescriptor IdeState
plugin = forall a.
[PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' [PluginDescriptor IdeState
plugin] forall a. Default a => a
def forall a. Default a => a
def ClientCapabilities
fullCaps

runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter :: forall a.
PluginDescriptor IdeState
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginDescriptor IdeState
plugin FilePath
formatter PluginConfig
conf =
  forall a.
[PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer'
    [PluginDescriptor IdeState
plugin]
    forall a. Default a => a
def
      { formattingProvider :: Text
formattingProvider = FilePath -> Text
T.pack FilePath
formatter
      , plugins :: Map Text PluginConfig
plugins = forall k a. k -> a -> Map k a
M.singleton (FilePath -> Text
T.pack FilePath
formatter) PluginConfig
conf
      }
    forall a. Default a => a
def
    ClientCapabilities
fullCaps

-- | Restore cwd after running an action
keepCurrentDirectory :: IO a -> IO a
keepCurrentDirectory :: forall a. IO a -> IO a
keepCurrentDirectory = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FilePath
getCurrentDirectory FilePath -> IO ()
setCurrentDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

{-# NOINLINE lock #-}
-- | Never run in parallel
lock :: Lock
lock :: Lock
lock = forall a. IO a -> a
unsafePerformIO IO Lock
newLock


-- | Host a server, and run a test session on it
-- Note: cwd will be shifted into @root@ in @Session a@
runSessionWithServer' ::
  -- | plugins to load on the server
  [PluginDescriptor IdeState] ->
  -- | lsp config for the server
  Config ->
  -- | config for the test session
  SessionConfig ->
  ClientCapabilities ->
  FilePath ->
  Session a ->
  IO a
runSessionWithServer' :: forall a.
[PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' [PluginDescriptor IdeState]
plugins Config
conf SessionConfig
sconf ClientCapabilities
caps FilePath
root Session a
s = forall a. Lock -> IO a -> IO a
withLock Lock
lock forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
keepCurrentDirectory forall a b. (a -> b) -> a -> b
$ do
    (Handle
inR, Handle
inW) <- IO (Handle, Handle)
createPipe
    (Handle
outR, Handle
outW) <- IO (Handle, Handle)
createPipe

    Recorder (WithPriority (Doc Any))
docWithPriorityRecorder <- forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn]
-> Priority -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder forall a. Maybe a
Nothing Priority
Debug

    FilePath
logStdErr <- forall a. a -> Maybe a -> a
fromMaybe FilePath
"0" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"LSP_TEST_LOG_STDERR"

    let
        docWithFilteredPriorityRecorder :: Recorder (WithPriority (Doc Any))
docWithFilteredPriorityRecorder@Recorder{ forall (m :: * -> *). MonadIO m => WithPriority (Doc Any) -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => WithPriority (Doc Any) -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ } =
            if FilePath
logStdErr forall a. Eq a => a -> a -> Bool
== FilePath
"0" then forall a. Monoid a => a
mempty
            else forall a. (a -> Bool) -> Recorder a -> Recorder a
cfilter (\WithPriority{ Priority
priority :: Priority
priority :: forall a. WithPriority a -> Priority
priority } -> Priority
priority forall a. Ord a => a -> a -> Bool
>= Priority
Debug) Recorder (WithPriority (Doc Any))
docWithPriorityRecorder

        -- exists until old logging style is phased out
        logger :: Logger
logger = (Priority -> Text -> IO ()) -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Priority
p Text
m -> forall (m :: * -> *). MonadIO m => WithPriority (Doc Any) -> m ()
logger_ (forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
p CallStack
emptyCallStack (forall a ann. Pretty a => a -> Doc ann
pretty Text
m))

        recorder :: Recorder (WithPriority Log)
recorder = forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio forall a ann. Pretty a => a -> Doc ann
pretty Recorder (WithPriority (Doc Any))
docWithFilteredPriorityRecorder

        arguments :: Arguments
arguments@Arguments{ IdePlugins IdeState
argsHlsPlugins :: Arguments -> IdePlugins IdeState
argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins, Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions, IO Logger
argsLogger :: Arguments -> IO Logger
argsLogger :: IO Logger
argsLogger } = Recorder (WithPriority Log) -> Logger -> Arguments
defaultArguments (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder) Logger
logger

        hlsPlugins :: [PluginDescriptor IdeState]
hlsPlugins =
            [PluginDescriptor IdeState]
plugins
            forall a. [a] -> [a] -> [a]
++ [forall state. PluginId -> PluginDescriptor state
Test.blockCommandDescriptor PluginId
"block-command", PluginDescriptor IdeState
Test.plugin]
            forall a. [a] -> [a] -> [a]
++ forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
idePluginsToPluginDesc IdePlugins IdeState
argsHlsPlugins
        ideOptions :: Config -> Action IdeGhcSession -> IdeOptions
ideOptions Config
config Action IdeGhcSession
ghcSession =
            let defIdeOptions :: IdeOptions
defIdeOptions = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
config Action IdeGhcSession
ghcSession
            in IdeOptions
defIdeOptions
                    { optTesting :: IdeTesting
optTesting = Bool -> IdeTesting
IdeTesting Bool
True
                    , optCheckProject :: IO Bool
optCheckProject = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                    }

    Async ()
server <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$
        Recorder (WithPriority Log) -> Arguments -> IO ()
Ghcide.defaultMain (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder)
            Arguments
arguments
                { argsHandleIn :: IO Handle
argsHandleIn = forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
inR
                , argsHandleOut :: IO Handle
argsHandleOut = forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
outW
                , argsDefaultHlsConfig :: Config
argsDefaultHlsConfig = Config
conf
                , argsLogger :: IO Logger
argsLogger = IO Logger
argsLogger
                , argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = Config -> Action IdeGhcSession -> IdeOptions
ideOptions
                , argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins [PluginDescriptor IdeState]
hlsPlugins
                }

    a
x <- forall a.
Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithHandles Handle
inW Handle
outR SessionConfig
sconf ClientCapabilities
caps FilePath
root Session a
s
    Handle -> IO ()
hClose Handle
inW
    forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
3 (forall a. Async a -> IO a
wait Async ()
server) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe ()
Nothing -> do
            FilePath -> IO ()
putStrLn FilePath
"Server does not exit in 3s, canceling the async task..."
            (Seconds
t, ()
_) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO ()
cancel Async ()
server
            FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Finishing canceling (took " forall a. Semigroup a => a -> a -> a
<> Seconds -> FilePath
showDuration Seconds
t forall a. Semigroup a => a -> a -> a
<> FilePath
"s)"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | Wait for the next progress end step
waitForProgressDone :: Session ()
waitForProgressDone :: Session ()
waitForProgressDone = forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess SMethod m
SProgress (NotificationMessage Text
_ SMethod 'Progress
_ (ProgressParams ProgressToken
_ (End WorkDoneProgressEndParams
_))) -> forall a. a -> Maybe a
Just ()
  FromServerMessage
_ -> forall a. Maybe a
Nothing

-- | Wait for all progress to be done
-- Needs at least one progress done notification to return
waitForAllProgressDone :: Session ()
waitForAllProgressDone :: Session ()
waitForAllProgressDone = Session ()
loop
  where
    loop :: Session ()
loop = do
      ~() <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
        FromServerMess SMethod m
SProgress (NotificationMessage Text
_ SMethod 'Progress
_ (ProgressParams ProgressToken
_ (End WorkDoneProgressEndParams
_))) -> forall a. a -> Maybe a
Just ()
        FromServerMessage
_ -> forall a. Maybe a
Nothing
      Bool
done <- forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Set ProgressToken)
getIncompleteProgressSessions
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done Session ()
loop

-- | Wait for the build queue to be empty
waitForBuildQueue :: Session Seconds
waitForBuildQueue :: Session Seconds
waitForBuildQueue = do
    let m :: SMethod 'CustomMethod
m = forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
waitId <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
m (forall a. ToJSON a => a -> Value
toJSON TestRequest
WaitForShakeQueue)
    (Seconds
td, ResponseMessage 'CustomMethod
resp) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
m LspId 'CustomMethod
waitId
    case ResponseMessage 'CustomMethod
resp of
        ResponseMessage{$sel:_result:ResponseMessage :: forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Either ResponseError (ResponseResult m)
_result=Right Value
ResponseResult 'CustomMethod
Null} -> forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
td
        -- assume a ghcide binary lacking the WaitForShakeQueue method
        ResponseMessage 'CustomMethod
_                                   -> forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
0

callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
callTestPlugin :: forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin TestRequest
cmd = do
    let cm :: SMethod 'CustomMethod
cm = forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
waitId <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm (forall a. ToJSON a => a -> Value
A.toJSON TestRequest
cmd)
    ResponseMessage{Either ResponseError (ResponseResult 'CustomMethod)
_result :: Either ResponseError (ResponseResult 'CustomMethod)
$sel:_result:ResponseMessage :: forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Either ResponseError (ResponseResult m)
_result} <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm LspId 'CustomMethod
waitId
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      Value
e <- Either ResponseError (ResponseResult 'CustomMethod)
_result
      case forall a. FromJSON a => Value -> Result a
A.fromJSON Value
e of
        A.Error FilePath
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (FilePath -> Text
T.pack FilePath
err) forall a. Maybe a
Nothing
        A.Success b
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a

waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction :: FilePath
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction FilePath
key TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} =
    forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin (FilePath -> Uri -> TestRequest
WaitForIdeRule FilePath
key Uri
_uri)

waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)
waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)
waitForTypecheck TextDocumentIdentifier
tid = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WaitForIdeRuleResult -> Bool
ideResultSuccess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction FilePath
"typecheck" TextDocumentIdentifier
tid

getLastBuildKeys :: Session (Either ResponseError [T.Text])
getLastBuildKeys :: Session (Either ResponseError [Text])
getLastBuildKeys = forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin TestRequest
GetBuildKeysBuilt

sendConfigurationChanged :: Value -> Session ()
sendConfigurationChanged :: Value -> Session ()
sendConfigurationChanged Value
config =
  forall (m :: Method 'FromClient 'Notification).
SClientMethod m -> MessageParams m -> Session ()
sendNotification SMethod 'WorkspaceDidChangeConfiguration
SWorkspaceDidChangeConfiguration (Value -> DidChangeConfigurationParams
DidChangeConfigurationParams Value
config)

waitForKickDone :: Session ()
waitForKickDone :: Session ()
waitForKickDone = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage Session ()
nonTrivialKickDone

waitForKickStart :: Session ()
waitForKickStart :: Session ()
waitForKickStart = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage Session ()
nonTrivialKickStart

nonTrivialKickDone :: Session ()
nonTrivialKickDone :: Session ()
nonTrivialKickDone = Text -> Session [FilePath]
kick Text
"done" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null

nonTrivialKickStart :: Session ()
nonTrivialKickStart :: Session ()
nonTrivialKickStart = Text -> Session [FilePath]
kick Text
"start" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null

kick :: T.Text -> Session [FilePath]
kick :: Text -> Session [FilePath]
kick Text
msg = do
  NotMess NotificationMessage{MessageParams 'CustomMethod
$sel:_params:NotificationMessage :: forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> MessageParams m
_params :: MessageParams 'CustomMethod
_params} <- Text -> Session (ServerMessage 'CustomMethod)
customNotification forall a b. (a -> b) -> a -> b
$ Text
"kick/" forall a. Semigroup a => a -> a -> a
<> Text
msg
  case forall a. FromJSON a => Value -> Result a
fromJSON MessageParams 'CustomMethod
_params of
    Success [FilePath]
x -> forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
x
    Result [FilePath]
other     -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to parse kick/done details: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Result [FilePath]
other