{-# 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
  ( 
  -- * High-level API
    buildCoreFn
  , builtIn
  
  -- * Evaluation
  
  -- ** Eval/apply
  , eval
  , apply
  
  -- * Conversion to and from Haskell types
  , ToValue(..)
  -- ** Higher-order functions
  , ToValueRHS(..)
  -- ** Records
  , ObjectOptions(..)
  , defaultObjectOptions
  , genericToValue
  , genericFromValue
  , ToObject(..)
  
  , module Dovetail.Types
  
  -- ** Utilities
  , 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

-- | Evaluate each of the bindings in a compiled PureScript module, and store
-- the evaluated values in the environment, without evaluating any main
-- expression.
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
  
-- | Create an environment from a Haskell value.
--
-- It is recommended that a type annotation is given for the type of the value
-- being provided.
--
-- For example:
--
-- @
-- builtIn (ModuleName "Main") "greeting" ("Hello, World!" :: Text)
-- builtIn (ModuleName "Main") "somePrimes" ([2, 3, 5, 7, 11] :: Vector Integer)
-- @
--
-- Functions can be provided as built-ins, but the 'EvalT' monad needs to be
-- used to wrap any outputs (or values in positive position):
--
-- @
-- builtIn (ModuleName "Main") "strip" ((pure . Text.strip) :: Text -> EvalT m Text)
-- builtIn (ModuleName "Main") "map" (traverse :: (Value -> EvalT m Value) -> Vector Value -> EvalT m (Vector Value))
-- @
--
-- Polymorphic functions can also be provided as built-ins, but values with 
-- polymoprhic types will need to be passed across the FFI boundary with 
-- monomorphic types. The type 'Value' can always be used to represent values of
-- unknown or polymorphic type, as in the @map@ example above.
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)

-- | Evaluate a PureScript CoreFn expression in the given environment.
--
-- Note: it should not be necessary to call this function directly in most
-- circumstances. It is provided as a helper function, for some more advanced
-- use cases, such as setting up a custom environment.
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 a value which represents an unevaluated closure to an argument.
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)

-- | Values which can be communicated across the FFI boundary from Haskell to 
-- PureScript.
--
-- Instances should identify and document any valid representations as a subset 
-- of the semantic domain 'Value'. Such a subset can be identified by an
-- injective function 'toValue', and a partial inverse, 'fromValue', defined
-- on the image of 'toValue'.
--
-- Laws:
--
-- @
-- fromValue . toValue = pure
-- @
class MonadFix m => ToValue m a where
  toValue :: a -> Value m
  
  -- | The default implementation uses generic deriving to identify a Haskell
  -- record type with a single data constructor with a PureScript record with
  -- the same field names.
  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

-- | The Haskell 'Integer' type corresponds to PureScript's integer type.
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)
  
-- | The Haskell 'Douvle' type corresponds to the subset of PureScript
-- values consisting of its Number type.
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)

-- | The Haskell 'Text' type is represented by PureScript strings
-- which contain no lone surrogates.
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)

-- | The Haskell 'Char' type is represented by PureScript characters.
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)

-- | Haskell booleans are represented by boolean values.
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)
  
-- | Haskell functions are represented as closures which take valid
-- representations for the domain type to valid representations of the codomain
-- type.
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))

-- | Haskell vectors are represented as homogeneous vectors of values, each of
-- which are valid representations of the element type.
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)
    
-- | 'ToValue' should support functions with types such as
--
-- @
-- a -> EvalT m b
-- a -> b -> EvalT m c
-- a -> b -> c -> EvalT m d
-- (a -> EvalT m b) -> EvalT m c
-- (a -> b -> EvalT m c) -> EvalT m d
-- @
--
-- Note that every type in a return position is wrapped in the 'EvalT' monad
-- transformer. This is because evaluation in general may result in errors.
-- However, a naive translation would result in too many applications of 'EvalT'.
--
-- Specifically, we do not want to require types such as these, in which 'EvalT'
-- appears on the right hand side of every function arrow:
--
-- @
-- a -> EvalT m b (b -> EvalT m c)
-- a -> EvalT m b (b -> EvalT m (c -> EvalT m d))
-- @
--
-- For this reason, the 'ToValue' instance for functions delegates to this
-- type class for the type on the right hand side of the function. It skips the
-- application of 'EvalT' for nested function types.
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)
  
-- | Options for customizing generic deriving of record instances
data ObjectOptions = ObjectOptions
  { ObjectOptions -> Text -> Text
toPureScriptField :: Text -> Text
  -- ^ Map a Haskell field name to a PureScript field name on the corresponding
  -- record type.
  }
  
-- | * Maps Haskell field names to PureScript field names, unmodified.
defaultObjectOptions :: ObjectOptions
defaultObjectOptions :: ObjectOptions
defaultObjectOptions = ObjectOptions :: (Text -> Text) -> ObjectOptions
ObjectOptions
  { toPureScriptField :: Text -> Text
toPureScriptField = Text -> Text
forall a. a -> a
id
  }

-- | Derived 'toValue' function for Haskell record types which should map to 
-- corresponding PureScript record types.
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

-- | Derived 'fromValue' function for Haskell record types which should map to 
-- corresponding PureScript record types.
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)
       
-- | This class is used in the default instance for 'ToValue', via generic
-- deriving, in order to identify a Haskell record type (with a single data
-- constructor and named fields) with values in the semantic domain
-- corresponding to a PureScript record type with the same field names.
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