{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module                  : Language.Jsonnet.Eval
-- Copyright               : (c) 2020-2021 Alexandre Moreno
-- SPDX-License-Identifier : BSD-3-Clause OR Apache-2.0
-- Maintainer              : Alexandre Moreno <alexmorenocano@gmail.com>
-- Stability               : experimental
-- Portability             : non-portable
module Language.Jsonnet.Eval where

import Control.Applicative
import Control.Lens (locally, view)
import Control.Monad.Except
import qualified Data.Aeson as JSON
import Data.Aeson.Text (encodeToLazyText)
import Data.Bifunctor (second)
import Data.Bits
import Data.ByteString (ByteString)
import Data.Foldable
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
import Data.IORef
import Data.Int (Int64)
import qualified Data.List as L (sort)
import qualified Data.Map.Lazy as M
import Data.Maybe
import Data.Scientific
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text.Lazy (toStrict)
import Data.Traversable (for)
import Data.Vector (Vector, (!?))
import qualified Data.Vector as V
import Debug.Trace
import Language.Jsonnet.Common
import Language.Jsonnet.Core
import Language.Jsonnet.Error
import Language.Jsonnet.Eval.Monad
import Language.Jsonnet.Pretty ()
import Language.Jsonnet.Value
import Text.PrettyPrint.ANSI.Leijen hiding (equals, (<$>))
import Unbound.Generics.LocallyNameless
import Prelude hiding (length)
import qualified Prelude as P (length)

rnf :: Core -> Eval JSON.Value
rnf :: Core -> Eval Value
rnf = Core -> Eval Value
whnf (Core -> Eval Value) -> (Value -> Eval Value) -> Core -> Eval Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> Eval Value
manifest

whnfV :: Value -> Eval Value
whnfV :: Value -> Eval Value
whnfV (VIndir Ref
loc) = Ref -> Eval Value
whnfIndir Ref
loc Eval Value -> (Value -> Eval Value) -> Eval Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Eval Value
whnfV
whnfV (VThunk Core
c Env
e) = Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
withEnv Env
e (Core -> Eval Value
whnf Core
c)
whnfV Value
v = Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v

whnf :: Core -> Eval Value
whnf :: Core -> Eval Value
whnf (CVar Name Core
n) = Name Core -> Eval Value
lookupVar Name Core
n
whnf (CLoc SrcSpan
sp Core
c) = ASetter
  (EvalState Value) (EvalState Value) (Maybe SrcSpan) (Maybe SrcSpan)
-> (Maybe SrcSpan -> Maybe SrcSpan) -> Eval Value -> Eval Value
forall s (m :: * -> *) a b r.
MonadReader s m =>
ASetter s s a b -> (a -> b) -> m r -> m r
locally ASetter
  (EvalState Value) (EvalState Value) (Maybe SrcSpan) (Maybe SrcSpan)
forall a. Lens' (EvalState a) (Maybe SrcSpan)
currentPos (Maybe SrcSpan -> Maybe SrcSpan -> Maybe SrcSpan
forall a b. a -> b -> a
const (Maybe SrcSpan -> Maybe SrcSpan -> Maybe SrcSpan)
-> Maybe SrcSpan -> Maybe SrcSpan -> Maybe SrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just SrcSpan
sp) (Core -> Eval Value
whnf Core
c)
whnf (CLit Literal
l) = Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> Value
whnfLiteral Literal
l)
whnf (CObj [CField]
bnd) = [CField] -> Eval Value
whnfObj [CField]
bnd
whnf (CArr [Core]
cs) = Vector Value -> Value
VArr (Vector Value -> Value)
-> ([Value] -> Vector Value) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Vector Value
forall a. [a] -> Vector a
V.fromList ([Value] -> Value) -> EvalM Value [Value] -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Core -> Eval Value) -> [Core] -> EvalM Value [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Core -> Eval Value
mkValue [Core]
cs
whnf (CLet Let
bnd) = Let -> Eval Value
whnfLetrec Let
bnd
whnf (CPrim Prim
p) = Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prim -> Value
VPrim Prim
p)
whnf (CApp Core
e Args Core
es) = Core -> Args Core -> Eval Value
whnfApp Core
e Args Core
es
whnf (CLam Let
f) = Let -> Env -> Value
VClos Let
f (Env -> Value) -> EvalM Value Env -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting Env (EvalState Value) Env -> EvalM Value Env
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Env (EvalState Value) Env
forall a a2. Lens (EvalState a) (EvalState a2) (Ctx a) (Ctx a2)
ctx
whnf (CComp Comp
comp Core
e) = Comp -> Core -> Eval Value
whnfComp Comp
comp Core
e

mkValue :: Core -> Eval Value
mkValue :: Core -> Eval Value
mkValue c :: Core
c@(CLit Literal
_) = Core -> Eval Value
whnf Core
c
mkValue c :: Core
c@(CLam Let
_) = Core -> Eval Value
whnf Core
c
mkValue c :: Core
c@(CPrim Prim
_) = Core -> Eval Value
whnf Core
c
mkValue Core
c = Core -> Eval Value
mkThunk Core
c Eval Value -> (Value -> Eval Value) -> Eval Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Eval Value
forall (m :: * -> *). MonadIO m => Value -> m Value
mkIndirV

lookupVar :: Name Core -> Eval Value
lookupVar :: Name Core -> Eval Value
lookupVar Name Core
n = do
  Env
rho <- Getting Env (EvalState Value) Env -> EvalM Value Env
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Env (EvalState Value) Env
forall a a2. Lens (EvalState a) (EvalState a2) (Ctx a) (Ctx a2)
ctx
  Value
v <- EvalError -> Maybe Value -> Eval Value
forall a. EvalError -> Maybe a -> Eval a
liftMaybe (Doc -> EvalError
VarNotFound (Name Core -> Doc
forall a. Pretty a => a -> Doc
pretty Name Core
n)) (Name Core -> Env -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name Core
n Env
rho)
  Value -> Eval Value
whnfV Value
v

whnfLiteral :: Literal -> Value
whnfLiteral :: Literal -> Value
whnfLiteral = \case
  Literal
Null -> Value
VNull
  Bool Bool
b -> Bool -> Value
VBool Bool
b
  String Text
s -> Text -> Value
VStr Text
s
  Number Scientific
n -> Scientific -> Value
VNum Scientific
n

whnfArgs :: Args Core -> Eval [Arg Value]
whnfArgs :: Args Core -> Eval [Arg Value]
whnfArgs = \case
  as :: Args Core
as@(Args [Arg Core]
_ Strictness
Strict) -> Args Value -> [Arg Value]
forall a. Args a -> [Arg a]
args (Args Value -> [Arg Value])
-> EvalM Value (Args Value) -> Eval [Arg Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Core -> Eval Value) -> Args Core -> EvalM Value (Args Value)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Core -> Eval Value
whnf Args Core
as
  as :: Args Core
as@(Args [Arg Core]
_ Strictness
Lazy) -> Args Value -> [Arg Value]
forall a. Args a -> [Arg a]
args (Args Value -> [Arg Value])
-> EvalM Value (Args Value) -> Eval [Arg Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Core -> Eval Value) -> Args Core -> EvalM Value (Args Value)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Core -> Eval Value
mkValue Args Core
as

