{-# 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           Data.Maybe                      (fromMaybe)
import qualified Data.Map                        as M
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, formattingProvider, PluginConfig, 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 :: Log -> Doc ann
pretty = \case
    LogIDEMain Log
log -> Log -> Doc ann
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 (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
  -> 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)
  (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ PluginDescriptor IdeState
-> FilePath
-> PluginConfig
-> FilePath
-> Session ByteString
-> IO ByteString
forall a.
PluginDescriptor IdeState
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginDescriptor IdeState
plugin FilePath
formatter PluginConfig
conf 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 -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter :: PluginDescriptor IdeState
-> FilePath -> PluginConfig -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginDescriptor IdeState
plugin FilePath
formatter PluginConfig
conf =
  [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
      , plugins :: Map Text PluginConfig
plugins = Text -> PluginConfig -> Map Text PluginConfig
forall k a. k -> a -> Map k a
M.singleton (FilePath -> Text
T.pack FilePath
formatter) PluginConfig
conf
      }
    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]
plugins 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

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

  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"

  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 FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"0" then Recorder (WithPriority (Doc Any))
forall a. Monoid a => a
mempty
      else (WithPriority (Doc Any) -> Bool)
-> Recorder (WithPriority (Doc Any))
-> Recorder (WithPriority (Doc Any))
forall a. (a -> Bool) -> Recorder a -> Recorder a
cfilter (\WithPriority{ Priority
priority :: Priority
priority :: forall a. WithPriority a -> Priority
priority } -> Priority
priority Priority -> Priority -> Bool
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 ((Priority -> Text -> IO ()) -> Logger)
-> (Priority -> Text -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Priority
p Text
m -> WithPriority (Doc Any) -> IO ()
forall (m :: * -> *). MonadIO m => WithPriority (Doc Any) -> m ()
logger_ (Priority -> CallStack -> Doc Any -> WithPriority (Doc Any)
forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
p CallStack
emptyCallStack (Text -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Text
m))

    recorder :: Recorder (WithPriority Log)
recorder = (Log -> Doc Any)
-> Recorder (WithPriority (Doc Any)) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Doc Any
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 ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
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 =
      IdePlugins IdeState -> [PluginDescriptor IdeState]
forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
idePluginsToPluginDesc IdePlugins IdeState
argsHlsPlugins
      [PluginDescriptor IdeState]
-> [PluginDescriptor IdeState] -> [PluginDescriptor IdeState]
forall a. [a] -> [a] -> [a]
++ [PluginId -> PluginDescriptor IdeState
forall state. PluginId -> PluginDescriptor state
Test.blockCommandDescriptor PluginId
"block-command", PluginDescriptor IdeState
Test.plugin]
      [PluginDescriptor IdeState]
-> [PluginDescriptor IdeState] -> [PluginDescriptor IdeState]
forall a. [a] -> [a] -> [a]
++ [PluginDescriptor IdeState]
plugins
    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 = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
           }

  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
$
      Recorder (WithPriority Log) -> Arguments -> IO ()
Ghcide.defaultMain
        ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
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 = 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
argsLogger
          , argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = Config -> Action IdeGhcSession -> IdeOptions
ideOptions
          , argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins = [PluginDescriptor IdeState] -> IdePlugins IdeState
forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins [PluginDescriptor IdeState]
hlsPlugins }

  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