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

-- | 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
  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 -> 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 =
  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
    [ 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)
-> Parser EntryName -> ParsecT Void EntryName Identity (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
"in"
        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
<*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep,
      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

    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)

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

-- | 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 <- 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 (Compound Value)
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m (Compound Value))
-> EntryName -> m (Compound Value)
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] ->
      Compound Value -> m (Compound Value)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Compound Value -> m (Compound Value))
-> Compound Value -> m (Compound Value)
forall a b. (a -> b) -> a -> b
$ Value -> Compound Value
forall v. v -> Compound v
V.ValueAtom Value
v
    Just [Value]
vs ->
      Compound Value -> m (Compound Value)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Compound Value -> m (Compound Value))
-> Compound Value -> m (Compound Value)
forall a b. (a -> b) -> a -> b
$ [Compound Value] -> Compound Value
forall v. [Compound v] -> Compound v
V.ValueTuple ([Compound Value] -> Compound Value)
-> [Compound Value] -> Compound Value
forall a b. (a -> b) -> a -> b
$ (Value -> Compound Value) -> [Value] -> [Compound Value]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Compound Value
forall v. v -> Compound v
V.ValueAtom [Value]
vs

pathArg ::
  (MonadError T.Text f) =>
  FilePath ->
  T.Text ->
  [V.Compound V.Value] ->
  f FilePath
pathArg :: forall (f :: * -> *).
MonadError EntryName f =>
String -> EntryName -> [Compound Value] -> f String
pathArg String
dir EntryName
cmd [Compound Value]
vs =
  case [Compound Value]
vs of
    [V.ValueAtom Value
v]
      | Just [Word8]
path <- Value -> Maybe [Word8]
forall t. GetValue t => Value -> Maybe t
V.getValue Value
v ->
          String -> f String
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> f String) -> String -> f 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])
    [Compound Value]
_ ->
      EntryName -> f String
forall a. EntryName -> f a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> f String) -> EntryName -> f String
forall a b. (a -> b) -> a -> b
$
        EntryName
"$"
          EntryName -> EntryName -> EntryName
forall a. Semigroup a => a -> a -> a
<> EntryName
cmd
          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
", " ((Compound Value -> EntryName) -> [Compound Value] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map (Compound ValueType -> EntryName
forall a. Pretty a => a -> EntryName
prettyText (Compound ValueType -> EntryName)
-> (Compound Value -> Compound ValueType)
-> Compound Value
-> EntryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> ValueType) -> Compound Value -> Compound ValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
V.valueType) [Compound Value]
vs)

-- | 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 EntryName
"loaddata" [Compound Value]
vs = do
  String -> m (Compound Value)
forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> m (Compound Value)
loadData (String -> m (Compound Value)) -> m String -> m (Compound Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> EntryName -> [Compound Value] -> m String
forall (f :: * -> *).
MonadError EntryName f =>
String -> EntryName -> [Compound Value] -> f String
pathArg String
dir EntryName
"loaddata" [Compound Value]
vs
scriptBuiltin String
dir EntryName
"loadbytes" [Compound Value]
vs = do
  (ByteString -> Compound Value)
-> m ByteString -> m (Compound Value)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> Compound Value
forall v. v -> Compound v
V.ValueAtom (Value -> Compound Value)
-> (ByteString -> Value) -> ByteString -> Compound Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Value
forall t. PutValue1 t => t -> Value
V.putValue1) (m ByteString -> m (Compound Value))
-> (String -> m ByteString) -> String -> m (Compound Value)
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 (Compound Value)) -> m String -> m (Compound Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> EntryName -> [Compound Value] -> m String
forall (f :: * -> *).
MonadError EntryName f =>
String -> EntryName -> [Compound Value] -> f String
pathArg String
dir EntryName
"loadbytes" [Compound Value]
vs
scriptBuiltin String
_ EntryName
f [Compound Value]
_ =
  EntryName -> m (Compound Value)
forall a. EntryName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EntryName -> m (Compound Value))
-> EntryName -> m (Compound Value)
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

-- | 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 <- 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 []
  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 = 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

      mkRecord :: EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t [EntryName]
vs = do
        EntryName
v <- EntryName -> m EntryName
forall {m :: * -> *}. MonadIO m => 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
forall {m :: * -> *}. MonadIO m => 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

      toVal :: ValOrVar -> m V.Value
      toVal :: ValOrVar -> m Value
toVal (VVal Value
v) = Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
      toVal (VVar EntryName
v) = Server -> EntryName -> m Value
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) = 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
forall {m :: * -> *}. MonadIO m => 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

      scriptValueToVal :: ScriptValue ValOrVar -> m V.Value
      scriptValueToVal :: ScriptValue ValOrVar -> m Value