whnfApp :: Core -> Args Core -> Eval Value
whnfApp :: Core -> Args Core -> Eval Value
whnfApp Core
e Args Core
es = Core -> Eval Value -> Eval Value
forall a. Core -> Eval a -> Eval a
withStackFrame Core
e (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ do
  [Arg Value]
vs <- Args Core -> Eval [Arg Value]
whnfArgs Args Core
es
  Core -> Eval Value
whnf Core
e Eval Value -> (Value -> Eval Value) -> Eval Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Eval Value
whnfV Eval Value -> (Value -> Eval Value) -> Eval Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    VClos Let
f Env
env -> Env -> Let -> [Arg Value] -> Eval Value
whnfClos Env
env Let
f [Arg Value]
vs
    VPrim Prim
op -> Prim -> [Arg Value] -> Eval Value
whnfPrim Prim
op [Arg Value]
vs
    v :: Value
v@(VFun Value -> Eval Value
_) -> (Value -> Arg Value -> Eval Value)
-> Value -> [Arg Value] -> Eval Value
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Value -> Arg Value -> Eval Value
f Value
v [Arg Value]
vs
      where
        f :: Value -> Arg Value -> Eval Value
f (VFun Value -> Eval Value
g) (Pos Value
v) = Value -> Eval Value
g Value
v
        f Value
v Arg Value
_ = Text -> Value -> Eval Value
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"function" Value
v
    Value
v -> Text -> Value -> Eval Value
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"function" Value
v

withStackFrame :: Core -> Eval a -> Eval a
withStackFrame :: Core -> Eval a -> Eval a
withStackFrame (CLoc SrcSpan
sp (CVar Name Core
n)) Eval a
e =
  (Name Core, Maybe SrcSpan) -> Eval a -> Eval a
forall a b. (Name Core, Maybe SrcSpan) -> EvalM a b -> EvalM a b
pushStackFrame (Name Core
n, SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just SrcSpan
sp) Eval a
e
withStackFrame (CLoc SrcSpan
sp Core
_) Eval a
e =
  (Name Core, Maybe SrcSpan) -> Eval a -> Eval a
forall a b. (Name Core, Maybe SrcSpan) -> EvalM a b -> EvalM a b
pushStackFrame (String -> Name Core
forall a. String -> Name a
s2n String
"anonymous", SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just SrcSpan
sp) Eval a
e
withStackFrame (CVar Name Core
_) Eval a
e = Eval a
e
--pushStackFrame (n, Nothing) e
withStackFrame Core
_ Eval a
e = Eval a
e

--pushStackFrame (s2n "anonymous", Nothing) e

whnfClos :: Env -> Lam -> [Arg Value] -> Eval Value
whnfClos :: Env -> Let -> [Arg Value] -> Eval Value
whnfClos Env
rho Let
f [Arg Value]
args = do
  (Rec [Param Core]
bnds, Core
e) <- Let -> EvalM Value (Rec [Param Core], Core)
forall p t (m :: * -> *).
(Alpha p, Alpha t, Fresh m) =>
Bind p t -> m (p, t)
unbind Let
f
  ([(Name Core, Core)]
rs, [(Name Core, Value)]
ps, [(Name Core, Value)]
ns) <- [Arg Value]
-> [(Name Core, Core)]
-> EvalM
     Value
     ([(Name Core, Core)], [(Name Core, Value)], [(Name Core, Value)])
forall b a b a.
[Arg b]
-> [(Name a, b)]
-> EvalM a ([(Name a, b)], [(Name a, b)], [(Name a, b)])
splitArgs [Arg Value]
args ((Embed Core -> Core) -> Param Core -> (Name Core, Core)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Embed Core -> Core
forall e. IsEmbed e => e -> Embedded e
unembed (Param Core -> (Name Core, Core))
-> [Param Core] -> [(Name Core, Core)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rec [Param Core] -> [Param Core]
forall p. Alpha p => Rec p -> p
unrec Rec [Param Core]
bnds)
  Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
withEnv Env
rho (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$
    Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv ([(Name Core, Value)] -> Env
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name Core, Value)]
ps) (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$
      Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv ([(Name Core, Value)] -> Env
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name Core, Value)]
ns) (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$
        [(Name Core, Core)] -> Core -> Eval Value
appDefaults [(Name Core, Core)]
rs Core
e

-- all parameter names are bound in default values
appDefaults :: [(Name Core, Core)] -> Core -> Eval Value
appDefaults :: [(Name Core, Core)] -> Core -> Eval Value
appDefaults [(Name Core, Core)]
rs Core
e = mdo
  Env
bnds <-
    [(Name Core, Value)] -> Env
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      ([(Name Core, Value)] -> Env)
-> EvalM Value [(Name Core, Value)] -> EvalM Value Env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name Core, Core) -> EvalM Value (Name Core, Value))
-> [(Name Core, Core)] -> EvalM Value [(Name Core, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
        ( \(Name Core
n, Core
e) -> do
            Value
th <- Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv Env
bnds (Core -> Eval Value
mkValue Core
e)
            (Name Core, Value) -> EvalM Value (Name Core, Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name Core
n, Value
th)
        )
        [(Name Core, Core)]
rs
  Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv Env
bnds (Core -> Eval Value
whnf Core
e)

-- returns a triple with unapplied binders, positional and named
splitArgs :: [Arg b]
-> [(Name a, b)]
-> EvalM a ([(Name a, b)], [(Name a, b)], [(Name a, b)])
splitArgs [Arg b]
args [(Name a, b)]
bnds = do
  [(Name a, b)]
named <- EvalM a [(Name a, b)]
forall a. EvalM a [(Name a, b)]
getNamed
  [(Name a, b)]
pos <- EvalM a [(Name a, b)]
forall a. EvalM a [(Name a, b)]
getPos
  [(Name a, b)]
unapp <- [(Name a, b)] -> EvalM a [(Name a, b)]
forall (f :: * -> *) b.
Applicative f =>
[(Name a, b)] -> f [(Name a, b)]
getUnapp [(Name a, b)]
named
  ([(Name a, b)], [(Name a, b)], [(Name a, b)])
-> EvalM a ([(Name a, b)], [(Name a, b)], [(Name a, b)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name a, b)]
unapp, [(Name a, b)]
pos, [(Name a, b)]
named)
  where
    ([(Name a, b)]
bnds1, [(Name a, b)]
bnds2) = Int -> [(Name a, b)] -> ([(Name a, b)], [(Name a, b)])
forall a. Int -> [a] -> ([a], [a])
splitAt ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
ps) [(Name a, b)]
bnds
    ([b]
ps, [(String, b)]
ns) = [Arg b] -> ([b], [(String, b)])
forall b. [Arg b] -> ([b], [(String, b)])
split [Arg b]
args
    pNames :: [Name a]
pNames = ((Name a, b) -> Name a) -> [(Name a, b)] -> [Name a]
forall a b. (a -> b) -> [a] -> [b]
map (Name a, b) -> Name a
forall a b. (a, b) -> a
fst [(Name a, b)]
bnds

    getPos :: EvalM a [(Name a, b)]
getPos =
      if [b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [(Name a, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name a, b)]
bnds
        then EvalError -> EvalM a [(Name a, b)]
forall a b. EvalError -> EvalM a b
throwE (EvalError -> EvalM a [(Name a, b)])
-> EvalError -> EvalM a [(Name a, b)]
forall a b. (a -> b) -> a -> b
$ Int -> EvalError
TooManyArgs ([(Name a, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name a, b)]
bnds)
        else [(Name a, b)] -> EvalM a [(Name a, b)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name a, b)] -> EvalM a [(Name a, b)])
-> [(Name a, b)] -> EvalM a [(Name a, b)]
forall a b. (a -> b) -> a -> b
$ [Name a] -> [b] -> [(Name a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Name a, b) -> Name a) -> [(Name a, b)] -> [Name a]
forall a b. (a -> b) -> [a] -> [b]
map (Name a, b) -> Name a
forall a b. (a, b) -> a
fst [(Name a, b)]
bnds1) [b]
ps

    -- checks the provided named arguments exist
    getNamed :: EvalM a [(Name a, b)]
getNamed = ((String, b) -> EvalM a (Name a, b))
-> [(String, b)] -> EvalM a [(Name a, b)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String, b) -> EvalM a (Name a, b)
forall b a. (String, b) -> EvalM a (Name a, b)
f [(String, b)]
ns
      where
        f :: (String, b) -> EvalM a (Name a, b)
f (String
a, b
b) = case String -> Maybe (Name a)
g String
a of
          Maybe (Name a)
Nothing -> EvalError -> EvalM a (Name a, b)
forall a b. EvalError -> EvalM a b
throwE (EvalError -> EvalM a (Name a, b))
-> EvalError -> EvalM a (Name a, b)
forall a b. (a -> b) -> a -> b
$ Doc -> EvalError
BadParam (String -> Doc
forall a. Pretty a => a -> Doc
pretty String
a)
          Just Name a
n -> (Name a, b) -> EvalM a (Name a, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name a
n, b
b)
        g :: String -> Maybe (Name a)
g String
a = (Name a -> Bool) -> [Name a] -> Maybe (Name a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (Name a -> String) -> Name a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name a -> String
forall a. Name a -> String
name2String) [Name a]
pNames

    getUnapp :: [(Name a, b)] -> f [(Name a, b)]
getUnapp [(Name a, b)]
named =
      [(Name a, b)] -> f [(Name a, b)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name a, b)] -> f [(Name a, b)])
-> [(Name a, b)] -> f [(Name a, b)]
forall a b. (a -> b) -> a -> b
$ ((Name a, b) -> Bool) -> [(Name a, b)] -> [(Name a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name a -> [Name a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name a]
ns) (Name a -> Bool) -> ((Name a, b) -> Name a) -> (Name a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name a, b) -> Name a
forall a b. (a, b) -> a
fst) [(Name a, b)]
bnds2
      where
        ns :: [Name a]
ns = ((Name a, b) -> Name a) -> [(Name a, b)] -> [Name a]
forall a b. (a -> b) -> [a] -> [b]
map (Name a, b) -> Name a
forall a b. (a, b) -> a
fst [(Name a, b)]
named

    split :: [Arg b] -> ([b], [(String, b)])
