module Futhark.Script
(
ScriptServer,
withScriptServer,
withScriptServer',
Func (..),
Exp (..),
parseExp,
parseExpFromText,
varsInExp,
ScriptValueType (..),
ScriptValue (..),
scriptValueType,
serverVarsInValue,
ValOrVar (..),
ExpValue,
EvalBuiltin,
scriptBuiltin,
evalExp,
getExpValue,
evalExpToGround,
valueToExp,
freeValue,
)
where
import Control.Monad
import Control.Monad.Except (MonadError (..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bifunctor (bimap)
import Data.ByteString.Lazy qualified as LBS
import Data.Char
import Data.Foldable (toList)
import Data.Functor
import Data.IORef
import Data.List (intersperse)
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Traversable
import Data.Vector.Storable qualified as SVec
import Data.Void
import Data.Word (Word8)
import Futhark.Data.Parser qualified as V
import Futhark.Server
import Futhark.Server.Values (getValue, putValue)
import Futhark.Test.Values qualified as V
import Futhark.Util (nubOrd)
import Futhark.Util.Pretty hiding (line, sep, space, (</>))
import Language.Futhark.Core (Name, nameFromText, nameToText)
import Language.Futhark.Tuple (areTupleFields)
import System.FilePath ((</>))
import Text.Megaparsec
import Text.Megaparsec.Char (space)
import Text.Megaparsec.Char.Lexer (charLiteral)
type TypeMap = M.Map TypeName (Maybe [(Name, TypeName)])
typeMap :: MonadIO m => Server -> m TypeMap
typeMap :: forall (m :: * -> *). MonadIO m => Server -> m TypeMap
typeMap Server
server = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty) [EntryName] -> IO TypeMap
onTypes forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Server -> IO (Either CmdFailure [EntryName])
cmdTypes Server
server
where
onTypes :: [EntryName] -> IO TypeMap
onTypes [EntryName]
types = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [EntryName]
types forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EntryName -> IO (Maybe [(Name, EntryName)])
onType [EntryName]
types
onType :: EntryName -> IO (Maybe [(Name, EntryName)])
onType EntryName
t =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map EntryName -> (Name, EntryName)
onField) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> EntryName -> IO (Either CmdFailure [EntryName])
cmdFields Server
server EntryName
t
onField :: EntryName -> (Name, EntryName)
onField = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap EntryName -> Name
nameFromText (Int -> EntryName -> EntryName
T.drop Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntryName -> EntryName -> (EntryName, EntryName)
T.breakOn EntryName
" "
isRecord :: TypeName -> TypeMap -> Maybe [(Name, TypeName)]
isRecord :: EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
t TypeMap
m = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntryName
t TypeMap
m
isTuple :: TypeName -> TypeMap -> Maybe [TypeName]
isTuple :: EntryName -> TypeMap -> Maybe [EntryName]
isTuple EntryName
t TypeMap
m = forall a. Map Name a -> Maybe [a]
areTupleFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
t TypeMap
m
data ScriptServer = ScriptServer
{ ScriptServer -> Server
scriptServer :: Server,
ScriptServer -> IORef Int
scriptCounter :: IORef Int,
ScriptServer -> TypeMap
scriptTypes :: TypeMap
}
withScriptServer' :: MonadIO m => Server -> (ScriptServer -> m a) -> m a
withScriptServer' :: forall (m :: * -> *) a.
MonadIO m =>
Server -> (ScriptServer -> m a) -> m a
withScriptServer' Server
server ScriptServer -> m a
f = do
IORef Int
counter <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Int
0
TypeMap
types <- forall (m :: * -> *). MonadIO m => Server -> m TypeMap
typeMap Server
server
ScriptServer -> m a
f forall a b. (a -> b) -> a -> b
$ Server -> IORef Int -> TypeMap -> ScriptServer
ScriptServer Server
server IORef Int
counter TypeMap
types
withScriptServer :: ServerCfg -> (ScriptServer -> IO a) -> IO a
withScriptServer :: forall a. ServerCfg -> (ScriptServer -> IO a) -> IO a
withScriptServer ServerCfg
cfg ScriptServer -> IO a
f =
forall a. ServerCfg -> (Server -> IO a) -> IO a
withServer ServerCfg
cfg forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
MonadIO m =>
Server -> (ScriptServer -> m a) -> m a
withScriptServer' ScriptServer -> IO a
f
data Func = FuncFut EntryName | FuncBuiltin T.Text
deriving (Int -> Func -> ShowS
[Func] -> ShowS
Func -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Func] -> ShowS
$cshowList :: [Func] -> ShowS
show :: Func -> String
$cshow :: Func -> String
showsPrec :: Int -> Func -> ShowS
$cshowsPrec :: Int -> Func -> ShowS
Show)
data Exp
= Call Func [Exp]
| Const V.Value
| Tuple [Exp]
| Record [(T.Text, Exp)]
| StringLit T.Text
| Let [VarName] Exp Exp
|
ServerVar TypeName VarName
deriving (Int -> Exp -> ShowS
[Exp] -> ShowS
Exp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exp] -> ShowS
$cshowList :: [Exp] -> ShowS
show :: Exp -> String
$cshow :: Exp -> String
showsPrec :: Int -> Exp -> ShowS
$cshowsPrec :: Int -> Exp -> ShowS
Show)
instance Pretty Func where
pretty :: forall ann. Func -> Doc ann
pretty (FuncFut EntryName
f) = forall a ann. Pretty a => a -> Doc ann
pretty EntryName
f
pretty (FuncBuiltin EntryName
f) = Doc ann
"$" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty EntryName
f
instance Pretty Exp where
pretty :: forall ann. Exp -> Doc ann
pretty = forall {t} {ann}. (Ord t, Num t) => t -> Exp -> Doc ann
pprPrec (Int
0 :: Int)
where
pprPrec :: t -> Exp -> Doc ann
pprPrec t
_ (ServerVar EntryName
_ EntryName
v) = Doc ann
"$" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty EntryName
v
pprPrec t
_ (Const Value
v) = forall a. [Doc a] -> Doc a
stack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ EntryName -> [EntryName]
T.lines forall a b. (a -> b) -> a -> b
$ Value -> EntryName
V.valueText Value
v
pprPrec t
i (Let [EntryName]
pat Exp
e1 Exp
e2) =
forall a. Bool -> Doc a -> Doc a
parensIf (t
i forall a. Ord a => a -> a -> Bool
> t
0) forall a b. (a -> b) -> a -> b
$ Doc ann
"let" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall {ann}. Doc ann
pat' forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall {ann}. Doc ann
equals forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Exp
e1 forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Exp
e2
where
pat' :: Doc ann
pat' = case [EntryName]
pat of
[EntryName
x] -> forall a ann. Pretty a => a -> Doc ann
pretty EntryName
x
[EntryName]
_ -> forall ann. Doc ann -> Doc ann
parens forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
align forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [EntryName]
pat
pprPrec t
_ (Call Func
v []) = forall a ann. Pretty a => a -> Doc ann
pretty Func
v
pprPrec t
i (Call Func
v [Exp]
args) =
forall a. Bool -> Doc a -> Doc a
parensIf (t
i forall a. Ord a => a -> a -> Bool
> t
0) forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Func
v forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. [Doc a] -> Doc a
hsep (forall a b. (a -> b) -> [a] -> [b]
map (forall ann. Doc ann -> Doc ann
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Exp -> Doc ann
pprPrec t
1) [Exp]
args)
pprPrec t
_ (Tuple [Exp]
vs) =
forall ann. Doc ann -> Doc ann
parens forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall ann. Doc ann -> Doc ann
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) [Exp]
vs
pprPrec t
_ (StringLit EntryName
s) = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show EntryName
s
pprPrec t
_ (Record [(EntryName, Exp)]
m) = forall ann. Doc ann -> Doc ann
braces forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
align forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {ann}. (Pretty a, Pretty a) => (a, a) -> Doc ann
field [(EntryName, Exp)]
m
where
field :: (a, a) -> Doc ann
field (a
k, a
v) = forall ann. Doc ann -> Doc ann
align (forall a ann. Pretty a => a -> Doc ann
pretty a
k forall a. Semigroup a => a -> a -> a
<> forall {ann}. Doc ann
equals forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty a
v)
type Parser = Parsec Void T.Text
lexeme :: Parser () -> Parser a -> Parser a
lexeme :: forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser a
p = Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sep
inParens :: Parser () -> Parser a -> Parser a
inParens :: forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"(") (forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
")")
inBraces :: Parser () -> Parser a -> Parser a
inBraces :: forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"{") (forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"}")
parseExp :: Parsec Void T.Text () -> Parsec Void T.Text Exp
parseExp :: Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep =
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"let"
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [EntryName] -> Exp -> Exp -> Exp
Let
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void EntryName Identity [EntryName]
pPat
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"="
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"in"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep,
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ Func -> [Exp] -> Exp
Call forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void EntryName Identity Func
parseFunc forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parsec Void EntryName Exp
pAtom,
Parsec Void EntryName Exp
pAtom
]
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"expression"
where
pField :: ParsecT Void EntryName Identity (EntryName, Exp)
pField = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EntryName
pVarName forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser EntryName
pEquals forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep)
pEquals :: Parser EntryName
pEquals = forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
"="
pComma :: Parser EntryName
pComma = forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser EntryName
","
mkTuple :: [Exp] -> Exp
mkTuple [Exp
v] = Exp
v
mkTuple [Exp]
vs = [Exp] -> Exp
Tuple [Exp]
vs
pAtom :: Parsec Void EntryName Exp
pAtom =
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep ([Exp] -> Exp
mkTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Parser EntryName
pComma)),
forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep forall a b. (a -> b) -> a -> b
$ Parser () -> Parsec Void EntryName Exp
parseExp Parser ()
sep,
forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep ([(EntryName, Exp)] -> Exp
Record forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void EntryName Identity (EntryName, Exp)
pField forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Parser EntryName
pComma)),
EntryName -> Exp
StringLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EntryName
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (Parser EntryName
"\"" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
charLiteral Parser EntryName
"\""),
Value -> Exp
Const forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parsec Void EntryName Value
V.parseValue Parser ()
sep,
Func -> [Exp] -> Exp
Call forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void EntryName Identity Func
parseFunc forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
]
pPat :: ParsecT Void EntryName Identity [EntryName]
pPat =
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep forall a b. (a -> b) -> a -> b
$ Parser EntryName
pVarName forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Parser EntryName
pComma,
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EntryName
pVarName
]
parseFunc :: ParsecT Void EntryName Identity Func
parseFunc =
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ EntryName -> Func
FuncBuiltin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser EntryName
"$" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser EntryName
pVarName),
EntryName -> Func
FuncFut forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EntryName
pVarName
]
reserved :: [EntryName]
reserved = [EntryName
"let", EntryName
"in"]
pVarName :: Parser EntryName
pVarName = forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
EntryName
v <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> EntryName
T.pack forall a b. (a -> b) -> a -> b
$ (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAlpha forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
constituent)
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ EntryName
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [EntryName]
reserved
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v
where
constituent :: Char -> Bool
constituent Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'
parseExpFromText :: FilePath -> T.Text -> Either T.Text Exp
parseExpFromText :: String -> EntryName -> Either EntryName Exp
parseExpFromText String
f EntryName
s =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EntryName
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser () -> Parsec Void EntryName Exp
parseExp forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space) String
f EntryName
s
readVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> m V.Value
readVar :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> m Value
readVar Server
server EntryName
v =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> EntryName -> IO (Either EntryName Value)
getValue Server
server EntryName
v)
writeVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> V.Value -> m ()
writeVar :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> Value -> m ()
writeVar Server
server EntryName
v Value
val =
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> EntryName -> Value -> IO (Maybe CmdFailure)
putValue Server
server EntryName
v Value
val)
data ScriptValue v
= SValue TypeName v
|
SFun EntryName [TypeName] [TypeName] [ScriptValue v]
deriving (Int -> ScriptValue v -> ShowS
forall v. Show v => Int -> ScriptValue v -> ShowS
forall v. Show v => [ScriptValue v] -> ShowS
forall v. Show v => ScriptValue v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptValue v] -> ShowS
$cshowList :: forall v. Show v => [ScriptValue v] -> ShowS
show :: ScriptValue v -> String
$cshow :: forall v. Show v => ScriptValue v -> String
showsPrec :: Int -> ScriptValue v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> ScriptValue v -> ShowS
Show)
instance Functor ScriptValue where
fmap :: forall a b. (a -> b) -> ScriptValue a -> ScriptValue b
fmap = forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault
instance Foldable ScriptValue where
foldMap :: forall m a. Monoid m => (a -> m) -> ScriptValue a -> m
foldMap = forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault
instance Traversable ScriptValue where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ScriptValue a -> f (ScriptValue b)
traverse a -> f b
f (SValue EntryName
t a
v) = forall v. EntryName -> v -> ScriptValue v
SValue EntryName
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
v
traverse a -> f b
f (SFun EntryName
fname [EntryName]
ins [EntryName]
outs [ScriptValue a]
vs) =
forall v.
EntryName
-> [EntryName] -> [EntryName] -> [ScriptValue v] -> ScriptValue v
SFun EntryName
fname [EntryName]
ins [EntryName]
outs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) [ScriptValue a]
vs
data ScriptValueType
= STValue TypeName
|
STFun [TypeName] [TypeName]
deriving (ScriptValueType -> ScriptValueType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptValueType -> ScriptValueType -> Bool
$c/= :: ScriptValueType -> ScriptValueType -> Bool
== :: ScriptValueType -> ScriptValueType -> Bool
$c== :: ScriptValueType -> ScriptValueType -> Bool
Eq, Int -> ScriptValueType -> ShowS
[ScriptValueType] -> ShowS
ScriptValueType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptValueType] -> ShowS
$cshowList :: [ScriptValueType] -> ShowS
show :: ScriptValueType -> String
$cshow :: ScriptValueType -> String
showsPrec :: Int -> ScriptValueType -> ShowS
$cshowsPrec :: Int -> ScriptValueType -> ShowS
Show)
instance Pretty ScriptValueType where
pretty :: forall ann. ScriptValueType -> Doc ann
pretty (STValue EntryName
t) = forall a ann. Pretty a => a -> Doc ann
pretty EntryName
t
pretty (STFun [EntryName]
ins [EntryName]
outs) =
forall a. [Doc a] -> Doc a
hsep forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Doc ann
"->" (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [EntryName]
ins forall a. [a] -> [a] -> [a]
++ [forall {ann}. Doc ann
outs'])
where
outs' :: Doc ann
outs' = case [EntryName]
outs of
[EntryName
out] -> forall a ann. Pretty a => a -> Doc ann
pretty EntryName
out
[EntryName]
_ -> forall ann. Doc ann -> Doc ann
parens forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [EntryName]
outs
data ValOrVar = VVal V.Value | VVar VarName
deriving (Int -> ValOrVar -> ShowS
[ValOrVar] -> ShowS
ValOrVar -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValOrVar] -> ShowS
$cshowList :: [ValOrVar] -> ShowS
show :: ValOrVar -> String
$cshow :: ValOrVar -> String
showsPrec :: Int -> ValOrVar -> ShowS
$cshowsPrec :: Int -> ValOrVar -> ShowS
Show)
type ExpValue = V.Compound (ScriptValue ValOrVar)
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
serverVarsInValue :: ExpValue -> S.Set VarName
serverVarsInValue :: ExpValue -> Set EntryName
serverVarsInValue = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue ValOrVar -> [EntryName]
isVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
where
isVar :: ScriptValue ValOrVar -> [EntryName]
isVar (SValue EntryName
_ (VVar EntryName
x)) = [EntryName
x]
isVar (SValue EntryName
_ (VVal Value
_)) = []
isVar (SFun EntryName
_ [EntryName]
_ [EntryName]
_ [ScriptValue ValOrVar]
closure) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue ValOrVar -> [EntryName]
isVar forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [ScriptValue ValOrVar]
closure
valueToExp :: ExpValue -> Exp
valueToExp :: ExpValue -> Exp
valueToExp (V.ValueAtom (SValue EntryName
t (VVar EntryName
v))) =
EntryName -> EntryName -> Exp
ServerVar EntryName
t EntryName
v
valueToExp (V.ValueAtom (SValue EntryName
_ (VVal Value
v))) =
Value -> Exp
Const Value
v
valueToExp (V.ValueAtom (SFun EntryName
fname [EntryName]
_ [EntryName]
_ [ScriptValue ValOrVar]
closure)) =
Func -> [Exp] -> Exp
Call (EntryName -> Func
FuncFut EntryName
fname) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ExpValue -> Exp
valueToExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. v -> Compound v
V.ValueAtom) [ScriptValue ValOrVar]
closure
valueToExp (V.ValueRecord Map EntryName ExpValue
fs) =
[(EntryName, Exp)] -> Exp
Record forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
M.map ExpValue -> Exp
valueToExp Map EntryName ExpValue
fs
valueToExp (V.ValueTuple [ExpValue]
fs) =
[Exp] -> Exp
Tuple forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ExpValue -> Exp
valueToExp [ExpValue]
fs
parseTypeName :: TypeName -> Maybe (Int, V.PrimType)
parseTypeName :: EntryName -> Maybe (Int, PrimType)
parseTypeName EntryName
s
| Just PrimType
pt <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup EntryName
s [(EntryName, PrimType)]
m =
forall a. a -> Maybe a
Just (Int
0, PrimType
pt)
| EntryName
"[]" EntryName -> EntryName -> Bool
`T.isPrefixOf` EntryName
s = do
(Int
d, PrimType
pt) <- EntryName -> Maybe (Int, PrimType)
parseTypeName (Int -> EntryName -> EntryName
T.drop Int
2 EntryName
s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
d forall a. Num a => a -> a -> a
+ Int
1, PrimType
pt)
| Bool
otherwise = forall a. Maybe a
Nothing
where
prims :: [PrimType]
prims = [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
primtexts :: [EntryName]
primtexts = forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> EntryName
V.valueTypeText forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> PrimType -> ValueType
V.ValueType []) [PrimType]
prims
m :: [(EntryName, PrimType)]
m = forall a b. [a] -> [b] -> [(a, b)]
zip [EntryName]
primtexts [PrimType]
prims
coerceValue :: TypeName -> V.Value -> Maybe V.Value
coerceValue :: EntryName -> Value -> Maybe Value
coerceValue EntryName
t Value
v = do
(Int
_, PrimType
pt) <- EntryName -> Maybe (Int, PrimType)
parseTypeName EntryName
t
case Value
v of
V.I8Value Vector Int
shape Vector Int8
vs ->
PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
pt Vector Int
shape forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> [a]
SVec.toList Vector Int8
vs
V.I16Value Vector Int
shape Vector Int16
vs ->
PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
pt Vector Int
shape forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> [a]
SVec.toList Vector Int16
vs
V.I32Value Vector Int
shape Vector Int32
vs ->
PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
pt Vector Int
shape forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> [a]
SVec.toList Vector Int32
vs
V.I64Value Vector Int
shape Vector Int64
vs ->
PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
pt Vector Int
shape forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> [a]
SVec.toList Vector Int64
vs
Value
_ ->
forall a. Maybe a
Nothing
where
coerceInts :: PrimType -> Vector Int -> [Integer] -> Maybe Value
coerceInts PrimType
V.I8 Vector Int
shape =
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int8 -> Value
V.I8Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
coerceInts PrimType
V.I16 Vector Int
shape =
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int16 -> Value
V.I16Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
coerceInts PrimType
V.I32 Vector Int
shape =
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int32 -> Value
V.I32Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
coerceInts PrimType
V.I64 Vector Int
shape =
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Int64 -> Value
V.I64Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
coerceInts PrimType
V.F32 Vector Int
shape =
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Float -> Value
V.F32Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
coerceInts PrimType
V.F64 Vector Int
shape =
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Vector Double -> Value
V.F64Value Vector Int
shape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
SVec.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger
coerceInts PrimType
_ Vector Int
_ =
forall a b. a -> b -> a
const forall a. Maybe a
Nothing
type EvalBuiltin m = T.Text -> [V.CompoundValue] -> m V.CompoundValue
loadData ::
(MonadIO m, MonadError T.Text m) =>
FilePath ->
m (V.Compound V.Value)
loadData :: forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> m (Compound Value)
loadData String
datafile = do
ByteString
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
LBS.readFile String
datafile
let maybe_vs :: Maybe [Value]
maybe_vs = ByteString -> Maybe [Value]
V.readValues ByteString
contents
case Maybe [Value]
maybe_vs of
Maybe [Value]
Nothing ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ EntryName
"Failed to read data file " forall a. Semigroup a => a -> a -> a
<> String -> EntryName
T.pack String
datafile
Just [Value
v] ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
V.ValueAtom Value
v
Just [Value]
vs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. [Compound v] -> Compound v
V.ValueTuple forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> Compound v
V.ValueAtom [Value]
vs
scriptBuiltin :: (MonadIO m, MonadError T.Text m) => FilePath -> EvalBuiltin m
scriptBuiltin :: forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> EvalBuiltin m
scriptBuiltin String
dir EntryName
"loaddata" [Compound Value]
vs =
case [Compound Value]
vs of
[V.ValueAtom Value
v]
| Just [Word8]
path <- forall t. GetValue t => Value -> Maybe t
V.getValue Value
v -> do
let path' :: String
path' = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8]
path :: [Word8])
forall (m :: * -> *).
(MonadIO m, MonadError EntryName m) =>
String -> m (Compound Value)
loadData forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
path'
[Compound Value]
_ ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
EntryName
"$loaddata does not accept arguments of types: "
forall a. Semigroup a => a -> a -> a
<> EntryName -> [EntryName] -> EntryName
T.intercalate EntryName
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> EntryName
prettyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
V.valueType) [Compound Value]
vs)
scriptBuiltin String
_ EntryName
f [Compound Value]
_ =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ EntryName
"Unknown builtin function $" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText EntryName
f
type VTable = M.Map VarName ExpValue
evalExp ::
forall m.
(MonadError T.Text m, MonadIO m) =>
EvalBuiltin m ->
ScriptServer ->
Exp ->
m ExpValue
evalExp :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
evalExp EvalBuiltin m
builtin ScriptServer
sserver Exp
top_level_e = do
IORef [EntryName]
vars <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
let ( ScriptServer
{ scriptServer :: ScriptServer -> Server
scriptServer = Server
server,
scriptCounter :: ScriptServer -> IORef Int
scriptCounter = IORef Int
counter,
scriptTypes :: ScriptServer -> TypeMap
scriptTypes = TypeMap
types
}
) = ScriptServer
sserver
newVar :: EntryName -> m EntryName
newVar EntryName
base = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Int
x <- forall a. IORef a -> IO a
readIORef IORef Int
counter
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Int
counter (forall a. Num a => a -> a -> a
+ Int
1)
let v :: EntryName
v = EntryName
base forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText Int
x
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [EntryName]
vars (EntryName
v :)
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v
mkRecord :: EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t [EntryName]
vs = do
EntryName
v <- forall {m :: * -> *}. MonadIO m => EntryName -> m EntryName
newVar EntryName
"record"
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ Server
-> EntryName -> EntryName -> [EntryName] -> IO (Maybe CmdFailure)
cmdNew Server
server EntryName
v EntryName
t [EntryName]
vs
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v
getField :: EntryName -> (Name, b) -> m EntryName
getField EntryName
from (Name
f, b
_) = do
EntryName
to <- forall {m :: * -> *}. MonadIO m => EntryName -> m EntryName
newVar EntryName
"field"
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ Server
-> EntryName -> EntryName -> EntryName -> IO (Maybe CmdFailure)
cmdProject Server
server EntryName
to EntryName
from forall a b. (a -> b) -> a -> b
$ Name -> EntryName
nameToText Name
f
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
to
toVal :: ValOrVar -> m V.Value
toVal :: ValOrVar -> m Value
toVal (VVal Value
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
toVal (VVar EntryName
v) = forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> m Value
readVar Server
server EntryName
v
toVar :: ValOrVar -> m VarName
toVar :: ValOrVar -> m EntryName
toVar (VVar EntryName
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v
toVar (VVal Value
val) = do
EntryName
v <- forall {m :: * -> *}. MonadIO m => EntryName -> m EntryName
newVar EntryName
"const"
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> Value -> m ()
writeVar Server
server EntryName
v Value
val
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryName
v
scriptValueToValOrVar :: ScriptValue a -> m a
scriptValueToValOrVar (SFun EntryName
f [EntryName]
_ [EntryName]
_ [ScriptValue a]
_) =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ EntryName
"Function " forall a. Semigroup a => a -> a -> a
<> EntryName
f forall a. Semigroup a => a -> a -> a
<> EntryName
" not fully applied."
scriptValueToValOrVar (SValue EntryName
_ a
v) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
scriptValueToVal :: ScriptValue ValOrVar -> m V.Value
scriptValueToVal :: ScriptValue ValOrVar -> m Value
scriptValueToVal = ValOrVar -> m Value
toVal forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall {m :: * -> *} {a}.
MonadError EntryName m =>
ScriptValue a -> m a
scriptValueToValOrVar
scriptValueToVar :: ScriptValue ValOrVar -> m VarName
scriptValueToVar :: ScriptValue ValOrVar -> m EntryName
scriptValueToVar = ValOrVar -> m EntryName
toVar forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall {m :: * -> *} {a}.
MonadError EntryName m =>
ScriptValue a -> m a
scriptValueToValOrVar
interValToVal :: ExpValue -> m V.CompoundValue
interValToVal :: ExpValue -> m (Compound Value)
interValToVal = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ScriptValue ValOrVar -> m Value
scriptValueToVal
interValToVar :: m VarName -> TypeName -> ExpValue -> m VarName
interValToVar :: m EntryName -> EntryName -> ExpValue -> m EntryName
interValToVar m EntryName
_ EntryName
t (V.ValueAtom ScriptValue ValOrVar
v)
| EntryName -> ScriptValueType
STValue EntryName
t forall a. Eq a => a -> a -> Bool
== forall v. ScriptValue v -> ScriptValueType
scriptValueType ScriptValue ValOrVar
v = ScriptValue ValOrVar -> m EntryName
scriptValueToVar ScriptValue ValOrVar
v
interValToVar m EntryName
bad EntryName
t (V.ValueTuple [ExpValue]
vs)
| Just [EntryName]
ts <- EntryName -> TypeMap -> Maybe [EntryName]
isTuple EntryName
t TypeMap
types,
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
ts =
forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m EntryName -> EntryName -> ExpValue -> m EntryName
interValToVar m EntryName
bad) [EntryName]
ts [ExpValue]
vs
interValToVar m EntryName
bad EntryName
t (V.ValueRecord Map EntryName ExpValue
vs)
| Just [(Name, EntryName)]
fs <- EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
t TypeMap
types,
Just [ExpValue]
vs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map EntryName ExpValue
vs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> EntryName
nameToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Name, EntryName)]
fs =
forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m EntryName -> EntryName -> ExpValue -> m EntryName
interValToVar m EntryName
bad) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, EntryName)]
fs) [ExpValue]
vs'
interValToVar m EntryName
_ EntryName
t (V.ValueAtom (SValue EntryName
vt (VVar EntryName
v)))
| Just [(Name, EntryName)]
t_fs <- EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
t TypeMap
types,
Just [(Name, EntryName)]
vt_fs <- EntryName -> TypeMap -> Maybe [(Name, EntryName)]
isRecord EntryName
vt TypeMap
types,
[(Name, EntryName)]
vt_fs forall a. Eq a => a -> a -> Bool
== [(Name, EntryName)]
t_fs =
forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
EntryName -> [EntryName] -> m EntryName
mkRecord EntryName
t forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *} {b}.
(MonadIO m, MonadError EntryName m) =>
EntryName -> (Name, b) -> m EntryName
getField EntryName
v) [(Name, EntryName)]
vt_fs
interValToVar m EntryName
_ EntryName
t (V.ValueAtom (SValue EntryName
_ (VVal Value
v)))
| Just Value
v' <- EntryName -> Value -> Maybe Value
coerceValue EntryName
t Value
v =
ScriptValue ValOrVar -> m EntryName
scriptValueToVar forall a b. (a -> b) -> a -> b
$ forall v. EntryName -> v -> ScriptValue v
SValue EntryName
t forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
v'
interValToVar m EntryName
bad EntryName
_ ExpValue
_ = m EntryName
bad
valToInterVal :: V.CompoundValue -> ExpValue
valToInterVal :: Compound Value -> ExpValue
valToInterVal = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \Value
v ->
forall v. EntryName -> v -> ScriptValue v
SValue (ValueType -> EntryName
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
v)) forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
v
letMatch :: [VarName] -> ExpValue -> m VTable
letMatch :: [EntryName] -> ExpValue -> m (Map EntryName ExpValue)
letMatch [EntryName]
vs ExpValue
val
| [ExpValue]
vals <- forall v. Compound v -> [Compound v]
V.unCompound ExpValue
val,
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
vs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vals =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [EntryName]
vs [ExpValue]
vals)
| Bool
otherwise =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
EntryName
"Pat: "
forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyTextOneLine [EntryName]
vs
forall a. Semigroup a => a -> a -> a
<> EntryName
"\nDoes not match value of type: "
forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyTextOneLine (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
val)
evalExp' :: VTable -> Exp -> m ExpValue
evalExp' :: Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
_ (ServerVar EntryName
t EntryName
v) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
V.ValueAtom forall a b. (a -> b) -> a -> b
$ forall v. EntryName -> v -> ScriptValue v
SValue EntryName
t forall a b. (a -> b) -> a -> b
$ EntryName -> ValOrVar
VVar EntryName
v
evalExp' Map EntryName ExpValue
vtable (Call (FuncBuiltin EntryName
name) [Exp]
es) = do
Compound Value
v <- EvalBuiltin m
builtin EntryName
name forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExpValue -> m (Compound Value)
interValToVal forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) [Exp]
es
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Compound Value -> ExpValue
valToInterVal Compound Value
v
evalExp' Map EntryName ExpValue
vtable (Call (FuncFut EntryName
name) [Exp]
es)
| Just ExpValue
e <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntryName
name Map EntryName ExpValue
vtable = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
es) forall a b. (a -> b) -> a -> b
$
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
EntryName
"Locally bound name cannot be invoked as a function: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText EntryName
name
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
e
evalExp' Map EntryName ExpValue
vtable (Call (FuncFut EntryName
name) [Exp]
es) = do
[EntryName]
in_types <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map InputType -> EntryName
inputType) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError EntryName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> EntryName -> IO (Either CmdFailure [InputType])
cmdInputs Server
server EntryName
name
[EntryName]
out_types <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map OutputType -> EntryName
outputType) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError EntryName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> EntryName -> IO (Either CmdFailure [OutputType])
cmdOutputs Server
server EntryName
name
[ExpValue]
es' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) [Exp]
es
let es_types :: [Compound ScriptValueType]
es_types = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall v. ScriptValue v -> ScriptValueType
scriptValueType) [ExpValue]
es'
let cannotApply :: m a
cannotApply =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
EntryName
"Function \""
forall a. Semigroup a => a -> a -> a
<> EntryName
name
forall a. Semigroup a => a -> a -> a
<> EntryName
"\" expects arguments of types:\n"
forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText (forall v. [Compound v] -> Compound v
V.mkCompound forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> Compound v
V.ValueAtom [EntryName]
in_types)
forall a. Semigroup a => a -> a -> a
<> EntryName
"\nBut called with arguments of types:\n"
forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText (forall v. [Compound v] -> Compound v
V.mkCompound forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> Compound v
V.ValueAtom [Compound ScriptValueType]
es_types)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Compound ScriptValueType]
es_types forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
in_types) forall {a}. m a
cannotApply
[EntryName]
ins <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m EntryName -> EntryName -> ExpValue -> m EntryName
interValToVar forall {a}. m a
cannotApply) [EntryName]
in_types [ExpValue]
es'
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
in_types forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
ins
then do
[EntryName]
outs <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryName]
out_types) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}. MonadIO m => EntryName -> m EntryName
newVar EntryName
"out"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError EntryName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server
-> EntryName
-> [EntryName]
-> [EntryName]
-> IO (Either CmdFailure [EntryName])
cmdCall Server
server EntryName
name [EntryName]
outs [EntryName]
ins
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. [Compound v] -> Compound v
V.mkCompound forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> Compound v
V.ValueAtom forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall v. EntryName -> v -> ScriptValue v
SValue [EntryName]
out_types forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map EntryName -> ValOrVar
VVar [EntryName]
outs
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. v -> Compound v
V.ValueAtom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v.
EntryName
-> [EntryName] -> [EntryName] -> [ScriptValue v] -> ScriptValue v
SFun EntryName
name [EntryName]
in_types [EntryName]
out_types forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall v. EntryName -> v -> ScriptValue v
SValue [EntryName]
in_types forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map EntryName -> ValOrVar
VVar [EntryName]
ins
evalExp' Map EntryName ExpValue
_ (StringLit EntryName
s) =
case forall t. PutValue t => t -> Maybe Value
V.putValue EntryName
s of
Just Value
s' ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
V.ValueAtom forall a b. (a -> b) -> a -> b
$ forall v. EntryName -> v -> ScriptValue v
SValue (ValueType -> EntryName
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
s')) forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
s'
Maybe Value
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unable to write value " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyString EntryName
s
evalExp' Map EntryName ExpValue
_ (Const Value
val) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
V.ValueAtom forall a b. (a -> b) -> a -> b
$ forall v. EntryName -> v -> ScriptValue v
SValue (ValueType -> EntryName
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
val)) forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
val
evalExp' Map EntryName ExpValue
vtable (Tuple [Exp]
es) =
forall v. [Compound v] -> Compound v
V.ValueTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) [Exp]
es
evalExp' Map EntryName ExpValue
vtable e :: Exp
e@(Record [(EntryName, Exp)]
m) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Ord a => [a] -> [a]
nubOrd (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(EntryName, Exp)]
m)) forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(EntryName, Exp)]
m)) forall a b. (a -> b) -> a -> b
$
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
EntryName
"Record " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> EntryName
prettyText Exp
e forall a. Semigroup a => a -> a -> a
<> EntryName
" has duplicate fields."
forall v. Map EntryName (Compound v) -> Compound v
V.ValueRecord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable) (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(EntryName, Exp)]
m)
evalExp' Map EntryName ExpValue
vtable (Let [EntryName]
pat Exp
e1 Exp
e2) = do
ExpValue
v <- Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' Map EntryName ExpValue
vtable Exp
e1
Map EntryName ExpValue
pat_vtable <- [EntryName] -> ExpValue -> m (Map EntryName ExpValue)
letMatch [EntryName]
pat ExpValue
v
Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' (Map EntryName ExpValue
pat_vtable forall a. Semigroup a => a -> a -> a
<> Map EntryName ExpValue
vtable) Exp
e2
let freeNonresultVars :: ExpValue -> m ExpValue
freeNonresultVars ExpValue
v = do
let v_vars :: Set EntryName
v_vars = ExpValue -> Set EntryName
serverVarsInValue ExpValue
v
[EntryName]
to_free <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set EntryName
v_vars) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef [EntryName]
vars
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ Server -> [EntryName] -> IO (Maybe CmdFailure)
cmdFree Server
server [EntryName]
to_free
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
v
freeVarsOnError :: e -> m b
freeVarsOnError e
e = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Server -> [EntryName] -> IO (Maybe CmdFailure)
cmdFree Server
server forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IORef a -> IO a
readIORef IORef [EntryName]
vars
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
(forall {m :: * -> *}.
(MonadIO m, MonadError EntryName m) =>
ExpValue -> m ExpValue
freeNonresultVars forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Map EntryName ExpValue -> Exp -> m ExpValue
evalExp' forall a. Monoid a => a
mempty Exp
top_level_e) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` forall {m :: * -> *} {e} {b}.
(MonadIO m, MonadError e m) =>
e -> m b
freeVarsOnError
getExpValue ::
(MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m V.CompoundValue
getExpValue :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Compound Value)
getExpValue ScriptServer
server ExpValue
e =
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *} {a}.
MonadError EntryName m =>
ScriptValue a -> m a
toGround forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}.
(MonadError EntryName m, MonadIO m) =>
ValOrVar -> m Value
onLeaf) ExpValue
e
where
onLeaf :: ValOrVar -> m Value
onLeaf (VVar EntryName
v) = forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
Server -> EntryName -> m Value
readVar (ScriptServer -> Server
scriptServer ScriptServer
server) EntryName
v
onLeaf (VVal Value
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
toGround :: ScriptValue a -> m a
toGround (SFun EntryName
fname [EntryName]
_ [EntryName]
_ [ScriptValue a]
_) =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ EntryName
"Function " forall a. Semigroup a => a -> a -> a
<> EntryName
fname forall a. Semigroup a => a -> a -> a
<> EntryName
" not fully applied."
toGround (SValue EntryName
_ a
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
evalExpToGround ::
(MonadError T.Text m, MonadIO m) =>
EvalBuiltin m ->
ScriptServer ->
Exp ->
m (Either (V.Compound ScriptValueType) V.CompoundValue)
evalExpToGround :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
EvalBuiltin m
-> ScriptServer
-> Exp
-> m (Either (Compound ScriptValueType) (Compound Value))
evalExpToGround EvalBuiltin m
builtin ScriptServer
server Exp
e = do
ExpValue
v <- forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
evalExp EvalBuiltin m
builtin ScriptServer
server Exp
e
(forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Compound Value)
getExpValue ScriptServer
server ExpValue
v)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
v)
varsInExp :: Exp -> S.Set EntryName
varsInExp :: Exp -> Set EntryName
varsInExp ServerVar {} = forall a. Monoid a => a
mempty
varsInExp (Call (FuncFut EntryName
v) [Exp]
es) = forall a. Ord a => a -> Set a -> Set a
S.insert EntryName
v forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp [Exp]
es
varsInExp (Call (FuncBuiltin EntryName
_) [Exp]
es) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp [Exp]
es
varsInExp (Tuple [Exp]
es) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp [Exp]
es
varsInExp (Record [(EntryName, Exp)]
fs) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set EntryName
varsInExp) [(EntryName, Exp)]
fs
varsInExp Const {} = forall a. Monoid a => a
mempty
varsInExp StringLit {} = forall a. Monoid a => a
mempty
varsInExp (Let [EntryName]
pat Exp
e1 Exp
e2) = Exp -> Set EntryName
varsInExp Exp
e1 forall a. Semigroup a => a -> a -> a
<> forall a. (a -> Bool) -> Set a -> Set a
S.filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [EntryName]
pat) (Exp -> Set EntryName
varsInExp Exp
e2)
freeValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m ()
freeValue :: forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
ScriptServer -> ExpValue -> m ()
freeValue ScriptServer
server =
forall (m :: * -> *).
(MonadError EntryName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server -> [EntryName] -> IO (Maybe CmdFailure)
cmdFree (ScriptServer -> Server
scriptServer ScriptServer
server) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpValue -> Set EntryName
serverVarsInValue