{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Dovetail.Evaluate
(
buildCoreFn
, builtIn
, eval
, apply
, ToValue(..)
, ToValueRHS(..)
, ObjectOptions(..)
, defaultObjectOptions
, genericToValue
, genericFromValue
, ToObject(..)
, module Dovetail.Types
, evalPSString
) where
import Control.Monad (guard, foldM, mzero, zipWithM)
import Control.Monad.Fix (MonadFix, mfix)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Reader.Class
import Data.Align qualified as Align
import Data.Foldable (asum, fold)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Map qualified as Map
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.These (These(..))
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import Dovetail.Types
import GHC.Generics qualified as G
import GHC.TypeLits (KnownSymbol, symbolVal)
import Language.PureScript.CoreFn qualified as CoreFn
import Language.PureScript.Names (Qualified(..))
import Language.PureScript.Names qualified as Names
import Language.PureScript.PSString qualified as PSString
buildCoreFn :: MonadFix m => Env m -> CoreFn.Module CoreFn.Ann -> EvalT m (Env m)
buildCoreFn :: Env m -> Module Ann -> EvalT m (Env m)
buildCoreFn Env m
env CoreFn.Module{ ModuleName
moduleName :: forall a. Module a -> ModuleName
moduleName :: ModuleName
CoreFn.moduleName, [Bind Ann]
moduleDecls :: forall a. Module a -> [Bind a]
moduleDecls :: [Bind Ann]
CoreFn.moduleDecls } =
Maybe ModuleName -> Env m -> [Bind Ann] -> EvalT m (Env m)
forall (m :: * -> *).
MonadFix m =>
Maybe ModuleName -> Env m -> [Bind Ann] -> EvalT m (Env m)
bind (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
moduleName) Env m
env [Bind Ann]
moduleDecls
builtIn :: ToValue m a => Names.ModuleName -> Text -> a -> Env m
builtIn :: ModuleName -> Text -> a -> Env m
builtIn ModuleName
mn Text
name a
value =
let qualName :: Qualified Ident
qualName = Ident -> ModuleName -> Qualified Ident
forall a. a -> ModuleName -> Qualified a
Names.mkQualified (Text -> Ident
Names.Ident Text
name) ModuleName
mn
in Qualified Ident -> Value m -> Env m
forall k a. k -> a -> Map k a
Map.singleton Qualified Ident
qualName (Value m -> Env m) -> Value m -> Env m
forall a b. (a -> b) -> a -> b
$ a -> Value m
forall (m :: * -> *) a. ToValue m a => a -> Value m
toValue a
value
evalPSString :: MonadFix m => PSString.PSString -> EvalT m Text
evalPSString :: PSString -> EvalT m Text
evalPSString PSString
pss =
case PSString -> Maybe Text
PSString.decodeString PSString
pss of
Just Text
field -> Text -> EvalT m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
field
Maybe Text
_ -> EvaluationErrorType m -> EvalT m Text
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (PSString -> EvaluationErrorType m
forall (m :: * -> *). PSString -> EvaluationErrorType m
InvalidFieldName PSString
pss)
eval
:: forall m
. MonadFix m
=> Env m
-> CoreFn.Expr CoreFn.Ann
-> EvalT m (Value m)
eval :: Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env Expr Ann
expr = Env m -> Expr Ann -> EvalT m (Value m) -> EvalT m (Value m)
forall (m :: * -> *) a.
Monad m =>
Env m -> Expr Ann -> EvalT m a -> EvalT m a
pushStackFrame Env m
env Expr Ann
expr (Expr Ann -> EvalT m (Value m)
evalHelper Expr Ann
expr) where
evalHelper :: Expr Ann -> EvalT m (Value m)
evalHelper (CoreFn.Literal Ann
_ Literal (Expr Ann)
lit) =
Env m -> Literal (Expr Ann) -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Literal (Expr Ann) -> EvalT m (Value m)
evalLit Env m
env Literal (Expr Ann)
lit
evalHelper (CoreFn.Accessor Ann
_ PSString
pss Expr Ann
e) = do
Value m
val <- Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env Expr Ann
e
Text
field <- PSString -> EvalT m Text
forall (m :: * -> *). MonadFix m => PSString -> EvalT m Text
evalPSString PSString
pss
case Value m
val of
Object HashMap Text (Value m)
o ->
case Text -> HashMap Text (Value m) -> Maybe (Value m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
field HashMap Text (Value m)
o of
Just Value m
x -> Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value m
x
Maybe (Value m)
Nothing -> EvaluationErrorType m -> EvalT m (Value m)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
FieldNotFound Text
field Value m
val)
Value m
_ -> EvaluationErrorType m -> EvalT m (Value m)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"object" Value m
val)
evalHelper (CoreFn.Abs Ann
_ Ident
arg Expr Ann
body) = do
EvaluationContext m
ctx <- EvalT m (EvaluationContext m)
forall r (m :: * -> *). MonadReader r m => m r
ask
Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value m -> EvalT m (Value m))
-> ((Value m -> EvalT m (Value m)) -> Value m)
-> (Value m -> EvalT m (Value m))
-> EvalT m (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value m -> EvalT m (Value m)) -> Value m
forall (m :: * -> *). (Value m -> EvalT m (Value m)) -> Value m
Closure ((Value m -> EvalT m (Value m)) -> EvalT m (Value m))
-> (Value m -> EvalT m (Value m)) -> EvalT m (Value m)
forall a b. (a -> b) -> a -> b
$ \Value m
v -> (EvaluationContext m -> EvaluationContext m)
-> EvalT m (Value m) -> EvalT m (Value m)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (EvaluationContext m -> EvaluationContext m -> EvaluationContext m
forall a b. a -> b -> a
const EvaluationContext m
ctx) (EvalT m (Value m) -> EvalT m (Value m))
-> EvalT m (Value m) -> EvalT m (Value m)
forall a b. (a -> b) -> a -> b
$ Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval (Qualified Ident -> Value m -> Env m -> Env m
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Maybe ModuleName -> Ident -> Qualified Ident
forall a. Maybe ModuleName -> a -> Qualified a
Qualified Maybe ModuleName
forall a. Maybe a
Nothing Ident
arg) Value m
v Env m
env) Expr Ann
body
evalHelper (CoreFn.App Ann
_ Expr Ann
f Expr Ann
x) = do
Value m
x_ <- Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env Expr Ann
x
Value m
f_ <- Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env Expr Ann
f
Value m -> Value m -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Value m -> Value m -> EvalT m (Value m)
apply Value m
f_ Value m
x_
evalHelper (CoreFn.Var Ann
_ Qualified Ident
name) =
case Qualified Ident -> Env m -> Maybe (Value m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Qualified Ident
name Env m
env of
Maybe (Value m)
Nothing -> EvaluationErrorType m -> EvalT m (Value m)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (EvaluationErrorType m -> EvalT m (Value m))
-> EvaluationErrorType m -> EvalT m (Value m)
forall a b. (a -> b) -> a -> b
$ Qualified Ident -> EvaluationErrorType m
forall (m :: * -> *). Qualified Ident -> EvaluationErrorType m
UnknownIdent Qualified Ident
name
Just Value m
val -> Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value m
val
evalHelper (CoreFn.Let Ann
_ [Bind Ann]
binders Expr Ann
body) = do
Env m
env' <- Maybe ModuleName -> Env m -> [Bind Ann] -> EvalT m (Env m)
forall (m :: * -> *).
MonadFix m =>
Maybe ModuleName -> Env m -> [Bind Ann] -> EvalT m (Env m)
bind Maybe ModuleName
forall a. Maybe a
Nothing Env m
env [Bind Ann]
binders
Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env' Expr Ann
body
evalHelper (CoreFn.ObjectUpdate Ann
_ Expr Ann
e [(PSString, Expr Ann)]
updates) = do
Value m
val <- Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env Expr Ann
e
let updateOne
:: HashMap Text (Value m)
-> (PSString.PSString, CoreFn.Expr CoreFn.Ann)
-> EvalT m (HashMap Text (Value m))
updateOne :: HashMap Text (Value m)
-> (PSString, Expr Ann) -> EvalT m (HashMap Text (Value m))
updateOne HashMap Text (Value m)
o (PSString
pss, Expr Ann
new) = do
Text
field <- PSString -> EvalT m Text
forall (m :: * -> *). MonadFix m => PSString -> EvalT m Text
evalPSString PSString
pss
Value m
newVal <- Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env Expr Ann
new
HashMap Text (Value m) -> EvalT m (HashMap Text (Value m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text (Value m) -> EvalT m (HashMap Text (Value m)))
-> HashMap Text (Value m) -> EvalT m (HashMap Text (Value m))
forall a b. (a -> b) -> a -> b
$ Text -> Value m -> HashMap Text (Value m) -> HashMap Text (Value m)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Text
field Value m
newVal HashMap Text (Value m)
o
case Value m
val of
Object HashMap Text (Value m)
o -> HashMap Text (Value m) -> Value m
forall (m :: * -> *). HashMap Text (Value m) -> Value m
Object (HashMap Text (Value m) -> Value m)
-> EvalT m (HashMap Text (Value m)) -> EvalT m (Value m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HashMap Text (Value m)
-> (PSString, Expr Ann) -> EvalT m (HashMap Text (Value m)))
-> HashMap Text (Value m)
-> [(PSString, Expr Ann)]
-> EvalT m (HashMap Text (Value m))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HashMap Text (Value m)
-> (PSString, Expr Ann) -> EvalT m (HashMap Text (Value m))
updateOne HashMap Text (Value m)
o [(PSString, Expr Ann)]
updates
Value m
_ -> EvaluationErrorType m -> EvalT m (Value m)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"object" Value m
val)
evalHelper (CoreFn.Case Ann
_ [Expr Ann]
args [CaseAlternative Ann]
alts) = do
[Value m]
vals <- (Expr Ann -> EvalT m (Value m)) -> [Expr Ann] -> EvalT m [Value m]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env) [Expr Ann]
args
Maybe (Env m, Expr Ann)
result <- MaybeT (EvalT m) (Env m, Expr Ann)
-> EvalT m (Maybe (Env m, Expr Ann))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT ([MaybeT (EvalT m) (Env m, Expr Ann)]
-> MaybeT (EvalT m) (Env m, Expr Ann)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((CaseAlternative Ann -> MaybeT (EvalT m) (Env m, Expr Ann))
-> [CaseAlternative Ann] -> [MaybeT (EvalT m) (Env m, Expr Ann)]
forall a b. (a -> b) -> [a] -> [b]
map (Env m
-> [Value m]
-> CaseAlternative Ann
-> MaybeT (EvalT m) (Env m, Expr Ann)
forall (m :: * -> *).
MonadFix m =>
Env m
-> [Value m]
-> CaseAlternative Ann
-> MaybeT (EvalT m) (Env m, Expr Ann)
match Env m
env [Value m]
vals) [CaseAlternative Ann]
alts))
case Maybe (Env m, Expr Ann)
result of
Maybe (Env m, Expr Ann)
Nothing -> EvaluationErrorType m -> EvalT m (Value m)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext ([Value m] -> EvaluationErrorType m
forall (m :: * -> *). [Value m] -> EvaluationErrorType m
InexhaustivePatternMatch [Value m]
vals)
Just (Env m
newEnv, Expr Ann
matchedExpr) -> Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval (Env m
newEnv Env m -> Env m -> Env m
forall a. Semigroup a => a -> a -> a
<> Env m
env) Expr Ann
matchedExpr
evalHelper (CoreFn.Constructor Ann
_ ProperName 'TypeName
_tyName ProperName 'ConstructorName
ctor [Ident]
fields) =
Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value m -> EvalT m (Value m)) -> Value m -> EvalT m (Value m)
forall a b. (a -> b) -> a -> b
$ [Ident] -> [Value m] -> Value m
go [Ident]
fields []
where
go :: [Ident] -> [Value m] -> Value m
go [] [Value m]
applied = ProperName 'ConstructorName -> [Value m] -> Value m
forall (m :: * -> *).
ProperName 'ConstructorName -> [Value m] -> Value m
Constructor ProperName 'ConstructorName
ctor ([Value m] -> [Value m]
forall a. [a] -> [a]
reverse [Value m]
applied)
go (Ident
_ : [Ident]
tl) [Value m]
applied = (Value m -> EvalT m (Value m)) -> Value m
forall (m :: * -> *). (Value m -> EvalT m (Value m)) -> Value m
Closure \Value m
arg -> Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Ident] -> [Value m] -> Value m
go [Ident]
tl (Value m
arg Value m -> [Value m] -> [Value m]
forall a. a -> [a] -> [a]
: [Value m]
applied))
match :: MonadFix m
=> Env m
-> [Value m]
-> CoreFn.CaseAlternative CoreFn.Ann
-> MaybeT (EvalT m) (Env m, CoreFn.Expr CoreFn.Ann)
match :: Env m
-> [Value m]
-> CaseAlternative Ann
-> MaybeT (EvalT m) (Env m, Expr Ann)
match Env m
env [Value m]
vals (CoreFn.CaseAlternative [Binder Ann]
binders Either [(Expr Ann, Expr Ann)] (Expr Ann)
expr)
| [Value m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value m]
vals Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Binder Ann] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binder Ann]
binders = do
Env m
newEnv <- [Env m] -> Env m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Env m] -> Env m)
-> MaybeT (EvalT m) [Env m] -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value m -> Binder Ann -> MaybeT (EvalT m) (Env m))
-> [Value m] -> [Binder Ann] -> MaybeT (EvalT m) [Env m]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
forall (m :: * -> *).
MonadFix m =>
Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
matchOne [Value m]
vals [Binder Ann]
binders
case Either [(Expr Ann, Expr Ann)] (Expr Ann)
expr of
Left [(Expr Ann, Expr Ann)]
guards -> (Env m
newEnv, ) (Expr Ann -> (Env m, Expr Ann))
-> MaybeT (EvalT m) (Expr Ann)
-> MaybeT (EvalT m) (Env m, Expr Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MaybeT (EvalT m) (Expr Ann)] -> MaybeT (EvalT m) (Expr Ann)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (((Expr Ann, Expr Ann) -> MaybeT (EvalT m) (Expr Ann))
-> [(Expr Ann, Expr Ann)] -> [MaybeT (EvalT m) (Expr Ann)]
forall a b. (a -> b) -> [a] -> [b]
map ((Expr Ann -> Expr Ann -> MaybeT (EvalT m) (Expr Ann))
-> (Expr Ann, Expr Ann) -> MaybeT (EvalT m) (Expr Ann)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Env m -> Expr Ann -> Expr Ann -> MaybeT (EvalT m) (Expr Ann)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> Expr Ann -> MaybeT (EvalT m) (Expr Ann)
evalGuard Env m
env)) [(Expr Ann, Expr Ann)]
guards)
Right Expr Ann
e -> (Env m, Expr Ann) -> MaybeT (EvalT m) (Env m, Expr Ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env m
newEnv, Expr Ann
e)
| Bool
otherwise = EvaluationErrorType m -> MaybeT (EvalT m) (Env m, Expr Ann)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Int -> Int -> EvaluationErrorType m
forall (m :: * -> *). Int -> Int -> EvaluationErrorType m
InvalidNumberOfArguments ([Value m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value m]
vals) ([Binder Ann] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binder Ann]
binders))
evalGuard
:: MonadFix m
=> Env m
-> CoreFn.Guard CoreFn.Ann
-> CoreFn.Expr CoreFn.Ann
-> MaybeT (EvalT m) (CoreFn.Expr CoreFn.Ann)
evalGuard :: Env m -> Expr Ann -> Expr Ann -> MaybeT (EvalT m) (Expr Ann)
evalGuard Env m
env Expr Ann
g Expr Ann
e = do
Value m
test <- EvalT m (Value m) -> MaybeT (EvalT m) (Value m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EvalT m (Value m) -> MaybeT (EvalT m) (Value m))
-> EvalT m (Value m) -> MaybeT (EvalT m) (Value m)
forall a b. (a -> b) -> a -> b
$ Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env Expr Ann
g
case Value m
test of
Bool Bool
b -> Bool -> MaybeT (EvalT m) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
b
Value m
_ -> EvaluationErrorType m -> MaybeT (EvalT m) ()
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"boolean" Value m
test )
Expr Ann -> MaybeT (EvalT m) (Expr Ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr Ann
e
matchOne
:: MonadFix m
=> Value m
-> CoreFn.Binder CoreFn.Ann
-> MaybeT (EvalT m) (Env m)
matchOne :: Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
matchOne Value m
_ (CoreFn.NullBinder Ann
_) = Env m -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env m
forall a. Monoid a => a
mempty
matchOne Value m
val (CoreFn.LiteralBinder Ann
_ Literal (Binder Ann)
lit) = Value m -> Literal (Binder Ann) -> MaybeT (EvalT m) (Env m)
forall (m :: * -> *).
MonadFix m =>
Value m -> Literal (Binder Ann) -> MaybeT (EvalT m) (Env m)
matchLit Value m
val Literal (Binder Ann)
lit
matchOne Value m
val (CoreFn.VarBinder Ann
_ Ident
ident) = do
Env m -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Qualified Ident -> Value m -> Env m
forall k a. k -> a -> Map k a
Map.singleton (Maybe ModuleName -> Ident -> Qualified Ident
forall a. Maybe ModuleName -> a -> Qualified a
Qualified Maybe ModuleName
forall a. Maybe a
Nothing Ident
ident) Value m
val)
matchOne Value m
val (CoreFn.NamedBinder Ann
_ Ident
ident Binder Ann
b) = do
Env m
env <- Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
forall (m :: * -> *).
MonadFix m =>
Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
matchOne Value m
val Binder Ann
b
Env m -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Qualified Ident -> Value m -> Env m -> Env m
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Maybe ModuleName -> Ident -> Qualified Ident
forall a. Maybe ModuleName -> a -> Qualified a
Qualified Maybe ModuleName
forall a. Maybe a
Nothing Ident
ident) Value m
val Env m
env)
matchOne (Constructor ProperName 'ConstructorName
ctor [Value m]
vals) (CoreFn.ConstructorBinder Ann
_ Qualified (ProperName 'TypeName)
_tyName Qualified (ProperName 'ConstructorName)
ctor' [Binder Ann]
bs)
| ProperName 'ConstructorName
ctor ProperName 'ConstructorName -> ProperName 'ConstructorName -> Bool
forall a. Eq a => a -> a -> Bool
== Qualified (ProperName 'ConstructorName)
-> ProperName 'ConstructorName
forall a. Qualified a -> a
Names.disqualify Qualified (ProperName 'ConstructorName)
ctor'
= if [Value m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value m]
vals Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Binder Ann] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binder Ann]
bs
then [Env m] -> Env m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Env m] -> Env m)
-> MaybeT (EvalT m) [Env m] -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value m -> Binder Ann -> MaybeT (EvalT m) (Env m))
-> [Value m] -> [Binder Ann] -> MaybeT (EvalT m) [Env m]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
forall (m :: * -> *).
MonadFix m =>
Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
matchOne [Value m]
vals [Binder Ann]
bs
else EvaluationErrorType m -> MaybeT (EvalT m) (Env m)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext EvaluationErrorType m
forall (m :: * -> *). EvaluationErrorType m
UnsaturatedConstructorApplication
matchOne Value m
_ Binder Ann
_ = MaybeT (EvalT m) (Env m)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
matchLit
:: forall m
. MonadFix m
=> Value m
-> CoreFn.Literal (CoreFn.Binder CoreFn.Ann)
-> MaybeT (EvalT m) (Env m)
matchLit :: Value m -> Literal (Binder Ann) -> MaybeT (EvalT m) (Env m)
matchLit (Int Integer
n) (CoreFn.NumericLiteral (Left Integer
i))
| Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
n = Env m -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env m
forall a. Monoid a => a
mempty
matchLit (Number Double
n) (CoreFn.NumericLiteral (Right Double
d))
| Double -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
n = Env m -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env m
forall a. Monoid a => a
mempty
matchLit (String Text
s) (CoreFn.StringLiteral PSString
pss) = do
Text
s' <- EvalT m Text -> MaybeT (EvalT m) Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PSString -> EvalT m Text
forall (m :: * -> *). MonadFix m => PSString -> EvalT m Text
evalPSString PSString
pss)
Bool -> MaybeT (EvalT m) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s')
Env m -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env m
forall a. Monoid a => a
mempty
matchLit (Char Char
c) (CoreFn.CharLiteral Char
c')
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c' = Env m -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env m
forall a. Monoid a => a
mempty
matchLit (Bool Bool
b) (CoreFn.BooleanLiteral Bool
b')
| Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b' = Env m -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env m
forall a. Monoid a => a
mempty
matchLit (Array Vector (Value m)
xs) (CoreFn.ArrayLiteral [Binder Ann]
bs)
| Vector (Value m) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector (Value m)
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Binder Ann] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binder Ann]
bs
= [Env m] -> Env m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Env m] -> Env m)
-> MaybeT (EvalT m) [Env m] -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value m -> Binder Ann -> MaybeT (EvalT m) (Env m))
-> [Value m] -> [Binder Ann] -> MaybeT (EvalT m) [Env m]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
forall (m :: * -> *).
MonadFix m =>
Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
matchOne (Vector (Value m) -> [Value m]
forall a. Vector a -> [a]
Vector.toList Vector (Value m)
xs) [Binder Ann]
bs
matchLit val :: Value m
val@(Object HashMap Text (Value m)
o) (CoreFn.ObjectLiteral [(PSString, Binder Ann)]
bs) = do
let evalField :: (PSString, b) -> t (EvalT m) (Text, (Text, b))
evalField (PSString
pss, b
b) = do
Text
t <- EvalT m Text -> t (EvalT m) Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PSString -> EvalT m Text
forall (m :: * -> *). MonadFix m => PSString -> EvalT m Text
evalPSString PSString
pss)
(Text, (Text, b)) -> t (EvalT m) (Text, (Text, b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
t, (Text
t, b
b))
HashMap Text (Text, Binder Ann)
vals <- [(Text, (Text, Binder Ann))] -> HashMap Text (Text, Binder Ann)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, (Text, Binder Ann))] -> HashMap Text (Text, Binder Ann))
-> MaybeT (EvalT m) [(Text, (Text, Binder Ann))]
-> MaybeT (EvalT m) (HashMap Text (Text, Binder Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PSString, Binder Ann)
-> MaybeT (EvalT m) (Text, (Text, Binder Ann)))
-> [(PSString, Binder Ann)]
-> MaybeT (EvalT m) [(Text, (Text, Binder Ann))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (PSString, Binder Ann)
-> MaybeT (EvalT m) (Text, (Text, Binder Ann))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) b.
(MonadTrans t, Monad (t (EvalT m)), MonadFix m) =>
(PSString, b) -> t (EvalT m) (Text, (Text, b))
evalField [(PSString, Binder Ann)]
bs
let matchField :: These (Value m) (Text, CoreFn.Binder CoreFn.Ann) -> MaybeT (EvalT m) (Env m)
matchField :: These (Value m) (Text, Binder Ann) -> MaybeT (EvalT m) (Env m)
matchField This{} = Env m -> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env m
forall a. Monoid a => a
mempty
matchField (That (Text
pss, Binder Ann
_)) = EvaluationErrorType m -> MaybeT (EvalT m) (Env m)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
FieldNotFound Text
pss Value m
val)
matchField (These Value m
val' (Text
_, Binder Ann
b)) = Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
forall (m :: * -> *).
MonadFix m =>
Value m -> Binder Ann -> MaybeT (EvalT m) (Env m)
matchOne Value m
val' Binder Ann
b
HashMap Text (Env m) -> Env m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (HashMap Text (Env m) -> Env m)
-> MaybeT (EvalT m) (HashMap Text (Env m))
-> MaybeT (EvalT m) (Env m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (MaybeT (EvalT m) (Env m))
-> MaybeT (EvalT m) (HashMap Text (Env m))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ((These (Value m) (Text, Binder Ann) -> MaybeT (EvalT m) (Env m))
-> HashMap Text (Value m)
-> HashMap Text (Text, Binder Ann)
-> HashMap Text (MaybeT (EvalT m) (Env m))
forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
Align.alignWith These (Value m) (Text, Binder Ann) -> MaybeT (EvalT m) (Env m)
matchField HashMap Text (Value m)
o HashMap Text (Text, Binder Ann)
vals)
matchLit Value m
_ Literal (Binder Ann)
_ = MaybeT (EvalT m) (Env m)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
evalLit :: MonadFix m => Env m -> CoreFn.Literal (CoreFn.Expr CoreFn.Ann) -> EvalT m (Value m)
evalLit :: Env m -> Literal (Expr Ann) -> EvalT m (Value m)
evalLit Env m
_ (CoreFn.NumericLiteral (Left Integer
int)) =
Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value m -> EvalT m (Value m)) -> Value m -> EvalT m (Value m)
forall a b. (a -> b) -> a -> b
$ Integer -> Value m
forall (m :: * -> *). Integer -> Value m
Int (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
int)
evalLit Env m
_ (CoreFn.NumericLiteral (Right Double
dbl)) =
Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value m -> EvalT m (Value m)) -> Value m -> EvalT m (Value m)
forall a b. (a -> b) -> a -> b
$ Double -> Value m
forall (m :: * -> *). Double -> Value m
Number (Double -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
dbl)
evalLit Env m
_ (CoreFn.StringLiteral PSString
str) =
Text -> Value m
forall (m :: * -> *). Text -> Value m
String (Text -> Value m) -> EvalT m Text -> EvalT m (Value m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PSString -> EvalT m Text
forall (m :: * -> *). MonadFix m => PSString -> EvalT m Text
evalPSString PSString
str
evalLit Env m
_ (CoreFn.CharLiteral Char
chr) =
Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value m -> EvalT m (Value m)) -> Value m -> EvalT m (Value m)
forall a b. (a -> b) -> a -> b
$ Char -> Value m
forall (m :: * -> *). Char -> Value m
Char Char
chr
evalLit Env m
_ (CoreFn.BooleanLiteral Bool
b) =
Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value m -> EvalT m (Value m)) -> Value m -> EvalT m (Value m)
forall a b. (a -> b) -> a -> b
$ Bool -> Value m
forall (m :: * -> *). Bool -> Value m
Bool Bool
b
evalLit Env m
env (CoreFn.ArrayLiteral [Expr Ann]
xs) = do
[Value m]
vs <- (Expr Ann -> EvalT m (Value m)) -> [Expr Ann] -> EvalT m [Value m]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env) [Expr Ann]
xs
Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value m -> EvalT m (Value m)) -> Value m -> EvalT m (Value m)
forall a b. (a -> b) -> a -> b
$ Vector (Value m) -> Value m
forall (m :: * -> *). Vector (Value m) -> Value m
Array ([Value m] -> Vector (Value m)
forall a. [a] -> Vector a
Vector.fromList [Value m]
vs)
evalLit Env m
env (CoreFn.ObjectLiteral [(PSString, Expr Ann)]
xs) = do
let evalField :: (PSString, Expr Ann) -> EvalT m (Text, Value m)
evalField (PSString
pss, Expr Ann
e) = do
Text
field <- PSString -> EvalT m Text
forall (m :: * -> *). MonadFix m => PSString -> EvalT m Text
evalPSString PSString
pss
Value m
val <- Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env Expr Ann
e
(Text, Value m) -> EvalT m (Text, Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
field, Value m
val)
HashMap Text (Value m) -> Value m
forall (m :: * -> *). HashMap Text (Value m) -> Value m
Object (HashMap Text (Value m) -> Value m)
-> ([(Text, Value m)] -> HashMap Text (Value m))
-> [(Text, Value m)]
-> Value m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value m)] -> HashMap Text (Value m)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, Value m)] -> Value m)
-> EvalT m [(Text, Value m)] -> EvalT m (Value m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PSString, Expr Ann) -> EvalT m (Text, Value m))
-> [(PSString, Expr Ann)] -> EvalT m [(Text, Value m)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (PSString, Expr Ann) -> EvalT m (Text, Value m)
evalField [(PSString, Expr Ann)]
xs
bind
:: forall m
. MonadFix m
=> Maybe Names.ModuleName
-> Env m
-> [CoreFn.Bind CoreFn.Ann]
-> EvalT m (Env m)
bind :: Maybe ModuleName -> Env m -> [Bind Ann] -> EvalT m (Env m)
bind Maybe ModuleName
scope = (Env m -> Bind Ann -> EvalT m (Env m))
-> Env m -> [Bind Ann] -> EvalT m (Env m)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Env m -> Bind Ann -> EvalT m (Env m)
go where
go :: Env m -> CoreFn.Bind CoreFn.Ann -> EvalT m (Env m)
go :: Env m -> Bind Ann -> EvalT m (Env m)
go Env m
env (CoreFn.NonRec Ann
_ Ident
name Expr Ann
e) = do
Value m
val <- Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
env Expr Ann
e
Env m -> EvalT m (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env m -> EvalT m (Env m)) -> Env m -> EvalT m (Env m)
forall a b. (a -> b) -> a -> b
$ Qualified Ident -> Value m -> Env m -> Env m
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Maybe ModuleName -> Ident -> Qualified Ident
forall a. Maybe ModuleName -> a -> Qualified a
Qualified Maybe ModuleName
scope Ident
name) Value m
val Env m
env
go Env m
env (CoreFn.Rec [((Ann, Ident), Expr Ann)]
exprs) = (Env m -> EvalT m (Env m)) -> EvalT m (Env m)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix \Env m
newEnv -> do
[Env m]
vals <- ((((Ann, Ident), Expr Ann) -> EvalT m (Env m))
-> [((Ann, Ident), Expr Ann)] -> EvalT m [Env m])
-> [((Ann, Ident), Expr Ann)]
-> (((Ann, Ident), Expr Ann) -> EvalT m (Env m))
-> EvalT m [Env m]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Ann, Ident), Expr Ann) -> EvalT m (Env m))
-> [((Ann, Ident), Expr Ann)] -> EvalT m [Env m]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [((Ann, Ident), Expr Ann)]
exprs \((Ann
_, Ident
name), Expr Ann
e) -> do
Value m
val <- Env m -> Expr Ann -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Env m -> Expr Ann -> EvalT m (Value m)
eval Env m
newEnv Expr Ann
e
Env m -> EvalT m (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env m -> EvalT m (Env m)) -> Env m -> EvalT m (Env m)
forall a b. (a -> b) -> a -> b
$ Qualified Ident -> Value m -> Env m
forall k a. k -> a -> Map k a
Map.singleton (Maybe ModuleName -> Ident -> Qualified Ident
forall a. Maybe ModuleName -> a -> Qualified a
Qualified Maybe ModuleName
scope Ident
name) Value m
val
Env m -> EvalT m (Env m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Env m] -> Env m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Env m]
vals Env m -> Env m -> Env m
forall a. Semigroup a => a -> a -> a
<> Env m
env)
apply
:: MonadFix m
=> Value m
-> Value m
-> EvalT m (Value m)
apply :: Value m -> Value m -> EvalT m (Value m)
apply (Closure Value m -> EvalT m (Value m)
f) Value m
arg = Value m -> EvalT m (Value m)
f Value m
arg
apply Value m
val Value m
_ = EvaluationErrorType m -> EvalT m (Value m)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"closure" Value m
val)
class MonadFix m => ToValue m a where
toValue :: a -> Value m
default toValue :: (G.Generic a, ToObject m (G.Rep a)) => a -> Value m
toValue = ObjectOptions -> a -> Value m
forall (m :: * -> *) a.
(MonadFix m, Generic a, ToObject m (Rep a)) =>
ObjectOptions -> a -> Value m
genericToValue ObjectOptions
defaultObjectOptions
fromValue :: Value m -> EvalT m a
default fromValue :: (G.Generic a, ToObject m (G.Rep a)) => Value m -> EvalT m a
fromValue = ObjectOptions -> Value m -> EvalT m a
forall (m :: * -> *) a.
(MonadFix m, Generic a, ToObject m (Rep a)) =>
ObjectOptions -> Value m -> EvalT m a
genericFromValue ObjectOptions
defaultObjectOptions
instance MonadFix m => ToValue m (Value m) where
toValue :: Value m -> Value m
toValue = Value m -> Value m
forall a. a -> a
id
fromValue :: Value m -> EvalT m (Value m)
fromValue = Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance MonadFix m => ToValue m Integer where
toValue :: Integer -> Value m
toValue = Integer -> Value m
forall (m :: * -> *). Integer -> Value m
Int
fromValue :: Value m -> EvalT m Integer
fromValue = \case
Int Integer
i -> Integer -> EvalT m Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
i
Value m
val -> EvaluationErrorType m -> EvalT m Integer
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"integer" Value m
val)
instance MonadFix m => ToValue m Double where
toValue :: Double -> Value m
toValue = Double -> Value m
forall (m :: * -> *). Double -> Value m
Number
fromValue :: Value m -> EvalT m Double
fromValue = \case
Number Double
s -> Double -> EvalT m Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
s
Value m
val -> EvaluationErrorType m -> EvalT m Double
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"number" Value m
val)
instance MonadFix m => ToValue m Text where
toValue :: Text -> Value m
toValue = Text -> Value m
forall (m :: * -> *). Text -> Value m
String
fromValue :: Value m -> EvalT m Text
fromValue = \case
String Text
s -> Text -> EvalT m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
Value m
val -> EvaluationErrorType m -> EvalT m Text
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"string" Value m
val)
instance MonadFix m => ToValue m Char where
toValue :: Char -> Value m
toValue = Char -> Value m
forall (m :: * -> *). Char -> Value m
Char
fromValue :: Value m -> EvalT m Char
fromValue = \case
Char Char
c -> Char -> EvalT m Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
Value m
val -> EvaluationErrorType m -> EvalT m Char
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"char" Value m
val)
instance MonadFix m => ToValue m Bool where
toValue :: Bool -> Value m
toValue = Bool -> Value m
forall (m :: * -> *). Bool -> Value m
Bool
fromValue :: Value m -> EvalT m Bool
fromValue = \case
Bool Bool
b -> Bool -> EvalT m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
Value m
val -> EvaluationErrorType m -> EvalT m Bool
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"boolean" Value m
val)
instance (MonadFix m, ToValue m a, ToValueRHS m b) => ToValue m (a -> b) where
toValue :: (a -> b) -> Value m
toValue a -> b
f = (Value m -> EvalT m (Value m)) -> Value m
forall (m :: * -> *). (Value m -> EvalT m (Value m)) -> Value m
Closure (\Value m
v -> b -> EvalT m (Value m)
forall (m :: * -> *) a. ToValueRHS m a => a -> EvalT m (Value m)
toValueRHS (b -> EvalT m (Value m)) -> (a -> b) -> a -> EvalT m (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> EvalT m (Value m)) -> EvalT m a -> EvalT m (Value m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value m -> EvalT m a
forall (m :: * -> *) a. ToValue m a => Value m -> EvalT m a
fromValue Value m
v)
fromValue :: Value m -> EvalT m (a -> b)
fromValue Value m
f = (a -> b) -> EvalT m (a -> b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> b) -> EvalT m (a -> b)) -> (a -> b) -> EvalT m (a -> b)
forall a b. (a -> b) -> a -> b
$ \a
a -> EvalT m (Value m) -> b
forall (m :: * -> *) a. ToValueRHS m a => EvalT m (Value m) -> a
fromValueRHS (Value m -> Value m -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Value m -> Value m -> EvalT m (Value m)
apply Value m
f (a -> Value m
forall (m :: * -> *) a. ToValue m a => a -> Value m
toValue a
a))
instance ToValue m a => ToValue m (Vector a) where
toValue :: Vector a -> Value m
toValue = Vector (Value m) -> Value m
forall (m :: * -> *). Vector (Value m) -> Value m
Array (Vector (Value m) -> Value m)
-> (Vector a -> Vector (Value m)) -> Vector a -> Value m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value m) -> Vector a -> Vector (Value m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value m
forall (m :: * -> *) a. ToValue m a => a -> Value m
toValue
fromValue :: Value m -> EvalT m (Vector a)
fromValue = \case
Array Vector (Value m)
xs -> (Value m -> EvalT m a) -> Vector (Value m) -> EvalT m (Vector a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value m -> EvalT m a
forall (m :: * -> *) a. ToValue m a => Value m -> EvalT m a
fromValue Vector (Value m)
xs
Value m
val -> EvaluationErrorType m -> EvalT m (Vector a)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"array" Value m
val)
class ToValueRHS m a where
toValueRHS :: a -> EvalT m (Value m)
fromValueRHS :: EvalT m (Value m) -> a
instance (MonadFix m, ToValue m a, ToValueRHS m b) => ToValueRHS m (a -> b) where
toValueRHS :: (a -> b) -> EvalT m (Value m)
toValueRHS a -> b
f = Value m -> EvalT m (Value m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value m -> EvalT m (Value m)) -> Value m
forall (m :: * -> *). (Value m -> EvalT m (Value m)) -> Value m
Closure (\Value m
v -> b -> EvalT m (Value m)
forall (m :: * -> *) a. ToValueRHS m a => a -> EvalT m (Value m)
toValueRHS (b -> EvalT m (Value m)) -> (a -> b) -> a -> EvalT m (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> EvalT m (Value m)) -> EvalT m a -> EvalT m (Value m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value m -> EvalT m a
forall (m :: * -> *) a. ToValue m a => Value m -> EvalT m a
fromValue Value m
v))
fromValueRHS :: EvalT m (Value m) -> a -> b
fromValueRHS EvalT m (Value m)
mv a
a = EvalT m (Value m) -> b
forall (m :: * -> *) a. ToValueRHS m a => EvalT m (Value m) -> a
fromValueRHS do
Value m
v <- EvalT m (Value m)
mv
EvalT m (Value m) -> EvalT m (Value m)
forall (m :: * -> *) a. ToValueRHS m a => EvalT m (Value m) -> a
fromValueRHS (Value m -> Value m -> EvalT m (Value m)
forall (m :: * -> *).
MonadFix m =>
Value m -> Value m -> EvalT m (Value m)
apply Value m
v (a -> Value m
forall (m :: * -> *) a. ToValue m a => a -> Value m
toValue a
a))
instance (ToValue m a, n ~ m) => ToValueRHS m (EvalT n a) where
toValueRHS :: EvalT n a -> EvalT m (Value m)
toValueRHS = (a -> Value m) -> EvalT m a -> EvalT m (Value m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value m
forall (m :: * -> *) a. ToValue m a => a -> Value m
toValue
fromValueRHS :: EvalT m (Value m) -> EvalT n a
fromValueRHS = (EvalT n (Value m) -> (Value m -> EvalT n a) -> EvalT n a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value m -> EvalT n a
forall (m :: * -> *) a. ToValue m a => Value m -> EvalT m a
fromValue)
data ObjectOptions = ObjectOptions
{ ObjectOptions -> Text -> Text
toPureScriptField :: Text -> Text
}
defaultObjectOptions :: ObjectOptions
defaultObjectOptions :: ObjectOptions
defaultObjectOptions = ObjectOptions :: (Text -> Text) -> ObjectOptions
ObjectOptions
{ toPureScriptField :: Text -> Text
toPureScriptField = Text -> Text
forall a. a -> a
id
}
genericToValue
:: (MonadFix m, G.Generic a, ToObject m (G.Rep a))
=> ObjectOptions
-> a
-> Value m
genericToValue :: ObjectOptions -> a -> Value m
genericToValue ObjectOptions
opts = HashMap Text (Value m) -> Value m
forall (m :: * -> *). HashMap Text (Value m) -> Value m
Object (HashMap Text (Value m) -> Value m)
-> (a -> HashMap Text (Value m)) -> a -> Value m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectOptions -> Rep a Any -> HashMap Text (Value m)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> f x -> HashMap Text (Value m)
toObject ObjectOptions
opts (Rep a Any -> HashMap Text (Value m))
-> (a -> Rep a Any) -> a -> HashMap Text (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
G.from
genericFromValue
:: (MonadFix m, G.Generic a, ToObject m (G.Rep a))
=> ObjectOptions
-> Value m
-> EvalT m a
genericFromValue :: ObjectOptions -> Value m -> EvalT m a
genericFromValue ObjectOptions
opts = \case
Object HashMap Text (Value m)
o -> Rep a Any -> a
forall a x. Generic a => Rep a x -> a
G.to (Rep a Any -> a) -> EvalT m (Rep a Any) -> EvalT m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObjectOptions -> HashMap Text (Value m) -> EvalT m (Rep a Any)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)
fromObject ObjectOptions
opts HashMap Text (Value m)
o
Value m
val -> EvaluationErrorType m -> EvalT m a
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
TypeMismatch Text
"object" Value m
val)
class ToObject m f where
toObject :: ObjectOptions -> f x -> HashMap Text (Value m)
fromObject :: ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)
instance (Functor m, ToObject m f) => ToObject m (G.M1 G.D t f) where
toObject :: ObjectOptions -> M1 D t f x -> HashMap Text (Value m)
toObject ObjectOptions
opts = ObjectOptions -> f x -> HashMap Text (Value m)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> f x -> HashMap Text (Value m)
toObject ObjectOptions
opts (f x -> HashMap Text (Value m))
-> (M1 D t f x -> f x) -> M1 D t f x -> HashMap Text (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 D t f x -> f x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1
fromObject :: ObjectOptions -> HashMap Text (Value m) -> EvalT m (M1 D t f x)
fromObject ObjectOptions
opts = (f x -> M1 D t f x) -> EvalT m (f x) -> EvalT m (M1 D t f x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f x -> M1 D t f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (EvalT m (f x) -> EvalT m (M1 D t f x))
-> (HashMap Text (Value m) -> EvalT m (f x))
-> HashMap Text (Value m)
-> EvalT m (M1 D t f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)
fromObject ObjectOptions
opts
instance (Functor m, ToObject m f) => ToObject m (G.M1 G.C t f) where
toObject :: ObjectOptions -> M1 C t f x -> HashMap Text (Value m)
toObject ObjectOptions
opts = ObjectOptions -> f x -> HashMap Text (Value m)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> f x -> HashMap Text (Value m)
toObject ObjectOptions
opts (f x -> HashMap Text (Value m))
-> (M1 C t f x -> f x) -> M1 C t f x -> HashMap Text (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 C t f x -> f x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1
fromObject :: ObjectOptions -> HashMap Text (Value m) -> EvalT m (M1 C t f x)
fromObject ObjectOptions
opts = (f x -> M1 C t f x) -> EvalT m (f x) -> EvalT m (M1 C t f x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f x -> M1 C t f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (EvalT m (f x) -> EvalT m (M1 C t f x))
-> (HashMap Text (Value m) -> EvalT m (f x))
-> HashMap Text (Value m)
-> EvalT m (M1 C t f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)
fromObject ObjectOptions
opts
instance (MonadFix m, ToObject m f, ToObject m g) => ToObject m (f G.:*: g) where
toObject :: ObjectOptions -> (:*:) f g x -> HashMap Text (Value m)
toObject ObjectOptions
opts (f x
f G.:*: g x
g) = ObjectOptions -> f x -> HashMap Text (Value m)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> f x -> HashMap Text (Value m)
toObject ObjectOptions
opts f x
f HashMap Text (Value m)
-> HashMap Text (Value m) -> HashMap Text (Value m)
forall a. Semigroup a => a -> a -> a
<> ObjectOptions -> g x -> HashMap Text (Value m)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> f x -> HashMap Text (Value m)
toObject ObjectOptions
opts g x
g
fromObject :: ObjectOptions -> HashMap Text (Value m) -> EvalT m ((:*:) f g x)
fromObject ObjectOptions
opts HashMap Text (Value m)
o = f x -> g x -> (:*:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(G.:*:) (f x -> g x -> (:*:) f g x)
-> EvalT m (f x) -> EvalT m (g x -> (:*:) f g x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)
fromObject ObjectOptions
opts HashMap Text (Value m)
o EvalT m (g x -> (:*:) f g x)
-> EvalT m (g x) -> EvalT m ((:*:) f g x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ObjectOptions -> HashMap Text (Value m) -> EvalT m (g x)
forall k (m :: * -> *) (f :: k -> *) (x :: k).
ToObject m f =>
ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)
fromObject ObjectOptions
opts HashMap Text (Value m)
o
instance
forall m field u s l r a
. ( KnownSymbol field
, ToValue m a
)
=> ToObject m
(G.M1
G.S
('G.MetaSel
('Just field)
u s l)
(G.K1 r a))
where
toObject :: ObjectOptions
-> M1 S ('MetaSel ('Just field) u s l) (K1 r a) x
-> HashMap Text (Value m)
toObject ObjectOptions
opts (G.M1 (G.K1 a
a)) = do
let field :: Text
field = ObjectOptions -> Text -> Text
toPureScriptField ObjectOptions
opts (String -> Text
Text.pack (Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @field (Proxy field
forall k (t :: k). Proxy t
Proxy :: Proxy field)))
in Text -> Value m -> HashMap Text (Value m)
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Text
field (a -> Value m
forall (m :: * -> *) a. ToValue m a => a -> Value m
toValue a
a)
fromObject :: ObjectOptions
-> HashMap Text (Value m)
-> EvalT m (M1 S ('MetaSel ('Just field) u s l) (K1 r a) x)
fromObject ObjectOptions
opts HashMap Text (Value m)
o = do
let field :: Text
field = ObjectOptions -> Text -> Text
toPureScriptField ObjectOptions
opts (String -> Text
Text.pack (Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @field (Proxy field
forall k (t :: k). Proxy t
Proxy :: Proxy field)))
case Text -> HashMap Text (Value m) -> Maybe (Value m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
field HashMap Text (Value m)
o of
Maybe (Value m)
Nothing -> EvaluationErrorType m
-> EvalT m (M1 S ('MetaSel ('Just field) u s l) (K1 r a) x)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
FieldNotFound Text
field (HashMap Text (Value m) -> Value m
forall (m :: * -> *). HashMap Text (Value m) -> Value m
Object HashMap Text (Value m)
o))
Just Value m
v -> K1 r a x -> M1 S ('MetaSel ('Just field) u s l) (K1 r a) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (K1 r a x -> M1 S ('MetaSel ('Just field) u s l) (K1 r a) x)
-> (a -> K1 r a x)
-> a
-> M1 S ('MetaSel ('Just field) u s l) (K1 r a) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 r a x
forall k i c (p :: k). c -> K1 i c p
G.K1 (a -> M1 S ('MetaSel ('Just field) u s l) (K1 r a) x)
-> EvalT m a
-> EvalT m (M1 S ('MetaSel ('Just field) u s l) (K1 r a) x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value m -> EvalT m a
forall (m :: * -> *) a. ToValue m a => Value m -> EvalT m a
fromValue Value m
v