split [] = ([], [])
    split (Pos b
p : [Arg b]
xs) =
      let ([b]
ys, [(String, b)]
zs) = [Arg b] -> ([b], [(String, b)])
split [Arg b]
xs in (b
p b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
ys, [(String, b)]
zs)
    split (Named String
n b
v : [Arg b]
xs) =
      let ([b]
ys, [(String, b)]
zs) = [Arg b] -> ([b], [(String, b)])
split [Arg b]
xs in ([b]
ys, (String
n, b
v) (String, b) -> [(String, b)] -> [(String, b)]
forall a. a -> [a] -> [a]
: [(String, b)]
zs)

whnfPrim :: Prim -> [Arg Value] -> Eval Value
whnfPrim :: Prim -> [Arg Value] -> Eval Value
whnfPrim (UnyOp UnyOp
op) [Pos Value
e] = Value -> Eval Value
whnfV Value
e Eval Value -> (Value -> Eval Value) -> Eval Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnyOp -> Value -> Eval Value
whnfUnyOp UnyOp
op
whnfPrim (BinOp BinOp
LAnd) [Pos Value
e1, Pos Value
e2] = (Bool -> Bool) -> Value -> Value -> Eval Value
forall a. HasValue a => (a -> Bool) -> Value -> Value -> Eval Value
whnfLogical Bool -> Bool
forall a. a -> a
id Value
e1 Value
e2
whnfPrim (BinOp BinOp
LOr) [Pos Value
e1, Pos Value
e2] = (Bool -> Bool) -> Value -> Value -> Eval Value
forall a. HasValue a => (a -> Bool) -> Value -> Value -> Eval Value
whnfLogical Bool -> Bool
not Value
e1 Value
e2
whnfPrim (BinOp BinOp
op) [Pos Value
e1, Pos Value
e2] =
  (Value -> Value -> (Value, Value))
-> Eval Value -> Eval Value -> EvalM Value (Value, Value)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Value -> Eval Value
whnfV Value
e1) (Value -> Eval Value
whnfV Value
e2) EvalM Value (Value, Value)
-> ((Value, Value) -> Eval Value) -> Eval Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Value -> Eval Value) -> (Value, Value) -> Eval Value
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (BinOp -> Value -> Value -> Eval Value
whnfBinOp BinOp
op)
whnfPrim Prim
Cond [Pos Value
c, Pos Value
t, Pos Value
e] = Value -> Value -> Value -> Eval Value
whnfCond Value
c Value
t Value
e

whnfBinOp :: BinOp -> Value -> Value -> Eval Value
whnfBinOp :: BinOp -> Value -> Value -> Eval Value
whnfBinOp BinOp
Lookup Value
e1 Value
e2 = Value -> Value -> Eval Value
whnfLookup Value
e1 Value
e2
whnfBinOp BinOp
Add x :: Value
x@(VStr Text
_) Value
y = Text -> Value
forall a. HasValue a => a -> Value
inj (Text -> Value) -> EvalM Value Text -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Value -> EvalM Value Text
append Value
x Value
y
whnfBinOp BinOp
Add Value
x y :: Value
y@(VStr Text
_) = Text -> Value
forall a. HasValue a => a -> Value
inj (Text -> Value) -> EvalM Value Text -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Value -> EvalM Value Text
append Value
x Value
y
whnfBinOp BinOp
Add x :: Value
x@(VArr Vector Value
_) y :: Value
y@(VArr Vector Value
_) = (Vector Value -> Vector Value -> Vector Value)
-> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Vector Value -> Vector Value -> Vector Value
forall a. Vector a -> Vector a -> Vector a
(V.++) @Value) Value
x Value
y
whnfBinOp BinOp
Add (VObj Object
x) (VObj Object
y) = Object
x Object -> Object -> Eval Value
`mergeWith` Object
y
whnfBinOp BinOp
Add Value
n1 Value
n2 = (Double -> Double -> Double) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Num Double => Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) @Double) Value
n1 Value
n2
whnfBinOp BinOp
Sub Value
n1 Value
n2 = (Double -> Double -> Double) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 ((-) @Double) Value
n1 Value
n2
whnfBinOp BinOp
Mul Value
n1 Value
n2 = (Double -> Double -> Double) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Num Double => Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) @Double) Value
n1 Value
n2
whnfBinOp BinOp
Div (VNum Scientific
_) (VNum Scientific
0) = EvalError -> Eval Value
forall a b. EvalError -> EvalM a b
throwE EvalError
DivByZero
whnfBinOp BinOp
Div Value
n1 Value
n2 = (Double -> Double -> Double) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Fractional Double => Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/) @Double) Value
n1 Value
n2
whnfBinOp BinOp
Mod (VNum Scientific
_) (VNum Scientific
0) = EvalError -> Eval Value
forall a b. EvalError -> EvalM a b
throwE EvalError
DivByZero
whnfBinOp BinOp
Mod Value
n1 Value
n2 = (Int64 -> Int64 -> Int64) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Integral Int64 => Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
mod @Int64) Value
n1 Value
n2
whnfBinOp BinOp
Eq Value
e1 Value
e2 = Bool -> Value
forall a. HasValue a => a -> Value
inj (Bool -> Value) -> EvalM Value Bool -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Value -> EvalM Value Bool
equals Value
e1 Value
e2
whnfBinOp BinOp
Ne Value
e1 Value
e2 = Bool -> Value
forall a. HasValue a => a -> Value
inj (Bool -> Value) -> (Bool -> Bool) -> Bool -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Value) -> EvalM Value Bool -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Value -> EvalM Value Bool
equals Value
e1 Value
e2
whnfBinOp BinOp
Lt Value
e1 Value
e2 = (Double -> Double -> Bool) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Ord Double => Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(<) @Double) Value
e1 Value
e2
whnfBinOp BinOp
Gt Value
e1 Value
e2 = (Double -> Double -> Bool) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Ord Double => Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(>) @Double) Value
e1 Value
e2
whnfBinOp BinOp
Le Value
e1 Value
e2 = (Double -> Double -> Bool) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Ord Double => Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(<=) @Double) Value
e1 Value
e2
whnfBinOp BinOp
Ge Value
e1 Value
e2 = (Double -> Double -> Bool) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Ord Double => Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(>=) @Double) Value
e1 Value
e2
whnfBinOp BinOp
And Value
e1 Value
e2 = (Int64 -> Int64 -> Int64) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Bits Int64 => Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
(.&.) @Int64) Value
e1 Value
e2
whnfBinOp BinOp
Or Value
e1 Value
e2 = (Int64 -> Int64 -> Int64) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Bits Int64 => Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
(.|.) @Int64) Value
e1 Value
e2
whnfBinOp BinOp
Xor Value
e1 Value
e2 = (Int64 -> Int64 -> Int64) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Bits Int64 => Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
xor @Int64) Value
e1 Value
e2
whnfBinOp BinOp
ShiftL Value
e1 Value
e2 = (Int64 -> Int -> Int64) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Bits Int64 => Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
shiftL @Int64) Value
e1 Value
e2
whnfBinOp BinOp
ShiftR Value
e1 Value
e2 = (Int64 -> Int -> Int64) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (Bits Int64 => Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
shiftR @Int64) Value
e1 Value
e2
whnfBinOp BinOp
In Value
s Value
o = (Object -> Text -> Bool) -> Value -> Value -> Eval Value
forall a b c.
(HasValue a, HasValue b, HasValue c) =>
(a -> b -> c) -> Value -> Value -> Eval Value
liftF2 (\Object
o Text
s -> Object -> Text -> Bool -> Bool
objectHasEx Object
o Text
s Bool
True) Value
o Value
s

whnfLogical :: HasValue a => (a -> Bool) -> Value -> Value -> Eval Value
whnfLogical :: (a -> Bool) -> Value -> Value -> Eval Value
whnfLogical a -> Bool
f Value
e1 Value
e2 = do
  a
x <- Value -> Eval Value
whnfV Value
e1 Eval Value -> (Value -> EvalM Value a) -> EvalM Value a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> EvalM Value a
forall a. HasValue a => Value -> Eval a
proj'
  if a -> Bool
f a
x
    then Bool -> Value
forall a. HasValue a => a -> Value
inj (Bool -> Value) -> EvalM Value Bool -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Eval Value
whnfV Value
e2 Eval Value -> (Value -> EvalM Value Bool) -> EvalM Value Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasValue Bool => Value -> EvalM Value Bool
forall a. HasValue a => Value -> Eval a
proj' @Bool)
    else Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Value
