-- | 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,

    -- * Evaluation
    EvalBuiltin,
    scriptBuiltin,
    evalExp,
    getExpValue,
    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.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
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty) [EntryName] -> IO TypeMap
onTypes 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 = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [EntryName]
types forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EntryName -> IO (Maybe [(Name, EntryName)])
onType [EntryName]
types
    onType :: EntryName -> IO (Maybe [(Name, EntryName)])
onType EntryName
t =
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map EntryName -> (Name, EntryName)
onField) 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 = 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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntryName -> EntryName -> (EntryName, EntryName)
T.breakOn EntryName
" "

isRecord :: TypeName -> TypeMap -> Maybe [(Name, TypeName)]
isRecord :: EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
t TypeMap
m = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ 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 = forall a. Map Name a -> Maybe [a]
areTupleFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList 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
  }

-- | 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Int
0
  TypeMap
types <- forall (m :: * -> *). MonadIO m => Server -> m TypeMap
typeMap Server
server
  ScriptServer -> m a
f forall a b. (a -> b) -> a -> b
$ Server -> IORef Int -> TypeMap -> ScriptServer
ScriptServer Server
server IORef Int
counter TypeMap
types

-- | 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 =
  forall a. ServerCfg -> (Server -> IO a) -> IO a
withServer ServerCfg
cfg forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Func] -> ShowS
$cshowList :: [Func] -> ShowS
show :: Func -> String
$cshow :: Func -> String
showsPrec :: Int -> Func -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exp] -> ShowS
$cshowList :: [Exp] -> ShowS
show :: Exp -> String
$cshow :: Exp -> String
showsPrec :: Int -> Exp -> ShowS
$cshowsPrec :: Int -> Exp -> ShowS
Show)

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

instance Pretty Exp where
  pretty :: forall ann. Exp -> Doc ann
pretty = 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
"$" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty EntryName
v
      pprPrec t
_ (Const Value
v) = forall a. [Doc a] -> Doc a
stack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ EntryName -> [EntryName]
T.lines forall a b. (a -> b) -> a -> b
$ Value -> EntryName
V.valueText Value
v
      pprPrec t
i (Let [EntryName]
pat Exp
e1 Exp
e2) =
        forall a. Bool -> Doc a -> Doc a
parensIf (t
i forall a. Ord a => a -> a -> Bool
> t
0) forall a b. (a -> b) -> a -> b
$ Doc ann
"let" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall {ann}. Doc ann
pat' forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall {ann}. Doc ann
equals forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Exp
e1 forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Exp
e2
        where
          pat' :: Doc ann
pat' = case [EntryName]
pat of
            [EntryName
x] -> forall a ann. Pretty a => a -> Doc ann
pretty EntryName
x
            [EntryName]
_ -> forall ann. Doc ann -> Doc ann
parens forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
align forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [EntryName]
pat
      pprPrec t
_ (Call Func
v []) = forall a ann. Pretty a => a -> Doc ann
pretty Func
v
      pprPrec t
i (Call Func
v [Exp]
args) =
        forall a. Bool -> Doc a -> Doc a
parensIf (t
i forall a. Ord a => a -> a -> Bool
> t
0) forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Func
v forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. [Doc a] -> Doc a
hsep (forall a b. (a -> b) -> [a] -> [b]
map (forall ann. Doc ann -> Doc ann
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Exp -> Doc ann
pprPrec t
1) [Exp]
args)
      pprPrec t
_ (Tuple [Exp]
vs) =
        forall ann. Doc ann -> Doc ann
parens forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall ann. Doc ann -> Doc ann
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) [Exp]
vs
      pprPrec t
_ (StringLit EntryName
s) = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show EntryName
s
      pprPrec t
