-- | FutharkScript is a (tiny) subset of Futhark used to write small
-- expressions that are evaluated by server executables.  The @futhark
-- literate@ command is the main user.
module Futhark.Script
  ( -- * Server
    ScriptServer,
    withScriptServer,
    withScriptServer',

    -- * Expressions, values, and types
    Func (..),
    Exp (..),
    parseExp,
    parseExpFromText,
    varsInExp,
    ScriptValueType (..),
    ScriptValue (..),
    scriptValueType,
    serverVarsInValue,
    ValOrVar (..),
    ExpValue,
    valToExpValue,
    storeExpValue,

    -- * Evaluation
    EvalBuiltin,
    scriptBuiltin,
    evalExp,
    getScriptValue,
    getExpValue,
    getHaskellValue,
    evalExpToGround,
    valueToExp,
    freeValue,
  )
where

import Control.Monad
import Control.Monad.Except (MonadError (..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bifunctor (bimap)
import Data.Binary qualified as Bin
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Char
import Data.Foldable (toList)
import Data.Functor
import Data.IORef
import Data.List (intersperse)
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Traversable
import Data.Vector.Storable qualified as SVec
import Data.Void
import Data.Word (Word8)
import Futhark.Data.Parser qualified as V
import Futhark.Server
import Futhark.Server.Values (getValue, putValue)
import Futhark.Test.Values qualified as V
import Futhark.Util (nubOrd)
import Futhark.Util.Pretty hiding (line, sep, space, (</>))
import Language.Futhark.Core (Name, nameFromText, nameToText)
import Language.Futhark.Tuple (areTupleFields)
import System.FilePath ((</>))
import Text.Megaparsec
import Text.Megaparsec.Char (space)
import Text.Megaparsec.Char.Lexer (charLiteral)

type TypeMap = M.Map TypeName (Maybe [(Name, TypeName)])

typeMap :: (MonadIO m) => Server -> m TypeMap
typeMap :: forall (m :: * -> *). MonadIO m => Server -> m TypeMap
typeMap Server
server = do
  IO TypeMap -> m TypeMap
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TypeMap -> m TypeMap) -> IO TypeMap -> m TypeMap
forall a b. (a -> b) -> a -> b
$ (CmdFailure -> IO TypeMap)
-> ([EntryName] -> IO TypeMap)
-> Either CmdFailure [EntryName]
-> IO TypeMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO TypeMap -> CmdFailure -> IO TypeMap
forall a. a -> CmdFailure -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO TypeMap
forall a. Monoid a => a
mempty) [EntryName] -> IO TypeMap
onTypes (Either CmdFailure [EntryName] -> IO TypeMap)
-> IO (Either CmdFailure [EntryName]) -> IO TypeMap
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Server -> IO (Either CmdFailure [EntryName])
cmdTypes Server
server
  where
    onTypes :: [EntryName] -> IO TypeMap
onTypes [EntryName]
types = [(EntryName, Maybe [(Name, EntryName)])] -> TypeMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EntryName, Maybe [(Name, EntryName)])] -> TypeMap)
-> ([Maybe [(Name, EntryName)]]
    -> [(EntryName, Maybe [(Name, EntryName)])])
-> [Maybe [(Name, EntryName)]]
-> TypeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EntryName]
-> [Maybe [(Name, EntryName)]]
-> [(EntryName, Maybe [(Name, EntryName)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [EntryName]
types ([Maybe [(Name, EntryName)]] -> TypeMap)
-> IO [Maybe [(Name, EntryName)]] -> IO TypeMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EntryName -> IO (Maybe [(Name, EntryName)]))
-> [EntryName] -> IO [Maybe [(Name, EntryName)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM EntryName -> IO (Maybe [(Name, EntryName)])
onType [EntryName]
types
    onType :: EntryName -> IO (Maybe [(Name, EntryName)])
onType EntryName
t =
      (CmdFailure -> Maybe [(Name, EntryName)])
-> ([EntryName] -> Maybe [(Name, EntryName)])
-> Either CmdFailure [EntryName]
-> Maybe [(Name, EntryName)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe [(Name, EntryName)]
-> CmdFailure -> Maybe [(Name, EntryName)]
forall a b. a -> b -> a
const Maybe [(Name, EntryName)]
forall a. Maybe a
Nothing) ([(Name, EntryName)] -> Maybe [(Name, EntryName)]
forall a. a -> Maybe a
Just ([(Name, EntryName)] -> Maybe [(Name, EntryName)])
-> ([EntryName] -> [(Name, EntryName)])
-> [EntryName]
-> Maybe [(Name, EntryName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EntryName -> (Name, EntryName))
-> [EntryName] -> [(Name, EntryName)]
forall a b. (a -> b) -> [a] -> [b]
map EntryName -> (Name, EntryName)
onField) (Either CmdFailure [EntryName] -> Maybe [(Name, EntryName)])
-> IO (Either CmdFailure [EntryName])
-> IO (Maybe [(Name, EntryName)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> EntryName -> IO (Either CmdFailure [EntryName])
cmdFields Server
server EntryName
t
    onField :: EntryName -> (Name, EntryName)
onField = (EntryName -> Name)
-> (EntryName -> EntryName)
-> (EntryName, EntryName)
-> (Name, EntryName)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap EntryName -> Name
nameFromText (Int -> EntryName -> EntryName
T.drop Int
1) ((EntryName, EntryName) -> (Name, EntryName))
-> (EntryName -> (EntryName, EntryName))
-> EntryName
-> (Name, EntryName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => EntryName -> EntryName -> (EntryName, EntryName)
EntryName -> EntryName -> (EntryName, EntryName)
T.breakOn EntryName
" "

isRecord :: TypeName -> TypeMap -> Maybe [(Name, TypeName)]
isRecord :: EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
t TypeMap
m = Maybe (Maybe [(Name, EntryName)]) -> Maybe [(Name, EntryName)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe [(Name, EntryName)]) -> Maybe [(Name, EntryName)])
-> Maybe (Maybe [(Name, EntryName)]) -> Maybe [(Name, EntryName)]
forall a b. (a -> b) -> a -> b
$ EntryName -> TypeMap -> Maybe (Maybe [(Name, EntryName)])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntryName
t TypeMap
m

isTuple :: TypeName -> TypeMap -> Maybe [TypeName]
isTuple :: EntryName -> TypeMap -> Maybe [EntryName]
isTuple EntryName
t TypeMap
m = Map Name EntryName -> Maybe [EntryName]
forall a. Map Name a -> Maybe [a]
areTupleFields (Map Name EntryName -> Maybe [EntryName])
-> ([(Name, EntryName)] -> Map Name EntryName)
-> [(Name, EntryName)]
-> Maybe [EntryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, EntryName)] -> Map Name EntryName
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, EntryName)] -> Maybe [EntryName])
-> Maybe [(Name, EntryName)] -> Maybe [EntryName]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
t TypeMap
m

-- | Like a 'Server', but keeps a bit more state to make FutharkScript
-- more convenient.
data ScriptServer = ScriptServer
  { ScriptServer -> Server
scriptServer :: Server,
    ScriptServer -> IORef Int
scriptCounter :: IORef Int,
    ScriptServer -> TypeMap
scriptTypes :: TypeMap,
    ScriptServer -> IORef [EntryName]
scriptVars :: IORef [VarName]
  }

-- | Run an action with a 'ScriptServer' produced by an existing
-- 'Server', without shutting it down at the end.
withScriptServer' :: (MonadIO m) => Server -> (ScriptServer -> m a) -> m a
withScriptServer' :: forall (m :: * -> *) a.
MonadIO m =>
Server -> (ScriptServer -> m a) -> m a
withScriptServer' Server
server ScriptServer -> m a
f = do
  IORef Int
counter <- IO (IORef Int) -> m (IORef Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> m (IORef Int))
-> IO (IORef Int) -> m (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
  IORef [EntryName]
vars <- IO (IORef [EntryName]) -> m (IORef [EntryName])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [EntryName]) -> m (IORef [EntryName]))
-> IO (IORef [EntryName]) -> m (IORef [EntryName])
forall a b. (a -> b) -> a -> b
$ [EntryName] -> IO (IORef [EntryName])
forall a. a -> IO (IORef a)
newIORef []
  TypeMap
types <- Server -> m TypeMap
forall (m :: * -> *). MonadIO m => Server -> m TypeMap
typeMap Server
server
  ScriptServer -> m a
f (ScriptServer -> m a) -> ScriptServer -> m a
forall a b. (a -> b) -> a -> b
$ Server -> IORef Int -> TypeMap -> IORef [EntryName] -> ScriptServer
ScriptServer Server
server IORef Int
counter TypeMap
types IORef [EntryName]
vars

-- | Start a server, execute an action, then shut down the server.
-- Similar to 'withServer'.
withScriptServer :: ServerCfg -> (ScriptServer -> IO a) -> IO a
withScriptServer :: forall a. ServerCfg -> (ScriptServer -> IO a) -> IO a
withScriptServer ServerCfg
cfg ScriptServer -> IO a
f =
  ServerCfg -> (Server -> IO a) -> IO a
forall a. ServerCfg -> (Server -> IO a) -> IO a
withServer ServerCfg
cfg ((Server -> IO a) -> IO a) -> (Server -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (Server -> (ScriptServer -> IO a) -> IO a)
-> (ScriptServer -> IO a) -> Server -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Server -> (ScriptServer -> IO a) -> IO a
forall (m :: * -> *) a.
MonadIO m =>
Server -> (ScriptServer -> m a) -> m a
withScriptServer' ScriptServer -> IO a
f

-- | A function called in a 'Call' expression can be either a Futhark
-- function or a builtin function.
data Func = FuncFut EntryName | FuncBuiltin T.Text
  deriving (Int -> Func -> ShowS
[Func] -> ShowS
Func -> String
(Int -> Func -> ShowS)
-> (Func -> String) -> ([Func] -> ShowS) -> Show Func
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Func -> ShowS
showsPrec :: Int -> Func -> ShowS
$cshow :: Func -> String
show :: Func -> String
$cshowList :: [Func] -> ShowS
showList :: [Func] -> ShowS
Show)

-- | A FutharkScript expression.  This is a simple AST that might not
-- correspond exactly to what the user wrote (e.g. no parentheses or
-- source locations).  This is fine for small expressions, which is
-- all this is meant for.
data Exp
  = Call Func [Exp]
  | Const V.Value
  | Tuple [Exp]
  | Record [(T.Text, Exp)]
  | StringLit T.Text
  | Let [VarName] Exp Exp
  | -- | Server-side variable, *not* Futhark variable (these are
    -- handled in 'Call').
    ServerVar TypeName VarName
  deriving (Int -> Exp -> ShowS
[Exp] -> ShowS
Exp -> String
(Int -> Exp -> ShowS)
-> (Exp -> String) -> ([Exp] -> ShowS) -> Show Exp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Exp -> ShowS
showsPrec :: Int -> Exp -> ShowS
$cshow :: Exp -> String
show :: Exp -> String
$cshowList :: [Exp] -> ShowS
showList :: [Exp] -> ShowS
Show)

instance Pretty Func where
  pretty :: forall ann. Func -> Doc ann
pretty (FuncFut EntryName
f) = EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty EntryName
f
  pretty (FuncBuiltin EntryName
f) = Doc ann
"$" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty EntryName
f

instance Pretty Exp where
  pretty :: forall ann. Exp -> Doc ann
pretty = Int -> Exp -> Doc ann
forall {t} {ann}. (Ord t, Num t) => t -> Exp -> Doc ann
pprPrec (Int
0 :: Int)
    where
      pprPrec :: t -> Exp -> Doc ann
pprPrec t
_ (ServerVar EntryName
_ EntryName
v) = Doc ann
"$" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty EntryName
v
      pprPrec t
_ (Const Value
v) = [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
stack ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (EntryName -> Doc ann) -> [EntryName] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([EntryName] -> [Doc ann]) -> [EntryName] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ EntryName -> [EntryName]
T.lines (EntryName -> [EntryName]) -> EntryName -> [EntryName]
forall a b. (a -> b) -> a -> b
$ Value -> EntryName
V.valueText Value
v
      pprPrec t
i (Let [EntryName]
pat Exp
e1 Exp
e2) =
        Bool -> Doc ann -> Doc ann
forall a. Bool -> Doc a -> Doc a
parensIf (t
i t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"let" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall {ann}. Doc ann
pat' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall {ann}. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Exp -> Doc ann
pretty Exp
e1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Exp -> Doc ann
pretty Exp
e2
        where
          pat' :: Doc ann
pat' = case [EntryName]
pat of
            [EntryName
x] -> EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty EntryName
x
            [EntryName]
_ -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
commasep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (EntryName -> Doc ann) -> [EntryName] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [EntryName]
pat
      pprPrec t
_ (Call Func
v []) = Func -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Func -> Doc ann
pretty Func
v
      pprPrec t
i (Call Func
v [Exp]
args) =
        Bool -> Doc ann -> Doc ann
forall a. Bool -> Doc a -> Doc a
parensIf (t
i t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Func -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Func -> Doc ann
pretty Func
v Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
hsep ((Exp -> Doc ann) -> [Exp] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> (Exp -> Doc ann) -> Exp -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Exp -> Doc ann
pprPrec t
1) [Exp]
args)
      pprPrec t
_ (Tuple [Exp]
vs) =
        Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
commasep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Exp -> Doc ann) -> [Exp] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> (Exp -> Doc ann) -> Exp -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Exp -> Doc ann
pretty) [Exp]
vs
      pprPrec t
_ (StringLit EntryName
s) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ EntryName -> String
forall a. Show a => a -> String
show EntryName
s
      pprPrec t
_ (Record [(EntryName, Exp)]
m) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
commasep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ ((EntryName, Exp) -> Doc ann) -> [(EntryName, Exp)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (EntryName, Exp) -> Doc ann
forall {a} {a} {ann}. (Pretty a, Pretty a) => (a, a) -> Doc ann
field [(EntryName, Exp)]
m
        where
          field :: (a, a) -> Doc ann
field (a
k, a
v) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
k Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall {ann}. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
v)

type Parser = Parsec Void T.Text

lexeme :: Parser () -> Parser a -> Parser a
lexeme :: forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser a
p = Parser a
p Parser a -> Parser () -> Parser a
forall a b.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
-> ParsecT Void EntryName Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sep

inParens :: Parser () -> Parser a -> Parser a
inParens :: forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep = Parser EntryName
-> Parser EntryName
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"(") (Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
")")

inBraces :: Parser () -> Parser a -> Parser a
inBraces :: forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep = Parser EntryName
-> Parser EntryName
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"{") (Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"}")

-- | Parse a FutharkScript expression, given a whitespace parser.
parseExp :: Parsec Void T.Text () -> Parsec Void T.Text Exp
parseExp :: Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep =
  [Parsec Void EntryName Exp] -> Parsec Void EntryName Exp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parsec Void EntryName Exp
pLet,
      Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parsec Void EntryName Exp -> Parsec Void EntryName Exp)
-> Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a b. (a -> b) -> a -> b
$ Func -> [Exp] -> Exp
Call (Func -> [Exp] -> Exp)
-> ParsecT Void EntryName Identity Func
-> ParsecT Void EntryName Identity ([Exp] -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void EntryName Identity Func
parseFunc ParsecT Void EntryName Identity ([Exp] -> Exp)
-> ParsecT Void EntryName Identity [Exp]
-> Parsec Void EntryName Exp
forall a b.
ParsecT Void EntryName Identity (a -> b)
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Void EntryName Exp -> ParsecT Void EntryName Identity [Exp]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parsec Void EntryName Exp
pAtom,
      Parsec Void EntryName Exp
pAtom
    ]
    Parsec Void EntryName Exp -> String -> Parsec Void EntryName Exp
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"expression"
  where
    pField :: ParsecT Void EntryName Identity (EntryName, Exp)
pField = (,) (EntryName -> Exp -> (EntryName, Exp))
-> Parser EntryName
-> ParsecT Void EntryName Identity (Exp -> (EntryName, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EntryName
pVarName ParsecT Void EntryName Identity (Exp -> (EntryName, Exp))
-> Parsec Void EntryName Exp
-> ParsecT Void EntryName Identity (EntryName, Exp)
forall a b.
ParsecT Void EntryName Identity (a -> b)
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser EntryName
pEquals Parser EntryName
-> Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a b.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep)
    pEquals :: Parser EntryName
pEquals = Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"="
    pComma :: Parser EntryName
pComma = Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
","
    mkTuple :: [Exp] -> Exp
mkTuple [Exp
v] = Exp
v
    mkTuple [Exp]
vs = [Exp] -> Exp
Tuple [Exp]
vs

    pLet :: Parsec Void EntryName Exp
pLet =
      Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"let"
        Parser EntryName
-> ([EntryName] -> Exp -> Exp -> Exp)
-> ParsecT
     Void EntryName Identity ([EntryName] -> Exp -> Exp -> Exp)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [EntryName] -> Exp -> Exp -> Exp
Let
        ParsecT Void EntryName Identity ([EntryName] -> Exp -> Exp -> Exp)
-> ParsecT Void EntryName Identity [EntryName]
-> ParsecT Void EntryName Identity (Exp -> Exp -> Exp)
forall a b.
ParsecT Void EntryName Identity (a -> b)
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void EntryName Identity [EntryName]
pPat
        ParsecT Void EntryName Identity (Exp -> Exp -> Exp)
-> Parser EntryName
-> ParsecT Void EntryName Identity (Exp -> Exp -> Exp)
forall a b.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
-> ParsecT Void EntryName Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"="
        ParsecT Void EntryName Identity (Exp -> Exp -> Exp)
-> Parsec Void EntryName Exp
-> ParsecT Void EntryName Identity (Exp -> Exp)
forall a b.
ParsecT Void EntryName Identity (a -> b)
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep
        ParsecT Void EntryName Identity (Exp -> Exp)
-> Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a b.
ParsecT Void EntryName Identity (a -> b)
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Parsec Void EntryName Exp] -> Parsec Void EntryName Exp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
          [ Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"in" Parser EntryName
-> Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a b.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep,
            Parsec Void EntryName Exp
pLet
          ]

    pAtom :: Parsec Void EntryName Exp
pAtom =
      [Parsec Void EntryName Exp] -> Parsec Void EntryName Exp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parsec Void EntryName Exp -> Parsec Void EntryName Exp)
-> Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a b. (a -> b) -> a -> b
$ Parser () -> Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep ([Exp] -> Exp
mkTuple ([Exp] -> Exp)
-> ParsecT Void EntryName Identity [Exp]
-> Parsec Void EntryName Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep Parsec Void EntryName Exp
-> Parser EntryName -> ParsecT Void EntryName Identity [Exp]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` Parser EntryName
pComma)),
          Parser () -> Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep (Parsec Void EntryName Exp -> Parsec Void EntryName Exp)
-> Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a b. (a -> b) -> a -> b
$ Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep,
          Parser () -> Parsec Void EntryName Exp -> Parsec Void EntryName Exp
forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep ([(EntryName, Exp)] -> Exp
Record ([(EntryName, Exp)] -> Exp)
-> ParsecT Void EntryName Identity [(EntryName, Exp)]
-> Parsec Void EntryName Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void EntryName Identity (EntryName, Exp)
pField ParsecT Void EntryName Identity (EntryName, Exp)
-> Parser EntryName
-> ParsecT Void EntryName Identity [(EntryName, Exp)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` Parser EntryName
pComma)),
          EntryName -> Exp
StringLit (EntryName -> Exp) -> (String -> EntryName) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EntryName
T.pack (String -> Exp)
-> ParsecT Void EntryName Identity String
-> Parsec Void EntryName Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ()
-> ParsecT Void EntryName Identity String
-> ParsecT Void EntryName Identity String
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (Parser EntryName
"\"" Parser EntryName
-> ParsecT Void EntryName Identity String
-> ParsecT Void EntryName Identity String
forall a b.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void EntryName Identity Char
-> Parser EntryName -> ParsecT Void EntryName Identity String
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill ParsecT Void EntryName Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
charLiteral Parser EntryName
"\""),
          Value -> Exp
Const (Value -> Exp)
-> ParsecT Void EntryName Identity Value
-> Parsec Void EntryName Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> ParsecT Void EntryName Identity Value
V.parseValue Parser ()
sep,
          Func -> [Exp] -> Exp
Call (Func -> [Exp] -> Exp)
-> ParsecT Void EntryName Identity Func
-> ParsecT Void EntryName Identity ([Exp] -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void EntryName Identity Func
parseFunc ParsecT Void EntryName Identity ([Exp] -> Exp)
-> ParsecT Void EntryName Identity [Exp]
-> Parsec Void EntryName Exp
forall a b.
ParsecT Void EntryName Identity (a -> b)
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Exp] -> ParsecT Void EntryName Identity [Exp]
forall a. a -> ParsecT Void EntryName Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        ]

    pPat :: ParsecT Void EntryName Identity [EntryName]
pPat =
      [ParsecT Void EntryName Identity [EntryName]]
-> ParsecT Void EntryName Identity [EntryName]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Parser ()
-> ParsecT Void EntryName Identity [EntryName]
-> ParsecT Void EntryName Identity [EntryName]
forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep (ParsecT Void EntryName Identity [EntryName]
 -> ParsecT Void EntryName Identity [EntryName])