forall a. HasValue a => a -> Value
inj a
x)

append :: Value -> Value -> Eval Text
append :: Value -> Value -> EvalM Value Text
append Value
v1 Value
v2 = Text -> Text -> Text
T.append (Text -> Text -> Text)
-> EvalM Value Text -> EvalM Value (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> EvalM Value Text
toString Value
v1 EvalM Value (Text -> Text) -> EvalM Value Text -> EvalM Value Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> EvalM Value Text
toString Value
v2

whnfUnyOp :: UnyOp -> Value -> Eval Value
whnfUnyOp :: UnyOp -> Value -> Eval Value
whnfUnyOp UnyOp
Compl Value
x = Int64 -> Value
forall a. HasValue a => a -> Value
inj (Int64 -> Value) -> EvalM Value Int64 -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int64 -> Int64) -> EvalM Value Int64 -> EvalM Value Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bits Int64 => Int64 -> Int64
forall a. Bits a => a -> a
complement @Int64) (Value -> EvalM Value Int64
forall a. HasValue a => Value -> Eval a
proj' Value
x)
whnfUnyOp UnyOp
LNot Value
x = Bool -> Value
forall a. HasValue a => a -> Value
inj (Bool -> Value) -> EvalM Value Bool -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool) -> EvalM Value Bool -> EvalM Value Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Value -> EvalM Value Bool
forall a. HasValue a => Value -> Eval a
proj' Value
x)
whnfUnyOp UnyOp
Minus Value
x = Double -> Value
forall a. HasValue a => a -> Value
inj (Double -> Value) -> EvalM Value Double -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Double) -> EvalM Value Double -> EvalM Value Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Num Double => Double -> Double
forall a. Num a => a -> a
negate @Double) (Value -> EvalM Value Double
forall a. HasValue a => Value -> Eval a
proj' Value
x)
whnfUnyOp UnyOp
Plus Value
x = Double -> Value
forall a. HasValue a => a -> Value
inj (Double -> Value) -> EvalM Value Double -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Double) -> EvalM Value Double -> EvalM Value Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double
forall a. a -> a
id @Double) (Value -> EvalM Value Double
forall a. HasValue a => Value -> Eval a
proj' Value
x)
whnfUnyOp UnyOp
Err Value
x = (Value -> EvalM Value Text
toString (Value -> EvalM Value Text)
-> (Text -> Eval Value) -> Value -> Eval Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> EvalError -> Eval Value
forall a b. EvalError -> EvalM a b
throwE (EvalError -> Eval Value)
-> (Text -> EvalError) -> Text -> Eval Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> EvalError
RuntimeError (Doc -> EvalError) -> (Text -> Doc) -> Text -> EvalError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
forall a. Pretty a => a -> Doc
pretty) Value
x

toString :: Value -> Eval Text
toString :: Value -> EvalM Value Text
toString (VStr Text
s) = Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
toString Value
v = Text -> Text
toStrict (Text -> Text) -> (Value -> Text) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText (Value -> Text) -> Eval Value -> EvalM Value Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Eval Value
manifest Value
v

whnfCond :: Value -> Value -> Value -> Eval Value
whnfCond :: Value -> Value -> Value -> Eval Value
whnfCond Value
c Value
e1 Value
e2 = do
  Bool
c' <- Value -> EvalM Value Bool
forall a. HasValue a => Value -> Eval a
proj' Value
c
  if Bool
c'
    then Value -> Eval Value
whnfV Value
e1
    else Value -> Eval Value
whnfV Value
e2

whnfLookup :: Value -> Value -> Eval Value
whnfLookup :: Value -> Value -> Eval Value
whnfLookup (VObj Object
o) (VStr Text
s) =
  Value -> Eval Value
whnfV (Value -> Eval Value) -> (VField -> Value) -> VField -> Eval Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VField -> Value
fieldValWHNF (VField -> Eval Value) -> EvalM Value VField -> Eval Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EvalError -> Maybe VField -> EvalM Value VField
forall a. EvalError -> Maybe a -> Eval a
liftMaybe (Doc -> EvalError
NoSuchKey (Text -> Doc
forall a. Pretty a => a -> Doc
pretty Text
s)) (Text -> Object -> Maybe VField
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
s Object
o)
whnfLookup (VArr Vector Value
a) (VNum Scientific
i)
  | Scientific -> Bool
isInteger Scientific
i =
    Value -> Eval Value
whnfV (Value -> Eval Value) -> Eval Value -> Eval Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EvalError -> Maybe Value -> Eval Value
forall a. EvalError -> Maybe a -> Eval a
liftMaybe (Scientific -> EvalError
IndexOutOfBounds Scientific
i) ((Vector Value
a Vector Value -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
!?) (Int -> Maybe Value) -> Maybe Int -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
i)
whnfLookup (VArr Vector Value
_) Value
_ =
  EvalError -> Eval Value
forall a b. EvalError -> EvalM a b
throwE (Doc -> EvalError
InvalidIndex Doc
"array index was not integer")
whnfLookup (VStr Text
s) (VNum Scientific
i)
  | Scientific -> Bool
isInteger Scientific
i =
    EvalError -> Maybe Value -> Eval Value
forall a. EvalError -> Maybe a -> Eval a
liftMaybe (Scientific -> EvalError
IndexOutOfBounds Scientific
i) (Int -> Maybe Value
f (Int -> Maybe Value) -> Maybe Int -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Int
bounded)
  where
    f :: Int -> Maybe Value
f = Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe Value) -> (Int -> Value) -> Int -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
VStr (Text -> Value) -> (Int -> Text) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton (Char -> Text) -> (Int -> Char) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int -> Char
T.index Text
s
    bounded :: Maybe Int
bounded =
      Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
i Maybe Int -> (Int -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
i' ->
        if Text -> Int
T.length Text
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i' Bool -> Bool -> Bool
&& Int
i' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
          then Maybe Int
forall a. Maybe a
Nothing
          else Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i'
whnfLookup (VStr Text
_) Value
_ =
  EvalError -> Eval Value
forall a b. EvalError -> EvalM a b
throwE (Doc -> EvalError
InvalidIndex Doc
"string index was not integer")
whnfLookup Value
v Value
_ = Text -> Value -> Eval Value
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"array/object/string" Value
v

whnfIndir :: Ref -> Eval Value
whnfIndir :: Ref -> Eval Value
whnfIndir Ref
ref = do
  Cell
c <- IO Cell -> EvalM Value Cell
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Cell -> EvalM Value Cell) -> IO Cell -> EvalM Value Cell
forall a b. (a -> b) -> a -> b
$ Ref -> IO Cell
forall a. IORef a -> IO a
readIORef Ref
ref
  case Cell
c of
    Cell Value
v Bool
True ->
      Value -> Eval Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v -- Already evaluated, just return it
    Cell Value
v Bool
False -> do
      Value
v' <- Value -> Eval Value
whnfV Value
v -- Needs to be reduced
      IO () -> EvalM Value ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EvalM Value ()) -> IO () -> EvalM Value ()
forall a b. (a -> b) -> a -> b
$ Ref -> Cell -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef Ref
ref (Value -> Bool -> Cell
Cell Value
v' Bool
True)
      Value -> Eval Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v'

whnfLetrec :: Let -> Eval Value
whnfLetrec :: Let -> Eval Value
whnfLetrec Let
bnd = mdo
  (Rec [Param Core]
r, Core
e1) <- Let -> EvalM Value (Rec [Param Core], Core)
forall p t (m :: * -> *).
(Alpha p, Alpha t, Fresh m) =>
Bind p t -> m (p, t)
unbind Let
bnd
  Env
bnds <-
    [(Name Core, Value)] -> Env
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      ([(Name Core, Value)] -> Env)
-> EvalM Value [(Name Core, Value)] -> EvalM Value Env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param Core -> EvalM Value (Name Core, Value))
-> [Param Core] -> EvalM Value [(Name Core, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
        ( \(Name Core
n, Embed Core
e) -> do
            Value
v <- Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv Env
bnds (Core -> Eval Value
mkValue Core
e)
            (Name Core, Value) -> EvalM Value (Name Core, Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name Core
n, Value
v)
        )
        (Rec [Param Core] -> [Param Core]
forall p. Alpha p => Rec p -> p
unrec Rec [Param Core]
r)
  Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv Env
bnds (Core -> Eval Value
mkValue Core
e1)

whnfObj :: [CField] -> Eval Value
whnfObj :: [CField] -> Eval Value
whnfObj [CField]
xs = mdo
  Value
obj <-
    Value -> Eval Value
forall (m :: * -> *). MonadIO m => Value -> m Value
mkIndirV (Value -> Eval Value)
-> ([Maybe (Text, VField)] -> Value)
-> [Maybe (Text, VField)]
-> Eval Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
VObj (Object -> Value)
-> ([Maybe (Text, VField)] -> Object)
-> [Maybe (Text, VField)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, VField)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList ([(Text, VField)] -> Object)
-> ([Maybe (Text, VField)] -> [(Text, VField)])
-> [Maybe (Text, VField)]
-> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, VField)] -> [(Text, VField)]
forall a. [Maybe a] -> [a]
catMaybes
      ([Maybe (Text, VField)] -> Eval Value)