_ (Record [(EntryName, Exp)]
m) = forall ann. Doc ann -> Doc ann
braces forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
align forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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) = forall ann. Doc ann -> Doc ann
align (forall a ann. Pretty a => a -> Doc ann
pretty a
k forall a. Semigroup a => a -> a -> a
<> forall {ann}. Doc ann
equals forall a. Semigroup a => a -> a -> a
<> 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 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 = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep 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 = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep 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 =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"let"
        forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [EntryName] -> Exp -> Exp -> Exp
Let
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void EntryName Identity [EntryName]
pPat
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"="
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"in"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep,
      forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ Func -> [Exp] -> Exp
Call forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void EntryName Identity Func
parseFunc forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parsec Void EntryName Exp
pAtom,
      Parsec Void EntryName Exp
pAtom
    ]
    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 = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EntryName
pVarName forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser EntryName
pEquals forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep)
    pEquals :: Parser EntryName
pEquals = forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"="
    pComma :: Parser EntryName
pComma = 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

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

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

    parseFunc :: ParsecT Void EntryName Identity Func
parseFunc =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ EntryName -> Func
FuncBuiltin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser EntryName
"$" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser EntryName
pVarName),
          EntryName -> Func
FuncFut 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 = forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
      EntryName
v <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> EntryName
T.pack forall a b. (a -> b) -> a -> b
$ (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAlpha forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
constituent)
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ EntryName
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [EntryName]
reserved
      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 forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c 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 =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EntryName
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser () -> Parsec Void EntryName Exp
parseExp forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space) 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 =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 =
  forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ 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
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
showList :: [ScriptValue v] -> ShowS
$cshowList :: forall v. Show v => [ScriptValue v] -> ShowS
show :: ScriptValue v -> String
$cshow :: forall v. Show v => ScriptValue v -> String
showsPrec :: Int -> ScriptValue v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> ScriptValue v -> ShowS
Show)

instance Functor ScriptValue where
  fmap :: forall a b. (a -> b) -> ScriptValue a -> ScriptValue b
fmap = 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 = 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) = forall v. EntryName -> v -> ScriptValue v
SValue EntryName
t 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) =
    forall v.
EntryName
-> [EntryName] -> [EntryName] -> [ScriptValue v] -> ScriptValue v
SFun EntryName
fname [EntryName]
ins [EntryName]
outs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptValueType -> ScriptValueType -> Bool
$c/= :: ScriptValueType -> ScriptValueType -> Bool
== :: ScriptValueType -> ScriptValueType -> Bool
$c== :: ScriptValueType -> ScriptValueType -> Bool
Eq, Int -> ScriptValueType -> ShowS
[ScriptValueType] -> ShowS
ScriptValueType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptValueType] -> ShowS
$cshowList :: [ScriptValueType] -> ShowS
show :: ScriptValueType -> String
$cshow :: ScriptValueType -> String
showsPrec :: Int -> ScriptValueType -> ShowS
$cshowsPrec :: Int -> ScriptValueType -> ShowS
Show)

instance Pretty ScriptValueType where
  pretty :: forall ann. ScriptValueType -> Doc ann
pretty (STValue EntryName
t) = forall a ann. Pretty a => a -> Doc ann
pretty EntryName
t
  pretty (STFun [EntryName]
ins [EntryName]
outs) =
    forall a. [Doc a] -> Doc a
hsep forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Doc ann
"->" (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [EntryName]
ins forall a. [a] -> [a] -> [a]
++ [forall {ann}. Doc ann
outs'])
    where
      outs' :: Doc ann
outs' = case [EntryName]
outs of
        [EntryName
out] -> forall a ann. Pretty a => a -> Doc ann
pretty EntryName
out
        [EntryName]
_ -> forall ann. Doc ann -> Doc ann
parens forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValOrVar] -> ShowS
$cshowList :: [ValOrVar] -> ShowS
show :: ValOrVar -> String
$cshow :: ValOrVar -> String
showsPrec :: Int -> ValOrVar -> ShowS
$cshowsPrec :: Int -> 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)