-> ParsecT Void EntryName Identity [EntryName]
-> ParsecT Void EntryName Identity [EntryName]
forall a b. (a -> b) -> a -> b
$ Parser EntryName
pVarName Parser EntryName
-> Parser EntryName -> ParsecT Void EntryName Identity [EntryName]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` Parser EntryName
pComma,
          EntryName -> [EntryName]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EntryName -> [EntryName])
-> Parser EntryName -> ParsecT Void EntryName Identity [EntryName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EntryName
pVarName
        ]

    parseFunc :: ParsecT Void EntryName Identity Func
parseFunc =
      [ParsecT Void EntryName Identity Func]
-> ParsecT Void EntryName Identity Func
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ EntryName -> Func
FuncBuiltin (EntryName -> Func)
-> Parser EntryName -> ParsecT Void EntryName Identity Func
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser EntryName
"$" Parser EntryName -> Parser EntryName -> Parser EntryName
forall a b.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser EntryName
pVarName),
          EntryName -> Func
FuncFut (EntryName -> Func)
-> Parser EntryName -> ParsecT Void EntryName Identity Func
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EntryName
pVarName
        ]

    reserved :: [EntryName]
reserved = [EntryName
"let", EntryName
"in"]

    pVarName :: Parser EntryName
pVarName = Parser () -> Parser EntryName -> Parser EntryName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (Parser EntryName -> Parser EntryName)
-> (Parser EntryName -> Parser EntryName)
-> Parser EntryName
-> Parser EntryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser EntryName -> Parser EntryName
forall a.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser EntryName -> Parser EntryName)
-> Parser EntryName -> Parser EntryName
forall a b. (a -> b) -> a -> b
$ do
      EntryName
v <- (String -> EntryName)
-> ParsecT Void EntryName Identity String -> Parser EntryName
forall a b.
(a -> b)
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> EntryName
T.pack (ParsecT Void EntryName Identity String -> Parser EntryName)
-> ParsecT Void EntryName Identity String -> Parser EntryName
forall a b. (a -> b) -> a -> b
$ (:) (Char -> ShowS)
-> ParsecT Void EntryName Identity Char
-> ParsecT Void EntryName Identity ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token EntryName -> Bool)
-> ParsecT Void EntryName Identity (Token EntryName)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token EntryName -> Bool
isAlpha ParsecT Void EntryName Identity ShowS
-> ParsecT Void EntryName Identity String
-> ParsecT Void EntryName Identity String
forall a b.
ParsecT Void EntryName Identity (a -> b)
-> ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void EntryName Identity Char
-> ParsecT Void EntryName Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((Token EntryName -> Bool)
-> ParsecT Void EntryName Identity (Token EntryName)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token EntryName -> Bool
constituent)
      Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ EntryName
v EntryName -> [EntryName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [EntryName]
reserved
      EntryName -> Parser EntryName
forall a. a -> ParsecT Void EntryName Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v
      where
        constituent :: Char -> Bool
constituent Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

-- | Parse a FutharkScript expression with normal whitespace handling.
parseExpFromText :: FilePath -> T.Text -> Either T.Text Exp
parseExpFromText :: String -> EntryName -> Either EntryName Exp
parseExpFromText String
f EntryName
s =
  (ParseErrorBundle EntryName Void -> Either EntryName Exp)
-> (Exp -> Either EntryName Exp)
-> Either (ParseErrorBundle EntryName Void) Exp
-> Either EntryName Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (EntryName -> Either EntryName Exp
forall a b. a -> Either a b
Left (EntryName -> Either EntryName Exp)
-> (ParseErrorBundle EntryName Void -> EntryName)
-> ParseErrorBundle EntryName Void
-> Either EntryName Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EntryName
T.pack (String -> EntryName)
-> (ParseErrorBundle EntryName Void -> String)
-> ParseErrorBundle EntryName Void
-> EntryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle EntryName Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) Exp -> Either EntryName Exp
forall a b. b -> Either a b
Right (Either (ParseErrorBundle EntryName Void) Exp
 -> Either EntryName Exp)
-> Either (ParseErrorBundle EntryName Void) Exp
-> Either EntryName Exp
forall a b. (a -> b) -> a -> b
$ Parsec Void EntryName Exp
-> String
-> EntryName
-> Either (ParseErrorBundle EntryName Void) Exp
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space Parsec Void EntryName Exp -> Parser () -> Parsec Void EntryName Exp
forall a b.
ParsecT Void EntryName Identity a
-> ParsecT Void EntryName Identity b
-> ParsecT Void EntryName Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
f EntryName
s

readVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> m V.Value
readVar :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> m Value
readVar Server
server EntryName
v =
  (EntryName -> m Value)
-> (Value -> m Value) -> Either EntryName Value -> m Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either EntryName -> m Value
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EntryName Value -> m Value)
-> m (Either EntryName Value) -> m Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either EntryName Value) -> m (Either EntryName Value)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> EntryName -> IO (Either EntryName Value)
getValue Server
server EntryName
v)

writeVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> V.Value -> m ()
writeVar :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> Value -> m ()
writeVar Server
server EntryName
v Value
val =
  IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe CmdFailure) -> IO (Maybe CmdFailure)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> EntryName -> Value -> IO (Maybe CmdFailure)
putValue Server
server EntryName
v Value
val)

-- | A ScriptValue is either a base value or a partially applied
-- function.  We don't have real first-class functions in
-- FutharkScript, but we sort of have closures.
data ScriptValue v
  = SValue TypeName v
  | -- | Ins, then outs.  Yes, this is the opposite of more or less
    -- everywhere else.
    SFun EntryName [TypeName] [TypeName] [ScriptValue v]
  deriving (Int -> ScriptValue v -> ShowS
[ScriptValue v] -> ShowS
ScriptValue v -> String
(Int -> ScriptValue v -> ShowS)
-> (ScriptValue v -> String)
-> ([ScriptValue v] -> ShowS)
-> Show (ScriptValue v)
forall v. Show v => Int -> ScriptValue v -> ShowS
forall v. Show v => [ScriptValue v] -> ShowS
forall v. Show v => ScriptValue v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> ScriptValue v -> ShowS
showsPrec :: Int -> ScriptValue v -> ShowS
$cshow :: forall v. Show v => ScriptValue v -> String
show :: ScriptValue v -> String
$cshowList :: forall v. Show v => [ScriptValue v] -> ShowS
showList :: [ScriptValue v] -> ShowS
Show)

instance Functor ScriptValue where
  fmap :: forall a b. (a -> b) -> ScriptValue a -> ScriptValue b
fmap = (a -> b) -> ScriptValue a -> ScriptValue b
forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault

instance Foldable ScriptValue where
  foldMap :: forall m a. Monoid m => (a -> m) -> ScriptValue a -> m
foldMap = (a -> m) -> ScriptValue a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault

instance Traversable ScriptValue where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ScriptValue a -> f (ScriptValue b)
traverse a -> f b
f (SValue EntryName
t a
v) = EntryName -> b -> ScriptValue b
forall v. EntryName -> v -> ScriptValue v
SValue EntryName
t (b -> ScriptValue b) -> f b -> f (ScriptValue b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
v
  traverse a -> f b
f (SFun EntryName
fname [EntryName]
ins [EntryName]
outs [ScriptValue a]
vs) =
    EntryName
-> [EntryName] -> [EntryName] -> [ScriptValue b] -> ScriptValue b
forall v.
EntryName
-> [EntryName] -> [EntryName] -> [ScriptValue v] -> ScriptValue v
SFun EntryName
fname [EntryName]
ins [EntryName]
outs ([ScriptValue b] -> ScriptValue b)
-> f [ScriptValue b] -> f (ScriptValue b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ScriptValue a -> f (ScriptValue b))
-> [ScriptValue a] -> f [ScriptValue b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((a -> f b) -> ScriptValue a -> f (ScriptValue b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ScriptValue a -> f (ScriptValue b)
traverse a -> f b
f) [ScriptValue a]
vs

-- | The type of a 'ScriptValue' - either a value type or a function type.
data ScriptValueType
  = STValue TypeName
  | -- | Ins, then outs.
    STFun [TypeName] [TypeName]
  deriving (ScriptValueType -> ScriptValueType -> Bool
(ScriptValueType -> ScriptValueType -> Bool)
-> (ScriptValueType -> ScriptValueType -> Bool)
-> Eq ScriptValueType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptValueType -> ScriptValueType -> Bool
== :: ScriptValueType -> ScriptValueType -> Bool
$c/= :: ScriptValueType -> ScriptValueType -> Bool
/= :: ScriptValueType -> ScriptValueType -> Bool
Eq, Int -> ScriptValueType -> ShowS
[ScriptValueType] -> ShowS
ScriptValueType -> String
(Int -> ScriptValueType -> ShowS)
-> (ScriptValueType -> String)
-> ([ScriptValueType] -> ShowS)
-> Show ScriptValueType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptValueType -> ShowS
showsPrec :: Int -> ScriptValueType -> ShowS
$cshow :: ScriptValueType -> String
show :: ScriptValueType -> String
$cshowList :: [ScriptValueType] -> ShowS
showList :: [ScriptValueType] -> ShowS
Show)

instance Pretty ScriptValueType where
  pretty :: forall ann. ScriptValueType -> Doc ann
pretty (STValue EntryName
t) = EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty EntryName
t
  pretty (STFun [EntryName]
ins [EntryName]
outs) =
    [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
intersperse Doc ann
"->" ((EntryName -> Doc ann) -> [EntryName] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [EntryName]
ins [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [Doc ann
forall {ann}. Doc ann
outs'])
    where
      outs' :: Doc ann
outs' = case [EntryName]
outs of
        [EntryName
out] -> EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty EntryName
out
        [EntryName]
_ -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
commasep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (EntryName -> Doc ann) -> [EntryName] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map EntryName -> Doc ann
forall ann. EntryName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [EntryName]
outs

-- | A Haskell-level value or a variable on the server.
data ValOrVar = VVal V.Value | VVar VarName
  deriving (Int -> ValOrVar -> ShowS
[ValOrVar] -> ShowS
ValOrVar -> String
(Int -> ValOrVar -> ShowS)
-> (ValOrVar -> String) -> ([ValOrVar] -> ShowS) -> Show ValOrVar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValOrVar -> ShowS
showsPrec :: Int -> ValOrVar -> ShowS
$cshow :: ValOrVar -> String
show :: ValOrVar -> String
$cshowList :: [ValOrVar] -> ShowS
showList :: [ValOrVar] -> ShowS
Show)

-- | The intermediate values produced by an expression - in
-- particular, these may not be on the server.
type ExpValue = V.Compound (ScriptValue ValOrVar)

-- | Turn a purely manifested value into an 'ExpValue'.
valToExpValue :: V.CompoundValue -> ExpValue
valToExpValue :: CompoundValue -> ExpValue
valToExpValue = (Value -> ScriptValue ValOrVar) -> CompoundValue -> ExpValue
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> ScriptValue ValOrVar) -> CompoundValue -> ExpValue)
-> (Value -> ScriptValue ValOrVar) -> CompoundValue -> ExpValue
forall a b. (a -> b) -> a -> b
$ \Value
v ->
  EntryName -> ValOrVar -> ScriptValue ValOrVar
forall v. EntryName -> v -> ScriptValue v
SValue (ValueType -> EntryName
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
v)) (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
v

-- | The type of a 'ScriptValue'.
scriptValueType :: ScriptValue v -> ScriptValueType
scriptValueType :: forall v. ScriptValue v -> ScriptValueType
scriptValueType (SValue EntryName
t v
_) = EntryName -> ScriptValueType
STValue EntryName
t
scriptValueType (SFun EntryName
_ [EntryName]
ins [EntryName]
outs [ScriptValue v]
_) = [EntryName] -> [EntryName] -> ScriptValueType
STFun [EntryName]
ins [EntryName]
outs

-- | The set of server-side variables in the value.
serverVarsInValue :: ExpValue -> S.Set VarName
serverVarsInValue :: ExpValue -> Set EntryName
serverVarsInValue = [EntryName] -> Set EntryName
forall a. Ord a => [a] -> Set a
S.fromList ([EntryName] -> Set EntryName)
-> (ExpValue -> [EntryName]) -> ExpValue -> Set EntryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptValue ValOrVar -> [EntryName])
-> [ScriptValue ValOrVar] -> [EntryName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue ValOrVar -> [EntryName]
isVar ([ScriptValue ValOrVar] -> [EntryName])
-> (ExpValue -> [ScriptValue ValOrVar]) -> ExpValue -> [EntryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpValue -> [ScriptValue ValOrVar]
forall a. Compound a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
    isVar :: ScriptValue ValOrVar -> [EntryName]
isVar (SValue EntryName
_ (VVar EntryName
x)) = [EntryName
x]
    isVar (SValue EntryName
_ (VVal Value
_)) = []
    isVar (SFun EntryName
_ [EntryName]
_ [EntryName]
_ [ScriptValue ValOrVar]
closure) = (ScriptValue ValOrVar -> [EntryName])
-> [ScriptValue ValOrVar] -> [EntryName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue ValOrVar -> [EntryName]
isVar ([ScriptValue ValOrVar] -> [EntryName])
-> [ScriptValue ValOrVar] -> [EntryName]
forall a b. (a -> b) -> a -> b
$ [ScriptValue ValOrVar] -> [ScriptValue ValOrVar]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [ScriptValue ValOrVar]
closure

-- | Convert a value into a corresponding expression.
valueToExp :: ExpValue -> Exp
valueToExp :: ExpValue -> Exp
valueToExp (V.ValueAtom (SValue EntryName
t (VVar EntryName
v))) =
  EntryName -> EntryName -> Exp
ServerVar EntryName
t EntryName
v
valueToExp (V.ValueAtom (SValue EntryName
_ (VVal Value
v))) =
  Value -> Exp
Const Value
v
valueToExp (V.ValueAtom (SFun EntryName
fname [EntryName]
_ [EntryName]
_ [ScriptValue ValOrVar]
closure)) =
  Func -> [Exp] -> Exp
Call (EntryName -> Func
FuncFut EntryName
fname) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (ScriptValue ValOrVar -> Exp) -> [ScriptValue ValOrVar] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (ExpValue -> Exp
valueToExp (ExpValue -> Exp)
-> (ScriptValue ValOrVar -> ExpValue)
-> ScriptValue ValOrVar
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom) [ScriptValue ValOrVar]
closure
valueToExp (V.ValueRecord Map EntryName ExpValue
fs) =
  [(EntryName, Exp)] -> Exp
Record ([(EntryName, Exp)] -> Exp) -> [(EntryName, Exp)] -> Exp
forall a b. (a -> b) -> a -> b
$ Map EntryName Exp -> [(EntryName, Exp)]
forall k a. Map k a -> [(k, a)]
M.toList (Map EntryName Exp -> [(EntryName, Exp)])
-> Map EntryName Exp -> [(EntryName, Exp)]
forall a b. (a -> b) -> a -> b
$ (ExpValue -> Exp) -> Map EntryName ExpValue -> Map EntryName Exp
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ExpValue -> Exp
valueToExp Map EntryName ExpValue
fs
valueToExp (V.ValueTuple [ExpValue]
fs) =
  [Exp] -> Exp
Tuple ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (ExpValue -> Exp) -> [ExpValue] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map ExpValue -> Exp
valueToExp [ExpValue]
fs

-- Decompose a type name into a rank and an element type.
parseTypeName :: TypeName -> Maybe (Int, V.PrimType)
parseTypeName :: EntryName -> Maybe (Int, PrimType)
parseTypeName EntryName
s
  | Just PrimType
pt <- EntryName -> [(EntryName, PrimType)] -> Maybe PrimType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup EntryName
s [(EntryName, PrimType)]
m =
      (Int, PrimType) -> Maybe (Int, PrimType)
forall a. a -> Maybe a
Just (Int
0, PrimType
pt)
  | EntryName
"[]" EntryName -> EntryName -> Bool
`T.isPrefixOf` EntryName
s = do
      (Int
d, PrimType
pt) <- EntryName -> Maybe (Int, PrimType)
parseTypeName (Int -> EntryName -> EntryName
T.drop Int
2 EntryName
s)
      (Int, PrimType) -> Maybe (Int, PrimType)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, PrimType
pt)
  | Bool
otherwise = Maybe (Int, PrimType)
forall a. Maybe a
Nothing
  where
    prims :: [PrimType]
prims = [PrimType
forall a. Bounded a => a
minBound .. PrimType
forall a. Bounded a => a
maxBound]
    primtexts :: [EntryName]
primtexts = (PrimType -> EntryName) -> [PrimType] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> EntryName
V.valueTypeText (ValueType -> EntryName)
-> (PrimType -> ValueType) -> PrimType -> EntryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> PrimType -> ValueType
V.ValueType []) [PrimType]
prims
    m :: [(EntryName, PrimType)]
m = [EntryName] -> [PrimType] -> [(EntryName, PrimType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EntryName]
primtexts [PrimType]
prims

coerceValue :: TypeName -> V.Value -> Maybe V.Value
coerceValue :: EntryName -> Value -> Maybe Value
coerceValue EntryName
t Value
v = do
  (Int
_, PrimType
pt) <- EntryName -> Maybe (Int, PrimType)
parseTypeName EntryName
t
  case Value
v of
    V.I8Value Vector Int
shape Vector Int8
vs ->
      PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
pt Vector Int
shape ([Integer] -> Maybe Value) -> [Integer] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ (Int8 -> Integer) -> [Int8] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int8 -> Integer
forall a. Integral a => a -> Integer
toInteger ([Int8] -> [Integer]) -> [Int8] -> [Integer]
forall a b. (a -> b) -> a -> b
$ Vector Int8 -> [Int8]
forall a. Storable a => Vector a -> [a]
SVec.toList Vector Int8
vs
    V.I16Value Vector Int
shape Vector Int16
vs ->
      PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
pt Vector Int
shape ([Integer] -> Maybe Value) -> [Integer] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ (Int16 -> Integer) -> [Int16] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int16 -> Integer
forall a. Integral a => a -> Integer
toInteger ([Int16] -> [Integer]) -> [Int16] -> [Integer]
forall a b. (a -> b) -> a -> b
$ Vector Int16 -> [Int16]
forall a. Storable a => Vector a -> [a]
SVec.toList Vector Int16
vs
    V.I32Value Vector Int
shape Vector Int32
vs ->
      PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
pt Vector Int
shape ([Integer] -> Maybe Value) -> [Integer] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ (Int32 -> Integer) -> [Int32] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger ([Int32] -> [Integer]) -> [Int32] -> [Integer]
forall a b. (a -> b) -> a -> b
$ Vector Int32 -> [Int32]
forall a. Storable a => Vector a -> [a]
SVec.toList Vector Int32
vs
    V.I64Value Vector Int
shape Vector Int64
vs ->
      PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
pt Vector Int
shape ([Integer] -> Maybe Value) -> [Integer] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ (Int64 -> Integer) -> [Int64] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger ([Int64] -> [Integer]) -> [Int64] -> [Integer]
forall a b. (a -> b) -> a -> b
$ Vector Int64 -> [Int64]
forall a. Storable a => Vector a -> [a]
SVec.toList Vector Int64
vs
    Value
_ ->
      Maybe Value
forall a. Maybe a
Nothing
  where
    coerceInts :: PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
V.I8 Vector Int
shape =
      Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> ([Integer] -> Value) -> [Integer] -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int8 -> Value
V.I8Value Vector Int
shape (Vector Int8 -> Value)
-> ([Integer] -> Vector Int8) -> [Integer] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int8] -> Vector Int8
forall a. Storable a => [a] -> Vector a
SVec.fromList ([Int8] -> Vector Int8)
-> ([Integer] -> [Int8]) -> [Integer] -> Vector Int8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Int8) -> [Integer] -> [Int8]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int8
forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.I16 Vector Int
shape =
      Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> ([Integer] -> Value) -> [Integer] -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int16 -> Value
V.I16Value Vector Int
shape (Vector Int16 -> Value)
-> ([Integer] -> Vector Int16) -> [Integer] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int16] -> Vector Int16
forall a. Storable a => [a] -> Vector a
SVec.fromList ([Int16] -> Vector Int16)
-> ([Integer] -> [Int16]) -> [Integer] -> Vector Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Int16) -> [Integer] -> [Int16]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int16
forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.I32 Vector Int
shape =
      Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> ([Integer] -> Value) -> [Integer] -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int32 -> Value
V.I32Value Vector Int
shape (Vector Int32 -> Value)
-> ([Integer] -> Vector Int32) -> [Integer] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int32] -> Vector Int32
forall a. Storable a => [a] -> Vector a
SVec.fromList ([Int32] -> Vector Int32)
-> ([Integer] -> [Int32]) -> [Integer] -> Vector Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Int32) -> [Integer] -> [Int32]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int32
forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.I64 Vector Int
shape =
      Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> ([Integer] -> Value) -> [Integer] -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int64 -> Value
V.I64Value Vector Int
shape (Vector Int64 -> Value)
-> ([Integer] -> Vector Int64) -> [Integer] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int64] -> Vector Int64
forall a. Storable a => [a] -> Vector a
SVec.fromList ([Int64] -> Vector Int64)
-> ([Integer] -> [Int64]) -> [Integer] -> Vector Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Int64) -> [Integer] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int64
forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.F32 Vector Int
shape =
      Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> ([Integer] -> Value) -> [Integer] -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Float -> Value
V.F32Value Vector Int
shape (Vector Float -> Value)
-> ([Integer] -> Vector Float) -> [Integer] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Float] -> Vector Float
forall a. Storable a => [a] -> Vector a
SVec.fromList ([Float] -> Vector Float)
-> ([Integer] -> [Float]) -> [Integer] -> Vector Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Float) -> [Integer] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Float
forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.F64 Vector Int
shape =
      Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> ([Integer] -> Value) -> [Integer] -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Double -> Value
V.F64Value Vector Int
shape (Vector Double -> Value)
-> ([Integer] -> Vector Double) -> [Integer] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Double] -> Vector Double
forall a. Storable a => [a] -> Vector a
SVec.fromList ([Double] -> Vector Double)
-> ([Integer] -> [Double]) -> [Integer] -> Vector Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Double) -> [Integer] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Double
forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
_ Vector Int
_ =
      Maybe Value -> [Integer] -> Maybe Value
forall a b. a -> b -> a
const Maybe Value
forall a. Maybe a
Nothing

-- | Store the provided value to the specified file. Fails if `ExpValue` is not
-- either a primitive or a single variable stored on the server. TODO: make this
-- handle arbitrary values.
storeExpValue ::
  (MonadIO m, MonadError T.Text m) =>
  ScriptServer ->
  FilePath ->
  ExpValue ->
  m ()
storeExpValue :: forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
ScriptServer -> String -> ExpValue -> m ()
storeExpValue ScriptServer
server String
path (V.ValueAtom (SValue EntryName
_ ValOrVar
v)) = do
  case ValOrVar
v of
    VVal Value
vv' ->
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
path (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. Binary a => a -> ByteString
Bin.encode Value
vv'
    VVar EntryName
vv' ->
      IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> String -> [EntryName] -> IO (Maybe CmdFailure)
cmdStore (ScriptServer -> Server
scriptServer ScriptServer
server) String
path [EntryName
vv']
storeExpValue ScriptServer
_ String
_ ExpValue
v =
  EntryName -> m ()
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m ()) -> EntryName -> m ()
forall a b. (a -> b) -> a -> b
$
    EntryName
"Cannot store value of type " EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> EntryName
forall a. Pretty a => a -> EntryName
prettyText ((ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
v)

-- | How to evaluate a builtin function.
type EvalBuiltin m = ScriptServer -> T.Text -> [ExpValue] -> m ExpValue

loadData ::
  (MonadIO m, MonadError T.Text m) =>
  FilePath ->
  m ExpValue
loadData :: forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> m ExpValue
loadData String
datafile = do
  ByteString
contents <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
LBS.readFile String
datafile
  let maybe_vs :: Maybe [Value]
maybe_vs = ByteString -> Maybe [Value]
V.readValues ByteString
contents
  case Maybe [Value]
maybe_vs of
    Maybe [Value]
Nothing ->
      EntryName -> m ExpValue
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m ExpValue) -> EntryName -> m ExpValue
forall a b. (a -> b) -> a -> b
$ EntryName
"Failed to read data file " EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> String -> EntryName
T.pack String
datafile
    Just [Value
v] ->
      ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ CompoundValue -> ExpValue
valToExpValue (CompoundValue -> ExpValue) -> CompoundValue -> ExpValue
forall a b. (a -> b) -> a -> b
$ Value -> CompoundValue
forall v. v -> Compound v
V.ValueAtom Value
v
    Just [Value]
vs ->
      ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ CompoundValue -> ExpValue
valToExpValue (CompoundValue -> ExpValue) -> CompoundValue -> ExpValue
forall a b. (a -> b) -> a -> b
$ [CompoundValue] -> CompoundValue
forall v. [Compound v] -> Compound v
V.ValueTuple ([CompoundValue] -> CompoundValue)
-> [CompoundValue] -> CompoundValue
forall a b. (a -> b) -> a -> b
$ (Value -> CompoundValue) -> [Value] -> [CompoundValue]
forall a b. (a -> b) -> [a] -> [b]
map Value -> CompoundValue
forall v. v -> Compound v
V.ValueAtom [Value]
vs

wrongArguments ::
  (MonadError T.Text m) => T.Text -> [ExpValue] -> m a
wrongArguments :: forall (m :: * -> *) a.
MonadError EntryName m =>
EntryName -> [ExpValue] -> m a
wrongArguments EntryName
fname [ExpValue]
vs =
  EntryName -> m a
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m a) -> EntryName -> m a
forall a b. (a -> b) -> a -> b
$
    EntryName
"$"
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
fname
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
" does not accept arguments of types: "
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName -> [EntryName] -> EntryName
T.intercalate EntryName
", " ((ExpValue -> EntryName) -> [ExpValue] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map (Compound ScriptValueType -> EntryName
forall a. Pretty a => a -> EntryName
prettyText (Compound ScriptValueType -> EntryName)
-> (ExpValue -> Compound ScriptValueType) -> ExpValue -> EntryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType) [ExpValue]
vs)

pathArg ::
  (MonadIO m, MonadError T.Text m) =>
  FilePath ->
  ScriptServer ->
  T.Text ->
  [ExpValue] ->
  m FilePath
pathArg :: forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> ScriptServer -> EntryName -> [ExpValue] -> m String
pathArg String
dir ScriptServer
server EntryName
cmd vs :: [ExpValue]
vs@[ExpValue
v] = do
  Maybe [Word8]
v' <- ScriptServer -> ExpValue -> m (Maybe [Word8])
forall t (m :: * -> *).
(GetValue t, MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Maybe t)
getHaskellValue ScriptServer
server ExpValue
v
  case Maybe [Word8]
v' of
    Just [Word8]
path ->
      String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8]
path :: [Word8])
    Maybe [Word8]
_ ->
      EntryName -> [ExpValue] -> m String
forall (m :: * -> *) a.
MonadError EntryName m =>
EntryName -> [ExpValue] -> m a
wrongArguments EntryName
cmd [ExpValue]
vs
pathArg String
_ ScriptServer
_ EntryName
cmd [ExpValue]
vs =
  EntryName -> [ExpValue] -> m String
forall (m :: * -> *) a.
MonadError EntryName m =>
EntryName -> [ExpValue] -> m a
wrongArguments EntryName
cmd [ExpValue]
vs

newVar :: (MonadIO m) => ScriptServer -> T.Text -> m T.Text
newVar :: forall (m :: * -> *).
MonadIO m =>
ScriptServer -> EntryName -> m EntryName
newVar ScriptServer
server EntryName
base = IO EntryName -> m EntryName
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EntryName -> m EntryName) -> IO EntryName -> m EntryName
forall a b. (a -> b) -> a -> b
$ do
  Int
x <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
counter
  IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Int
counter (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  let v :: EntryName
v = EntryName
base EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> Int -> EntryName
forall a. Pretty a => a -> EntryName
prettyText Int
x
  IORef [EntryName] -> ([EntryName] -> [EntryName]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [EntryName]
vars (EntryName
v :)
  EntryName -> IO EntryName
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v
  where
    vars :: IORef [EntryName]
vars = ScriptServer -> IORef [EntryName]
scriptVars ScriptServer
server
    counter :: IORef Int
counter = ScriptServer -> IORef Int
scriptCounter ScriptServer
server

-- | Handles the following builtin functions: @loaddata@, @loadbytes@.
-- Fails for everything else. The 'FilePath' indicates the directory
-- that files should be read relative to.
scriptBuiltin :: (MonadIO m, MonadError T.Text m) => FilePath -> EvalBuiltin m
scriptBuiltin :: forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> EvalBuiltin m
scriptBuiltin String
dir ScriptServer
server EntryName
"loaddata" [ExpValue]
vs =
  String -> m ExpValue
forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> m ExpValue
loadData (String -> m ExpValue) -> m String -> m ExpValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ScriptServer -> EntryName -> [ExpValue] -> m String
forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> ScriptServer -> EntryName -> [ExpValue] -> m String
pathArg String
dir ScriptServer
server EntryName
"loaddata" [ExpValue]
vs
scriptBuiltin String
dir ScriptServer
server EntryName
"loadbytes" [ExpValue]
vs =
  (ByteString -> ExpValue) -> m ByteString -> m ExpValue
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> (ByteString -> ScriptValue ValOrVar) -> ByteString -> ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntryName -> ValOrVar -> ScriptValue ValOrVar
forall v. EntryName -> v -> ScriptValue v
SValue EntryName
"[]u8" (ValOrVar -> ScriptValue ValOrVar)
-> (ByteString -> ValOrVar) -> ByteString -> ScriptValue ValOrVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValOrVar
VVal (Value -> ValOrVar)
-> (ByteString -> Value) -> ByteString -> ValOrVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Value
forall t. PutValue1 t => t -> Value
V.putValue1) (m ByteString -> m ExpValue)
-> (String -> m ByteString) -> String -> m ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (String -> IO ByteString) -> String -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BS.readFile
    (String -> m ExpValue) -> m String -> m ExpValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ScriptServer -> EntryName -> [ExpValue] -> m String
forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> ScriptServer -> EntryName -> [ExpValue] -> m String
pathArg String
dir ScriptServer
server EntryName
"loadbytes" [ExpValue]
vs
scriptBuiltin String
dir ScriptServer
server EntryName
"restore" [ExpValue]
vs
  | [ExpValue
tv, ExpValue
fv] <- [ExpValue]
vs = do
      Maybe [Word8]
tv' <- ScriptServer -> ExpValue -> m (Maybe [Word8])
forall t (m :: * -> *).
(GetValue t, MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Maybe t)
getHaskellValue ScriptServer
server ExpValue
tv
      Maybe [Word8]
fv' <- ScriptServer -> ExpValue -> m (Maybe [Word8])
forall t (m :: * -> *).
(GetValue t, MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Maybe t)
getHaskellValue ScriptServer
server ExpValue
fv
      case (Maybe [Word8]
tv', Maybe [Word8]
fv') of
        (Just [Word8]
tname, Just [Word8]
fname) -> do
          let tname' :: EntryName
tname' = String -> EntryName
T.pack (String -> EntryName) -> String -> EntryName
forall a b. (a -> b) -> a -> b
$ (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8]
tname :: [Word8])
              fname' :: String
fname' = String
dir String -> ShowS
</> (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8]
fname :: [Word8])
          EntryName
v <- ScriptServer -> EntryName -> m EntryName
forall (m :: * -> *).
MonadIO m =>
ScriptServer -> EntryName -> m EntryName
newVar ScriptServer
server EntryName
"restore"
          IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server
-> String -> [(EntryName, EntryName)] -> IO (Maybe CmdFailure)
cmdRestore (ScriptServer -> Server
scriptServer ScriptServer
server) String
fname' [(EntryName
v, EntryName
tname')]
          ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> ScriptValue ValOrVar -> ExpValue
forall a b. (a -> b) -> a -> b
$ EntryName -> ValOrVar -> ScriptValue ValOrVar
forall v. EntryName -> v -> ScriptValue v
SValue EntryName
tname' (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ EntryName -> ValOrVar
VVar EntryName
v
        (Maybe [Word8], Maybe [Word8])
_ ->
          EntryName -> [ExpValue] -> m ExpValue
forall (m :: * -> *) a.
MonadError EntryName m =>
EntryName -> [ExpValue] -> m a
wrongArguments EntryName
"restore" [ExpValue]
vs
  | Bool
otherwise =
      EntryName -> [ExpValue] -> m ExpValue
forall (m :: * -> *) a.
MonadError EntryName m =>
EntryName -> [ExpValue] -> m a
wrongArguments EntryName
"restore" [ExpValue]
vs
scriptBuiltin String
_ ScriptServer
_ EntryName
f [ExpValue]
_ =
  EntryName -> m ExpValue
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m ExpValue) -> EntryName -> m ExpValue
forall a b. (a -> b) -> a -> b
$ EntryName
"Unknown builtin function $" EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName -> EntryName
forall a. Pretty a => a -> EntryName
prettyText EntryName
f

-- | Symbol table used for local variable lookups during expression evaluation.
type VTable = M.Map VarName ExpValue

cannotApply ::
  (MonadError T.Text m, Pretty a, Pretty b) =>
  T.Text ->
  [a] ->
  [b] ->
  m c
cannotApply :: forall (m :: * -> *) a b c.
(MonadError EntryName m, Pretty a, Pretty b) =>
EntryName -> [a] -> [b] -> m c
cannotApply EntryName
fname [a]
expected [b]
actual =
  EntryName -> m c
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m c) -> EntryName -> m c
forall a b. (a -> b) -> a -> b
$
    EntryName
"Function \""
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
fname
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
"\" expects "
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> Int -> EntryName
forall a. Pretty a => a -> EntryName
prettyText ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
expected)
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
" argument(s) of types:\n"
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName -> [EntryName] -> EntryName
T.intercalate EntryName
"\n" ((a -> EntryName) -> [a] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map a -> EntryName
forall a. Pretty a => a -> EntryName
prettyTextOneLine [a]
expected)
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
"\nBut applied to "
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> Int -> EntryName
forall a. Pretty a => a -> EntryName
prettyText ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
actual)
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
" argument(s) of types:\n"
      EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName -> [EntryName] -> EntryName
T.intercalate EntryName
"\n" ((b -> EntryName) -> [b] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map b -> EntryName
forall a. Pretty a => a -> EntryName
prettyTextOneLine [b]
actual)

-- | Evaluate a FutharkScript expression relative to some running server.
evalExp ::
  forall m.
  (MonadError T.Text m, MonadIO m) =>
  EvalBuiltin m ->
  ScriptServer ->
  Exp ->
  m ExpValue
evalExp :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
evalExp EvalBuiltin m
builtin ScriptServer
sserver Exp
top_level_e = do
  let ( ScriptServer
          { scriptServer :: ScriptServer -> Server
scriptServer = Server
server,
            scriptTypes :: ScriptServer -> TypeMap
scriptTypes = TypeMap
types,
            scriptVars :: ScriptServer -> IORef [EntryName]
scriptVars = IORef [EntryName]
vars
          }
        ) = ScriptServer
sserver
  [EntryName]
old_vars <- IO [EntryName] -> m [EntryName]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [EntryName] -> m [EntryName])
-> IO [EntryName] -> m [EntryName]
forall a b. (a -> b) -> a -> b
$ IORef [EntryName] -> IO [EntryName]
forall a. IORef a -> IO a
readIORef IORef [EntryName]
vars
  let newVar' :: EntryName -> m EntryName
newVar' = ScriptServer -> EntryName -> m EntryName
forall (m :: * -> *).
MonadIO m =>
ScriptServer -> EntryName -> m EntryName
newVar ScriptServer
sserver

      mkRecord :: EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t [EntryName]
vs = do
        EntryName
v <- EntryName -> m EntryName
newVar' EntryName
"record"
        IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server
-> EntryName -> EntryName -> [EntryName] -> IO (Maybe CmdFailure)
cmdNew Server
server EntryName
v EntryName
t [EntryName]
vs
        EntryName -> m EntryName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v

      getField :: EntryName -> (Name, b) -> m EntryName
getField EntryName
from (Name
f, b
_) = do
        EntryName
to <- EntryName -> m EntryName
newVar' EntryName
"field"
        IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server
-> EntryName -> EntryName -> EntryName -> IO (Maybe CmdFailure)
cmdProject Server
server EntryName
to EntryName
from (EntryName -> IO (Maybe CmdFailure))
-> EntryName -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Name -> EntryName
nameToText Name
f
        EntryName -> m EntryName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
to

      toVar :: ValOrVar -> m VarName
      toVar :: ValOrVar -> m EntryName
toVar (VVar EntryName
v) = EntryName -> m EntryName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v
      toVar (VVal Value
val) = do
        EntryName
v <- EntryName -> m EntryName
newVar' EntryName
"const"
        Server -> EntryName -> Value -> m ()
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> Value -> m ()
writeVar Server
server EntryName
v Value
val
        EntryName -> m EntryName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v

      scriptValueToValOrVar :: ScriptValue a -> m a
scriptValueToValOrVar (SFun EntryName
f [EntryName]
_ [EntryName]
_ [ScriptValue a]
_) =
        EntryName -> m a
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m a) -> EntryName -> m a
forall a b. (a -> b) -> a -> b
$ EntryName
"Function " EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
f EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
" not fully applied."
      scriptValueToValOrVar (SValue EntryName
_ a
v) =
        a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

      scriptValueToVar :: ScriptValue ValOrVar -> m VarName
      scriptValueToVar :: ScriptValue ValOrVar -> m EntryName
scriptValueToVar = ValOrVar -> m EntryName
toVar (ValOrVar -> m EntryName)
-> (ScriptValue ValOrVar -> m ValOrVar)
-> ScriptValue ValOrVar
-> m EntryName
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ScriptValue ValOrVar -> m ValOrVar
forall {m :: * -> *} {a}.
MonadError EntryName m =>
ScriptValue a -> m a
scriptValueToValOrVar

      -- Apart from type checking, this function also converts
      -- FutharkScript tuples/records to Futhark-level tuples/records,
      -- as well as maps between different names for the same
      -- tuple/record.
      --
      -- We also implicitly convert the types of constants.
      interValToVar :: m VarName -> TypeName -> ExpValue -> m VarName
      interValToVar :: m EntryName -> EntryName -> ExpValue -> m EntryName
interValToVar m EntryName
_ EntryName
t (V.ValueAtom ScriptValue ValOrVar
v)
        | EntryName -> ScriptValueType
STValue EntryName
t ScriptValueType -> ScriptValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ScriptValue ValOrVar
v = ScriptValue ValOrVar -> m EntryName
scriptValueToVar ScriptValue ValOrVar
v
      interValToVar m EntryName
bad EntryName
t (V.ValueTuple [ExpValue]
vs)
        | Just [EntryName]
ts <- EntryName -> TypeMap -> Maybe [EntryName]
isTuple EntryName
t TypeMap
types,
          [ExpValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
ts =
            EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t ([EntryName] -> m EntryName) -> m [EntryName] -> m EntryName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (EntryName -> ExpValue -> m EntryName)
-> [EntryName] -> [ExpValue] -> m [EntryName]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m EntryName -> EntryName -> ExpValue -> m EntryName
interValToVar m EntryName
bad) [EntryName]
ts [ExpValue]
vs
      interValToVar m EntryName
bad EntryName
t (V.ValueRecord Map EntryName ExpValue
vs)
        | Just [(Name, EntryName)]
fs <- EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
t TypeMap
types,
          Just [ExpValue]
vs' <- ((Name, EntryName) -> Maybe ExpValue)
-> [(Name, EntryName)] -> Maybe [ExpValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((EntryName -> Map EntryName ExpValue -> Maybe ExpValue
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map EntryName ExpValue
vs) (EntryName -> Maybe ExpValue)
-> ((Name, EntryName) -> EntryName)
-> (Name, EntryName)
-> Maybe ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> EntryName
nameToText (Name -> EntryName)
-> ((Name, EntryName) -> Name) -> (Name, EntryName) -> EntryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, EntryName) -> Name
forall a b. (a, b) -> a
fst) [(Name, EntryName)]
fs =
            EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t ([EntryName] -> m EntryName) -> m [EntryName] -> m EntryName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (EntryName -> ExpValue -> m EntryName)
-> [EntryName] -> [ExpValue] -> m [EntryName]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m EntryName -> EntryName -> ExpValue -> m EntryName
interValToVar m EntryName
bad) (((Name, EntryName) -> EntryName)
-> [(Name, EntryName)] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map (Name, EntryName) -> EntryName
forall a b. (a, b) -> b
snd [(Name, EntryName)]
fs) [ExpValue]
vs'
      interValToVar m EntryName
_ EntryName
t (V.ValueAtom (SValue EntryName
vt (VVar EntryName
v)))
        | Just [(Name, EntryName)]
t_fs <- EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
t TypeMap
types,
          Just [(Name, EntryName)]
vt_fs <- EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
vt TypeMap
types,
          [(Name, EntryName)]
vt_fs [(Name, EntryName)] -> [(Name, EntryName)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Name, EntryName)]
t_fs =
            EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t ([EntryName] -> m EntryName) -> m [EntryName] -> m EntryName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Name, EntryName) -> m EntryName)
-> [(Name, EntryName)] -> m [EntryName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (EntryName -> (Name, EntryName) -> m EntryName
forall {b}. EntryName -> (Name, b) -> m EntryName
getField EntryName
v) [(Name, EntryName)]
vt_fs
      interValToVar m EntryName
_ EntryName
t (V.ValueAtom (SValue EntryName
_ (VVal Value
v)))
        | Just Value
v' <- EntryName -> Value -> Maybe Value
coerceValue EntryName
t Value
v =
            ScriptValue ValOrVar -> m EntryName
scriptValueToVar (ScriptValue ValOrVar -> m EntryName)
-> ScriptValue ValOrVar -> m EntryName
forall a b. (a -> b) -> a -> b
$ EntryName -> ValOrVar -> ScriptValue ValOrVar
forall v. EntryName -> v -> ScriptValue v
SValue EntryName
t (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
v'
      interValToVar m EntryName
bad EntryName
_ ExpValue
_ = m EntryName
bad

      letMatch :: [VarName] -> ExpValue -> m VTable
      letMatch :: [EntryName] -> ExpValue -> m (Map EntryName ExpValue)
letMatch [EntryName]
vs ExpValue
val
        | [ExpValue]
vals <- ExpValue -> [ExpValue]
forall v. Compound v -> [Compound v]
V.unCompound ExpValue
val,
          [EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ExpValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vals =
            Map EntryName ExpValue -> m (Map EntryName ExpValue)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map EntryName ExpValue -> m (Map EntryName ExpValue))
-> Map EntryName ExpValue -> m (Map EntryName ExpValue)
forall a b. (a -> b) -> a -> b
$ [(EntryName, ExpValue)] -> Map EntryName ExpValue
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([EntryName] -> [ExpValue] -> [(EntryName, ExpValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EntryName]
vs [ExpValue]
vals)
        | Bool
otherwise =
            EntryName -> m (Map EntryName ExpValue)
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m (Map EntryName ExpValue))
-> EntryName -> m (Map EntryName ExpValue)
forall a b. (a -> b) -> a -> b
$
              EntryName
"Pat: "
                EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> [EntryName] -> EntryName
forall a. Pretty a => a -> EntryName
prettyTextOneLine [EntryName]
vs
                EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
"\nDoes not match value of type: "
                EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> EntryName
forall a. Pretty a => a -> EntryName
prettyTextOneLine ((ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
val)

      evalExp' :: VTable -> Exp -> m ExpValue
      evalExp' :: Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
_ (ServerVar EntryName
t EntryName
v) =
        ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> ScriptValue ValOrVar -> ExpValue
forall a b. (a -> b) -> a -> b
$ EntryName -> ValOrVar -> ScriptValue ValOrVar
forall v. EntryName -> v -> ScriptValue v
SValue EntryName
t (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ EntryName -> ValOrVar
VVar EntryName
v
      evalExp' Map EntryName ExpValue
vtable (Call (FuncBuiltin EntryName
name) [Exp]
es) =
        EvalBuiltin m
builtin ScriptServer
sserver EntryName
name ([ExpValue] -> m ExpValue) -> m [ExpValue] -> m ExpValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Exp -> m ExpValue) -> [Exp] -> m [ExpValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) [Exp]
es
      evalExp' Map EntryName ExpValue
vtable (Call (FuncFut EntryName
name) [Exp]
es)
        | Just ExpValue
e <- EntryName -> Map EntryName ExpValue -> Maybe ExpValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntryName
name Map EntryName ExpValue
vtable = do
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
es) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
              EntryName -> m ()
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m ()) -> EntryName -> m ()
forall a b. (a -> b) -> a -> b
$
                EntryName
"Locally bound name cannot be invoked as a function: " EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName -> EntryName
forall a. Pretty a => a -> EntryName
prettyText EntryName
name
            ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
e
        | Bool
otherwise = do
            [EntryName]
in_types <- ([InputType] -> [EntryName]) -> m [InputType] -> m [EntryName]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InputType -> EntryName) -> [InputType] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map InputType -> EntryName
inputType) (m [InputType] -> m [EntryName]) -> m [InputType] -> m [EntryName]
forall a b. (a -> b) -> a -> b
$ IO (Either CmdFailure [InputType]) -> m [InputType]
forall (m :: * -> *) a.
(MonadError EntryName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [InputType]) -> m [InputType])
-> IO (Either CmdFailure [InputType]) -> m [InputType]
forall a b. (a -> b) -> a -> b
$ Server -> EntryName -> IO (Either CmdFailure [InputType])
cmdInputs Server
server EntryName
name
            [EntryName]
out_types <- ([OutputType] -> [EntryName]) -> m [OutputType] -> m [EntryName]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((OutputType -> EntryName) -> [OutputType] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map OutputType -> EntryName
outputType) (m [OutputType] -> m [EntryName])
-> m [OutputType] -> m [EntryName]
forall a b. (a -> b) -> a -> b
$ IO (Either CmdFailure [OutputType]) -> m [OutputType]
forall (m :: * -> *) a.
(MonadError EntryName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [OutputType]) -> m [OutputType])
-> IO (Either CmdFailure [OutputType]) -> m [OutputType]
forall a b. (a -> b) -> a -> b
$ Server -> EntryName -> IO (Either CmdFailure [OutputType])
cmdOutputs Server
server EntryName
name

            [ExpValue]
es' <- (Exp -> m ExpValue) -> [Exp] -> m [ExpValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) [Exp]
es

            let bad :: m c
bad = EntryName -> [EntryName] -> [Compound ScriptValueType] -> m c
forall (m :: * -> *) a b c.
(MonadError EntryName m, Pretty a, Pretty b) =>
EntryName -> [a] -> [b] -> m c
cannotApply EntryName
name [EntryName]
in_types ([Compound ScriptValueType] -> m c)
-> [Compound ScriptValueType] -> m c
forall a b. (a -> b) -> a -> b
$ (ExpValue -> Compound ScriptValueType)
-> [ExpValue] -> [Compound ScriptValueType]
forall a b. (a -> b) -> [a] -> [b]
map ((ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType) [ExpValue]
es'
                tryApply :: [ExpValue] -> m ExpValue
tryApply [ExpValue]
args = do
                  [EntryName]
arg_types <- (EntryName -> ExpValue -> m EntryName)
-> [EntryName] -> [ExpValue] -> m [EntryName]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m EntryName -> EntryName -> ExpValue -> m EntryName
interValToVar m EntryName
forall {c}. m c
bad) [EntryName]
in_types [ExpValue]
args

                  if [EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
in_types Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
arg_types
                    then do
                      [EntryName]
outs <- Int -> m EntryName -> m [EntryName]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
out_types) (m EntryName -> m [EntryName]) -> m EntryName -> m [EntryName]
forall a b. (a -> b) -> a -> b
$ EntryName -> m EntryName
newVar' EntryName
"out"
                      m [EntryName] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [EntryName] -> m ()) -> m [EntryName] -> m ()
forall a b. (a -> b) -> a -> b
$ IO (Either CmdFailure [EntryName]) -> m [EntryName]
forall (m :: * -> *) a.
(MonadError EntryName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [EntryName]) -> m [EntryName])
-> IO (Either CmdFailure [EntryName]) -> m [EntryName]
forall a b. (a -> b) -> a -> b
$ Server
-> EntryName
-> [EntryName]
-> [EntryName]
-> IO (Either CmdFailure [EntryName])
cmdCall Server
server EntryName
name [EntryName]
outs [EntryName]
arg_types
                      ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ [ExpValue] -> ExpValue
forall v. [Compound v] -> Compound v
V.mkCompound ([ExpValue] -> ExpValue) -> [ExpValue] -> ExpValue
forall a b. (a -> b) -> a -> b
$ (ScriptValue ValOrVar -> ExpValue)
-> [ScriptValue ValOrVar] -> [ExpValue]
forall a b. (a -> b) -> [a] -> [b]
map ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom ([ScriptValue ValOrVar] -> [ExpValue])
-> [ScriptValue ValOrVar] -> [ExpValue]
forall a b. (a -> b) -> a -> b
$ (EntryName -> ValOrVar -> ScriptValue ValOrVar)
-> [EntryName] -> [ValOrVar] -> [ScriptValue ValOrVar]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith EntryName -> ValOrVar -> ScriptValue ValOrVar
forall v. EntryName -> v -> ScriptValue v
SValue [EntryName]
out_types ([ValOrVar] -> [ScriptValue ValOrVar])
-> [ValOrVar] -> [ScriptValue ValOrVar]
forall a b. (a -> b) -> a -> b
$ (EntryName -> ValOrVar) -> [EntryName] -> [ValOrVar]
forall a b. (a -> b) -> [a] -> [b]
map EntryName -> ValOrVar
VVar [EntryName]
outs
                    else
                      ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue)
-> ([ScriptValue ValOrVar] -> ExpValue)
-> [ScriptValue ValOrVar]
-> m ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> ([ScriptValue ValOrVar] -> ScriptValue ValOrVar)
-> [ScriptValue ValOrVar]
-> ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntryName
-> [EntryName]
-> [EntryName]
-> [ScriptValue ValOrVar]
-> ScriptValue ValOrVar
forall v.
EntryName
-> [EntryName] -> [EntryName] -> [ScriptValue v] -> ScriptValue v
SFun EntryName
name [EntryName]
in_types [EntryName]
out_types ([ScriptValue ValOrVar] -> m ExpValue)
-> [ScriptValue ValOrVar] -> m ExpValue
forall a b. (a -> b) -> a -> b
$
                        (EntryName -> ValOrVar -> ScriptValue ValOrVar)
-> [EntryName] -> [ValOrVar] -> [ScriptValue ValOrVar]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith EntryName -> ValOrVar -> ScriptValue ValOrVar
forall v. EntryName -> v -> ScriptValue v
SValue [EntryName]
in_types ([ValOrVar] -> [ScriptValue ValOrVar])
-> [ValOrVar] -> [ScriptValue ValOrVar]
forall a b. (a -> b) -> a -> b
$
                          (EntryName -> ValOrVar) -> [EntryName] -> [ValOrVar]
forall a b. (a -> b) -> [a] -> [b]
map EntryName -> ValOrVar
VVar [EntryName]
arg_types

            -- Careful to not require saturated application, but do still
            -- check for over-saturation.
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
es Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
in_types) m ()
forall {c}. m c
bad

            -- Allow automatic uncurrying if applicable.
            case [ExpValue]
es' of
              [V.ValueTuple [ExpValue]
es''] | [ExpValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
es'' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
in_types -> [ExpValue] -> m ExpValue
tryApply [ExpValue]
es''
              [ExpValue]
_ -> [ExpValue] -> m ExpValue
tryApply [ExpValue]
es'
      evalExp' Map EntryName ExpValue
_ (StringLit EntryName
s) =
        case EntryName -> Maybe Value
forall t. PutValue t => t -> Maybe Value
V.putValue EntryName
s of
          Just Value
s' ->
            ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> ScriptValue ValOrVar -> ExpValue
forall a b. (a -> b) -> a -> b
$ EntryName -> ValOrVar -> ScriptValue ValOrVar
forall v. EntryName -> v -> ScriptValue v
SValue (ValueType -> EntryName
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
s')) (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
s'
          Maybe Value
Nothing -> String -> m ExpValue
forall a. HasCallStack => String -> a
error (String -> m ExpValue) -> String -> m ExpValue
forall a b. (a -> b) -> a -> b
$ String
"Unable to write value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ EntryName -> String
forall a. Pretty a => a -> String
prettyString EntryName
s
      evalExp' Map EntryName ExpValue
_ (Const Value
val) =
        ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> ScriptValue ValOrVar -> ExpValue
forall a b. (a -> b) -> a -> b
$ EntryName -> ValOrVar -> ScriptValue ValOrVar
forall v. EntryName -> v -> ScriptValue v
SValue (ValueType -> EntryName
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
val)) (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
val
      evalExp' Map EntryName ExpValue
vtable (Tuple [Exp]
es) =
        [ExpValue] -> ExpValue
forall v. [Compound v] -> Compound v
V.ValueTuple ([ExpValue] -> ExpValue) -> m [ExpValue] -> m ExpValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> m ExpValue) -> [Exp] -> m [ExpValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) [Exp]
es
      evalExp' Map EntryName ExpValue
vtable e :: Exp
e@(Record [(EntryName, Exp)]
m) = do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([EntryName] -> [EntryName]
forall a. Ord a => [a] -> [a]
nubOrd (((EntryName, Exp) -> EntryName)
-> [(EntryName, Exp)] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map (EntryName, Exp) -> EntryName
forall a b. (a, b) -> a
fst [(EntryName, Exp)]
m)) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (((EntryName, Exp) -> EntryName)
-> [(EntryName, Exp)] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map (EntryName, Exp) -> EntryName
forall a b. (a, b) -> a
fst [(EntryName, Exp)]
m)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          EntryName -> m ()
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m ()) -> EntryName -> m ()
forall a b. (a -> b) -> a -> b
$
            EntryName
"Record " EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> Exp -> EntryName
forall a. Pretty a => a -> EntryName
prettyText Exp
e EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
" has duplicate fields."
        Map EntryName ExpValue -> ExpValue
forall v. Map EntryName (Compound v) -> Compound v
V.ValueRecord (Map EntryName ExpValue -> ExpValue)
-> m (Map EntryName ExpValue) -> m ExpValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> m ExpValue)
-> Map EntryName Exp -> m (Map EntryName ExpValue)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map EntryName a -> f (Map EntryName b)
traverse (Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) ([(EntryName, Exp)] -> Map EntryName Exp
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(EntryName, Exp)]
m)
      evalExp' Map EntryName ExpValue
vtable (Let [EntryName]
pat Exp
e1 Exp
e2) = do
        ExpValue
v <- Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable Exp
e1
        Map EntryName ExpValue
pat_vtable <- [EntryName] -> ExpValue -> m (Map EntryName ExpValue)
letMatch [EntryName]
pat ExpValue
v
        Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' (Map EntryName ExpValue
pat_vtable Map EntryName ExpValue
-> Map EntryName ExpValue -> Map EntryName ExpValue
forall a. Semigroup a => a -> a -> a
<> Map EntryName ExpValue
vtable) Exp
e2

  let freeNonresultVars :: ExpValue -> m ExpValue
freeNonresultVars ExpValue
v = do
        let keep_vars :: Set EntryName
keep_vars = ExpValue -> Set EntryName
serverVarsInValue ExpValue
v Set EntryName -> Set EntryName -> Set EntryName
forall a. Semigroup a => a -> a -> a
<> [EntryName] -> Set EntryName
forall a. Ord a => [a] -> Set a
S.fromList [EntryName]
old_vars
        [EntryName]
to_free <- IO [EntryName] -> m [EntryName]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [EntryName] -> m [EntryName])
-> IO [EntryName] -> m [EntryName]
forall a b. (a -> b) -> a -> b
$ (EntryName -> Bool) -> [EntryName] -> [EntryName]
forall a. (a -> Bool) -> [a] -> [a]
filter (EntryName -> Set EntryName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set EntryName
keep_vars) ([EntryName] -> [EntryName]) -> IO [EntryName] -> IO [EntryName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [EntryName] -> IO [EntryName]
forall a. IORef a -> IO a
readIORef IORef [EntryName]
vars
        IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> [EntryName] -> IO (Maybe CmdFailure)
cmdFree Server
server [EntryName]
to_free
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [EntryName] -> [EntryName] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [EntryName]
vars ([EntryName] -> IO ()) -> [EntryName] -> IO ()
forall a b. (a -> b) -> a -> b
$ Set EntryName -> [EntryName]
forall a. Set a -> [a]
S.toList Set EntryName
keep_vars
        ExpValue -> m ExpValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
v
      freeVarsOnError :: e -> m b
freeVarsOnError e
e = do
        -- We are intentionally ignoring any errors produced by
        -- cmdFree, because we already have another error to
        -- propagate.  Also, not all of the variables that we put in
        -- 'vars' might actually exist server-side, if we failed in a
        -- Call.
        m (Maybe CmdFailure) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe CmdFailure) -> m ()) -> m (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe CmdFailure) -> m (Maybe CmdFailure)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CmdFailure) -> m (Maybe CmdFailure))
-> IO (Maybe CmdFailure) -> m (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Server -> [EntryName] -> IO (Maybe CmdFailure)
cmdFree Server
server ([EntryName] -> IO (Maybe CmdFailure))
-> IO [EntryName] -> IO (Maybe CmdFailure)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef [EntryName] -> IO [EntryName]
forall a. IORef a -> IO a
readIORef IORef [EntryName]
vars
        e -> m b
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
  (ExpValue -> m ExpValue
forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
ExpValue -> m ExpValue
freeNonresultVars (ExpValue -> m ExpValue) -> m ExpValue -> m ExpValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
forall a. Monoid a => a
mempty Exp
top_level_e) m ExpValue -> (EntryName -> m ExpValue) -> m ExpValue
forall a. m a -> (EntryName -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` EntryName -> m ExpValue
forall {m :: * -> *} {e} {b}.
(MonadIO m, MonadError e m) =>
e -> m b
freeVarsOnError

-- | Read actual values from the server. Fails for values that have no
-- well-defined external representation.
getScriptValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ScriptValue ValOrVar -> m V.Value
getScriptValue :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ScriptValue ValOrVar -> m Value
getScriptValue ScriptServer
server = ScriptValue Value -> m Value
forall {m :: * -> *} {a}.
MonadError EntryName m =>
ScriptValue a -> m a
toGround (ScriptValue Value -> m Value)
-> (ScriptValue ValOrVar -> m (ScriptValue Value))
-> ScriptValue ValOrVar
-> m Value
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (ValOrVar -> m Value)
-> ScriptValue ValOrVar -> m (ScriptValue Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ScriptValue a -> f (ScriptValue b)
traverse ValOrVar -> m Value
forall {m :: * -> *}.
(MonadError EntryName m, MonadIO m) =>
ValOrVar -> m Value
onLeaf
  where
    onLeaf :: ValOrVar -> m Value
onLeaf (VVar EntryName
v) = Server -> EntryName -> m Value
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> m Value
readVar (ScriptServer -> Server
scriptServer ScriptServer
server) EntryName
v
    onLeaf (VVal Value
v) = Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
    toGround :: ScriptValue a -> m a
toGround (SFun EntryName
fname [EntryName]
_ [EntryName]
_ [ScriptValue a]
_) =
      EntryName -> m a
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m a) -> EntryName -> m a
forall a b. (a -> b) -> a -> b
$ EntryName
"Function " EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
fname EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
" not fully applied."
    toGround (SValue EntryName
_ a
v) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