-> EvalM Value [Maybe (Text, VField)] -> Eval Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (CField -> EvalM Value (Maybe (Text, VField)))
-> [CField] -> EvalM Value [Maybe (Text, VField)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
        ( \CField
field ->
            let self :: Map (Name a) Value
self = Name a -> Value -> Map (Name a) Value
forall k a. k -> a -> Map k a
M.singleton (String -> Name a
forall a. String -> Name a
s2n String
"self") Value
obj
             in Env -> CField -> EvalM Value (Maybe (Text, VField))
whnfField Env
forall a. Map (Name a) Value
self CField
field
        )
        [CField]
xs
  Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
obj

whnfField ::
  -- | self object
  Env ->
  -- |
  CField ->
  -- |
  Eval (Maybe (Text, VField))
whnfField :: Env -> CField -> EvalM Value (Maybe (Text, VField))
whnfField Env
self (CField Core
k Core
v Visibility
h) = do
  let fieldVis :: Visibility
fieldVis = Visibility
h
  Value
fieldKey <- Core -> Eval Value
whnf Core
k -- keys are strictly evaluated
  Value
fieldValWHNF <- Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv Env
self (Core -> Eval Value
mkValue Core
v)
  Value
fieldVal <- Env -> Eval Value -> Eval Value
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv Env
self (Core -> Eval Value
mkThunk Core
v)
  (Text -> (Text, VField)) -> Maybe Text -> Maybe (Text, VField)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,VField :: Value -> Value -> Value -> Visibility -> VField
VField {Visibility
Value
fieldVis :: Visibility
fieldVal :: Value
fieldKey :: Value
fieldVal :: Value
fieldValWHNF :: Value
fieldKey :: Value
fieldVis :: Visibility
fieldValWHNF :: Value
..}) (Maybe Text -> Maybe (Text, VField))
-> EvalM Value (Maybe Text) -> EvalM Value (Maybe (Text, VField))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> EvalM Value (Maybe Text)
forall a. HasValue a => Value -> Eval a
proj' Value
fieldKey

flattenArrays :: Vector (Vector Value) -> Vector Value
flattenArrays :: Vector (Vector Value) -> Vector Value
flattenArrays = Vector (Vector Value) -> Vector Value
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

whnfComp ::
  Comp ->
  Core ->
  Eval Value
whnfComp :: Comp -> Core -> Eval Value
whnfComp (ArrC Bind (Name Core) (Core, Maybe Core)
bnd) Core
cs = do
  Vector (Maybe Value)
xs <- EvalM Value (Vector (Maybe Value))
comp
  (Vector (Vector Value) -> Vector Value) -> Value -> Eval Value
forall a b.
(HasValue a, HasValue b) =>
(a -> b) -> Value -> Eval Value
liftF Vector (Vector Value) -> Vector Value
flattenArrays (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ Vector Value -> Value
VArr (Vector Value -> Value) -> Vector Value -> Value
forall a b. (a -> b) -> a -> b
$ (Maybe Value -> Maybe Value)
-> Vector (Maybe Value) -> Vector Value
forall a b. (a -> Maybe b) -> Vector a -> Vector b
V.mapMaybe Maybe Value -> Maybe Value
forall a. a -> a
id Vector (Maybe Value)
xs
  where
    comp :: EvalM Value (Vector (Maybe Value))
comp =
      Core -> Eval Value
whnf Core
cs Eval Value
-> (Value -> EvalM Value (Vector (Maybe Value)))
-> EvalM Value (Vector (Maybe Value))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        VArr Vector Value
xs -> Vector Value
-> (Value -> EvalM Value (Maybe Value))
-> EvalM Value (Vector (Maybe Value))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Vector Value
xs ((Value -> EvalM Value (Maybe Value))
 -> EvalM Value (Vector (Maybe Value)))
-> (Value -> EvalM Value (Maybe Value))
-> EvalM Value (Vector (Maybe Value))
forall a b. (a -> b) -> a -> b
$ \Value
x -> do
          (Name Core
n, (Core
e, Maybe Core
cond)) <- Bind (Name Core) (Core, Maybe Core)
-> EvalM Value (Name Core, (Core, Maybe Core))
forall p t (m :: * -> *).
(Alpha p, Alpha t, Fresh m) =>
Bind p t -> m (p, t)
unbind Bind (Name Core) (Core, Maybe Core)
bnd
          Env -> EvalM Value (Maybe Value) -> EvalM Value (Maybe Value)
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv ([(Name Core, Value)] -> Env
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name Core
n, Value
x)]) (EvalM Value (Maybe Value) -> EvalM Value (Maybe Value))
-> EvalM Value (Maybe Value) -> EvalM Value (Maybe Value)
forall a b. (a -> b) -> a -> b
$ do
            Bool
b <- Maybe Core -> EvalM Value Bool
f Maybe Core
cond
            if Bool
b
              then Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Eval Value -> EvalM Value (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Core -> Eval Value
mkValue Core
e
              else Maybe Value -> EvalM Value (Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing
        Value
v -> Text -> Value -> EvalM Value (Vector (Maybe Value))
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"" Value
v
      where
        f :: Maybe Core -> EvalM Value Bool
f Maybe Core
Nothing = Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        f (Just Core
c) = Value -> EvalM Value Bool
forall a. HasValue a => Value -> Eval a
proj' (Value -> EvalM Value Bool) -> Eval Value -> EvalM Value Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Core -> Eval Value
whnf Core
c
whnfComp (ObjC Bind (Name Core) (CField, Maybe Core)
bnd) Core
cs = do
  Vector (Maybe (Text, VField))
xs <- EvalM Value (Vector (Maybe (Text, VField)))
comp
  Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
VObj (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, VField)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList ([(Text, VField)] -> Object) -> [(Text, VField)] -> Object
forall a b. (a -> b) -> a -> b
$ [Maybe (Text, VField)] -> [(Text, VField)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Text, VField)] -> [(Text, VField)])
-> [Maybe (Text, VField)] -> [(Text, VField)]
forall a b. (a -> b) -> a -> b
$ Vector (Maybe (Text, VField)) -> [Maybe (Text, VField)]
forall a. Vector a -> [a]
V.toList Vector (Maybe (Text, VField))
xs
  where
    comp :: EvalM Value (Vector (Maybe (Text, VField)))
comp =
      Core -> Eval Value
whnf Core
cs Eval Value
-> (Value -> EvalM Value (Vector (Maybe (Text, VField))))
-> EvalM Value (Vector (Maybe (Text, VField)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        VArr Vector Value
xs -> Vector Value
-> (Value -> EvalM Value (Maybe (Text, VField)))
-> EvalM Value (Vector (Maybe (Text, VField)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Vector Value
xs ((Value -> EvalM Value (Maybe (Text, VField)))
 -> EvalM Value (Vector (Maybe (Text, VField))))
-> (Value -> EvalM Value (Maybe (Text, VField)))
-> EvalM Value (Vector (Maybe (Text, VField)))
forall a b. (a -> b) -> a -> b
$ \Value
x -> do
          (Name Core
n, (CField Core
k Core
v Visibility
h, Maybe Core
cond)) <- Bind (Name Core) (CField, Maybe Core)
-> EvalM Value (Name Core, (CField, Maybe Core))
forall p t (m :: * -> *).
(Alpha p, Alpha t, Fresh m) =>
Bind p t -> m (p, t)
unbind Bind (Name Core) (CField, Maybe Core)
bnd
          Env
-> EvalM Value (Maybe (Text, VField))
-> EvalM Value (Maybe (Text, VField))
forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv ([(Name Core, Value)] -> Env
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name Core
n, Value
x)]) (EvalM Value (Maybe (Text, VField))
 -> EvalM Value (Maybe (Text, VField)))
-> EvalM Value (Maybe (Text, VField))
-> EvalM Value (Maybe (Text, VField))
forall a b. (a -> b) -> a -> b
$ do
            Bool
b <- Maybe Core -> EvalM Value Bool
f Maybe Core
cond
            if Bool
b
              then do
                Value
fieldKey <- Core -> Eval Value
whnf Core
k
                Value
fieldValWHNF <- Core -> Eval Value
mkValue Core
v
                Value
fieldVal <- Core -> Eval Value
mkThunk Core
v
                let fieldVis :: Visibility
fieldVis = Visibility
h
                (Text -> (Text, VField)) -> Maybe Text -> Maybe (Text, VField)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,VField :: Value -> Value -> Value -> Visibility -> VField
VField {Visibility
Value
fieldVis :: Visibility
fieldVal :: Value
fieldValWHNF :: Value
fieldKey :: Value
fieldVis :: Visibility
fieldVal :: Value
fieldKey :: Value
fieldValWHNF :: Value
..}) (Maybe Text -> Maybe (Text, VField))
-> EvalM Value (Maybe Text) -> EvalM Value (Maybe (Text, VField))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> EvalM Value (Maybe Text)
forall a. HasValue a => Value -> Eval a
proj' Value
fieldKey
              else Maybe (Text, VField) -> EvalM Value (Maybe (Text, VField))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, VField)