-- | 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 = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue ValOrVar -> [EntryName]
isVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue ValOrVar -> [EntryName]
isVar forall a b. (a -> b) -> a -> b
$ 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) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ExpValue -> Exp
valueToExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. v -> Compound v
V.ValueAtom) [ScriptValue ValOrVar]
closure
valueToExp (V.ValueRecord Map EntryName ExpValue
fs) =
  [(EntryName, Exp)] -> Exp
Record forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup EntryName
s [(EntryName, PrimType)]
m =
      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)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
d forall a. Num a => a -> a -> a
+ Int
1, PrimType
pt)
  | Bool
otherwise = forall a. Maybe a
Nothing
  where
    prims :: [PrimType]
prims = [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
    primtexts :: [EntryName]
primtexts = forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> EntryName
V.valueTypeText forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> PrimType -> ValueType
V.ValueType []) [PrimType]
prims
    m :: [(EntryName, PrimType)]
m = 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> [a]
SVec.toList Vector Int64
vs
    Value
_ ->
      forall a. Maybe a
Nothing
  where
    coerceInts :: PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
V.I8 Vector Int
shape =
      forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int8 -> Value
V.I8Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.I16 Vector Int
shape =
      forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int16 -> Value
V.I16Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.I32 Vector Int
shape =
      forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int32 -> Value
V.I32Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.I64 Vector Int
shape =
      forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int64 -> Value
V.I64Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.F32 Vector Int
shape =
      forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Float -> Value
V.F32Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
V.F64 Vector Int
shape =
      forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Double -> Value
V.F64Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
    coerceInts PrimType
_ Vector Int
_ =
      forall a b. a -> b -> a
const forall a. Maybe a
Nothing

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

loadData ::
  (MonadIO m, MonadError T.Text m) =>
  FilePath ->
  m (V.Compound V.Value)
loadData :: forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> m (Compound Value)
loadData String
datafile = do
  ByteString
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ EntryName
"Failed to read data file " forall a. Semigroup a => a -> a -> a
<> String -> EntryName
T.pack String
datafile
    Just [Value
v] ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
V.ValueAtom Value
v
    Just [Value]
vs ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. [Compound v] -> Compound v
V.ValueTuple forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> Compound v
V.ValueAtom [Value]
vs

-- | Handles the following builtin functions: @loaddata@.  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 EntryName
"loaddata" [Compound Value]
vs =
  case [Compound Value]
vs of
    [V.ValueAtom Value
v]
      | Just [Word8]
path <- forall t. GetValue t => Value -> Maybe t
V.getValue Value
v -> do
          let path' :: String
path' = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8]
path :: [Word8])
          forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> m (Compound Value)
loadData forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
path'
    [Compound Value]
_ ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
        EntryName
"$loaddata does not accept arguments of types: "
          forall a. Semigroup a => a -> a -> a
<> EntryName -> [EntryName] -> EntryName
T.intercalate EntryName
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> EntryName
prettyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
V.valueType) [Compound Value]
vs)
scriptBuiltin String
_ EntryName
f [Compound Value]
_ =
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ EntryName
"Unknown builtin function $" forall a. Semigroup a => a -> a -> a
<> 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

-- | 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
  IORef [EntryName]
vars <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
  let ( ScriptServer
          { scriptServer :: ScriptServer -> Server
scriptServer = Server
server,
            scriptCounter :: ScriptServer -> IORef Int
scriptCounter = IORef Int
counter,
            scriptTypes :: ScriptServer -> TypeMap
scriptTypes = TypeMap
types
          }
        ) = ScriptServer
sserver
      newVar :: EntryName -> m EntryName
newVar EntryName
base = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Int
x <- forall a. IORef a -> IO a
readIORef IORef Int
counter
        forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Int
counter (forall a. Num a => a -> a -> a
+ Int
1)
        let v :: EntryName
v = EntryName
base forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText Int
x
        forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [EntryName]
