{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Futhark.Server
(
Server,
ServerCfg (..),
newServerCfg,
withServer,
Cmd,
CmdFailure (..),
VarName,
TypeName,
EntryName,
InputType (..),
OutputType (..),
cmdRestore,
cmdStore,
cmdCall,
cmdFree,
cmdRename,
cmdInputs,
cmdOutputs,
cmdClear,
cmdReport,
cmdPauseProfiling,
cmdUnpauseProfiling,
cmdSetTuningParam,
cmdMaybe,
cmdEither,
startServer,
stopServer,
sendCommand,
)
where
import Control.Exception
import Control.Monad
import Control.Monad.Except
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.Directory (removeFile)
import System.Exit
import System.IO hiding (stdin, stdout)
import System.IO.Temp (getCanonicalTemporaryDirectory)
import qualified System.Process as P
type Cmd = Text
data Server = Server
{ Server -> Handle
serverStdin :: Handle,
Server -> Handle
serverStdout :: Handle,
Server -> FilePath
serverErrLog :: FilePath,
Server -> ProcessHandle
serverProc :: P.ProcessHandle,
Server -> Cmd -> Cmd -> IO ()
serverOnLine :: Cmd -> Text -> IO (),
Server -> Bool
serverDebug :: Bool
}
data ServerCfg = ServerCfg
{
ServerCfg -> FilePath
cfgProg :: FilePath,
ServerCfg -> [FilePath]
cfgProgOpts :: [String],
ServerCfg -> Bool
cfgDebug :: Bool,
ServerCfg -> Cmd -> Cmd -> IO ()
cfgOnLine :: Cmd -> Text -> IO ()
}
newServerCfg :: FilePath -> [String] -> ServerCfg
newServerCfg :: FilePath -> [FilePath] -> ServerCfg
newServerCfg FilePath
prog [FilePath]
opts =
ServerCfg :: FilePath
-> [FilePath] -> Bool -> (Cmd -> Cmd -> IO ()) -> ServerCfg
ServerCfg
{ cfgProg :: FilePath
cfgProg = FilePath
prog,
cfgProgOpts :: [FilePath]
cfgProgOpts = [FilePath]
opts,
cfgDebug :: Bool
cfgDebug = Bool
False,
cfgOnLine :: Cmd -> Cmd -> IO ()
cfgOnLine = \Cmd
_ Cmd
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
}
startServer :: ServerCfg -> IO Server
startServer :: ServerCfg -> IO Server
startServer (ServerCfg FilePath
prog [FilePath]
options Bool
debug Cmd -> Cmd -> IO ()
on_line_f) = do
FilePath
tmpdir <- IO FilePath
getCanonicalTemporaryDirectory
(FilePath
err_log_f, Handle
err_log_h) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
tmpdir FilePath
"futhark-server-stderr.log"
(Just Handle
stdin, Just Handle
stdout, Maybe Handle
Nothing, ProcessHandle
phandle) <-
CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
P.createProcess
( (FilePath -> [FilePath] -> CreateProcess
P.proc FilePath
prog [FilePath]
options)
{ std_err :: StdStream
P.std_err = Handle -> StdStream
P.UseHandle Handle
err_log_h,
std_in :: StdStream
P.std_in = StdStream
P.CreatePipe,
std_out :: StdStream
P.std_out = StdStream
P.CreatePipe
}
)
Maybe ExitCode
code <- ProcessHandle -> IO (Maybe ExitCode)
P.getProcessExitCode ProcessHandle
phandle
case Maybe ExitCode
code of
Just (ExitFailure Int
e) ->
FilePath -> IO Server
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO Server) -> FilePath -> IO Server
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot start " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
prog FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": error " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
e
Maybe ExitCode
_ -> do
let server :: Server
server =
Server :: Handle
-> Handle
-> FilePath
-> ProcessHandle
-> (Cmd -> Cmd -> IO ())
-> Bool
-> Server
Server
{ serverStdin :: Handle
serverStdin = Handle
stdin,
serverStdout :: Handle
serverStdout = Handle
stdout,
serverProc :: ProcessHandle
serverProc = ProcessHandle
phandle,
serverDebug :: Bool
serverDebug = Bool
debug,
serverErrLog :: FilePath
serverErrLog = FilePath
err_log_f,
serverOnLine :: Cmd -> Cmd -> IO ()
serverOnLine = Cmd -> Cmd -> IO ()
on_line_f
}
IO [Cmd] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Cmd -> Server -> IO [Cmd]
responseLines Cmd
"startup" Server
server) IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` Server -> IOError -> IO ()
forall a. Server -> IOError -> IO a
onStartupError Server
server
Server -> IO Server
forall (f :: * -> *) a. Applicative f => a -> f a
pure Server
server
where
onStartupError :: Server -> IOError -> IO a
onStartupError :: Server -> IOError -> IO a
onStartupError Server
s IOError
_ = do
ExitCode
code <- ProcessHandle -> IO ExitCode
P.waitForProcess (ProcessHandle -> IO ExitCode) -> ProcessHandle -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Server -> ProcessHandle
serverProc Server
s
FilePath
stderr_s <- FilePath -> IO FilePath
readFile (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Server -> FilePath
serverErrLog Server
s
FilePath -> IO ()
removeFile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> FilePath
serverErrLog Server
s
FilePath -> IO a
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$
FilePath
"Command failed with " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
code FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":\n"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords (FilePath
prog FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
options)
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\nStderr:\n"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
stderr_s
stopServer :: Server -> IO ()
stopServer :: Server -> IO ()
stopServer Server
s = (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (FilePath -> IO ()
removeFile (Server -> FilePath
serverErrLog Server
s)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
hClose (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Handle
serverStdin Server
s
ExitCode
code <- ProcessHandle -> IO ExitCode
P.waitForProcess (ProcessHandle -> IO ExitCode) -> ProcessHandle -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Server -> ProcessHandle
serverProc Server
s
case ExitCode
code of
ExitCode
ExitSuccess -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ExitFailure Int
_ -> do
FilePath
stderr_s <- FilePath -> IO FilePath
readFile (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Server -> FilePath
serverErrLog Server
s
FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
stderr_s
withServer :: ServerCfg -> (Server -> IO a) -> IO a
withServer :: ServerCfg -> (Server -> IO a) -> IO a
withServer ServerCfg
cfg Server -> IO a
m = ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Server
server <- ServerCfg -> IO Server
startServer ServerCfg
cfg
a
x <- IO a -> IO a
forall a. IO a -> IO a
restore (Server -> IO a
m Server
server) IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` Server -> SomeException -> IO a
forall b. Server -> SomeException -> IO b
mException Server
server
Server -> IO ()
stopServer Server
server
a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
where
mException :: Server -> SomeException -> IO b
mException Server
server SomeException
e = do
Server -> IO ()
stopServer Server
server IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> SomeException -> IO ()
forall a. SomeException -> SomeException -> IO a
stopServerException SomeException
e
SomeException -> IO b
forall a e. Exception e => e -> a
throw SomeException
e
stopServerException :: SomeException -> SomeException -> IO a
stopServerException :: SomeException -> SomeException -> IO a
stopServerException SomeException
e SomeException
_ = SomeException -> IO a
forall a e. Exception e => e -> a
throw SomeException
e
responseLines :: Cmd -> Server -> IO [Text]
responseLines :: Cmd -> Server -> IO [Cmd]
responseLines Cmd
cmd Server
s = do
Cmd
l <- Handle -> IO Cmd
T.hGetLine (Handle -> IO Cmd) -> Handle -> IO Cmd
forall a b. (a -> b) -> a -> b
$ Server -> Handle
serverStdout Server
s
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Server -> Bool
serverDebug Server
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Handle -> Cmd -> IO ()
T.hPutStrLn Handle
stderr (Cmd -> IO ()) -> Cmd -> IO ()
forall a b. (a -> b) -> a -> b
$ Cmd
"<<< " Cmd -> Cmd -> Cmd
forall a. Semigroup a => a -> a -> a
<> Cmd
l
case Cmd
l of
Cmd
"%%% OK" -> [Cmd] -> IO [Cmd]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Cmd
_ -> do
Server -> Cmd -> Cmd -> IO ()
serverOnLine Server
s Cmd
cmd Cmd
l
(Cmd
l Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
:) ([Cmd] -> [Cmd]) -> IO [Cmd] -> IO [Cmd]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cmd -> Server -> IO [Cmd]
responseLines Cmd
cmd Server
s
data CmdFailure = CmdFailure {CmdFailure -> [Cmd]
failureLog :: [Text], CmdFailure -> [Cmd]
failureMsg :: [Text]}
deriving (CmdFailure -> CmdFailure -> Bool
(CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> Bool) -> Eq CmdFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CmdFailure -> CmdFailure -> Bool
$c/= :: CmdFailure -> CmdFailure -> Bool
== :: CmdFailure -> CmdFailure -> Bool
$c== :: CmdFailure -> CmdFailure -> Bool
Eq, Eq CmdFailure
Eq CmdFailure
-> (CmdFailure -> CmdFailure -> Ordering)
-> (CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> CmdFailure)
-> (CmdFailure -> CmdFailure -> CmdFailure)
-> Ord CmdFailure
CmdFailure -> CmdFailure -> Bool
CmdFailure -> CmdFailure -> Ordering
CmdFailure -> CmdFailure -> CmdFailure
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CmdFailure -> CmdFailure -> CmdFailure
$cmin :: CmdFailure -> CmdFailure -> CmdFailure
max :: CmdFailure -> CmdFailure -> CmdFailure
$cmax :: CmdFailure -> CmdFailure -> CmdFailure
>= :: CmdFailure -> CmdFailure -> Bool
$c>= :: CmdFailure -> CmdFailure -> Bool
> :: CmdFailure -> CmdFailure -> Bool
$c> :: CmdFailure -> CmdFailure -> Bool
<= :: CmdFailure -> CmdFailure -> Bool
$c<= :: CmdFailure -> CmdFailure -> Bool
< :: CmdFailure -> CmdFailure -> Bool
$c< :: CmdFailure -> CmdFailure -> Bool
compare :: CmdFailure -> CmdFailure -> Ordering
$ccompare :: CmdFailure -> CmdFailure -> Ordering
$cp1Ord :: Eq CmdFailure
Ord, Int -> CmdFailure -> FilePath -> FilePath
[CmdFailure] -> FilePath -> FilePath
CmdFailure -> FilePath
(Int -> CmdFailure -> FilePath -> FilePath)
-> (CmdFailure -> FilePath)
-> ([CmdFailure] -> FilePath -> FilePath)
-> Show CmdFailure
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [CmdFailure] -> FilePath -> FilePath
$cshowList :: [CmdFailure] -> FilePath -> FilePath
show :: CmdFailure -> FilePath
$cshow :: CmdFailure -> FilePath
showsPrec :: Int -> CmdFailure -> FilePath -> FilePath
$cshowsPrec :: Int -> CmdFailure -> FilePath -> FilePath
Show)
checkForFailure :: [Text] -> Either CmdFailure [Text]
checkForFailure :: [Cmd] -> Either CmdFailure [Cmd]
checkForFailure [] = [Cmd] -> Either CmdFailure [Cmd]
forall a b. b -> Either a b
Right []
checkForFailure (Cmd
"%%% FAILURE" : [Cmd]
ls) = CmdFailure -> Either CmdFailure [Cmd]
forall a b. a -> Either a b
Left (CmdFailure -> Either CmdFailure [Cmd])
-> CmdFailure -> Either CmdFailure [Cmd]
forall a b. (a -> b) -> a -> b
$ [Cmd] -> [Cmd] -> CmdFailure
CmdFailure [Cmd]
forall a. Monoid a => a
mempty [Cmd]
ls
checkForFailure (Cmd
l : [Cmd]
ls) =
case [Cmd] -> Either CmdFailure [Cmd]
checkForFailure [Cmd]
ls of
Left (CmdFailure [Cmd]
xs [Cmd]
ys) -> CmdFailure -> Either CmdFailure [Cmd]
forall a b. a -> Either a b
Left (CmdFailure -> Either CmdFailure [Cmd])
-> CmdFailure -> Either CmdFailure [Cmd]
forall a b. (a -> b) -> a -> b
$ [Cmd] -> [Cmd] -> CmdFailure
CmdFailure (Cmd
l Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: [Cmd]
xs) [Cmd]
ys
Right [Cmd]
ls' -> [Cmd] -> Either CmdFailure [Cmd]
forall a b. b -> Either a b
Right ([Cmd] -> Either CmdFailure [Cmd])
-> [Cmd] -> Either CmdFailure [Cmd]
forall a b. (a -> b) -> a -> b
$ Cmd
l Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: [Cmd]
ls'
quoteWord :: Text -> Text
quoteWord :: Cmd -> Cmd
quoteWord Cmd
t
| Just Char
_ <- (Char -> Bool) -> Cmd -> Maybe Char
T.find (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Cmd
t =
Cmd
"\"" Cmd -> Cmd -> Cmd
forall a. Semigroup a => a -> a -> a
<> Cmd
t Cmd -> Cmd -> Cmd
forall a. Semigroup a => a -> a -> a
<> Cmd
"\""
| Bool
otherwise = Cmd
t
sendCommand :: Server -> Cmd -> [Text] -> IO (Either CmdFailure [Text])
sendCommand :: Server -> Cmd -> [Cmd] -> IO (Either CmdFailure [Cmd])
sendCommand Server
s Cmd
cmd [Cmd]
args = do
let cmd_and_args' :: Cmd
cmd_and_args' = [Cmd] -> Cmd
T.unwords ([Cmd] -> Cmd) -> [Cmd] -> Cmd
forall a b. (a -> b) -> a -> b
$ (Cmd -> Cmd) -> [Cmd] -> [Cmd]
forall a b. (a -> b) -> [a] -> [b]
map Cmd -> Cmd
quoteWord ([Cmd] -> [Cmd]) -> [Cmd] -> [Cmd]
forall a b. (a -> b) -> a -> b
$ Cmd
cmd Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: [Cmd]
args
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Server -> Bool
serverDebug Server
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Handle -> Cmd -> IO ()
T.hPutStrLn Handle
stderr (Cmd -> IO ()) -> Cmd -> IO ()
forall a b. (a -> b) -> a -> b
$ Cmd
">>> " Cmd -> Cmd -> Cmd
forall a. Semigroup a => a -> a -> a
<> Cmd
cmd_and_args'
Handle -> Cmd -> IO ()
T.hPutStrLn (Server -> Handle
serverStdin Server
s) Cmd
cmd_and_args'
Handle -> IO ()
hFlush (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Handle
serverStdin Server
s
[Cmd] -> Either CmdFailure [Cmd]
checkForFailure ([Cmd] -> Either CmdFailure [Cmd])
-> IO [Cmd] -> IO (Either CmdFailure [Cmd])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cmd -> Server -> IO [Cmd]
responseLines Cmd
cmd Server
s IO [Cmd] -> (IOError -> IO [Cmd]) -> IO [Cmd]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO [Cmd]
forall a. IOError -> IO a
onError
where
onError :: IOError -> IO a
onError :: IOError -> IO a
onError IOError
e = do
Maybe ExitCode
code <- ProcessHandle -> IO (Maybe ExitCode)
P.getProcessExitCode (ProcessHandle -> IO (Maybe ExitCode))
-> ProcessHandle -> IO (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ Server -> ProcessHandle
serverProc Server
s
let code_msg :: FilePath
code_msg =
case Maybe ExitCode
code of
Just (ExitFailure Int
x) ->
FilePath
"\nServer process exited unexpectedly with exit code: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
x
Maybe ExitCode
_ -> FilePath
forall a. Monoid a => a
mempty
FilePath
stderr_s <- FilePath -> IO FilePath
readFile (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Server -> FilePath
serverErrLog Server
s
FilePath -> IO a
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$
FilePath
"After sending command " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Cmd -> FilePath
forall a. Show a => a -> FilePath
show Cmd
cmd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to server process:"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
e
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
code_msg
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\nServer stderr:\n"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
stderr_s
type VarName = Text
type TypeName = Text
type EntryName = Text
data InputType = InputType
{ InputType -> Bool
inputConsumed :: Bool,
InputType -> Cmd
inputType :: TypeName
}
data OutputType = OutputType
{ OutputType -> Bool
outputUnique :: Bool,
OutputType -> Cmd
outputType :: TypeName
}
inOutType :: (Bool -> TypeName -> a) -> Text -> a
inOutType :: (Bool -> Cmd -> a) -> Cmd -> a
inOutType Bool -> Cmd -> a
f Cmd
t =
case Cmd -> Maybe (Char, Cmd)
T.uncons Cmd
t of
Just (Char
'*', Cmd
t') -> Bool -> Cmd -> a
f Bool
True Cmd
t'
Maybe (Char, Cmd)
_ -> Bool -> Cmd -> a
f Bool
False Cmd
t
helpCmd :: Server -> Cmd -> [Text] -> IO (Maybe CmdFailure)
helpCmd :: Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
cmd [Cmd]
args =
(CmdFailure -> Maybe CmdFailure)
-> ([Cmd] -> Maybe CmdFailure)
-> Either CmdFailure [Cmd]
-> Maybe CmdFailure
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CmdFailure -> Maybe CmdFailure
forall a. a -> Maybe a
Just (Maybe CmdFailure -> [Cmd] -> Maybe CmdFailure
forall a b. a -> b -> a
const Maybe CmdFailure
forall a. Maybe a
Nothing) (Either CmdFailure [Cmd] -> Maybe CmdFailure)
-> IO (Either CmdFailure [Cmd]) -> IO (Maybe CmdFailure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> Cmd -> [Cmd] -> IO (Either CmdFailure [Cmd])
sendCommand Server
s Cmd
cmd [Cmd]
args
cmdRestore :: Server -> FilePath -> [(VarName, TypeName)] -> IO (Maybe CmdFailure)
cmdRestore :: Server -> FilePath -> [(Cmd, Cmd)] -> IO (Maybe CmdFailure)
cmdRestore Server
s FilePath
fname [(Cmd, Cmd)]
vars = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"restore" ([Cmd] -> IO (Maybe CmdFailure)) -> [Cmd] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ FilePath -> Cmd
T.pack FilePath
fname Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: ((Cmd, Cmd) -> [Cmd]) -> [(Cmd, Cmd)] -> [Cmd]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cmd, Cmd) -> [Cmd]
forall a. (a, a) -> [a]
f [(Cmd, Cmd)]
vars
where
f :: (a, a) -> [a]
f (a
v, a
t) = [a
v, a
t]
cmdStore :: Server -> FilePath -> [VarName] -> IO (Maybe CmdFailure)
cmdStore :: Server -> FilePath -> [Cmd] -> IO (Maybe CmdFailure)
cmdStore Server
s FilePath
fname [Cmd]
vars = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"store" ([Cmd] -> IO (Maybe CmdFailure)) -> [Cmd] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ FilePath -> Cmd
T.pack FilePath
fname Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: [Cmd]
vars
cmdCall :: Server -> EntryName -> [VarName] -> [VarName] -> IO (Either CmdFailure [Text])
cmdCall :: Server -> Cmd -> [Cmd] -> [Cmd] -> IO (Either CmdFailure [Cmd])
cmdCall Server
s Cmd
entry [Cmd]
outs [Cmd]
ins =
Server -> Cmd -> [Cmd] -> IO (Either CmdFailure [Cmd])
sendCommand Server
s Cmd
"call" ([Cmd] -> IO (Either CmdFailure [Cmd]))
-> [Cmd] -> IO (Either CmdFailure [Cmd])
forall a b. (a -> b) -> a -> b
$ Cmd
entry Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: [Cmd]
outs [Cmd] -> [Cmd] -> [Cmd]
forall a. [a] -> [a] -> [a]
++ [Cmd]
ins
cmdFree :: Server -> [VarName] -> IO (Maybe CmdFailure)
cmdFree :: Server -> [Cmd] -> IO (Maybe CmdFailure)
cmdFree Server
s = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"free"
cmdRename :: Server -> VarName -> VarName -> IO (Maybe CmdFailure)
cmdRename :: Server -> Cmd -> Cmd -> IO (Maybe CmdFailure)
cmdRename Server
s Cmd
oldname Cmd
newname = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"rename" [Cmd
oldname, Cmd
newname]
cmdInputs :: Server -> EntryName -> IO (Either CmdFailure [InputType])
cmdInputs :: Server -> Cmd -> IO (Either CmdFailure [InputType])
cmdInputs Server
s Cmd
entry =
([Cmd] -> [InputType])
-> Either CmdFailure [Cmd] -> Either CmdFailure [InputType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cmd -> InputType) -> [Cmd] -> [InputType]
forall a b. (a -> b) -> [a] -> [b]
map ((Bool -> Cmd -> InputType) -> Cmd -> InputType
forall a. (Bool -> Cmd -> a) -> Cmd -> a
inOutType Bool -> Cmd -> InputType
InputType)) (Either CmdFailure [Cmd] -> Either CmdFailure [InputType])
-> IO (Either CmdFailure [Cmd])
-> IO (Either CmdFailure [InputType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> Cmd -> [Cmd] -> IO (Either CmdFailure [Cmd])
sendCommand Server
s Cmd
"inputs" [Cmd
entry]
cmdOutputs :: Server -> EntryName -> IO (Either CmdFailure [OutputType])
cmdOutputs :: Server -> Cmd -> IO (Either CmdFailure [OutputType])
cmdOutputs Server
s Cmd
entry =
([Cmd] -> [OutputType])
-> Either CmdFailure [Cmd] -> Either CmdFailure [OutputType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cmd -> OutputType) -> [Cmd] -> [OutputType]
forall a b. (a -> b) -> [a] -> [b]
map ((Bool -> Cmd -> OutputType) -> Cmd -> OutputType
forall a. (Bool -> Cmd -> a) -> Cmd -> a
inOutType Bool -> Cmd -> OutputType
OutputType)) (Either CmdFailure [Cmd] -> Either CmdFailure [OutputType])
-> IO (Either CmdFailure [Cmd])
-> IO (Either CmdFailure [OutputType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> Cmd -> [Cmd] -> IO (Either CmdFailure [Cmd])
sendCommand Server
s Cmd
"outputs" [Cmd
entry]
cmdClear :: Server -> IO (Maybe CmdFailure)
cmdClear :: Server -> IO (Maybe CmdFailure)
cmdClear Server
s = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"clear" []
cmdReport :: Server -> IO (Either CmdFailure [Text])
cmdReport :: Server -> IO (Either CmdFailure [Cmd])
cmdReport Server
s = Server -> Cmd -> [Cmd] -> IO (Either CmdFailure [Cmd])
sendCommand Server
s Cmd
"report" []
cmdPauseProfiling :: Server -> IO (Maybe CmdFailure)
cmdPauseProfiling :: Server -> IO (Maybe CmdFailure)
cmdPauseProfiling Server
s = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"pause_profiling" []
cmdUnpauseProfiling :: Server -> IO (Maybe CmdFailure)
cmdUnpauseProfiling :: Server -> IO (Maybe CmdFailure)
cmdUnpauseProfiling Server
s = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"unpause_profiling" []
cmdSetTuningParam :: Server -> Text -> Text -> IO (Either CmdFailure [Text])
cmdSetTuningParam :: Server -> Cmd -> Cmd -> IO (Either CmdFailure [Cmd])
cmdSetTuningParam Server
s Cmd
param Cmd
value = Server -> Cmd -> [Cmd] -> IO (Either CmdFailure [Cmd])
sendCommand Server
s Cmd
"set_tuning_param" [Cmd
param, Cmd
value]
cmdMaybe :: (MonadError Text m, MonadIO m) => IO (Maybe CmdFailure) -> m ()
cmdMaybe :: IO (Maybe CmdFailure) -> m ()
cmdMaybe = m () -> (CmdFailure -> m ()) -> Maybe CmdFailure -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Cmd -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Cmd -> m ()) -> (CmdFailure -> Cmd) -> CmdFailure -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cmd] -> Cmd
T.unlines ([Cmd] -> Cmd) -> (CmdFailure -> [Cmd]) -> CmdFailure -> Cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> [Cmd]
failureMsg) (Maybe CmdFailure -> m ())
-> (IO (Maybe CmdFailure) -> m (Maybe CmdFailure))
-> IO (Maybe CmdFailure)
-> m ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Maybe CmdFailure) -> m (Maybe CmdFailure)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
cmdEither :: (MonadError Text m, MonadIO m) => IO (Either CmdFailure a) -> m a
cmdEither :: IO (Either CmdFailure a) -> m a
cmdEither = (CmdFailure -> m a) -> (a -> m a) -> Either CmdFailure a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Cmd -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Cmd -> m a) -> (CmdFailure -> Cmd) -> CmdFailure -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cmd] -> Cmd
T.unlines ([Cmd] -> Cmd) -> (CmdFailure -> [Cmd]) -> CmdFailure -> Cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> [Cmd]
failureMsg) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CmdFailure a -> m a)
-> (IO (Either CmdFailure a) -> m (Either CmdFailure a))
-> IO (Either CmdFailure a)
-> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either CmdFailure a) -> m (Either CmdFailure a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO