module Futhark.Script
(
ScriptServer,
withScriptServer,
withScriptServer',
Func (..),
Exp (..),
parseExp,
parseExpFromText,
varsInExp,
ScriptValueType (..),
ScriptValue (..),
scriptValueType,
serverVarsInValue,
ValOrVar (..),
ExpValue,
EvalBuiltin,
evalExp,
getExpValue,
evalExpToGround,
valueToExp,
freeValue,
)
where
import Control.Monad.Except
import Data.Bifunctor (bimap)
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.Void
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 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
type EvalBuiltin m = T.Text -> [V.CompoundValue] -> m V.CompoundValue
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 CompoundValue
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
bad EntryName
_ ExpValue
_ = m EntryName
bad
valToInterVal :: V.CompoundValue -> ExpValue
valToInterVal :: CompoundValue -> 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
CompoundValue
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 CompoundValue
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
$ CompoundValue -> ExpValue
valToInterVal CompoundValue
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 CompoundValue
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) CompoundValue)
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 CompoundValue
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