forall a. Maybe a
Nothing
        Value
v -> Text -> Value -> EvalM Value (Vector (Maybe (Text, VField)))
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"array" Value
v
    f :: Maybe Core -> EvalM Value Bool
f Maybe Core
Nothing = Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    f (Just Core
c) = Value -> EvalM Value Bool
forall a. HasValue a => Value -> Eval a
proj' (Value -> EvalM Value Bool) -> Eval Value -> EvalM Value Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Core -> Eval Value
whnf Core
c

-- | Right-biased union of two objects, i.e. '{x : 1} + {x : 2} == {x : 2}'
--   with OO-like `self` and `super` support via value recursion (knot-tying)
mergeWith :: Object -> Object -> Eval Value
mergeWith :: Object -> Object -> Eval Value
mergeWith Object
xs Object
ys = mdo
  Value
zs' <- Value -> Eval Value
forall (m :: * -> *). MonadIO m => Value -> m Value
mkIndirV (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
VObj ((VField -> VField -> VField) -> Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
H.unionWith VField -> VField -> VField
forall p. HasVisibility p => p -> p -> p
f Object
xs' Object
ys')
  Object
xs' <- Object -> (VField -> EvalM Value VField) -> EvalM Value Object
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Object
xs (Name Core -> Value -> VField -> EvalM Value VField
forall (m :: * -> *).
MonadIO m =>
Name Core -> Value -> VField -> m VField
update Name Core
forall a. Name a
self Value
zs')
  Object
ys' <- do
    Value
xs'' <- Value -> Eval Value
forall (m :: * -> *). MonadIO m => Value -> m Value
mkIndirV (Object -> Value
VObj Object
xs')
    Object
ys'' <- Object -> (VField -> EvalM Value VField) -> EvalM Value Object
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Object
ys (Name Core -> Value -> VField -> EvalM Value VField
forall (m :: * -> *).
MonadIO m =>
Name Core -> Value -> VField -> m VField
update Name Core
forall a. Name a
self Value
zs')
    Object -> (VField -> EvalM Value VField) -> EvalM Value Object
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Object
ys'' (Name Core -> Value -> VField -> EvalM Value VField
forall (m :: * -> *).
MonadIO m =>
Name Core -> Value -> VField -> m VField
update Name Core
forall a. Name a
super Value
xs'')
  Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
zs'
  where
    self :: Name a
self = String -> Name a
forall a. String -> Name a
s2n String
"self"
    super :: Name a
super = String -> Name a
forall a. String -> Name a
s2n String
"super"
    f :: p -> p -> p
f p
a p
b
      | p -> Bool
forall a. HasVisibility a => a -> Bool
hidden p
a Bool -> Bool -> Bool
&& p -> Bool
forall a. HasVisibility a => a -> Bool
visible p
b = p
a
      | Bool
otherwise = p
b
    update :: Name Core -> Value -> VField -> m VField
update Name Core
name Value
xs f :: VField
f@VField {Visibility
Value
fieldVis :: Visibility
fieldVal :: Value
fieldValWHNF :: Value
fieldKey :: Value
fieldVis :: VField -> Visibility
fieldVal :: VField -> Value
fieldKey :: VField -> Value
fieldValWHNF :: VField -> Value
..} = case Value
fieldVal of
      VThunk Core
c Env
env -> do
        let env' :: Env
env' = Name Core -> Value -> Env -> Env
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name Core
name Value
xs Env
env
        let fieldVal :: Value
fieldVal = Core -> Env -> Value
VThunk Core
c Env
env'
        Value
fieldValWHNF <- Value -> m Value
forall (m :: * -> *). MonadIO m => Value -> m Value
mkIndirV Value
fieldVal
        VField -> m VField
forall (f :: * -> *) a. Applicative f => a -> f a
pure VField :: Value -> Value -> Value -> Visibility -> VField
VField {Visibility
Value
fieldValWHNF :: Value
fieldVal :: Value
fieldVis :: Visibility
fieldKey :: Value
fieldVis :: Visibility
fieldVal :: Value
fieldKey :: Value
fieldValWHNF :: Value
..}
      Value
_ -> VField -> m VField
forall (f :: * -> *) a. Applicative f => a -> f a
pure VField
f

visibleKeys :: Object -> HashMap Text Value
visibleKeys :: Object -> HashMap Text Value
visibleKeys = (VField -> Maybe Value) -> Object -> HashMap Text Value
forall v1 v2 k. (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
H.mapMaybe VField -> Maybe Value
f
  where
    f :: VField -> Maybe Value
f v :: VField
v@VField {Visibility
Value
fieldVis :: Visibility
fieldVal :: Value
fieldValWHNF :: Value
fieldKey :: Value
fieldVis :: VField -> Visibility
fieldVal :: VField -> Value
fieldKey :: VField -> Value
fieldValWHNF :: VField -> Value
..}
      | Bool -> Bool
not (VField -> Bool
forall a. HasVisibility a => a -> Bool
hidden VField
v) = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
fieldValWHNF
      | Bool
otherwise = Maybe Value
forall a. Maybe a
Nothing

liftMaybe :: EvalError -> Maybe a -> Eval a
liftMaybe :: EvalError -> Maybe a -> Eval a
liftMaybe EvalError
e =
  \case
    Maybe a
Nothing -> EvalError -> Eval a
forall a b. EvalError -> EvalM a b
throwE EvalError
e
    Just a
a -> a -> Eval a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

manifest :: Value -> Eval JSON.Value
manifest :: Value -> Eval Value
manifest = \case
  Value
VNull -> Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
JSON.Null
  VBool Bool
b -> Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
JSON.Bool Bool
b)
  VStr Text
s -> Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Value
JSON.String Text
s)
  VNum Scientific
n -> Value -> Eval Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> Value
JSON.Number Scientific
n)
  VObj Object
vs -> Object -> Value
JSON.Object (Object -> Value) -> EvalM Value Object -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Eval Value) -> HashMap Text Value -> EvalM Value Object
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Eval Value
manifest (Object -> HashMap Text Value
visibleKeys Object
vs)
  VArr Vector Value
vs -> Array -> Value
JSON.Array (Array -> Value) -> EvalM Value Array -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Eval Value) -> Vector Value -> EvalM Value Array
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Eval Value
manifest Vector Value
vs
  VClos {} -> EvalError -> Eval Value
forall a b. EvalError -> EvalM a b
throwE (Doc -> EvalError
ManifestError Doc
"function")
  VFun Value -> Eval Value
_ -> EvalError -> Eval Value
forall a b. EvalError -> EvalM a b
throwE (Doc -> EvalError
ManifestError Doc
"function")
  v :: Value
v@VThunk {} -> Value -> Eval Value
whnfV Value
v Eval Value -> (Value -> Eval Value) -> Eval Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Eval Value
manifest
  v :: Value
v@VIndir {} -> Value -> Eval Value
whnfV Value
v Eval Value -> (Value -> Eval Value) -> Eval Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Eval Value
manifest
  Value
_ -> EvalError -> Eval Value
forall a b. EvalError -> EvalM a b
throwE (Doc -> EvalError
ManifestError Doc
"impossible")

objectFieldsEx :: Object -> Bool -> [Text]
objectFieldsEx :: Object -> Bool -> [Text]
objectFieldsEx Object
o Bool
True = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort (Object -> [Text]
forall k v. HashMap k v -> [k]
H.keys Object
o) -- all fields
objectFieldsEx Object
o Bool
False = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Object -> [Text]
forall k v. HashMap k v -> [k]
H.keys (Object -> [Text]) -> Object -> [Text]
forall a b. (a -> b) -> a -> b
$ (VField -> Bool) -> Object -> Object
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
H.filter (Bool -> Bool
not (Bool -> Bool) -> (VField -> Bool) -> VField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VField -> Bool
forall a. HasVisibility a => a -> Bool
hidden) Object
o -- only visible (incl. forced)

objectHasEx :: Object -> Text -> Bool -> Bool
objectHasEx :: Object -> Text -> Bool -> Bool
objectHasEx Object
o Text
f Bool
all = Text
f Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Object -> Bool -> [Text]
objectFieldsEx Object
o Bool
all

primitiveEquals :: Value -> Value -> Eval Bool
primitiveEquals :: Value -> Value -> EvalM Value Bool
primitiveEquals Value
VNull Value
VNull = Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
primitiveEquals (VBool Bool
a) (VBool Bool
b) = Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b)
primitiveEquals (VStr Text
a) (VStr Text
b) = Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
b)
primitiveEquals (VNum Scientific
a) (VNum Scientific
b) = Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific
a Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
b)
primitiveEquals Value
a Value
b =
  EvalError -> EvalM Value Bool
