{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
module Test.Hls
( module Test.Tasty.HUnit,
module Test.Tasty,
module Test.Tasty.ExpectedFailure,
module Test.Hls.Util,
module Language.LSP.Protocol.Types,
module Language.LSP.Protocol.Message,
module Language.LSP.Test,
module Control.Monad.IO.Class,
module Control.Applicative.Combinators,
defaultTestRunner,
goldenGitDiff,
goldenWithHaskellDoc,
goldenWithHaskellAndCaps,
goldenWithCabalDoc,
goldenWithHaskellDocFormatter,
goldenWithCabalDocFormatter,
def,
runSessionWithServer,
runSessionWithServerAndCaps,
runSessionWithServer',
PluginDescriptor,
IdeState,
waitForProgressDone,
waitForAllProgressDone,
waitForBuildQueue,
waitForTypecheck,
waitForAction,
hlsConfigToClientConfig,
setHlsConfig,
getLastBuildKeys,
waitForKickDone,
waitForKickStart,
PluginTestDescriptor,
pluginTestRecorder,
mkPluginTestDescriptor,
mkPluginTestDescriptor',
WithPriority(..),
Recorder,
Priority(..),
)
where
import Control.Applicative.Combinators
import Control.Concurrent.Async (async, cancel, wait)
import Control.Concurrent.Extra
import Control.Exception.Base
import Control.Lens.Extras (is)
import Control.Monad (guard, unless, void)
import Control.Monad.Extra (forM)
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 Data.Proxy (Proxy (Proxy))
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.Options
import GHC.IO.Handle
import GHC.Stack (emptyCallStack)
import GHC.TypeLits
import Ide.Logger (Doc, Logger (Logger),
Pretty (pretty),
Priority (Debug),
Recorder (Recorder, logger_),
WithPriority (WithPriority, priority),
cfilter, cmapWithPrio,
makeDefaultStderrRecorder)
import Ide.Types
import Language.LSP.Protocol.Capabilities
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types hiding (Null)
import Language.LSP.Test
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
import Test.Tasty.Runners (NumThreads (..))
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
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
$ Int -> NumThreads
NumThreads Int
1) 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 :: String -> String -> [String]
gitDiff String
fRef String
fNew = [String
"git", String
"-c", String
"core.fileMode=false", String
"diff", String
"--no-index", String
"--text", String
"--exit-code", String
fRef, String
fNew]
goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree
goldenGitDiff :: String -> String -> IO ByteString -> TestTree
goldenGitDiff String
name = String
-> (String -> String -> [String])
-> String
-> IO ByteString
-> TestTree
goldenVsStringDiff String
name String -> String -> [String]
gitDiff
goldenWithHaskellDoc
:: Pretty b
=> Config
-> PluginTestDescriptor b
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDoc :: forall b.
Pretty b =>
Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDoc = forall b.
Pretty b =>
Text
-> Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc Text
"haskell"
goldenWithHaskellAndCaps
:: Pretty b
=> Config
-> ClientCapabilities
-> PluginTestDescriptor b
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellAndCaps :: forall b.
Pretty b =>
Config
-> ClientCapabilities
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellAndCaps Config
config ClientCapabilities
clientCaps PluginTestDescriptor b
plugin String
title String
testDataDir String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (String
testDataDir String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
Config
-> PluginTestDescriptor b
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServerAndCaps Config
config PluginTestDescriptor b
plugin ClientCapabilities
clientCaps String
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 <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
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
goldenWithCabalDoc
:: Pretty b
=> Config
-> PluginTestDescriptor b
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDoc :: forall b.
Pretty b =>
Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDoc = forall b.
Pretty b =>
Text
-> Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc Text
"cabal"
goldenWithDoc
:: Pretty b
=> T.Text
-> Config
-> PluginTestDescriptor b
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc :: forall b.
Pretty b =>
Text
-> Config
-> PluginTestDescriptor b
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithDoc Text
fileType Config
config PluginTestDescriptor b
plugin String
title String
testDataDir String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (String
testDataDir String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
Config -> PluginTestDescriptor b -> String -> Session a -> IO a
runSessionWithServer Config
config PluginTestDescriptor b
plugin String
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 <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
fileType
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
type PluginTestDescriptor b = Recorder (WithPriority b) -> IdePlugins IdeState
mkPluginTestDescriptor
:: (Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState)
-> PluginId
-> PluginTestDescriptor b
mkPluginTestDescriptor :: forall b.
(Recorder (WithPriority b)
-> PluginId -> PluginDescriptor IdeState)
-> PluginId -> PluginTestDescriptor b
mkPluginTestDescriptor Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState
pluginDesc PluginId
plId Recorder (WithPriority b)
recorder = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
IdePlugins [Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState
pluginDesc Recorder (WithPriority b)
recorder PluginId
plId]
mkPluginTestDescriptor'
:: (PluginId -> PluginDescriptor IdeState)
-> PluginId
-> PluginTestDescriptor b
mkPluginTestDescriptor' :: forall b.
(PluginId -> PluginDescriptor IdeState)
-> PluginId -> PluginTestDescriptor b
mkPluginTestDescriptor' PluginId -> PluginDescriptor IdeState
pluginDesc PluginId
plId Recorder (WithPriority b)
_recorder = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
IdePlugins [PluginId -> PluginDescriptor IdeState
pluginDesc PluginId
plId]
pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder :: forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder = do
(Recorder (WithPriority a)
recorder, WithPriority (Doc Any) -> IO ()
_) <- forall a ann.
Pretty a =>
[String]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder [String
"HLS_TEST_PLUGIN_LOG_STDERR", String
"HLS_TEST_LOG_STDERR"]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Recorder (WithPriority a)
recorder
initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder :: forall a ann.
Pretty a =>
[String]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder [String]
envVars = do
Recorder (WithPriority (Doc ann))
docWithPriorityRecorder <- forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder forall a. Maybe a
Nothing
[String]
definedEnvVars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
envVars (\String
var -> forall a. a -> Maybe a -> a
fromMaybe String
"0" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
var)
let logStdErr :: Bool
logStdErr = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
/= String
"0") [String]
definedEnvVars
docWithFilteredPriorityRecorder :: Recorder (WithPriority (Doc ann))
docWithFilteredPriorityRecorder =
if Bool
logStdErr then 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 ann))
docWithPriorityRecorder
else forall a. Monoid a => a
mempty
Recorder {forall (m :: * -> *). MonadIO m => WithPriority (Doc ann) -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => WithPriority (Doc ann) -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_} = Recorder (WithPriority (Doc ann))
docWithFilteredPriorityRecorder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio forall a ann. Pretty a => a -> Doc ann
pretty Recorder (WithPriority (Doc ann))
docWithFilteredPriorityRecorder, forall (m :: * -> *). MonadIO m => WithPriority (Doc ann) -> m ()
logger_)
runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a
runSessionWithServer :: forall b a.
Pretty b =>
Config -> PluginTestDescriptor b -> String -> Session a -> IO a
runSessionWithServer Config
config PluginTestDescriptor b
plugin String
fp Session a
act = do
Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServer' (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder) Config
config forall a. Default a => a
def ClientCapabilities
fullCaps String
fp Session a
act
runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a
runSessionWithServerAndCaps :: forall b a.
Pretty b =>
Config
-> PluginTestDescriptor b
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServerAndCaps Config
config PluginTestDescriptor b
plugin ClientCapabilities
caps String
fp Session a
act = do
Recorder (WithPriority b)
recorder <- forall a. Pretty a => IO (Recorder (WithPriority a))
pluginTestRecorder
forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServer' (PluginTestDescriptor b
plugin Recorder (WithPriority b)
recorder) Config
config forall a. Default a => a
def ClientCapabilities
caps String
fp Session a
act
goldenWithHaskellDocFormatter
:: Pretty b
=> Config
-> PluginTestDescriptor b
-> String
-> PluginConfig
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter :: forall b.
Pretty b =>
Config
-> PluginTestDescriptor b
-> String
-> PluginConfig
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter Config
config PluginTestDescriptor b
plugin String
formatter PluginConfig
conf String
title String
testDataDir String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
let config' :: Config
config' = Config
config { formattingProvider :: Text
formattingProvider = String -> Text
T.pack String
formatter , plugins :: Map PluginId PluginConfig
plugins = forall k a. k -> a -> Map k a
M.singleton (Text -> PluginId
PluginId forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
formatter) PluginConfig
conf }
in String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (String
testDataDir String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
Config -> PluginTestDescriptor b -> String -> Session a -> IO a
runSessionWithServer Config
config' PluginTestDescriptor b
plugin String
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 <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
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
goldenWithCabalDocFormatter
:: Pretty b
=> Config
-> PluginTestDescriptor b
-> String
-> PluginConfig
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDocFormatter :: forall b.
Pretty b =>
Config
-> PluginTestDescriptor b
-> String
-> PluginConfig
-> String
-> String
-> String
-> String
-> String
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithCabalDocFormatter Config
config PluginTestDescriptor b
plugin String
formatter PluginConfig
conf String
title String
testDataDir String
path String
desc String
ext TextDocumentIdentifier -> Session ()
act =
let config' :: Config
config' = Config
config { cabalFormattingProvider :: Text
cabalFormattingProvider = String -> Text
T.pack String
formatter , plugins :: Map PluginId PluginConfig
plugins = forall k a. k -> a -> Map k a
M.singleton (Text -> PluginId
PluginId forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
formatter) PluginConfig
conf }
in String -> String -> IO ByteString -> TestTree
goldenGitDiff String
title (String
testDataDir String -> String -> String
</> String
path String -> String -> String
<.> String
desc String -> String -> String
<.> String
ext)
forall a b. (a -> b) -> a -> b
$ forall b a.
Pretty b =>
Config -> PluginTestDescriptor b -> String -> Session a -> IO a
runSessionWithServer Config
config' PluginTestDescriptor b
plugin String
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 <- String -> Text -> Session TextDocumentIdentifier
openDoc (String
path String -> String -> String
<.> String
ext) Text
"cabal"
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
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 String
getCurrentDirectory String -> IO ()
setCurrentDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
{-# NOINLINE lock #-}
lock :: Lock
lock :: Lock
lock = forall a. IO a -> a
unsafePerformIO IO Lock
newLock
runSessionWithServer' ::
IdePlugins IdeState ->
Config ->
SessionConfig ->
ClientCapabilities ->
FilePath ->
Session a ->
IO a
runSessionWithServer' :: forall a.
IdePlugins IdeState
-> Config
-> SessionConfig
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithServer' IdePlugins IdeState
plugins Config
conf SessionConfig
sconf ClientCapabilities
caps String
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 Log)
recorder, WithPriority (Doc Any) -> IO ()
logger_) <- forall a ann.
Pretty a =>
[String]
-> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder
[String
"LSP_TEST_LOG_STDERR", String
"HLS_TEST_SERVER_LOG_STDERR", String
"HLS_TEST_LOG_STDERR"]
let
sconf' :: SessionConfig
sconf' = SessionConfig
sconf { lspConfig :: Object
lspConfig = Config -> Object
hlsConfigToClientConfig Config
conf }
logger :: Logger
logger = (Priority -> Text -> IO ()) -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Priority
p Text
m -> WithPriority (Doc Any) -> IO ()
logger_ (forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
p CallStack
emptyCallStack (forall a ann. Pretty a => a -> Doc ann
pretty Text
m))
hlsPlugins :: IdePlugins IdeState
hlsPlugins = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
IdePlugins [forall state. PluginId -> PluginDescriptor state
Test.blockCommandDescriptor PluginId
"block-command"] forall a. Semigroup a => a -> a -> a
<> IdePlugins IdeState
plugins
arguments :: Arguments
arguments@Arguments{ 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 -> IdePlugins IdeState -> Arguments
testing (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder) Logger
logger IdePlugins IdeState
hlsPlugins
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
}
a
x <- forall a.
Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> String
-> Session a
-> IO a
runSessionWithHandles Handle
inW Handle
outR SessionConfig
sconf' ClientCapabilities
caps String
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
String -> IO ()
putStrLn String
"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
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Finishing canceling (took " forall a. Semigroup a => a -> a -> a
<> Seconds -> String
showDuration Seconds
t forall a. Semigroup a => a -> a -> a
<> String
"s)"
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
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
SMethod_Progress (TNotificationMessage Text
_ SMethod 'Method_Progress
_ (ProgressParams ProgressToken
_ Value
v)) | forall s t a b. APrism s t a b -> s -> Bool
is Prism' Value WorkDoneProgressEnd
_workDoneProgressEnd Value
v-> forall a. a -> Maybe a
Just ()
FromServerMessage
_ -> forall a. Maybe a
Nothing
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
SMethod_Progress (TNotificationMessage Text
_ SMethod 'Method_Progress
_ (ProgressParams ProgressToken
_ Value
v)) | forall s t a b. APrism s t a b -> s -> Bool
is Prism' Value WorkDoneProgressEnd
_workDoneProgressEnd Value
v -> 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
waitForBuildQueue :: Session Seconds
waitForBuildQueue :: Session Seconds
waitForBuildQueue = do
let m :: SMethod ('Method_CustomMethod "test")
m = forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"test")
LspId ('Method_CustomMethod "test")
waitId <- forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
m (forall a. ToJSON a => a -> Value
toJSON TestRequest
WaitForShakeQueue)
(Seconds
td, TResponseMessage ('Method_CustomMethod "test")
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 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
m LspId ('Method_CustomMethod "test")
waitId
case TResponseMessage ('Method_CustomMethod "test")
resp of
TResponseMessage{$sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either ResponseError (MessageResult m)
_result=Right Value
MessageResult ('Method_CustomMethod "test")
Null} -> forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
td
TResponseMessage ('Method_CustomMethod "test")
_ -> 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 ('Method_CustomMethod "test")
cm = forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"test")
LspId ('Method_CustomMethod "test")
waitId <- forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm (forall a. ToJSON a => a -> Value
A.toJSON TestRequest
cmd)
TResponseMessage{Either ResponseError (MessageResult ('Method_CustomMethod "test"))
_result :: Either ResponseError (MessageResult ('Method_CustomMethod "test"))
$sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either ResponseError (MessageResult 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 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm LspId ('Method_CustomMethod "test")
waitId
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
Value
e <- Either ResponseError (MessageResult ('Method_CustomMethod "test"))
_result
case forall a. FromJSON a => Value -> Result a
A.fromJSON Value
e of
A.Error String
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InternalError) (String -> Text
T.pack String
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 :: String
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction String
key TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} =
forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
callTestPlugin (String -> Uri -> TestRequest
WaitForIdeRule String
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
<$> String
-> TextDocumentIdentifier
-> Session (Either ResponseError WaitForIdeRuleResult)
waitForAction String
"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
hlsConfigToClientConfig :: Config -> A.Object
hlsConfigToClientConfig :: Config -> Object
hlsConfigToClientConfig Config
config = [(Key
"haskell", forall a. ToJSON a => a -> Value
toJSON Config
config)]
setHlsConfig :: Config -> Session ()
setHlsConfig :: Config -> Session ()
setHlsConfig Config
config = do
Object -> Session ()
setConfig forall a b. (a -> b) -> a -> b
$ Config -> Object
hlsConfigToClientConfig Config
config
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (forall (f :: * -> *) a. Functor f => f a -> f ()
void Session FromServerMessage
configurationRequest)
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 = forall (k :: Symbol). KnownSymbol k => Proxy k -> Session [String]
kick (forall {k} (t :: k). Proxy t
Proxy @"kick/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 = forall (k :: Symbol). KnownSymbol k => Proxy k -> Session [String]
kick (forall {k} (t :: k). Proxy t
Proxy @"kick/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 :: KnownSymbol k => Proxy k -> Session [FilePath]
kick :: forall (k :: Symbol). KnownSymbol k => Proxy k -> Session [String]
kick Proxy k
proxyMsg = do
NotMess TNotificationMessage{MessageParams ('Method_CustomMethod k)
$sel:_params:TNotificationMessage :: forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> MessageParams m
_params :: MessageParams ('Method_CustomMethod k)
_params} <- forall (s :: Symbol).
KnownSymbol s =>
Proxy s -> Session (TMessage ('Method_CustomMethod s))
customNotification Proxy k
proxyMsg
case forall a. FromJSON a => Value -> Result a
fromJSON MessageParams ('Method_CustomMethod k)
_params of
Success [String]
x -> forall (m :: * -> *) a. Monad m => a -> m a
return [String]
x
Result [String]
other -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Failed to parse kick/done details: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Result [String]
other