{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Haskell code for interacting with a Futhark server program.  This
-- module presents a low-level interface.  See
-- <https://futhark.readthedocs.io/en/latest/server-protocol.html the
-- documentation of the server protocol> for the meaning of the
-- commands.  See also "Futhark.Server.Values" for higher-level
-- functions for loading data into a server.
--
-- Error messages produced by the server will be returned as a
-- 'CmdFailure'.  However, certain errors (such as if the server
-- process terminates unexpectedly, or temporary files cannot be
-- created) will result in an IO exception.
--
-- Many of the functions here are documented only as the server
-- protocol command they correspond to.  See the protocol
-- documentation for details.
module Futhark.Server
  ( -- * Server creation
    Server,
    ServerCfg (..),
    newServerCfg,
    withServer,

    -- * Commands
    Cmd,
    CmdFailure (..),
    VarName,
    TypeName,
    EntryName,
    InputType (..),
    OutputType (..),

    -- ** Main commands
    cmdRestore,
    cmdStore,
    cmdCall,
    cmdFree,
    cmdRename,
    cmdInputs,
    cmdOutputs,
    cmdClear,

    -- ** Interrogation
    cmdTypes,
    cmdEntryPoints,

    -- ** Records
    cmdNew,
    cmdProject,
    cmdFields,

    -- ** Auxiliary
    cmdReport,
    cmdPauseProfiling,
    cmdUnpauseProfiling,
    cmdSetTuningParam,

    -- * Utility
    cmdMaybe,
    cmdEither,

    -- * Raw
    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

-- | The name of a command.
type Cmd = Text

-- | A handle to a running server.
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
  }

-- | Configuration of the server.  Use 'newServerCfg' to conveniently
-- create a sensible default configuration.
data ServerCfg = ServerCfg
  { -- | Path to the server executable.
    ServerCfg -> FilePath
cfgProg :: FilePath,
    -- | Command line options to pass to the
    -- server executable.
    ServerCfg -> [FilePath]
cfgProgOpts :: [String],
    -- | If true, print a running log of server communication to stderr.
    ServerCfg -> Bool
cfgDebug :: Bool,
    -- | A function that is invoked on every line of input sent by the
    -- server, except the @%%% OK@ and @%%% FAILURE@ prompts.  This
    -- can be used to e.g. print or gather logging messages as they
    -- arrive, instead of waiting for the command to finish.  The name
    -- of the command leading to the message is also provided.  The
    -- default function does nothing.
    ServerCfg -> Cmd -> Cmd -> IO ()
cfgOnLine :: Cmd -> Text -> IO ()
  }

-- | Create a server config with the given 'cfgProg' and 'cfgProgOpts'.
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 ()
    }

-- | Start up a server.  Make sure that 'stopServer' is eventually
-- called on the server.  If this does not happen, then temporary
-- files may be left on the file system.  You almost certainly wish to
-- use 'bracket' or similar to avoid this.  Calls 'error' if startup
-- fails.
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

-- | Shut down a server.  It may not be used again.  Calls 'error' if
-- the server process terminates with a failing exit code
-- (i.e. anything but 'ExitSuccess').
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

-- | Start a server, execute an action, then shut down the server.
-- The 'Server' may not be returned from the action.
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
      -- Anything that goes wrong here is probably less interesting
      -- than the original exception.
      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

-- Read lines of response until the next %%% OK (which is what
-- indicates that the server is ready for new instructions).
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

-- | The command failed, and this is why.  The first 'Text' is any
-- output before the failure indicator, and the second Text is the
-- output after the indicator.
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)

-- Figure out whether the response is a failure, and if so, return the
-- failure message.
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'

-- Words with spaces in them must be quoted.
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

-- | Send an arbitrary command to the server.  This is only useful
-- when the server protocol has been extended without this module
-- having been similarly extended.  Be careful not to send invalid
-- commands.
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

-- | The name of a server-side variable.
type VarName = Text

-- | The name of a server-side type.
type TypeName = Text

-- | The name of an entry point.
type EntryName = Text

-- | The type of an input of an entry point.  If 'inputConsumed', then
-- the value passed in a 'cmdCall' must not be used again (nor any of
-- its aliases).
data InputType = InputType
  { InputType -> Bool
inputConsumed :: Bool,
    InputType -> Cmd
inputType :: TypeName
  }

-- | The type of an output of an entry point.  If 'outputUnique', then
-- the value returned does not alias any of the inputs.  See the
-- Futhark language manual itself for more details - the implications
-- are quite subtle (but you can ignore them unless you manually use
-- type annotations to make some entry point parameters unique).
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

-- | @restore filename var0 type0 var1 type1...@.
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]

-- | @store filename vars...@.
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

-- | @call entrypoint outs... ins...@.
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

-- | @free vars...@.
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"

-- | @rename oldname newname@.
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]

-- | @inputs entryname@, with uniqueness represented as True.
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]

-- | @outputs entryname@, with uniqueness represented as True.
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]

-- | @clear@
cmdClear :: Server -> IO (Maybe CmdFailure)
cmdClear :: Server -> IO (Maybe CmdFailure)
cmdClear Server
s = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"clear" []

-- | @report@
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" []

-- | @pause_profiling@
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" []

-- | @unpause_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" []

-- | @set_tuning_param param value@
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]

-- | @types@
cmdTypes :: Server -> IO (Either CmdFailure [Text])
cmdTypes :: Server -> IO (Either CmdFailure [Cmd])
cmdTypes Server
s = Server -> Cmd -> [Cmd] -> IO (Either CmdFailure [Cmd])
sendCommand Server
s Cmd
"types" []

-- | @entry_points@
cmdEntryPoints :: Server -> IO (Maybe CmdFailure)
cmdEntryPoints :: Server -> IO (Maybe CmdFailure)
cmdEntryPoints Server
s = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"entry_points" []

-- | @fields type@
cmdFields :: Server -> Text -> IO (Either CmdFailure [Text])
cmdFields :: Server -> Cmd -> IO (Either CmdFailure [Cmd])
cmdFields Server
s Cmd
t = Server -> Cmd -> [Cmd] -> IO (Either CmdFailure [Cmd])
sendCommand Server
s Cmd
"fields" [Cmd
t]

-- | @new var0 type var1...@
cmdNew :: Server -> Text -> Text -> [Text] -> IO (Maybe CmdFailure)
cmdNew :: Server -> Cmd -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
cmdNew Server
s Cmd
var0 Cmd
t [Cmd]
vars = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"new" ([Cmd] -> IO (Maybe CmdFailure)) -> [Cmd] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Cmd
var0 Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: Cmd
t Cmd -> [Cmd] -> [Cmd]
forall a. a -> [a] -> [a]
: [Cmd]
vars

-- | @project to from field@
cmdProject :: Server -> Text -> Text -> Text -> IO (Maybe CmdFailure)
cmdProject :: Server -> Cmd -> Cmd -> Cmd -> IO (Maybe CmdFailure)
cmdProject Server
s Cmd
to Cmd
from Cmd
field = Server -> Cmd -> [Cmd] -> IO (Maybe CmdFailure)
helpCmd Server
s Cmd
"project" [Cmd
to, Cmd
from, Cmd
field]

-- | Turn a 'Maybe'-producing command into a monadic action.
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

-- | Turn an 'Either'-producing command into a monadic action.
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