vars (EntryName
v :)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v

      mkRecord :: EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t [EntryName]
vs = do
        EntryName
v <- forall {m :: * -> *}. MonadIO m => EntryName -> m EntryName
newVar EntryName
"record"
        forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ Server
-> EntryName -> EntryName -> [EntryName] -> IO (Maybe CmdFailure)
cmdNew Server
server EntryName
v EntryName
t [EntryName]
vs
        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 <- forall {m :: * -> *}. MonadIO m => EntryName -> m EntryName
newVar EntryName
"field"
        forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ Server
-> EntryName -> EntryName -> EntryName -> IO (Maybe CmdFailure)
cmdProject Server
server EntryName
to EntryName
from forall a b. (a -> b) -> a -> b
$ Name -> EntryName
nameToText Name
f
        forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
to

      toVal :: ValOrVar -> m V.Value
      toVal :: ValOrVar -> m Value
toVal (VVal Value
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
      toVal (VVar EntryName
v) = forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> m Value
readVar Server
server EntryName
v

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

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

      scriptValueToVal :: ScriptValue ValOrVar -> m V.Value
      scriptValueToVal :: ScriptValue ValOrVar -> m Value
scriptValueToVal = ValOrVar -> m Value
toVal forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall {m :: * -> *} {a}.
MonadError EntryName m =>
ScriptValue a -> m a
scriptValueToValOrVar

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

      interValToVal :: ExpValue -> m V.CompoundValue
      interValToVal :: ExpValue -> m (Compound Value)
interValToVal = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ScriptValue ValOrVar -> m Value
scriptValueToVal

      -- 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 forall a. Eq a => a -> a -> Bool
== 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,
          forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
ts =
            forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map EntryName ExpValue
vs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> EntryName
nameToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Name, EntryName)]
fs =
            forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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) (forall a b. (a -> b) -> [a] -> [b]
map 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 forall a. Eq a => a -> a -> Bool
== [(Name, EntryName)]
t_fs =
            forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *} {b}.
(MonadIO m, MonadError EntryName m) =>
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 forall a b. (a -> b) -> a -> b
$ forall v. EntryName -> v -> ScriptValue v
SValue EntryName
t forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
v'
      interValToVar m EntryName
bad EntryName
_ ExpValue
_ = m EntryName
bad

      valToInterVal :: V.CompoundValue -> ExpValue
      valToInterVal :: Compound Value -> ExpValue
valToInterVal = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \Value
v ->
        forall v. EntryName -> v -> ScriptValue v
SValue (ValueType -> EntryName
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
v)) forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
v

      letMatch :: [VarName] -> ExpValue -> m VTable
      letMatch :: [EntryName] -> ExpValue -> m (Map EntryName ExpValue)
letMatch [EntryName]
vs ExpValue
val
        | [ExpValue]
vals <- forall v. Compound v -> [Compound v]
V.unCompound ExpValue
val,
          forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
vs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vals =
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [EntryName]
vs [ExpValue]
vals)
        | Bool
otherwise =
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
              EntryName
"Pat: "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyTextOneLine [EntryName]
vs
                forall a. Semigroup a => a -> a -> a
<> EntryName
"\nDoes not match value of type: "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyTextOneLine (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
V.ValueAtom forall a b. (a -> b) -> a -> b
$ forall v. EntryName -> v -> ScriptValue v
SValue EntryName
t forall a b. (a -> b) -> a -> b
$ EntryName -> ValOrVar
VVar EntryName
v
      evalExp' Map EntryName ExpValue
vtable (Call (FuncBuiltin EntryName
name) [Exp]
es) = do
        Compound Value
v <- EvalBuiltin m
builtin EntryName
name forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExpValue -> m (Compound Value)
interValToVal forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) [Exp]
es
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Compound Value -> ExpValue
valToInterVal Compound Value
v
      evalExp' Map EntryName ExpValue
