{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Futhark.Server
(
Server,
ServerCfg (..),
newServerCfg,
withServer,
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
data Server = Server
{ Server -> Handle
serverStdin :: Handle,
Server -> Handle
serverStdout :: Handle,
Server -> FilePath
serverErrLog :: FilePath,
Server -> ProcessHandle
serverProc :: P.ProcessHandle,
Server -> Bool
serverDebug :: Bool
}
data ServerCfg = ServerCfg
{
ServerCfg -> FilePath
cfgProg :: FilePath,
ServerCfg -> [FilePath]
cfgProgOpts :: [String],
ServerCfg -> Bool
cfgDebug :: Bool
}
deriving (ServerCfg -> ServerCfg -> Bool
(ServerCfg -> ServerCfg -> Bool)
-> (ServerCfg -> ServerCfg -> Bool) -> Eq ServerCfg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ServerCfg -> ServerCfg -> Bool
$c/= :: ServerCfg -> ServerCfg -> Bool
== :: ServerCfg -> ServerCfg -> Bool
$c== :: ServerCfg -> ServerCfg -> Bool
Eq, Eq ServerCfg
Eq ServerCfg
-> (ServerCfg -> ServerCfg -> Ordering)
-> (ServerCfg -> ServerCfg -> Bool)
-> (ServerCfg -> ServerCfg -> Bool)
-> (ServerCfg -> ServerCfg -> Bool)
-> (ServerCfg -> ServerCfg -> Bool)
-> (ServerCfg -> ServerCfg -> ServerCfg)
-> (ServerCfg -> ServerCfg -> ServerCfg)
-> Ord ServerCfg
ServerCfg -> ServerCfg -> Bool
ServerCfg -> ServerCfg -> Ordering
ServerCfg -> ServerCfg -> ServerCfg
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 :: ServerCfg -> ServerCfg -> ServerCfg
$cmin :: ServerCfg -> ServerCfg -> ServerCfg
max :: ServerCfg -> ServerCfg -> ServerCfg
$cmax :: ServerCfg -> ServerCfg -> ServerCfg
>= :: ServerCfg -> ServerCfg -> Bool
$c>= :: ServerCfg -> ServerCfg -> Bool
> :: ServerCfg -> ServerCfg -> Bool
$c> :: ServerCfg -> ServerCfg -> Bool
<= :: ServerCfg -> ServerCfg -> Bool
$c<= :: ServerCfg -> ServerCfg -> Bool
< :: ServerCfg -> ServerCfg -> Bool
$c< :: ServerCfg -> ServerCfg -> Bool
compare :: ServerCfg -> ServerCfg -> Ordering
$ccompare :: ServerCfg -> ServerCfg -> Ordering
$cp1Ord :: Eq ServerCfg
Ord, Int -> ServerCfg -> ShowS
[ServerCfg] -> ShowS
ServerCfg -> FilePath
(Int -> ServerCfg -> ShowS)
-> (ServerCfg -> FilePath)
-> ([ServerCfg] -> ShowS)
-> Show ServerCfg
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ServerCfg] -> ShowS
$cshowList :: [ServerCfg] -> ShowS
show :: ServerCfg -> FilePath
$cshow :: ServerCfg -> FilePath
showsPrec :: Int -> ServerCfg -> ShowS
$cshowsPrec :: Int -> ServerCfg -> ShowS
Show)
newServerCfg :: FilePath -> [String] -> ServerCfg
newServerCfg :: FilePath -> [FilePath] -> ServerCfg
newServerCfg FilePath
prog [FilePath]
opts =
ServerCfg :: FilePath -> [FilePath] -> Bool -> ServerCfg
ServerCfg
{ cfgProg :: FilePath
cfgProg = FilePath
prog,
cfgProgOpts :: [FilePath]
cfgProgOpts = [FilePath]
opts,
cfgDebug :: Bool
cfgDebug = Bool
False
}
startServer :: ServerCfg -> IO Server
startServer :: ServerCfg -> IO Server
startServer (ServerCfg FilePath
prog [FilePath]
options Bool
debug) = 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
prog FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": error " FilePath -> ShowS
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 -> 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
}
IO [Text] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Server -> IO [Text]
responseLines 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
code FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
":\n"
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords (FilePath
prog FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
options)
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\nStderr:\n"
FilePath -> ShowS
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 :: Server -> IO [Text]
responseLines :: Server -> IO [Text]
responseLines Server
s = do
Text
l <- Handle -> IO Text
T.hGetLine (Handle -> IO Text) -> Handle -> IO Text
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 -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"<<< " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l
case Text
l of
Text
"%%% OK" -> [Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Text
_ -> (Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> IO [Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> IO [Text]
responseLines Server
s
data CmdFailure = CmdFailure {CmdFailure -> [Text]
failureLog :: [Text], CmdFailure -> [Text]
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 -> ShowS
[CmdFailure] -> ShowS
CmdFailure -> FilePath
(Int -> CmdFailure -> ShowS)
-> (CmdFailure -> FilePath)
-> ([CmdFailure] -> ShowS)
-> Show CmdFailure
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CmdFailure] -> ShowS
$cshowList :: [CmdFailure] -> ShowS
show :: CmdFailure -> FilePath
$cshow :: CmdFailure -> FilePath
showsPrec :: Int -> CmdFailure -> ShowS
$cshowsPrec :: Int -> CmdFailure -> ShowS
Show)
checkForFailure :: [Text] -> Either CmdFailure [Text]
checkForFailure :: [Text] -> Either CmdFailure [Text]
checkForFailure [] = [Text] -> Either CmdFailure [Text]
forall a b. b -> Either a b
Right []
checkForFailure (Text
"%%% FAILURE" : [Text]
ls) = CmdFailure -> Either CmdFailure [Text]
forall a b. a -> Either a b
Left (CmdFailure -> Either CmdFailure [Text])
-> CmdFailure -> Either CmdFailure [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> CmdFailure
CmdFailure [Text]
forall a. Monoid a => a
mempty [Text]
ls
checkForFailure (Text
l : [Text]
ls) =
case [Text] -> Either CmdFailure [Text]
checkForFailure [Text]
ls of
Left (CmdFailure [Text]
xs [Text]
ys) -> CmdFailure -> Either CmdFailure [Text]
forall a b. a -> Either a b
Left (CmdFailure -> Either CmdFailure [Text])
-> CmdFailure -> Either CmdFailure [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> CmdFailure
CmdFailure (Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
xs) [Text]
ys
Right [Text]
ls' -> [Text] -> Either CmdFailure [Text]
forall a b. b -> Either a b
Right ([Text] -> Either CmdFailure [Text])
-> [Text] -> Either CmdFailure [Text]
forall a b. (a -> b) -> a -> b
$ Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ls'
quoteWord :: Text -> Text
quoteWord :: Text -> Text
quoteWord Text
t
| Just Char
_ <- (Char -> Bool) -> Text -> Maybe Char
T.find (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
t =
Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
| Bool
otherwise = Text
t
sendCommand :: Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand :: Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text]
command = do
let command' :: Text
command' = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
quoteWord [Text]
command
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 -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
">>> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
command'
Handle -> Text -> IO ()
T.hPutStrLn (Server -> Handle
serverStdin Server
s) Text
command'
Handle -> IO ()
hFlush (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Handle
serverStdin Server
s
[Text] -> Either CmdFailure [Text]
checkForFailure ([Text] -> Either CmdFailure [Text])
-> IO [Text] -> IO (Either CmdFailure [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> IO [Text]
responseLines Server
s IO [Text] -> (IOError -> IO [Text]) -> IO [Text]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO [Text]
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 -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> FilePath
forall a. Show a => a -> FilePath
show [Text]
command FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" to server process:"
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
e
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
code_msg
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\nServer stderr:\n"
FilePath -> ShowS
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 -> Text
inputType :: TypeName
}
data OutputType = OutputType
{ OutputType -> Bool
outputUnique :: Bool,
OutputType -> Text
outputType :: TypeName
}
inOutType :: (Bool -> TypeName -> a) -> Text -> a
inOutType :: (Bool -> Text -> a) -> Text -> a
inOutType Bool -> Text -> a
f Text
t =
case Text -> Maybe (Char, Text)
T.uncons Text
t of
Just (Char
'*', Text
t') -> Bool -> Text -> a
f Bool
True Text
t'
Maybe (Char, Text)
_ -> Bool -> Text -> a
f Bool
False Text
t
helpCmd :: Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd :: Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s [Text]
cmd =
(CmdFailure -> Maybe CmdFailure)
-> ([Text] -> Maybe CmdFailure)
-> Either CmdFailure [Text]
-> 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 -> [Text] -> Maybe CmdFailure
forall a b. a -> b -> a
const Maybe CmdFailure
forall a. Maybe a
Nothing) (Either CmdFailure [Text] -> Maybe CmdFailure)
-> IO (Either CmdFailure [Text]) -> IO (Maybe CmdFailure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text]
cmd
cmdRestore :: Server -> FilePath -> [(VarName, TypeName)] -> IO (Maybe CmdFailure)
cmdRestore :: Server -> FilePath -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
s FilePath
fname [(Text, Text)]
vars = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s ([Text] -> IO (Maybe CmdFailure))
-> [Text] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Text
"restore" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: FilePath -> Text
T.pack FilePath
fname Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text, Text) -> [Text]) -> [(Text, Text)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, Text) -> [Text]
forall a. (a, a) -> [a]
f [(Text, Text)]
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 -> [Text] -> IO (Maybe CmdFailure)
cmdStore Server
s FilePath
fname [Text]
vars = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s ([Text] -> IO (Maybe CmdFailure))
-> [Text] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Text
"store" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: FilePath -> Text
T.pack FilePath
fname Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
vars
cmdCall :: Server -> EntryName -> [VarName] -> [VarName] -> IO (Either CmdFailure [T.Text])
cmdCall :: Server -> Text -> [Text] -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
s Text
entry [Text]
outs [Text]
ins =
Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s ([Text] -> IO (Either CmdFailure [Text]))
-> [Text] -> IO (Either CmdFailure [Text])
forall a b. (a -> b) -> a -> b
$ Text
"call" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
entry Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
outs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
ins
cmdFree :: Server -> [VarName] -> IO (Maybe CmdFailure)
cmdFree :: Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
s [Text]
vs = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s ([Text] -> IO (Maybe CmdFailure))
-> [Text] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Text
"free" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
vs
cmdRename :: Server -> VarName -> VarName -> IO (Maybe CmdFailure)
cmdRename :: Server -> Text -> Text -> IO (Maybe CmdFailure)
cmdRename Server
s Text
oldname Text
newname = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s [Text
"rename", Text
oldname, Text
newname]
cmdInputs :: Server -> EntryName -> IO (Either CmdFailure [InputType])
cmdInputs :: Server -> Text -> IO (Either CmdFailure [InputType])
cmdInputs Server
s Text
entry =
([Text] -> [InputType])
-> Either CmdFailure [Text] -> Either CmdFailure [InputType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> InputType) -> [Text] -> [InputType]
forall a b. (a -> b) -> [a] -> [b]
map ((Bool -> Text -> InputType) -> Text -> InputType
forall a. (Bool -> Text -> a) -> Text -> a
inOutType Bool -> Text -> InputType
InputType)) (Either CmdFailure [Text] -> Either CmdFailure [InputType])
-> IO (Either CmdFailure [Text])
-> IO (Either CmdFailure [InputType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text
"inputs", Text
entry]
cmdOutputs :: Server -> EntryName -> IO (Either CmdFailure [OutputType])
cmdOutputs :: Server -> Text -> IO (Either CmdFailure [OutputType])
cmdOutputs Server
s Text
entry =
([Text] -> [OutputType])
-> Either CmdFailure [Text] -> Either CmdFailure [OutputType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> OutputType) -> [Text] -> [OutputType]
forall a b. (a -> b) -> [a] -> [b]
map ((Bool -> Text -> OutputType) -> Text -> OutputType
forall a. (Bool -> Text -> a) -> Text -> a
inOutType Bool -> Text -> OutputType
OutputType)) (Either CmdFailure [Text] -> Either CmdFailure [OutputType])
-> IO (Either CmdFailure [Text])
-> IO (Either CmdFailure [OutputType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text
"outputs", Text
entry]
cmdClear :: Server -> IO (Maybe CmdFailure)
cmdClear :: Server -> IO (Maybe CmdFailure)
cmdClear Server
s = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s [Text
"clear"]
cmdReport :: Server -> IO (Either CmdFailure [T.Text])
cmdReport :: Server -> IO (Either CmdFailure [Text])
cmdReport Server
s = Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text
"report"]
cmdPauseProfiling :: Server -> IO (Maybe CmdFailure)
cmdPauseProfiling :: Server -> IO (Maybe CmdFailure)
cmdPauseProfiling Server
s = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s [Text
"pause_profiling"]
cmdUnpauseProfiling :: Server -> IO (Maybe CmdFailure)
cmdUnpauseProfiling :: Server -> IO (Maybe CmdFailure)
cmdUnpauseProfiling Server
s = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s [Text
"unpause_profiling"]
cmdSetTuningParam :: Server -> Text -> Text -> IO (Either CmdFailure [T.Text])
cmdSetTuningParam :: Server -> Text -> Text -> IO (Either CmdFailure [Text])
cmdSetTuningParam Server
s Text
param Text
value = Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text
"set_tuning_param", Text
param, Text
value]
cmdMaybe :: (MonadError T.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 ()) (Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> (CmdFailure -> Text) -> CmdFailure -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Text) -> (CmdFailure -> [Text]) -> CmdFailure -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> [Text]
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 T.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 (Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m a) -> (CmdFailure -> Text) -> CmdFailure -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Text) -> (CmdFailure -> [Text]) -> CmdFailure -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> [Text]
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