{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Inferno.Eval where
import Control.Monad.Catch (MonadCatch, SomeException, try)
import Control.Monad.Except
( Except,
ExceptT,
MonadError (throwError),
forM,
runExcept,
runExceptT,
)
import Control.Monad.Identity (Identity)
import Control.Monad.Reader (ask, local)
import Data.Foldable (foldrM)
import Data.List.NonEmpty (NonEmpty (..), toList)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Text as Text
import Inferno.Eval.Error
( EvalError (AssertionFailed, RuntimeError),
)
import Inferno.Module.Builtin (enumBoolHash)
import Inferno.Types.Syntax
( BaseType (..),
Expr (..),
ExtIdent (..),
Ident (..),
ImplExpl (..),
InfernoType (TBase),
Lit (LDouble, LHex, LInt, LText),
Pat (..),
tListToList,
toEitherList,
)
import Inferno.Types.Value
( ImplEnvM,
Value
( VArray,
VDouble,
VEmpty,
VEnum,
VFun,
VInt,
VOne,
VText,
VTuple,
VTypeRep,
VWord64
),
runImplEnvM,
)
import Inferno.Types.VersionControl (VCObjectHash)
import Inferno.Utils.Prettyprinter (renderPretty)
import Prettyprinter
( LayoutOptions (LayoutOptions),
PageWidth (Unbounded),
Pretty (pretty),
layoutPretty,
)
import Prettyprinter.Render.Text (renderStrict)
type TermEnv hash c m = (Map.Map ExtIdent (Value c m), Map.Map hash (Value c m))
type Interpreter t = Except EvalError t
emptyTmenv :: TermEnv hash c m
emptyTmenv :: forall hash c (m :: * -> *). TermEnv hash c m
emptyTmenv = (forall k a. Map k a
Map.empty, forall k a. Map k a
Map.empty)
eval :: (MonadError EvalError m, MonadError EvalError (ImplEnvM m c), Pretty c) => TermEnv VCObjectHash c (ImplEnvM m c) -> Expr (Maybe VCObjectHash) a -> ImplEnvM m c (Value c (ImplEnvM m c))
eval :: forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval env :: (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env@(Map ExtIdent (Value c (ImplEnvM m c))
localEnv, Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv) Expr (Maybe VCObjectHash) a
expr = case Expr (Maybe VCObjectHash) a
expr of
Lit_ (LInt Int64
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall custom (m :: * -> *).
(Value custom m -> m (Value custom m)) -> Value custom m
VFun forall a b. (a -> b) -> a -> b
$ \case
VTypeRep (TBase BaseType
TInt) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *). Int64 -> Value custom m
VInt Int64
k
VTypeRep (TBase BaseType
TDouble) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *). Double -> Value custom m
VDouble forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
k
Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"Invalid runtime rep for numeric constant."
Lit_ (LDouble Double
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *). Double -> Value custom m
VDouble Double
k
Lit_ (LHex Word64
w) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *). Word64 -> Value custom m
VWord64 Word64
w
Lit_ (LText Text
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *). Text -> Value custom m
VText Text
t
InterpolatedString_ SomeIStr (a, Expr (Maybe VCObjectHash) a, a)
es -> do
[Value c (ImplEnvM m c)]
res <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall e. SomeIStr e -> [Either Text e]
toEitherList SomeIStr (a, Expr (Maybe VCObjectHash) a, a)
es) forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). Text -> Value custom m
VText) (\(a
_, Expr (Maybe VCObjectHash) a
e, a
_) -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *). Text -> Value custom m
VText forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {custom} {m :: * -> *}.
Pretty custom =>
Value custom m -> Text
toText [Value c (ImplEnvM m c)]
res
where
toText :: Value custom m -> Text
toText (VText Text
t) = Text
t
toText Value custom m
e = forall ann. SimpleDocStream ann -> Text
renderStrict forall a b. (a -> b) -> a -> b
$ forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty (PageWidth -> LayoutOptions
LayoutOptions PageWidth
Unbounded) forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Value custom m
e
Array_ [(Expr (Maybe VCObjectHash) a, Maybe a)]
es ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (\(Expr (Maybe VCObjectHash) a
e, Maybe a
_) [Value c (ImplEnvM m c)]
vs -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [Value c (ImplEnvM m c)]
vs)) [] [(Expr (Maybe VCObjectHash) a, Maybe a)]
es forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). [Value custom m] -> Value custom m
VArray
ArrayComp_ Expr (Maybe VCObjectHash) a
e NonEmpty (a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a)
srcs Maybe (a, Expr (Maybe VCObjectHash) a)
mCond -> do
[[(ExtIdent, Value c (ImplEnvM m c))]]
vals <- forall (m :: * -> *) c a.
(MonadError EvalError m, Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> NonEmpty (a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a)
-> ImplEnvM m c [[(ExtIdent, Value c (ImplEnvM m c))]]
sequence' (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env NonEmpty (a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a)
srcs
forall custom (m :: * -> *). [Value custom m] -> Value custom m
VArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe (a, Expr (Maybe VCObjectHash) a)
mCond of
Maybe (a, Expr (Maybe VCObjectHash) a)
Nothing ->
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[(ExtIdent, Value c (ImplEnvM m c))]]
vals forall a b. (a -> b) -> a -> b
$ \[(ExtIdent, Value c (ImplEnvM m c))]
vs ->
let nenv :: Map ExtIdent (Value c (ImplEnvM m c))
nenv = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert) Map ExtIdent (Value c (ImplEnvM m c))
localEnv [(ExtIdent, Value c (ImplEnvM m c))]
vs in forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c))
nenv, Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv) Expr (Maybe VCObjectHash) a
e
Just (a
_, Expr (Maybe VCObjectHash) a
cond) ->
forall a. [Maybe a] -> [a]
catMaybes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[(ExtIdent, Value c (ImplEnvM m c))]]
vals forall a b. (a -> b) -> a -> b
$ \[(ExtIdent, Value c (ImplEnvM m c))]
vs -> do
let nenv :: Map ExtIdent (Value c (ImplEnvM m c))
nenv = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert) Map ExtIdent (Value c (ImplEnvM m c))
localEnv [(ExtIdent, Value c (ImplEnvM m c))]
vs
forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c))
nenv, Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv) Expr (Maybe VCObjectHash) a
cond forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
VEnum VCObjectHash
hash Ident
"true" ->
if VCObjectHash
hash forall a. Eq a => a -> a -> Bool
== VCObjectHash
enumBoolHash
then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c))
nenv, Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv) Expr (Maybe VCObjectHash) a
e)
else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a bool"
VEnum VCObjectHash
hash Ident
"false" ->
if VCObjectHash
hash forall a. Eq a => a -> a -> Bool
== VCObjectHash
enumBoolHash
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a bool"
Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a bool"
)
where
sequence' :: (MonadError EvalError m, Pretty c) => TermEnv VCObjectHash c (ImplEnvM m c) -> NonEmpty (a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a) -> ImplEnvM m c [[(ExtIdent, Value c (ImplEnvM m c))]]
sequence' :: forall (m :: * -> *) c a.
(MonadError EvalError m, Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> NonEmpty (a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a)
-> ImplEnvM m c [[(ExtIdent, Value c (ImplEnvM m c))]]
sequence' env' :: TermEnv VCObjectHash c (ImplEnvM m c)
env'@(Map ExtIdent (Value c (ImplEnvM m c))
localEnv', Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv') = \case
(a
_, Ident Text
x, a
_, Expr (Maybe VCObjectHash) a
e_s, Maybe a
_) :| [] -> do
forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval TermEnv VCObjectHash c (ImplEnvM m c)
env' Expr (Maybe VCObjectHash) a
e_s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
VArray [Value c (ImplEnvM m c)]
vals -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
: []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Int Text -> ExtIdent
ExtIdent forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
x,)) [Value c (ImplEnvM m c)]
vals
Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with an array"
(a
_, Ident Text
x, a
_, Expr (Maybe VCObjectHash) a
e_s, Maybe a
_) :| ((a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a)
r : [(a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a)]
rs) -> do
forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval TermEnv VCObjectHash c (ImplEnvM m c)
env' Expr (Maybe VCObjectHash) a
e_s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
VArray [Value c (ImplEnvM m c)]
vals ->
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Value c (ImplEnvM m c)]
vals forall a b. (a -> b) -> a -> b
$ \Value c (ImplEnvM m c)
v -> do
[[(ExtIdent, Value c (ImplEnvM m c))]]
res <- forall (m :: * -> *) c a.
(MonadError EvalError m, Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> NonEmpty (a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a)
-> ImplEnvM m c [[(ExtIdent, Value c (ImplEnvM m c))]]
sequence' (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Either Int Text -> ExtIdent
ExtIdent forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
x) Value c (ImplEnvM m c)
v Map ExtIdent (Value c (ImplEnvM m c))
localEnv', Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv') ((a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a)
r forall a. a -> [a] -> NonEmpty a
:| [(a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a)]
rs)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Either Int Text -> ExtIdent
ExtIdent forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
x, Value c (ImplEnvM m c)
v) forall a. a -> [a] -> [a]
:) [[(ExtIdent, Value c (ImplEnvM m c))]]
res
)
Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with an array"
Enum_ (Just VCObjectHash
hash) Scoped ModuleName
_ Ident
i -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *).
VCObjectHash -> Ident -> Value custom m
VEnum VCObjectHash
hash Ident
i
Enum_ Maybe VCObjectHash
Nothing Scoped ModuleName
_ Ident
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"All enums must be pinned"
Var_ (Just VCObjectHash
hash) Scoped ModuleName
_ ImplExpl
x ->
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup VCObjectHash
hash Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv of
Just Value c (ImplEnvM m c)
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Value c (ImplEnvM m c)
v
Maybe (Value c (ImplEnvM m c))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ImplExpl
x forall a. Semigroup a => a -> a -> a
<> String
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show VCObjectHash
hash forall a. Semigroup a => a -> a -> a
<> String
") not found in the pinned env"
Var_ Maybe VCObjectHash
Nothing Scoped ModuleName
_ (Expl ExtIdent
x) -> do
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ExtIdent
x Map ExtIdent (Value c (ImplEnvM m c))
localEnv of
Just Value c (ImplEnvM m c)
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Value c (ImplEnvM m c)
v
Maybe (Value c (ImplEnvM m c))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ExtIdent
x forall a. Semigroup a => a -> a -> a
<> String
" not found in the unpinned env"
Var_ Maybe VCObjectHash
Nothing Scoped ModuleName
_ (Impl ExtIdent
x) -> do
Map ExtIdent (Value c (ImplEnvM m c))
implEnv <- forall r (m :: * -> *). MonadReader r m => m r
ask
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ExtIdent
x Map ExtIdent (Value c (ImplEnvM m c))
implEnv of
Just Value c (ImplEnvM m c)
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Value c (ImplEnvM m c)
v
Maybe (Value c (ImplEnvM m c))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ExtIdent
x forall a. Semigroup a => a -> a -> a
<> String
" not found in the implicit env"
OpVar_ (Just VCObjectHash
hash) Scoped ModuleName
_ Ident
x ->
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup VCObjectHash
hash Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv of
Just Value c (ImplEnvM m c)
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Value c (ImplEnvM m c)
v
Maybe (Value c (ImplEnvM m c))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Ident
x forall a. Semigroup a => a -> a -> a
<> String
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show VCObjectHash
hash forall a. Semigroup a => a -> a -> a
<> String
") not found in the pinned env"
OpVar_ Maybe VCObjectHash
Nothing Scoped ModuleName
_ (Ident Text
x) -> do
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Either Int Text -> ExtIdent
ExtIdent forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
x) Map ExtIdent (Value c (ImplEnvM m c))
localEnv of
Just Value c (ImplEnvM m c)
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Value c (ImplEnvM m c)
v
Maybe (Value c (ImplEnvM m c))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Text
x forall a. Semigroup a => a -> a -> a
<> String
" not found in env"
TypeRep_ InfernoType
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *). InfernoType -> Value custom m
VTypeRep InfernoType
t
Op_ Expr (Maybe VCObjectHash) a
_ Maybe VCObjectHash
Nothing Scoped ModuleName
_ Ident
op Expr (Maybe VCObjectHash) a
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Ident
op forall a. Semigroup a => a -> a -> a
<> String
" should be pinned"
Op_ Expr (Maybe VCObjectHash) a
a (Just VCObjectHash
hash) Scoped ModuleName
_ns Ident
op Expr (Maybe VCObjectHash) a
b -> do
Value c (ImplEnvM m c)
a' <- forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
a
Value c (ImplEnvM m c)
b' <- forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
b
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup VCObjectHash
hash Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv of
Maybe (Value c (ImplEnvM m c))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Ident
op forall a. Semigroup a => a -> a -> a
<> String
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show VCObjectHash
hash forall a. Semigroup a => a -> a -> a
<> String
") not found in the pinned env"
Just (VFun Value c (ImplEnvM m c) -> ImplEnvM m c (Value c (ImplEnvM m c))
f) ->
Value c (ImplEnvM m c) -> ImplEnvM m c (Value c (ImplEnvM m c))
f Value c (ImplEnvM m c)
a' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
VFun Value c (ImplEnvM m c) -> ImplEnvM m c (Value c (ImplEnvM m c))
f' -> Value c (ImplEnvM m c) -> ImplEnvM m c (Value c (ImplEnvM m c))
f' Value c (ImplEnvM m c)
b'
Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Ident
op forall a. Semigroup a => a -> a -> a
<> String
" not bound to a binary function in env"
Just Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Ident
op forall a. Semigroup a => a -> a -> a
<> String
" not bound to a function in env"
PreOp_ Maybe VCObjectHash
Nothing Scoped ModuleName
_ Ident
op Expr (Maybe VCObjectHash) a
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Ident
op forall a. Semigroup a => a -> a -> a
<> String
" should be pinned"
PreOp_ (Just VCObjectHash
hash) Scoped ModuleName
_ns Ident
op Expr (Maybe VCObjectHash) a
a -> do
Value c (ImplEnvM m c)
a' <- forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
a
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup VCObjectHash
hash Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv of
Maybe (Value c (ImplEnvM m c))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Ident
op forall a. Semigroup a => a -> a -> a
<> String
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show VCObjectHash
hash forall a. Semigroup a => a -> a -> a
<> String
") not found in the pinned env"
Just (VFun Value c (ImplEnvM m c) -> ImplEnvM m c (Value c (ImplEnvM m c))
f) -> Value c (ImplEnvM m c) -> ImplEnvM m c (Value c (ImplEnvM m c))
f Value c (ImplEnvM m c)
a'
Just Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Ident
op forall a. Semigroup a => a -> a -> a
<> String
" not bound to a function in env"
Lam_ NonEmpty (a, Maybe ExtIdent)
args Expr (Maybe VCObjectHash) a
body -> Map ExtIdent (Value c (ImplEnvM m c))
-> [(a, Maybe ExtIdent)] -> ImplEnvM m c (Value c (ImplEnvM m c))
go Map ExtIdent (Value c (ImplEnvM m c))
localEnv forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList NonEmpty (a, Maybe ExtIdent)
args
where
go :: Map ExtIdent (Value c (ImplEnvM m c))
-> [(a, Maybe ExtIdent)] -> ImplEnvM m c (Value c (ImplEnvM m c))
go Map ExtIdent (Value c (ImplEnvM m c))
nenv = \case
[] -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c))
nenv, Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv) Expr (Maybe VCObjectHash) a
body
(a
_, Just ExtIdent
x) : [(a, Maybe ExtIdent)]
xs ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *).
(Value custom m -> m (Value custom m)) -> Value custom m
VFun forall a b. (a -> b) -> a -> b
$ \Value c (ImplEnvM m c)
arg -> Map ExtIdent (Value c (ImplEnvM m c))
-> [(a, Maybe ExtIdent)] -> ImplEnvM m c (Value c (ImplEnvM m c))
go (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ExtIdent
x Value c (ImplEnvM m c)
arg Map ExtIdent (Value c (ImplEnvM m c))
nenv) [(a, Maybe ExtIdent)]
xs
(a
_, Maybe ExtIdent
Nothing) : [(a, Maybe ExtIdent)]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *).
(Value custom m -> m (Value custom m)) -> Value custom m
VFun forall a b. (a -> b) -> a -> b
$ \Value c (ImplEnvM m c)
_arg -> Map ExtIdent (Value c (ImplEnvM m c))
-> [(a, Maybe ExtIdent)] -> ImplEnvM m c (Value c (ImplEnvM m c))
go Map ExtIdent (Value c (ImplEnvM m c))
nenv [(a, Maybe ExtIdent)]
xs
App_ Expr (Maybe VCObjectHash) a
fun Expr (Maybe VCObjectHash) a
arg -> do
forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
fun forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
VFun Value c (ImplEnvM m c) -> ImplEnvM m c (Value c (ImplEnvM m c))
f -> do
Value c (ImplEnvM m c)
argv <- forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
arg
Value c (ImplEnvM m c) -> ImplEnvM m c (Value c (ImplEnvM m c))
f Value c (ImplEnvM m c)
argv
Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a function"
Let_ (Expl ExtIdent
x) Expr (Maybe VCObjectHash) a
e Expr (Maybe VCObjectHash) a
body -> do
Value c (ImplEnvM m c)
e' <- forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
let nenv :: Map ExtIdent (Value c (ImplEnvM m c))
nenv = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ExtIdent
x Value c (ImplEnvM m c)
e' Map ExtIdent (Value c (ImplEnvM m c))
localEnv
forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c))
nenv, Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv) Expr (Maybe VCObjectHash) a
body
Let_ (Impl ExtIdent
x) Expr (Maybe VCObjectHash) a
e Expr (Maybe VCObjectHash) a
body -> do
Value c (ImplEnvM m c)
e' <- forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Map ExtIdent (Value c (ImplEnvM m c))
impEnv -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ExtIdent
x Value c (ImplEnvM m c)
e' Map ExtIdent (Value c (ImplEnvM m c))
impEnv) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
body
If_ Expr (Maybe VCObjectHash) a
cond Expr (Maybe VCObjectHash) a
tr Expr (Maybe VCObjectHash) a
fl ->
forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
cond forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
VEnum VCObjectHash
hash Ident
"true" ->
if VCObjectHash
hash forall a. Eq a => a -> a -> Bool
== VCObjectHash
enumBoolHash
then forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
tr
else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a bool"
VEnum VCObjectHash
hash Ident
"false" ->
if VCObjectHash
hash forall a. Eq a => a -> a -> Bool
== VCObjectHash
enumBoolHash
then forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
fl
else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a bool"
Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a bool"
Tuple_ TList (Expr (Maybe VCObjectHash) a, Maybe a)
es ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (\(Expr (Maybe VCObjectHash) a
e, Maybe a
_) [Value c (ImplEnvM m c)]
vs -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [Value c (ImplEnvM m c)]
vs)) [] (forall a. TList a -> [a]
tListToList TList (Expr (Maybe VCObjectHash) a, Maybe a)
es) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). [Value custom m] -> Value custom m
VTuple
One_ Expr (Maybe VCObjectHash) a
e -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). Value custom m -> Value custom m
VOne
Expr (Maybe VCObjectHash) a
Empty_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *). Value custom m
VEmpty
Assert_ Expr (Maybe VCObjectHash) a
cond Expr (Maybe VCObjectHash) a
e ->
forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
cond forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
VEnum VCObjectHash
hash Ident
"false" ->
if VCObjectHash
hash forall a. Eq a => a -> a -> Bool
== VCObjectHash
enumBoolHash
then forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvalError
AssertionFailed
else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a bool"
VEnum VCObjectHash
hash Ident
"true" ->
if VCObjectHash
hash forall a. Eq a => a -> a -> Bool
== VCObjectHash
enumBoolHash
then forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a bool"
Value c (ImplEnvM m c)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError String
"failed to match with a bool"
Case_ Expr (Maybe VCObjectHash) a
e NonEmpty
(a, Pat (Maybe VCObjectHash) a, a, Expr (Maybe VCObjectHash) a)
pats -> do
Value c (ImplEnvM m c)
v <- forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
Value c (ImplEnvM m c)
-> NonEmpty
(a, Pat (Maybe VCObjectHash) a, a, Expr (Maybe VCObjectHash) a)
-> ImplEnvM m c (Value c (ImplEnvM m c))
matchAny Value c (ImplEnvM m c)
v NonEmpty
(a, Pat (Maybe VCObjectHash) a, a, Expr (Maybe VCObjectHash) a)
pats
where
matchAny :: Value c (ImplEnvM m c)
-> NonEmpty
(a, Pat (Maybe VCObjectHash) a, a, Expr (Maybe VCObjectHash) a)
-> ImplEnvM m c (Value c (ImplEnvM m c))
matchAny Value c (ImplEnvM m c)
v ((a
_, Pat (Maybe VCObjectHash) a
p, a
_, Expr (Maybe VCObjectHash) a
body) :| []) = case Value c (ImplEnvM m c)
-> Pat (Maybe VCObjectHash) a
-> Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
match Value c (ImplEnvM m c)
v Pat (Maybe VCObjectHash) a
p of
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
nenv -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
nenv Expr (Maybe VCObjectHash) a
body
Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ String
"non-exhaustive patterns in case detected in " forall a. Semigroup a => a -> a -> a
<> (Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
renderPretty Value c (ImplEnvM m c)
v)
matchAny Value c (ImplEnvM m c)
v ((a
_, Pat (Maybe VCObjectHash) a
p, a
_, Expr (Maybe VCObjectHash) a
body) :| ((a, Pat (Maybe VCObjectHash) a, a, Expr (Maybe VCObjectHash) a)
r : [(a, Pat (Maybe VCObjectHash) a, a, Expr (Maybe VCObjectHash) a)]
rs)) = case Value c (ImplEnvM m c)
-> Pat (Maybe VCObjectHash) a
-> Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
match Value c (ImplEnvM m c)
v Pat (Maybe VCObjectHash) a
p of
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
nenv -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
nenv Expr (Maybe VCObjectHash) a
body
Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
Nothing -> Value c (ImplEnvM m c)
-> NonEmpty
(a, Pat (Maybe VCObjectHash) a, a, Expr (Maybe VCObjectHash) a)
-> ImplEnvM m c (Value c (ImplEnvM m c))
matchAny Value c (ImplEnvM m c)
v ((a, Pat (Maybe VCObjectHash) a, a, Expr (Maybe VCObjectHash) a)
r forall a. a -> [a] -> NonEmpty a
:| [(a, Pat (Maybe VCObjectHash) a, a, Expr (Maybe VCObjectHash) a)]
rs)
match :: Value c (ImplEnvM m c)
-> Pat (Maybe VCObjectHash) a
-> Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
match Value c (ImplEnvM m c)
v Pat (Maybe VCObjectHash) a
p = case (Value c (ImplEnvM m c)
v, Pat (Maybe VCObjectHash) a
p) of
(Value c (ImplEnvM m c)
_, PVar a
_ (Just (Ident Text
x))) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Either Int Text -> ExtIdent
ExtIdent forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
x) Value c (ImplEnvM m c)
v Map ExtIdent (Value c (ImplEnvM m c))
localEnv, Map VCObjectHash (Value c (ImplEnvM m c))
pinnedEnv)
(Value c (ImplEnvM m c)
_, PVar a
_ Maybe Ident
Nothing) -> forall a. a -> Maybe a
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env
(VEnum VCObjectHash
h1 Ident
_, PEnum a
_ (Just VCObjectHash
h2) Scoped ModuleName
_ Ident
_) ->
if VCObjectHash
h1 forall a. Eq a => a -> a -> Bool
== VCObjectHash
h2
then forall a. a -> Maybe a
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env
else forall a. Maybe a
Nothing
(VInt Int64
i1, PLit a
_ (LInt Int64
i2)) ->
if Int64
i1 forall a. Eq a => a -> a -> Bool
== Int64
i2
then forall a. a -> Maybe a
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env
else forall a. Maybe a
Nothing
(VDouble Double
d1, PLit a
_ (LDouble Double
d2)) ->
if Double
d1 forall a. Eq a => a -> a -> Bool
== Double
d2
then forall a. a -> Maybe a
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env
else forall a. Maybe a
Nothing
(VText Text
t1, PLit a
_ (LText Text
t2)) ->
if Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2
then forall a. a -> Maybe a
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env
else forall a. Maybe a
Nothing
(VWord64 Word64
h1, PLit a
_ (LHex Word64
h2)) ->
if Word64
h1 forall a. Eq a => a -> a -> Bool
== Word64
h2
then forall a. a -> Maybe a
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env
else forall a. Maybe a
Nothing
(VOne Value c (ImplEnvM m c)
v', POne a
_ Pat (Maybe VCObjectHash) a
p') -> Value c (ImplEnvM m c)
-> Pat (Maybe VCObjectHash) a
-> Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
match Value c (ImplEnvM m c)
v' Pat (Maybe VCObjectHash) a
p'
(Value c (ImplEnvM m c)
VEmpty, PEmpty a
_) -> forall a. a -> Maybe a
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env
(VTuple [Value c (ImplEnvM m c)]
vs, PTuple a
_ TList (Pat (Maybe VCObjectHash) a, Maybe a)
ps a
_) -> [Value c (ImplEnvM m c)]
-> [(Pat (Maybe VCObjectHash) a, Maybe a)]
-> Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
matchTuple [Value c (ImplEnvM m c)]
vs forall a b. (a -> b) -> a -> b
$ forall a. TList a -> [a]
tListToList TList (Pat (Maybe VCObjectHash) a, Maybe a)
ps
(Value c (ImplEnvM m c), Pat (Maybe VCObjectHash) a)
_ -> forall a. Maybe a
Nothing
matchTuple :: [Value c (ImplEnvM m c)]
-> [(Pat (Maybe VCObjectHash) a, Maybe a)]
-> Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
matchTuple [] [] = forall a. a -> Maybe a
Just (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env
matchTuple (Value c (ImplEnvM m c)
v' : [Value c (ImplEnvM m c)]
vs) ((Pat (Maybe VCObjectHash) a
p', Maybe a
_) : [(Pat (Maybe VCObjectHash) a, Maybe a)]
ps) = do
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env1 <- Value c (ImplEnvM m c)
-> Pat (Maybe VCObjectHash) a
-> Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
match Value c (ImplEnvM m c)
v' Pat (Maybe VCObjectHash) a
p'
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env2 <- [Value c (ImplEnvM m c)]
-> [(Pat (Maybe VCObjectHash) a, Maybe a)]
-> Maybe
(Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
matchTuple [Value c (ImplEnvM m c)]
vs [(Pat (Maybe VCObjectHash) a, Maybe a)]
ps
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env1 forall a. Semigroup a => a -> a -> a
<> (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env2
matchTuple [Value c (ImplEnvM m c)]
_ [(Pat (Maybe VCObjectHash) a, Maybe a)]
_ = forall a. Maybe a
Nothing
CommentAbove Comment a
_ Expr (Maybe VCObjectHash) a
e -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
CommentAfter Expr (Maybe VCObjectHash) a
e Comment a
_ -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
CommentBelow Expr (Maybe VCObjectHash) a
e Comment a
_ -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
Bracketed_ Expr (Maybe VCObjectHash) a
e -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
RenameModule_ ModuleName
_ ModuleName
_ Expr (Maybe VCObjectHash) a
e -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
OpenModule_ ModuleName
_ [(Import a, Maybe a)]
_ Expr (Maybe VCObjectHash) a
e -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (Map ExtIdent (Value c (ImplEnvM m c)),
Map VCObjectHash (Value c (ImplEnvM m c)))
env Expr (Maybe VCObjectHash) a
e
runEvalIO ::
(MonadCatch m, Pretty c) =>
ImplEnvM (ExceptT EvalError m) c (TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError m) c)) ->
Map.Map ExtIdent (Value c (ImplEnvM (ExceptT EvalError m) c)) ->
Expr (Maybe VCObjectHash) a ->
m (Either EvalError (Value c (ImplEnvM (ExceptT EvalError m) c)))
runEvalIO :: forall (m :: * -> *) c a.
(MonadCatch m, Pretty c) =>
ImplEnvM
(ExceptT EvalError m)
c
(TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError m) c))
-> Map ExtIdent (Value c (ImplEnvM (ExceptT EvalError m) c))
-> Expr (Maybe VCObjectHash) a
-> m (Either
EvalError (Value c (ImplEnvM (ExceptT EvalError m) c)))
runEvalIO ImplEnvM
(ExceptT EvalError m)
c
(TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError m) c))
env Map ExtIdent (Value c (ImplEnvM (ExceptT EvalError m) c))
implicitEnv Expr (Maybe VCObjectHash) a
ex = do
Either
SomeException
(Either EvalError (Value c (ImplEnvM (ExceptT EvalError m) c)))
input <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) a.
Map ExtIdent (Value c (ImplEnvM m c)) -> ImplEnvM m c a -> m a
runImplEnvM Map ExtIdent (Value c (ImplEnvM (ExceptT EvalError m) c))
implicitEnv forall a b. (a -> b) -> a -> b
$ (ImplEnvM
(ExceptT EvalError m)
c
(TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError m) c))
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError m) c)
env' -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError m) c)
env' Expr (Maybe VCObjectHash) a
ex)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either
SomeException
(Either EvalError (Value c (ImplEnvM (ExceptT EvalError m) c)))
input of
Left (SomeException
e :: SomeException) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> EvalError
RuntimeError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e
Right Either EvalError (Value c (ImplEnvM (ExceptT EvalError m) c))
res -> Either EvalError (Value c (ImplEnvM (ExceptT EvalError m) c))
res
pureEval ::
(Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError Identity) c) ->
Map.Map ExtIdent (Value c (ImplEnvM (ExceptT EvalError Identity) c)) ->
Expr (Maybe VCObjectHash) a ->
Either EvalError (Value c (ImplEnvM (ExceptT EvalError Identity) c))
pureEval :: forall c a.
Pretty c =>
TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError Identity) c)
-> Map ExtIdent (Value c (ImplEnvM (ExceptT EvalError Identity) c))
-> Expr (Maybe VCObjectHash) a
-> Either
EvalError (Value c (ImplEnvM (ExceptT EvalError Identity) c))
pureEval TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError Identity) c)
env Map ExtIdent (Value c (ImplEnvM (ExceptT EvalError Identity) c))
implicitEnv Expr (Maybe VCObjectHash) a
ex = forall e a. Except e a -> Either e a
runExcept forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) a.
Map ExtIdent (Value c (ImplEnvM m c)) -> ImplEnvM m c a -> m a
runImplEnvM Map ExtIdent (Value c (ImplEnvM (ExceptT EvalError Identity) c))
implicitEnv forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval TermEnv VCObjectHash c (ImplEnvM (ExceptT EvalError Identity) c)
env Expr (Maybe VCObjectHash) a
ex