-- | Read actual compound values from the server. Fails for values that have no
-- well-defined external representation.
getExpValue ::
  (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m V.CompoundValue
getExpValue :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue ScriptServer
server = (ScriptValue ValOrVar -> m Value) -> ExpValue -> m CompoundValue
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Compound a -> f (Compound b)
traverse (ScriptServer -> ScriptValue ValOrVar -> m Value
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ScriptValue ValOrVar -> m Value
getScriptValue ScriptServer
server)

-- | Retrieve a Haskell value from an 'ExpValue'. This returns 'Just' if the
-- 'ExpValue' is an atom with a non-opaque type.
getHaskellValue :: (V.GetValue t, MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m (Maybe t)
getHaskellValue :: forall t (m :: * -> *).
(GetValue t, MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Maybe t)
getHaskellValue ScriptServer
server ExpValue
v = do
  CompoundValue
v' <- ScriptServer -> ExpValue -> m CompoundValue
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue ScriptServer
server ExpValue
v
  case CompoundValue
v' of
    V.ValueAtom Value
v'' ->
      Maybe t -> m (Maybe t)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe t -> m (Maybe t)) -> Maybe t -> m (Maybe t)
forall a b. (a -> b) -> a -> b
$ Value -> Maybe t
forall t. GetValue t => Value -> Maybe t
V.getValue Value
v''
    CompoundValue
_ -> Maybe t -> m (Maybe t)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe t
forall a. Maybe a
Nothing

-- | Like 'evalExp', but requires all values to be non-functional.  If
-- the value has a bad type, return that type instead.  Other
-- evaluation problems (e.g. type failures) raise errors.
evalExpToGround ::
  (MonadError T.Text m, MonadIO m) =>
  EvalBuiltin m ->
  ScriptServer ->
  Exp ->
  m (Either (V.Compound ScriptValueType) V.CompoundValue)
evalExpToGround :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
EvalBuiltin m
-> ScriptServer
-> Exp
-> m (Either (Compound ScriptValueType) CompoundValue)
evalExpToGround EvalBuiltin m
builtin ScriptServer
server Exp
e = do
  ExpValue
v <- EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
evalExp EvalBuiltin m
builtin ScriptServer
server Exp
e
  -- This assumes that the only error that can occur during
  -- getExpValue is trying to read an opaque.
  (CompoundValue -> Either (Compound ScriptValueType) CompoundValue
forall a b. b -> Either a b
Right (CompoundValue -> Either (Compound ScriptValueType) CompoundValue)
-> m CompoundValue
-> m (Either (Compound ScriptValueType) CompoundValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptServer -> ExpValue -> m CompoundValue
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue ScriptServer
server ExpValue
v)
    m (Either (Compound ScriptValueType) CompoundValue)
-> (EntryName
    -> m (Either (Compound ScriptValueType) CompoundValue))
-> m (Either (Compound ScriptValueType) CompoundValue)
forall a. m a -> (EntryName -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` m (Either (Compound ScriptValueType) CompoundValue)
-> EntryName -> m (Either (Compound ScriptValueType) CompoundValue)
forall a b. a -> b -> a
const (Either (Compound ScriptValueType) CompoundValue
-> m (Either (Compound ScriptValueType) CompoundValue)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Compound ScriptValueType) CompoundValue
 -> m (Either (Compound ScriptValueType) CompoundValue))
-> Either (Compound ScriptValueType) CompoundValue
-> m (Either (Compound ScriptValueType) CompoundValue)
forall a b. (a -> b) -> a -> b
$ Compound ScriptValueType
-> Either (Compound ScriptValueType) CompoundValue
forall a b. a -> Either a b
Left (Compound ScriptValueType
 -> Either (Compound ScriptValueType) CompoundValue)
-> Compound ScriptValueType
-> Either (Compound ScriptValueType) CompoundValue
forall a b. (a -> b) -> a -> b
$ (ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
v)

-- | The set of Futhark variables that are referenced by the
-- expression - these will have to be entry points in the Futhark
-- program.
varsInExp :: Exp -> S.Set EntryName
varsInExp :: Exp -> Set EntryName
varsInExp ServerVar {} = Set EntryName
forall a. Monoid a => a
mempty
varsInExp (Call (FuncFut EntryName
v) [Exp]
es) = EntryName -> Set EntryName -> Set EntryName
forall a. Ord a => a -> Set a -> Set a
S.insert EntryName
v (Set EntryName -> Set EntryName) -> Set EntryName -> Set EntryName
forall a b. (a -> b) -> a -> b
$ (Exp -> Set EntryName) -> [Exp] -> Set EntryName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp [Exp]
es
varsInExp (Call (FuncBuiltin EntryName
_) [Exp]
es) = (Exp -> Set EntryName) -> [Exp] -> Set EntryName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp [Exp]
es
varsInExp (Tuple [Exp]
es) = (Exp -> Set EntryName) -> [Exp] -> Set EntryName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp [Exp]
es
varsInExp (Record [(EntryName, Exp)]
fs) = ((EntryName, Exp) -> Set EntryName)
-> [(EntryName, Exp)] -> Set EntryName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Exp -> Set EntryName) -> (EntryName, Exp) -> Set EntryName
forall m a. Monoid m => (a -> m) -> (EntryName, a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp) [(EntryName, Exp)]
fs
varsInExp Const {} = Set EntryName
forall a. Monoid a => a
mempty
varsInExp StringLit {} = Set EntryName
forall a. Monoid a => a
mempty
varsInExp (Let [EntryName]
pat Exp
e1 Exp
e2) = Exp -> Set EntryName
varsInExp Exp
e1 Set EntryName -> Set EntryName -> Set EntryName
forall a. Semigroup a => a -> a -> a
<> (EntryName -> Bool) -> Set EntryName -> Set EntryName
forall a. (a -> Bool) -> Set a -> Set a
S.filter (EntryName -> [EntryName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [EntryName]
pat) (Exp -> Set EntryName
varsInExp Exp
e2)

-- | Release all the server-side variables in the value.  Yes,
-- FutharkScript has manual memory management...
freeValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m ()
freeValue :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m ()
freeValue ScriptServer
server =
  IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ())
-> (ExpValue -> IO (Maybe CmdFailure)) -> ExpValue -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server -> [EntryName] -> IO (Maybe CmdFailure)
cmdFree (ScriptServer -> Server
scriptServer ScriptServer
server) ([EntryName] -> IO (Maybe CmdFailure))
-> (ExpValue -> [EntryName]) -> ExpValue -> IO (Maybe CmdFailure)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set EntryName -> [EntryName]
forall a. Set a -> [a]
S.toList (Set EntryName -> [EntryName])
-> (ExpValue -> Set EntryName) -> ExpValue -> [EntryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpValue -> Set EntryName
serverVarsInValue