forall a b. EvalError -> EvalM a b
throwE
    ( Doc -> EvalError
StdError (Doc -> EvalError) -> Doc -> EvalError
forall a b. (a -> b) -> a -> b
$
        String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
          Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
            Text
"primitiveEquals operates on primitive types "
            --  <> showTy a
            --  <> showTy b
    )

equals :: Value -> Value -> Eval Bool
equals :: Value -> Value -> EvalM Value Bool
equals Value
e1 Value
e2 = (Value -> Value -> (Value, Value))
-> Eval Value -> Eval Value -> EvalM Value (Value, Value)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Value -> Eval Value
whnfV Value
e1) (Value -> Eval Value
whnfV Value
e2) EvalM Value (Value, Value)
-> ((Value, Value) -> EvalM Value Bool) -> EvalM Value Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Value -> EvalM Value Bool)
-> (Value, Value) -> EvalM Value Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Value -> Value -> EvalM Value Bool
go
  where
    go :: Value -> Value -> EvalM Value Bool
go as :: Value
as@(VArr Vector Value
a) bs :: Value
bs@(VArr Vector Value
b)
      | Vector Value -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
P.length Vector Value
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector Value -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
P.length Vector Value
b = do
        [Value]
as' <- Value -> EvalM Value [Value]
forall a. HasValue a => Value -> Eval a
proj' Value
as
        [Value]
bs' <- Value -> EvalM Value [Value]
forall a. HasValue a => Value -> Eval a
proj' Value
bs
        ((Value, Value) -> EvalM Value Bool)