scriptValueToVal = ValOrVar -> m Value
toVal (ValOrVar -> m Value)
-> (ScriptValue ValOrVar -> m ValOrVar)
-> ScriptValue ValOrVar
-> m Value
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

      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

      interValToVal :: ExpValue -> m V.CompoundValue
      interValToVal :: ExpValue -> m (Compound Value)
interValToVal = (ScriptValue ValOrVar -> m Value) -> ExpValue -> m (Compound 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) -> Compound a -> f (Compound 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 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
forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
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
forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
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
forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
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 {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 (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

      valToInterVal :: V.CompoundValue -> ExpValue
      valToInterVal :: Compound Value -> ExpValue
valToInterVal = (Value -> ScriptValue ValOrVar) -> Compound Value -> 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) -> Compound Value -> ExpValue)
-> (Value -> ScriptValue ValOrVar) -> Compound Value -> 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

      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) = do
        Compound Value
v <- EvalBuiltin m
builtin EntryName
name ([Compound Value] -> m (Compound Value))
-> m [Compound Value] -> m (Compound Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Exp -> m (Compound Value)) -> [Exp] -> m [Compound Value]
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 (ExpValue -> m (Compound Value)
interValToVal (ExpValue -> m (Compound Value))
-> (Exp -> m ExpValue) -> Exp -> m (Compound Value)
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
        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
$ Compound Value -> ExpValue
valToInterVal Compound Value
v
      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
      evalExp' Map EntryName ExpValue
vtable (Call (FuncFut EntryName
name) [Exp]
es) = 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 es_types :: [Compound ScriptValueType]
es_types = (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'

        let cannotApply :: m a
cannotApply =
              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
name
                  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 ([EntryName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
in_types)
                  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" ((EntryName -> EntryName) -> [EntryName] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map EntryName -> EntryName
forall a. Pretty a => a -> EntryName
prettyTextOneLine [EntryName]
in_types)
                  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 ([Compound ScriptValueType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Compound ScriptValueType]
es_types)
                  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" ((Compound ScriptValueType -> EntryName)
-> [Compound ScriptValueType] -> [EntryName]
forall a b. (a -> b) -> [a] -> [b]
map Compound ScriptValueType -> EntryName
forall a. Pretty a => a -> EntryName
prettyTextOneLine [Compound ScriptValueType]
es_types)

            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 {a}. m a
cannotApply) [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
forall {m :: * -> *}. MonadIO m => 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 ([Compound ScriptValueType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Compound ScriptValueType]
es_types 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 {a}. m a
cannotApply

        -- 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 v_vars :: Set EntryName
v_vars = ExpValue -> Set EntryName
serverVarsInValue ExpValue
v
        [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
v_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
        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.
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 =
  (ScriptValue Value -> m Value)
-> Compound (ScriptValue Value) -> m (Compound 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) -> Compound a -> f (Compound b)
traverse ScriptValue Value -> m Value
forall {m :: * -> *} {a}.
MonadError EntryName m =>
ScriptValue a -> m a
toGround (Compound (ScriptValue Value) -> m (Compound Value))
-> m (Compound (ScriptValue Value)) -> m (Compound Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ScriptValue ValOrVar -> m (ScriptValue Value))
-> ExpValue -> m (Compound (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) -> Compound a -> f (Compound b)
traverse ((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) ExpValue
e
  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

-- | 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 <- 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.
  (Compound Value
-> Either (Compound ScriptValueType) (Compound Value)
forall a b. b -> Either a b
Right (Compound Value
 -> Either (Compound ScriptValueType) (Compound Value))
-> m (Compound Value)
-> m (Either (Compound ScriptValueType) (Compound Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptServer -> ExpValue -> m (Compound Value)
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Compound Value)
getExpValue ScriptServer
server ExpValue
v)
    m (Either (Compound ScriptValueType) (Compound Value))
-> (EntryName
    -> m (Either (Compound ScriptValueType) (Compound Value)))
-> m (Either (Compound ScriptValueType) (Compound Value))
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) (Compound Value))
-> EntryName
-> m (Either (Compound ScriptValueType) (Compound Value))
forall a b. a -> b -> a
const (Either (Compound ScriptValueType) (Compound Value)
-> m (Either (Compound ScriptValueType) (Compound Value))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Compound ScriptValueType) (Compound Value)
 -> m (Either (Compound ScriptValueType) (Compound Value)))
-> Either (Compound ScriptValueType) (Compound Value)
-> m (Either (Compound ScriptValueType) (Compound Value))
forall a b. (a -> b) -> a -> b
$ Compound ScriptValueType
-> Either (Compound ScriptValueType) (Compound Value)
forall a b. a -> Either a b
Left (Compound ScriptValueType
 -> Either (Compound ScriptValueType) (Compound Value))
-> Compound ScriptValueType
-> Either (Compound ScriptValueType) (Compound Value)
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