vtable (Call (FuncFut EntryName
name) [Exp]
es)
        | Just ExpValue
e <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntryName
name Map EntryName ExpValue
vtable = do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
es) forall a b. (a -> b) -> a -> b
$
              forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
                EntryName
"Locally bound name cannot be invoked as a function: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText EntryName
name
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
e
      evalExp' Map EntryName ExpValue
vtable (Call (FuncFut EntryName
name) [Exp]
es) = do
        [EntryName]
in_types <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map InputType -> EntryName
inputType) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError EntryName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> EntryName -> IO (Either CmdFailure [InputType])
cmdInputs Server
server EntryName
name
        [EntryName]
out_types <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map OutputType -> EntryName
outputType) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError EntryName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> EntryName -> IO (Either CmdFailure [OutputType])
cmdOutputs Server
server EntryName
name

        [ExpValue]
es' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) [Exp]
es
        let es_types :: [Compound ScriptValueType]
es_types = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall v. ScriptValue v -> ScriptValueType
scriptValueType) [ExpValue]
es'

        let cannotApply :: m a
cannotApply =
              forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
                EntryName
"Function \""
                  forall a. Semigroup a => a -> a -> a
<> EntryName
name
                  forall a. Semigroup a => a -> a -> a
<> EntryName
"\" expects arguments of types:\n"
                  forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText (forall v. [Compound v] -> Compound v
V.mkCompound forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> Compound v
V.ValueAtom [EntryName]
in_types)
                  forall a. Semigroup a => a -> a -> a
<> EntryName
"\nBut called with arguments of types:\n"
                  forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText (forall v. [Compound v] -> Compound v
V.mkCompound forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> Compound v
V.ValueAtom [Compound ScriptValueType]
es_types)

        -- Careful to not require saturated application, but do still
        -- check for over-saturation.
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Compound ScriptValueType]
es_types forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
in_types) forall {a}. m a
cannotApply
        [EntryName]
ins <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m EntryName -> EntryName -> ExpValue -> m EntryName
interValToVar forall {a}. m a
cannotApply) [EntryName]
in_types [ExpValue]
es'

        if forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
in_types forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
ins
          then do
            [EntryName]
outs <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
out_types) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}. MonadIO m => EntryName -> m EntryName
newVar EntryName
"out"
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError EntryName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server
-> EntryName
-> [EntryName]
-> [EntryName]
-> IO (Either CmdFailure [EntryName])
cmdCall Server
server EntryName
name [EntryName]
outs [EntryName]
ins
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. [Compound v] -> Compound v
V.mkCompound forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> Compound v
V.ValueAtom forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall v. EntryName -> v -> ScriptValue v
SValue [EntryName]
out_types forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map EntryName -> ValOrVar
VVar [EntryName]
outs
          else
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. v -> Compound v
V.ValueAtom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v.
EntryName
-> [EntryName] -> [EntryName] -> [ScriptValue v] -> ScriptValue v
SFun EntryName
name [EntryName]
in_types [EntryName]
out_types forall a b. (a -> b) -> a -> b
$
              forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall v. EntryName -> v -> ScriptValue v
SValue [EntryName]
in_types forall a b. (a -> b) -> a -> b
$
                forall a b. (a -> b) -> [a] -> [b]
map EntryName -> ValOrVar
VVar [EntryName]
ins
      evalExp' Map EntryName ExpValue
_ (StringLit EntryName
s) =
        case forall t. PutValue t => t -> Maybe Value
V.putValue EntryName
s of
          Just Value
s' ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
V.ValueAtom forall a b. (a -> b) -> a -> b
$ forall v. EntryName -> v -> ScriptValue v
SValue (ValueType -> EntryName
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
s')) forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
s'
          Maybe Value
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unable to write value " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyString EntryName
s
      evalExp' Map EntryName ExpValue
_ (Const Value
val) =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
V.ValueAtom forall a b. (a -> b) -> a -> b
$ forall v. EntryName -> v -> ScriptValue v
SValue (ValueType -> EntryName
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
val)) forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
val
      evalExp' Map EntryName ExpValue