-> [(Value, Value)] -> EvalM Value Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM ((Value -> Value -> EvalM Value Bool)
-> (Value, Value) -> EvalM Value Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Value -> Value -> EvalM Value Bool
equals) ([Value] -> [Value] -> [(Value, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Value]
as' [Value]
bs')
      | Vector Value -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
P.length Vector Value
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Vector Value -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
P.length Vector Value
b = Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    go (VObj Object
a) (VObj Object
b) = do
      let fields :: [Text]
fields = Object -> Bool -> [Text]
objectFieldsEx Object
a Bool
False
      if [Text]
fields [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
/= Object -> Bool -> [Text]
objectFieldsEx Object
b Bool
False
        then Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        else (Text -> EvalM Value Bool) -> [Text] -> EvalM Value Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Text -> EvalM Value Bool
objectFieldEquals [Text]
fields
      where
        objectFieldEquals :: Text -> EvalM Value Bool
objectFieldEquals Text
field =
          let a' :: Value
a' = VField -> Value
fieldValWHNF (Object
a Object -> Text -> VField
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
H.! Text
field)
              b' :: Value
b' = VField -> Value
fieldValWHNF (Object
b Object -> Text -> VField
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
H.! Text
field)
           in Value -> Value -> EvalM Value Bool
equals Value
a' Value
b'
    go Value
a Value
b = do
      Text
ta <- Value -> EvalM Value Text
showTy Value
a
      Text
tb <- Value -> EvalM Value Text
showTy Value
b
      if Text
ta Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tb
        then Value -> Value -> EvalM Value Bool
primitiveEquals Value
a Value
b
        else Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM :: (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
p = (a -> Bool -> m Bool) -> Bool -> [a] -> m Bool
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (\a
a Bool
b -> (Bool -> Bool -> Bool
&& Bool
b) (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m Bool
p a
a) Bool
True

-- better names?
liftF ::
  (HasValue a, HasValue b) =>
  (a -> b) ->
  (Value -> Eval Value)
liftF :: (a -> b) -> Value -> Eval Value
liftF a -> b
f Value
v = b -> Value
forall a. HasValue a => a -> Value
inj (b -> Value) -> (a -> b) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> Value) -> EvalM Value a -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> EvalM Value a
forall a. HasValue a => Value -> Eval a
proj' Value
v
{-# INLINE liftF #-}

liftF2 ::
  (HasValue a, HasValue b, HasValue c) =>
  (a -> b -> c) ->
  Value ->
  Value ->
  Eval Value
liftF2 :: (a -> b -> c) -> Value -> Value -> Eval Value
liftF2 a -> b -> c
f Value
v1 Value
v2 = c -> Value
forall a. HasValue a => a -> Value
inj (c -> Value) -> EvalM Value c -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b -> c) -> EvalM Value a -> EvalM Value b -> EvalM Value c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f (Value -> EvalM Value a
forall a. HasValue a => Value -> Eval a
proj' Value
v1) (Value -> EvalM Value b
forall a. HasValue a => Value -> Eval a
proj' Value
v2)
{-# INLINE liftF2 #-}

proj' :: HasValue a => Value -> Eval a
proj' :: Value -> Eval a
proj' = Value -> Eval Value
whnfV (Value -> Eval Value) -> (Value -> Eval a) -> Value -> Eval a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> Eval a
forall a. HasValue a => Value -> Eval a
proj
{-# INLINE proj' #-}

throwTypeMismatch :: Text -> Value -> Eval a
throwTypeMismatch :: Text -> Value -> Eval a
throwTypeMismatch Text
e = EvalError -> Eval a
forall a b. EvalError -> EvalM a b
throwE (EvalError -> Eval a) -> (Text -> EvalError) -> Text -> Eval a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> EvalError
TypeMismatch Text
e (Text -> Eval a) -> (Value -> EvalM Value Text) -> Value -> Eval a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> EvalM Value Text
showTy

showTy :: Value -> Eval Text
showTy :: Value -> EvalM Value Text
showTy = \case
  Value
VNull -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"null"
  VNum Scientific
_ -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"number"
  VBool Bool
_ -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"boolean"
  VStr Text
_ -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"string"
  VObj Object
_ -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"object"
  VArr Vector Value
_ -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"array"
  VClos {} -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"function"
  VFun Value -> Eval Value
_ -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"function"
  VPrim Prim
_ -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"function"
  VThunk {} -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"thunk"
  VIndir {} -> Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"pointer"

--v@VThunk {} -> whnfV v >>= showTy
--v@VIndir {} -> whnfV v >>= showTy

instance HasValue Bool where
  proj :: Value -> EvalM Value Bool
proj (VBool Bool
n) = Bool -> EvalM Value Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
n
  proj Value
v = Text -> Value -> EvalM Value Bool
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"bool" Value
v
  inj :: Bool -> Value
inj = Bool -> Value
VBool
  {-# INLINE inj #-}

instance HasValue Text where
  proj :: Value -> EvalM Value Text
proj (VStr Text
s) = Text -> EvalM Value Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
  proj Value
v = Text -> Value -> EvalM Value Text
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"string" Value
v
  inj :: Text -> Value
inj = Text -> Value
VStr
  {-# INLINE inj #-}

instance {-# OVERLAPPING #-} HasValue [Char] where
  proj :: Value -> Eval String
proj (VStr Text
s) = String -> Eval String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Eval String) -> String -> Eval String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s
  proj Value
v = Text -> Value -> Eval String
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"string" Value
v
  inj :: String -> Value
inj = Text -> Value
VStr (Text -> Value) -> (String -> Text) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
  {-# INLINE inj #-}

instance HasValue ByteString where
  proj :: Value -> Eval ByteString
proj (VStr Text
s) = ByteString -> Eval ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ByteString
encodeUtf8 Text
s)
  proj Value
v = Text -> Value -> Eval ByteString
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"string" Value
v
  inj :: ByteString -> Value
inj = Text -> Value
VStr (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8
  {-# INLINE inj #-}

instance HasValue Scientific where
  proj :: Value -> Eval Scientific
proj (VNum Scientific
n) = Scientific -> Eval Scientific
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
n
  proj Value
v = Text -> Value -> Eval Scientific
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"number" Value
v
  inj :: Scientific -> Value
inj = Scientific -> Value
VNum
  {-# INLINE inj #-}

instance HasValue Double where
  proj :: Value -> EvalM Value Double
proj (VNum Scientific
n) = Double -> EvalM Value Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
n)
  proj Value
v = Text -> Value -> EvalM Value Double
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"number" Value
v
  inj :: Double -> Value
inj = Scientific -> Value
VNum (Scientific -> Value) -> (Double -> Scientific) -> Double -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Scientific
forall a. RealFloat a => a -> Scientific
fromFloatDigits
  {-# INLINE inj #-}

instance {-# OVERLAPS #-} Integral a => HasValue a where
  proj :: Value -> Eval a
proj (VNum Scientific
n) = a -> Eval a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> a
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
n)
  proj Value
v = Text -> Value -> Eval a
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"number" Value
v
  inj :: a -> Value
inj = Scientific -> Value
VNum (Scientific -> Value) -> (a -> Scientific) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  {-# INLINE inj #-}

instance HasValue a => HasValue (Maybe a) where
  proj :: Value -> Eval (Maybe a)
proj Value
VNull = Maybe a -> Eval (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  proj Value
a = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> EvalM Value a -> Eval (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> EvalM Value a
forall a. HasValue a => Value -> Eval a
proj' Value
a
  inj :: Maybe a -> Value
inj Maybe a
Nothing = Value
VNull
  inj (Just a
a) = a -> Value
forall a. HasValue a => a -> Value
inj a
a
  {-# INLINE inj #-}

instance {-# OVERLAPS #-} HasValue Object where
  proj :: Value -> EvalM Value Object
proj (VObj Object
o) = Object -> EvalM Value Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
o
  proj Value
v = Text -> Value -> EvalM Value Object
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"object" Value
v
  inj :: Object -> Value
inj = Object -> Value
VObj
  {-# INLINE inj #-}

instance HasValue a => HasValue (Vector a) where
  proj :: Value -> Eval (Vector a)
proj (VArr Vector Value
as) = (Value -> EvalM Value a) -> Vector Value -> Eval (Vector a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> EvalM Value a
forall a. HasValue a => Value -> Eval a
proj' Vector Value
as
  proj Value
v = Text -> Value -> Eval (Vector a)
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"array" Value
v
  inj :: Vector a -> Value
inj Vector a
as = Vector Value -> Value
VArr (a -> Value
forall a. HasValue a => a -> Value
inj (a -> Value) -> Vector a -> Vector Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector a
as)
  {-# INLINE inj #-}

instance {-# OVERLAPPABLE #-} HasValue a => HasValue [a] where
  proj :: Value -> Eval [a]
proj = (Vector a -> [a]) -> EvalM Value (Vector a) -> Eval [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector a -> [a]
forall a. Vector a -> [a]
V.toList (EvalM Value (Vector a) -> Eval [a])
-> (Value -> EvalM Value (Vector a)) -> Value -> Eval [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> EvalM Value (Vector a)
forall a. HasValue a => Value -> Eval a
proj'
  inj :: [a] -> Value
inj = Vector a -> Value
forall a. HasValue a => a -> Value
inj (Vector a -> Value) -> ([a] -> Vector a) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Vector a
forall a. [a] -> Vector a
V.fromList
  {-# INLINE inj #-}

instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> b) where
  inj :: (a -> b) -> Value
inj a -> b
f = (Value -> Eval Value) -> Value
VFun ((Value -> Eval Value) -> Value) -> (Value -> Eval Value) -> Value
forall a b. (a -> b) -> a -> b
$ (a -> Value) -> EvalM Value a -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> Value
forall a. HasValue a => a -> Value
inj (b -> Value) -> (a -> b) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (EvalM Value a -> Eval Value)
-> (Value -> EvalM Value a) -> Value -> Eval Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> EvalM Value a
forall a. HasValue a => Value -> Eval a
proj'
  {-# INLINE inj #-}
  proj :: Value -> Eval (a -> b)
proj = Text -> Value -> Eval (a -> b)
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"impossible"

instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> c) where
  inj :: (a -> b -> c) -> Value
inj a -> b -> c
f = (a -> Value) -> Value
forall a. HasValue a => a -> Value
inj ((a -> Value) -> Value) -> (a -> Value) -> Value
forall a b. (a -> b) -> a -> b
$ \a
x -> (b -> c) -> Value
forall a. HasValue a => a -> Value
inj (a -> b -> c
f a
x)
  {-# INLINE inj #-}
  proj :: Value -> Eval (a -> b -> c)
proj = Text -> Value -> Eval (a -> b -> c)
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"impossible"

instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> Eval b) where
  inj :: (a -> Eval b) -> Value
inj a -> Eval b
f = (Value -> Eval Value) -> Value
VFun ((Value -> Eval Value) -> Value) -> (Value -> Eval Value) -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Eval a
forall a. HasValue a => Value -> Eval a
proj' (Value -> Eval a) -> (a -> Eval Value) -> Value -> Eval Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (b -> Value) -> Eval b -> Eval Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Value
forall a. HasValue a => a -> Value
inj (Eval b -> Eval Value) -> (a -> Eval b) -> a -> Eval Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Eval b
f
  {-# INLINE inj #-}
  proj :: Value -> Eval (a -> Eval b)
proj (VFun Value -> Eval Value
f) = (a -> Eval b) -> Eval (a -> Eval b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> Eval b) -> Eval (a -> Eval b))
-> (a -> Eval b) -> Eval (a -> Eval b)
forall a b. (a -> b) -> a -> b
$ \a
x -> Value -> Eval Value
f (a -> Value
forall a. HasValue a => a -> Value
inj a
x) Eval Value -> (Value -> Eval b) -> Eval b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Eval b
forall a. HasValue a => Value -> Eval a
proj'
  proj (VClos Let
f Env
e) = (a -> Eval b) -> Eval (a -> Eval b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> Eval b) -> Eval (a -> Eval b))
-> (a -> Eval b) -> Eval (a -> Eval b)
forall a b. (a -> b) -> a -> b
$ \a
x -> Value -> Eval b
forall a. HasValue a => Value -> Eval a
proj (Value -> Eval b) -> Eval Value -> Eval b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> Let -> [Arg Value] -> Eval Value
whnfClos Env
e Let
f [Value -> Arg Value
forall a. a -> Arg a
Pos (a -> Value
forall a. HasValue a => a -> Value
inj a
x)]
  proj Value
v = Text -> Value -> Eval (a -> Eval b)
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"function" Value
v

instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> Eval c) where
  inj :: (a -> b -> Eval c) -> Value
inj a -> b -> Eval c
f = (a -> Value) -> Value
forall a. HasValue a => a -> Value
inj ((a -> Value) -> Value) -> (a -> Value) -> Value
forall a b. (a -> b) -> a -> b
$ \a
x -> (b -> Eval c) -> Value
forall a. HasValue a => a -> Value
inj (a -> b -> Eval c
f a
x)
  {-# INLINE inj #-}
  proj :: Value -> Eval (a -> b -> Eval c)
proj (VFun Value -> Eval Value
f) = (a -> b -> Eval c) -> Eval (a -> b -> Eval c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> b -> Eval c) -> Eval (a -> b -> Eval c))
-> (a -> b -> Eval c) -> Eval (a -> b -> Eval c)
forall a b. (a -> b) -> a -> b
$ \a
x b
y -> Value -> Eval Value
f (a -> Value
forall a. HasValue a => a -> Value
inj a
x) Eval Value -> (Value -> Eval c) -> Eval c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(VFun Value -> Eval Value
g) -> Value -> Eval Value
g (b -> Value
forall a. HasValue a => a -> Value
inj b
y) Eval Value -> (Value -> Eval c) -> Eval c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Eval c
forall a. HasValue a => Value -> Eval a
proj'
  proj (VClos Let
f Env
env) = (a -> b -> Eval c) -> Eval (a -> b -> Eval c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> b -> Eval c) -> Eval (a -> b -> Eval c))
-> (a -> b -> Eval c) -> Eval (a -> b -> Eval c)
forall a b. (a -> b) -> a -> b
$ \a
x b
y -> Value -> Eval c
forall a. HasValue a => Value -> Eval a
proj' (Value -> Eval c) -> Eval Value -> Eval c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> Let -> [Arg Value] -> Eval Value
whnfClos Env
env Let
f [Value -> Arg Value
forall a. a -> Arg a
Pos (a -> Value
forall a. HasValue a => a -> Value
inj a
x), Value -> Arg Value
forall a. a -> Arg a
Pos (b -> Value
forall a. HasValue a => a -> Value
inj b
y)]
  proj Value
v = Text -> Value -> Eval (a -> b -> Eval c)
forall a. Text -> Value -> Eval a
throwTypeMismatch Text
"function" Value
v