{-# LANGUAGE GADTs             #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds         #-}
{-# LANGUAGE RecordWildCards   #-}
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           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, noLogging)
import           Development.IDE.Graph           (ShakeOptions (shakeThreads))
import           Development.IDE.Main
import qualified Development.IDE.Main            as Ghcide
import           Development.IDE.Plugin.Test     (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
                                                  WaitForIdeRuleResult (ideResultSuccess))
import           Development.IDE.Types.Options
import           GHC.IO.Handle
import           Ide.Plugin.Config               (Config, formattingProvider)
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           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

-- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner = TestTree -> IO ()
defaultMainWithRerun (TestTree -> IO ()) -> (TestTree -> TestTree) -> TestTree -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Timeout -> Timeout) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (Timeout -> Timeout -> Timeout
forall a b. a -> b -> a
const (Timeout -> Timeout -> Timeout) -> Timeout -> Timeout -> Timeout
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)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ PluginDescriptor IdeState
-> FilePath -> Session ByteString -> IO ByteString
forall a.
PluginDescriptor IdeState -> FilePath -> Session a -> IO a
runSessionWithServer PluginDescriptor IdeState
plugin FilePath
testDataDir
  (Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  (Text -> ByteString) -> Session Text -> Session ByteString
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"
    Session Seconds -> Session ()
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
  -> TestName
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> (TextDocumentIdentifier -> Session ())
  -> TestTree
goldenWithHaskellDocFormatter :: PluginDescriptor IdeState
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter PluginDescriptor IdeState
plugin FilePath
formatter 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)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ PluginDescriptor IdeState
-> FilePath -> FilePath -> Session ByteString -> IO ByteString
forall a.
PluginDescriptor IdeState
-> FilePath -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginDescriptor IdeState
plugin FilePath
formatter FilePath
testDataDir
  (Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  (Text -> ByteString) -> Session Text -> Session ByteString
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"
    Session Seconds -> Session ()
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 :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a
runSessionWithServer PluginDescriptor IdeState
plugin = [PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
forall a.
[PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' [PluginDescriptor IdeState
plugin] Config
forall a. Default a => a
def SessionConfig
forall a. Default a => a
def ClientCapabilities
fullCaps

runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> FilePath -> Session a -> IO a
runSessionWithServerFormatter :: PluginDescriptor IdeState
-> FilePath -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginDescriptor IdeState
plugin FilePath
formatter =
  [PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
forall a.
[PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer'
    [PluginDescriptor IdeState
plugin]
    Config
forall a. Default a => a
def {formattingProvider :: Text
formattingProvider = FilePath -> Text
T.pack FilePath
formatter}
    SessionConfig
forall a. Default a => a
def
    ClientCapabilities
fullCaps

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

{-# NOINLINE lock #-}
-- | Never run in parallel
lock :: Lock
lock :: Lock
lock = IO 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' :: [PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' [PluginDescriptor IdeState]
plugin Config
conf SessionConfig
sconf ClientCapabilities
caps FilePath
root Session a
s = Lock -> IO a -> IO a
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
keepCurrentDirectory (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  (Handle
inR, Handle
inW) <- IO (Handle, Handle)
createPipe
  (Handle
outR, Handle
outW) <- IO (Handle, Handle)
createPipe
  let logger :: IO Logger
logger = do
        FilePath
logStdErr <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"0" (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"LSP_TEST_LOG_STDERR"
        if FilePath
logStdErr FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"0"
            then Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return Logger
noLogging
            else Arguments -> IO Logger
argsLogger Arguments
testing

  Async ()
server <-
    IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
      Arguments -> IO ()
Ghcide.defaultMain
        Arguments
testing
          { argsHandleIn :: IO Handle
argsHandleIn = Handle -> IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
inR,
            argsHandleOut :: IO Handle
argsHandleOut = Handle -> IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
outW,
            argsDefaultHlsConfig :: Config
argsDefaultHlsConfig = Config
conf,
            argsLogger :: IO Logger
argsLogger = IO Logger
logger,
            argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = \Config
config Action IdeGhcSession
sessionLoader ->
              let ideOptions :: IdeOptions
ideOptions = (Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Arguments
forall a. Default a => a
def Config
config Action IdeGhcSession
sessionLoader)
                    {optTesting :: IdeTesting
optTesting = Bool -> IdeTesting
IdeTesting Bool
True
                    ,optCheckProject :: IO Bool
optCheckProject = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                    }
               in IdeOptions
ideOptions {optShakeOptions :: ShakeOptions
optShakeOptions = (IdeOptions -> ShakeOptions
optShakeOptions IdeOptions
ideOptions) {shakeThreads :: Int
shakeThreads = Int
2}},
            argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins = [PluginDescriptor IdeState] -> IdePlugins IdeState
forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins ([PluginDescriptor IdeState] -> IdePlugins IdeState)
-> [PluginDescriptor IdeState] -> IdePlugins IdeState
forall a b. (a -> b) -> a -> b
$ [PluginDescriptor IdeState]
plugin [PluginDescriptor IdeState]
-> [PluginDescriptor IdeState] -> [PluginDescriptor IdeState]
forall a. [a] -> [a] -> [a]
++ IdePlugins IdeState -> [PluginDescriptor IdeState]
forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
idePluginsToPluginDesc (Arguments -> IdePlugins IdeState
argsHlsPlugins Arguments
testing)
          }
  a
x <- Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
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
  Seconds -> IO () -> IO (Maybe ())
forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
3 (Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
server) IO (Maybe ()) -> (Maybe () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just () -> () -> IO ()
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, ()
_) <- IO () -> IO (Seconds, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (IO () -> IO (Seconds, ())) -> IO () -> IO (Seconds, ())
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
server
      FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Finishing canceling (took " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Seconds -> FilePath
showDuration Seconds
t FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"s)"
  a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | Wait for the next progress end step
waitForProgressDone :: Session ()
waitForProgressDone :: Session ()
waitForProgressDone = Session FromServerMessage -> Session () -> Session ()
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Maybe ()) -> Session ()
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe ((FromServerMessage -> Maybe ()) -> Session ())
-> (FromServerMessage -> Maybe ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess SMethod m
SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
  FromServerMessage
_ -> Maybe ()
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
      ~() <- Session FromServerMessage -> Session () -> Session ()
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Maybe ()) -> Session ()
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe ((FromServerMessage -> Maybe ()) -> Session ())
-> (FromServerMessage -> Maybe ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \case
        FromServerMess SMethod m
SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
        FromServerMessage
_ -> Maybe ()
forall a. Maybe a
Nothing
      Bool
done <- Set ProgressToken -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set ProgressToken -> Bool)
-> Session (Set ProgressToken) -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Set ProgressToken)
getIncompleteProgressSessions
      Bool -> Session () -> Session ()
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 = Text -> SMethod 'CustomMethod
forall (f :: From) (t :: MethodType). Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
waitId <- SClientMethod 'CustomMethod
-> MessageParams 'CustomMethod -> Session (LspId 'CustomMethod)
forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest SClientMethod 'CustomMethod
forall (f :: From) (t :: MethodType). SMethod 'CustomMethod
m (TestRequest -> Value
forall a. ToJSON a => a -> Value
toJSON TestRequest
WaitForShakeQueue)
    (Seconds
td, ResponseMessage 'CustomMethod
resp) <- Session (ResponseMessage 'CustomMethod)
-> Session (Seconds, ResponseMessage 'CustomMethod)
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (Session (ResponseMessage 'CustomMethod)
 -> Session (Seconds, ResponseMessage 'CustomMethod))
-> Session (ResponseMessage 'CustomMethod)
-> Session (Seconds, ResponseMessage 'CustomMethod)
forall a b. (a -> b) -> a -> b
$ Session FromServerMessage
-> Session (ResponseMessage 'CustomMethod)
-> Session (ResponseMessage 'CustomMethod)
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session (ResponseMessage 'CustomMethod)
 -> Session (ResponseMessage 'CustomMethod))
-> Session (ResponseMessage 'CustomMethod)
-> Session (ResponseMessage 'CustomMethod)
forall a b. (a -> b) -> a -> b
$ SClientMethod 'CustomMethod
-> LspId 'CustomMethod -> Session (ResponseMessage 'CustomMethod)
forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId SClientMethod 'CustomMethod
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 ResponseResult 'CustomMethod
Null} -> Seconds -> Session Seconds
forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
td
        -- assume a ghcide binary lacking the WaitForShakeQueue method
        ResponseMessage 'CustomMethod
_                                   -> Seconds -> Session Seconds
forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
0

callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
callTestPlugin :: TestRequest -> Session (Either ResponseError b)
callTestPlugin TestRequest
cmd = do
    let cm :: SMethod 'CustomMethod
cm = Text -> SMethod 'CustomMethod
forall (f :: From) (t :: MethodType). Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
waitId <- SClientMethod 'CustomMethod
-> MessageParams 'CustomMethod -> Session (LspId 'CustomMethod)
forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest SClientMethod 'CustomMethod
forall (f :: From) (t :: MethodType). SMethod 'CustomMethod
cm (TestRequest -> Value
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} <- Session FromServerMessage
-> Session (ResponseMessage 'CustomMethod)
-> Session (ResponseMessage 'CustomMethod)
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session (ResponseMessage 'CustomMethod)
 -> Session (ResponseMessage 'CustomMethod))
-> Session (ResponseMessage 'CustomMethod)
-> Session (ResponseMessage 'CustomMethod)
forall a b. (a -> b) -> a -> b
$ SClientMethod 'CustomMethod
-> LspId 'CustomMethod -> Session (ResponseMessage 'CustomMethod)
forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId SClientMethod 'CustomMethod
forall (f :: From) (t :: MethodType). SMethod 'CustomMethod
cm LspId 'CustomMethod
waitId
    Either ResponseError b -> Session (Either ResponseError b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError b -> Session (Either ResponseError b))
-> Either ResponseError b -> Session (Either ResponseError b)
forall a b. (a -> b) -> a -> b
$ do
      Value
e <- Either ResponseError Value
Either ResponseError (ResponseResult 'CustomMethod)
_result
      case Value -> Result b
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
e of
        A.Error FilePath
err -> ResponseError -> Either ResponseError b
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError b)
-> ResponseError -> Either ResponseError b
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (FilePath -> Text
T.pack FilePath
err) Maybe Value
forall a. Maybe a
Nothing
        A.Success b
a -> b -> Either ResponseError b
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} =
    TestRequest -> Session (Either ResponseError WaitForIdeRuleResult)
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 = (WaitForIdeRuleResult -> Bool)
-> Either ResponseError WaitForIdeRuleResult
-> Either ResponseError Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WaitForIdeRuleResult -> Bool
ideResultSuccess (Either ResponseError WaitForIdeRuleResult
 -> Either ResponseError Bool)
-> Session (Either ResponseError WaitForIdeRuleResult)
-> Session (Either ResponseError Bool)
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 = TestRequest -> Session (Either ResponseError [Text])
forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin TestRequest
GetBuildKeysBuilt

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

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

waitForKickStart :: Session ()
waitForKickStart :: Session ()
waitForKickStart = Session () -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ Session FromServerMessage -> Session () -> Session ()
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" Session [FilePath] -> ([FilePath] -> Session ()) -> Session ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Session ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Session ())
-> ([FilePath] -> Bool) -> [FilePath] -> Session ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> ([FilePath] -> Bool) -> [FilePath] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null

nonTrivialKickStart :: Session ()
nonTrivialKickStart :: Session ()
nonTrivialKickStart = Text -> Session [FilePath]
kick Text
"start" Session [FilePath] -> ([FilePath] -> Session ()) -> Session ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Session ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Session ())
-> ([FilePath] -> Bool) -> [FilePath] -> Session ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> ([FilePath] -> Bool) -> [FilePath] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> Bool
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 (Text -> Session (ServerMessage 'CustomMethod))
-> Text -> Session (ServerMessage 'CustomMethod)
forall a b. (a -> b) -> a -> b
$ Text
"kick/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
  case Value -> Result [FilePath]
forall a. FromJSON a => Value -> Result a
fromJSON Value
MessageParams 'CustomMethod
_params of
    Success [FilePath]
x -> [FilePath] -> Session [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
x
    Result [FilePath]
other     -> FilePath -> Session [FilePath]
forall a. HasCallStack => FilePath -> a
error (FilePath -> Session [FilePath]) -> FilePath -> Session [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to parse kick/done details: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Result [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show Result [FilePath]
other