vtable (Tuple [Exp]
es) =
        forall v. [Compound v] -> Compound v
V.ValueTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Ord a => [a] -> [a]
nubOrd (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(EntryName, Exp)]
m)) forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(EntryName, Exp)]
m)) forall a b. (a -> b) -> a -> b
$
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
            EntryName
"Record " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText Exp
e forall a. Semigroup a => a -> a -> a
<> EntryName
" has duplicate fields."
        forall v. Map EntryName (Compound v) -> Compound v
V.ValueRecord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) (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 forall a. Semigroup a => a -> a -> a
<> Map EntryName ExpValue
vtable) Exp
e2

  let freeNonresultVars :: ExpValue -> m ExpValue
freeNonresultVars ExpValue
v = do
        let v_vars :: Set EntryName
v_vars = ExpValue -> Set EntryName
serverVarsInValue ExpValue
v
        [EntryName]
to_free <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set EntryName
v_vars) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef [EntryName]
vars
        forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ Server -> [EntryName] -> IO (Maybe CmdFailure)
cmdFree Server
server [EntryName]
to_free
        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.
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Server -> [EntryName] -> IO (Maybe CmdFailure)
cmdFree Server
server forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IORef a -> IO a
readIORef IORef [EntryName]
vars
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
  (forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
ExpValue -> m ExpValue
freeNonresultVars forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' forall a. Monoid a => a
mempty Exp
top_level_e) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` 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.
getExpValue ::
  (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m V.CompoundValue
getExpValue :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Compound Value)
getExpValue ScriptServer
server ExpValue
e =
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *} {a}.
MonadError EntryName m =>
ScriptValue a -> m a
toGround forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}.
(MonadError EntryName m, MonadIO m) =>
ValOrVar -> m Value
onLeaf) ExpValue
e
  where
    onLeaf :: ValOrVar -> m Value
onLeaf (VVar EntryName
v) = forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> m Value
readVar (ScriptServer -> Server
scriptServer ScriptServer
server) EntryName
v
    onLeaf (VVal Value
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
    toGround :: ScriptValue a -> m a
toGround (SFun EntryName
fname [EntryName]
_ [EntryName]
_ [ScriptValue a]
_) =
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ EntryName
"Function " forall a. Semigroup a => a -> a -> a
<> EntryName
fname forall a. Semigroup a => a -> a -> a
<> EntryName
" not fully applied."
    toGround (SValue EntryName
_ a
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

-- | 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) (Compound Value))
evalExpToGround EvalBuiltin m
builtin ScriptServer
server Exp
e = do
  ExpValue
v <- 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.
  (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Compound Value)
getExpValue ScriptServer
server ExpValue
v)
    forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 {} = forall a. Monoid a => a
mempty
varsInExp (Call (FuncFut EntryName
v) [Exp]
es) = forall a. Ord a => a -> Set a -> Set a
S.insert EntryName
v forall a b. (a -> b) -> a -> b
$ 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) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp [Exp]
es
varsInExp (Tuple [Exp]
es) = 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) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp) [(EntryName, Exp)]
fs
varsInExp Const {} = forall a. Monoid a => a
mempty
varsInExp StringLit {} = forall a. Monoid a => a
mempty
varsInExp (Let [EntryName]
pat Exp
e1 Exp
e2) = Exp -> Set EntryName
varsInExp Exp
e1 forall a. Semigroup a => a -> a -> a
<> forall a. (a -> Bool) -> Set a -> Set a
S.filter (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 =
  forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server -> [EntryName] -> IO (Maybe CmdFailure)
cmdFree (ScriptServer -> Server
scriptServer ScriptServer
server) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpValue -> Set EntryName
serverVarsInValue