{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      : Text.EDE.Internal.Eval
-- Copyright   : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com>
-- License     : This Source Code Form is subject to the terms of
--               the Mozilla Public License, v. 2.0.
--               A copy of the MPL can be found in the LICENSE file or
--               you can obtain it at http://mozilla.org/MPL/2.0/.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- /Warning/: this is an internal module, and does not have a stable
-- API or name. Functions in this module may not check or enforce
-- preconditions expected by public modules. Use at your own risk!
module Text.EDE.Internal.Eval where

import Control.Comonad.Cofree (Cofree ((:<)))
import qualified Control.Monad as Monad
import Control.Monad.Reader (ReaderT)
import qualified Control.Monad.Reader as Reader
import Control.Monad.Trans (lift)
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (Object, Value (..))
import qualified Data.Foldable as Foldable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Scientific (isFloating)
import qualified Data.Text as Text
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Text.Builder
import Data.Text.Lazy.Builder.Scientific (FPFormat (Fixed), formatScientificBuilder)
import Data.Text.Manipulate (toOrdinal)
import Data.Text.Prettyprint.Doc ((<+>))
import qualified Data.Text.Prettyprint.Doc as PP
import Text.EDE.Internal.Filters (stdlib)
import Text.EDE.Internal.Quoting
import Text.EDE.Internal.Types
import Text.Trifecta.Delta (Delta)
import qualified Text.Trifecta.Delta as Trifecta.Delta

data Env = Env
  { Env -> HashMap Id (Exp Delta)
_templates :: HashMap Id (Exp Delta),
    Env -> HashMap Id Term
_quoted :: HashMap Id Term,
    Env -> HashMap Id Value
_values :: HashMap Id Value
  }

type Context = ReaderT Env Result

render ::
  HashMap Id (Exp Delta) ->
  HashMap Id Term ->
  Exp Delta ->
  HashMap Id Value ->
  Result Builder
render :: HashMap Id (Exp Delta)
-> HashMap Id Term
-> Exp Delta
-> HashMap Id Value
-> Result Builder
render HashMap Id (Exp Delta)
ts HashMap Id Term
fs Exp Delta
e HashMap Id Value
o =
  ReaderT Env Result Builder -> Env -> Result Builder
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT (Exp Delta -> Context Term
eval Exp Delta
e Context Term
-> (Term -> ReaderT Env Result Builder)
-> ReaderT Env Result Builder
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Term -> ReaderT Env Result Builder
nf) (HashMap Id (Exp Delta)
-> HashMap Id Term -> HashMap Id Value -> Env
Env HashMap Id (Exp Delta)
ts (HashMap Id Term
stdlib HashMap Id Term -> HashMap Id Term -> HashMap Id Term
forall a. Semigroup a => a -> a -> a
<> HashMap Id Term
fs) HashMap Id Value
o)
  where
    nf :: Term -> ReaderT Env Result Builder
nf (TVal Value
v) = Delta -> Value -> ReaderT Env Result Builder
build (Exp Delta -> Delta
forall t. HasDelta t => t -> Delta
Trifecta.Delta.delta Exp Delta
e) Value
v
    nf Term
_ =
      Result Builder -> ReaderT Env Result Builder
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Result Builder -> ReaderT Env Result Builder)
-> Result Builder -> ReaderT Env Result Builder
forall a b. (a -> b) -> a -> b
$
        AnsiDoc -> Result Builder
forall a. AnsiDoc -> Result a
Failure
          AnsiDoc
"unable to evaluate partially applied template to normal form."

eval :: Exp Delta -> Context Term
eval :: Exp Delta -> Context Term
eval (Delta
_ :< ELit Value
l) = Term -> Context Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Term
forall a. (ToJSON a, Quote a) => a -> Term
qprim Value
l)
eval (Delta
d :< EVar Var
v) = Id -> Int -> Value -> Term
forall a. Quote a => Id -> Int -> a -> Term
quote (String -> Id
Text.pack (Var -> String
forall a. Show a => a -> String
show Var
v)) Int
0 (Value -> Term) -> ReaderT Env Result Value -> Context Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delta -> Var -> ReaderT Env Result Value
variable Delta
d Var
v
eval (Delta
d :< EFun Id
i) = do
  Maybe Term
q <- Id -> HashMap Id Term -> Maybe Term
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Id
i (HashMap Id Term -> Maybe Term)
-> ReaderT Env Result (HashMap Id Term)
-> ReaderT Env Result (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env -> HashMap Id Term) -> ReaderT Env Result (HashMap Id Term)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks Env -> HashMap Id Term
_quoted
  Context Term
-> (Term -> Context Term) -> Maybe Term -> Context Term
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (Delta -> AnsiDoc -> Context Term
forall a. Delta -> AnsiDoc -> Context a
throwError Delta
d (AnsiDoc -> Context Term) -> AnsiDoc -> Context Term
forall a b. (a -> b) -> a -> b
$ AnsiDoc
"filter" AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc -> AnsiDoc
bold (Id -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp Id
i) AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"doesn't exist.")
    Term -> Context Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Maybe Term
q
eval (Delta
_ :< EApp (Delta
_ :< EFun Id
"defined") Exp Delta
e) = Exp Delta -> Context Term
predicate Exp Delta
e
eval (Delta
d :< EApp Exp Delta
a Exp Delta
b) = do
  Term
x <- Exp Delta -> Context Term
eval Exp Delta
a
  Term
y <- Exp Delta -> Context Term
eval Exp Delta
b
  Delta -> Term -> Term -> Context Term
binding Delta
d Term
x Term
y
eval (Delta
_ :< ELet Id
k Exp Delta
rhs Exp Delta
bdy) = do
  Term
q <- Exp Delta -> Context Term
eval Exp Delta
rhs
  Value
v <- Result Value -> ReaderT Env Result Value
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Id -> Int -> Term -> Result Value
forall a. Unquote a => Id -> Int -> Term -> Result a
unquote Id
k Int
0 Term
q)
  (HashMap Id Value -> HashMap Id Value)
-> Context Term -> Context Term
forall a.
(HashMap Id Value -> HashMap Id Value) -> Context a -> Context a
bind (Id -> Value -> HashMap Id Value -> HashMap Id Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Id
k Value
v) (Exp Delta -> Context Term
eval Exp Delta
bdy)

-- FIXME: We have to recompute c everytime due to the predicate
eval (Delta
d :< ECase Exp Delta
p [Alt (Exp Delta)]
ws) = [Alt (Exp Delta)] -> Context Term
go [Alt (Exp Delta)]
ws
  where
    go :: [Alt (Exp Delta)] -> Context Term
go [] = Term -> Context Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Term
forall a. (ToJSON a, Quote a) => a -> Term
qprim (Id -> Value
String Id
forall a. Monoid a => a
mempty))
    go ((Pat
a, Exp Delta
e) : [Alt (Exp Delta)]
as) =
      case Pat
a of
        Pat
PWild -> Exp Delta -> Context Term
eval Exp Delta
e
        PVar Var
v -> Exp Delta -> Context Term
eval (Delta
d Delta -> ExpF (Exp Delta) -> Exp Delta
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Var -> ExpF (Exp Delta)
forall a. Var -> ExpF a
EVar Var
v) Context Term -> (Term -> Context Term) -> Context Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Exp Delta -> [Alt (Exp Delta)] -> Term -> Context Term
cond Exp Delta
e [Alt (Exp Delta)]
as
        PLit Value
l -> Exp Delta -> Context Term
eval (Delta
d Delta -> ExpF (Exp Delta) -> Exp Delta
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Value -> ExpF (Exp Delta)
forall a. Value -> ExpF a
ELit Value
l) Context Term -> (Term -> Context Term) -> Context Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Exp Delta -> [Alt (Exp Delta)] -> Term -> Context Term
cond Exp Delta
e [Alt (Exp Delta)]
as

    cond :: Exp Delta -> [Alt (Exp Delta)] -> Term -> Context Term
cond Exp Delta
e [Alt (Exp Delta)]
as y :: Term
y@(TVal Bool {}) = do
      Term
x <- Exp Delta -> Context Term
predicate Exp Delta
p
      if Term
x Term -> Term -> Bool
`eq` Term
y
        then Exp Delta -> Context Term
eval Exp Delta
e
        else [Alt (Exp Delta)] -> Context Term
go [Alt (Exp Delta)]
as
    cond Exp Delta
e [Alt (Exp Delta)]
as y :: Term
y@TVal {} = do
      Term
x <- Exp Delta -> Context Term
eval Exp Delta
p
      if Term
x Term -> Term -> Bool
`eq` Term
y
        then Exp Delta -> Context Term
eval Exp Delta
e
        else [Alt (Exp Delta)] -> Context Term
go [Alt (Exp Delta)]
as
    cond Exp Delta
_ [Alt (Exp Delta)]
as Term
_ = [Alt (Exp Delta)] -> Context Term
go [Alt (Exp Delta)]
as

    eq :: Term -> Term -> Bool
eq (TVal Value
a) (TVal Value
b) = Value
a Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
b
    eq Term
_ Term
_ = Bool
False
eval (Delta
_ :< ELoop Id
i Exp Delta
v Exp Delta
bdy) = Exp Delta -> Context Term
eval Exp Delta
v Context Term
-> (Term -> ReaderT Env Result Collection)
-> ReaderT Env Result Collection
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result Collection -> ReaderT Env Result Collection
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Result Collection -> ReaderT Env Result Collection)
-> (Term -> Result Collection)
-> Term
-> ReaderT Env Result Collection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Int -> Term -> Result Collection
forall a. Unquote a => Id -> Int -> Term -> Result a
unquote Id
i Int
0 ReaderT Env Result Collection
-> (Collection -> Context Term) -> Context Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Collection -> Context Term
loop
  where
    d :: Delta
d = Exp Delta -> Delta
forall t. HasDelta t => t -> Delta
Trifecta.Delta.delta Exp Delta
bdy

    loop :: Collection -> Context Term
    loop :: Collection -> Context Term
loop (Col Int
l f (Maybe Id, Value)
xs) = (Int, Term) -> Term
forall a b. (a, b) -> b
snd ((Int, Term) -> Term)
-> ReaderT Env Result (Int, Term) -> Context Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, Term)
 -> (Maybe Id, Value) -> ReaderT Env Result (Int, Term))
-> (Int, Term)
-> f (Maybe Id, Value)
-> ReaderT Env Result (Int, Term)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Foldable.foldlM (Int, Term) -> (Maybe Id, Value) -> ReaderT Env Result (Int, Term)
iter (Int
1, Value -> Term
forall a. (ToJSON a, Quote a) => a -> Term
qprim (Id -> Value
String Id
forall a. Monoid a => a
mempty)) f (Maybe Id, Value)
xs
      where
        iter :: (Int, Term) -> (Maybe Id, Value) -> ReaderT Env Result (Int, Term)
iter (Int
n, Term
p) (Maybe Id, Value)
x = do
          Int -> ReaderT Env Result ()
shadowed Int
n
          Term
q <- (HashMap Id Value -> HashMap Id Value)
-> Context Term -> Context Term
forall a.
(HashMap Id Value -> HashMap Id Value) -> Context a -> Context a
bind (Id -> Value -> HashMap Id Value -> HashMap Id Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Id
i (Int -> (Maybe Id, Value) -> Value
context Int
n (Maybe Id, Value)
x)) (Exp Delta -> Context Term
eval Exp Delta
bdy)
          Term
r <- Delta -> Term -> Term -> Context Term
binding Delta
d Term
p Term
q
          (Int, Term) -> ReaderT Env Result (Int, Term)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Term
r)

        shadowed :: Int -> ReaderT Env Result ()
shadowed Int
n = do
          HashMap Id Value
m <- (Env -> HashMap Id Value) -> ReaderT Env Result (HashMap Id Value)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks Env -> HashMap Id Value
_values
          ReaderT Env Result ()
-> (Value -> ReaderT Env Result ())
-> Maybe Value
-> ReaderT Env Result ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (() -> ReaderT Env Result ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            (Int -> Value -> ReaderT Env Result ()
shadowedErr Int
n)
            (Id -> HashMap Id Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Id
i HashMap Id Value
m)

        shadowedErr :: Int -> Value -> ReaderT Env Result ()
shadowedErr Int
n Value
x =
          Delta -> AnsiDoc -> ReaderT Env Result ()
forall a. Delta -> AnsiDoc -> Context a
throwError Delta
d (AnsiDoc -> ReaderT Env Result ())
-> AnsiDoc -> ReaderT Env Result ()
forall a b. (a -> b) -> a -> b
$
            AnsiDoc
"variable"
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc -> AnsiDoc
bold (Id -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp Id
i)
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"shadows"
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp Value
x
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"in"
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Id -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp (Int -> Id
forall a. Integral a => a -> Id
toOrdinal Int
n)
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"loop iteration."

        context :: Int -> (Maybe Id, Value) -> Value
context Int
n (Maybe Id
k, Value
x) =
          [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
            [ Id
"value" Id -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= Value
x,
              Id
"length" Id -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= Int
l,
              Id
"index" Id -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= Int
n,
              Id
"index0" Id -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1),
              Id
"remainder" Id -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n),
              Id
"remainder0" Id -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1),
              Id
"first" Id -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1),
              Id
"last" Id -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l),
              Id
"odd" Id -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1),
              Id
"even" Id -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
            ]
              [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ Maybe Id -> [Pair]
forall a v. (KeyValue a, ToJSON v) => Maybe v -> [a]
key Maybe Id
k

        key :: Maybe v -> [a]
key (Just v
k) = [Id
"key" Id -> v -> a
forall kv v. (KeyValue kv, ToJSON v) => Id -> v -> kv
.= v
k]
        key Maybe v
Nothing = []
eval (Delta
d :< EIncl Id
i) = do
  HashMap Id (Exp Delta)
ts <- (Env -> HashMap Id (Exp Delta))
-> ReaderT Env Result (HashMap Id (Exp Delta))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks Env -> HashMap Id (Exp Delta)
_templates
  case Id -> HashMap Id (Exp Delta) -> Maybe (Exp Delta)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Id
i HashMap Id (Exp Delta)
ts of
    Just Exp Delta
e -> Exp Delta -> Context Term
eval Exp Delta
e
    Maybe (Exp Delta)
Nothing ->
      Delta -> AnsiDoc -> Context Term
forall a. Delta -> AnsiDoc -> Context a
throwError Delta
d (AnsiDoc -> Context Term) -> AnsiDoc -> Context Term
forall a b. (a -> b) -> a -> b
$
        AnsiDoc
"template"
          AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc -> AnsiDoc
bold (Id -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp Id
i)
          AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"is not in scope:"
          AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann
PP.brackets (Id -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp (Id -> [Id] -> Id
Text.intercalate Id
"," ([Id] -> Id) -> [Id] -> Id
forall a b. (a -> b) -> a -> b
$ HashMap Id (Exp Delta) -> [Id]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap Id (Exp Delta)
ts))
{-# INLINEABLE eval #-}

bind :: (Object -> Object) -> Context a -> Context a
bind :: (HashMap Id Value -> HashMap Id Value) -> Context a -> Context a
bind HashMap Id Value -> HashMap Id Value
f = (Env -> Env) -> Context a -> Context a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
Reader.withReaderT (\Env
x -> Env
x {_values :: HashMap Id Value
_values = HashMap Id Value -> HashMap Id Value
f (Env -> HashMap Id Value
_values Env
x)})
{-# INLINEABLE bind #-}

variable :: Delta -> Var -> Context Value
variable :: Delta -> Var -> ReaderT Env Result Value
variable Delta
d (Var NonEmpty Id
is) =
  (Env -> HashMap Id Value) -> ReaderT Env Result (HashMap Id Value)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks Env -> HashMap Id Value
_values ReaderT Env Result (HashMap Id Value)
-> (HashMap Id Value -> ReaderT Env Result Value)
-> ReaderT Env Result Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Id] -> [Id] -> Value -> ReaderT Env Result Value
go (NonEmpty Id -> [Id]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Id
is) [] (Value -> ReaderT Env Result Value)
-> (HashMap Id Value -> Value)
-> HashMap Id Value
-> ReaderT Env Result Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Id Value -> Value
Object
  where
    go :: [Id] -> [Id] -> Value -> ReaderT Env Result Value
go [] [Id]
_ Value
v = Value -> ReaderT Env Result Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
    go (Id
k : [Id]
ks) [Id]
r Value
v = do
      HashMap Id Value
m <- Value -> ReaderT Env Result (HashMap Id Value)
nest Value
v
      ReaderT Env Result Value
-> (Value -> ReaderT Env Result Value)
-> Maybe Value
-> ReaderT Env Result Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (Delta -> AnsiDoc -> ReaderT Env Result Value
forall a. Delta -> AnsiDoc -> Context a
throwError Delta
d (AnsiDoc -> ReaderT Env Result Value)
-> AnsiDoc -> ReaderT Env Result Value
forall a b. (a -> b) -> a -> b
$ AnsiDoc
"variable" AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> AnsiDoc
forall a. AnsiPretty a => a -> AnsiDoc
apretty Var
cur AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"doesn't exist.")
        ([Id] -> [Id] -> Value -> ReaderT Env Result Value
go [Id]
ks (Id
k Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
r))
        (Id -> HashMap Id Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Id
k HashMap Id Value
m)
      where
        cur :: Var
cur = NonEmpty Id -> Var
Var (Id
k Id -> [Id] -> NonEmpty Id
forall a. a -> [a] -> NonEmpty a
:| [Id]
r)

        nest :: Value -> Context Object
        nest :: Value -> ReaderT Env Result (HashMap Id Value)
nest (Object HashMap Id Value
o) = HashMap Id Value -> ReaderT Env Result (HashMap Id Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Id Value
o
        nest Value
x =
          Delta -> AnsiDoc -> ReaderT Env Result (HashMap Id Value)
forall a. Delta -> AnsiDoc -> Context a
throwError Delta
d (AnsiDoc -> ReaderT Env Result (HashMap Id Value))
-> AnsiDoc -> ReaderT Env Result (HashMap Id Value)
forall a b. (a -> b) -> a -> b
$
            AnsiDoc
"variable"
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> AnsiDoc
forall a. AnsiPretty a => a -> AnsiDoc
apretty Var
cur
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"::"
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp Value
x
              AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"doesn't supported nested accessors."
{-# INLINEABLE variable #-}

-- | A variable can be tested for truthiness, but a non-whnf expr cannot.
predicate :: Exp Delta -> Context Term
predicate :: Exp Delta -> Context Term
predicate Exp Delta
x =
  Context Term -> Env -> Result Term
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT (Exp Delta -> Context Term
eval Exp Delta
x) (Env -> Result Term)
-> ReaderT Env Result Env -> ReaderT Env Result (Result Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env Result Env
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask
    ReaderT Env Result (Result Term)
-> (Result Term -> Context Term) -> Context Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result Term -> Context Term
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Result Term -> Context Term)
-> (Result Term -> Result Term) -> Result Term -> Context Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Success Term
q
        | TVal Bool {} <- Term
q -> Term -> Result Term
forall a. a -> Result a
Success Term
q
      Success Term
q
        | TVal Value
Null <- Term
q -> Term -> Result Term
forall a. a -> Result a
Success (Bool -> Term
forall a. (ToJSON a, Quote a) => a -> Term
qprim Bool
False)
      Success Term
_ -> Term -> Result Term
forall a. a -> Result a
Success (Bool -> Term
forall a. (ToJSON a, Quote a) => a -> Term
qprim Bool
True)
      Failure AnsiDoc
_
        | Delta
_ :< EVar {} <- Exp Delta
x -> Term -> Result Term
forall a. a -> Result a
Success (Bool -> Term
forall a. (ToJSON a, Quote a) => a -> Term
qprim Bool
False)
      Failure AnsiDoc
e -> AnsiDoc -> Result Term
forall a. AnsiDoc -> Result a
Failure AnsiDoc
e
{-# INLINEABLE predicate #-}

binding :: Delta -> Term -> Term -> Context Term
binding :: Delta -> Term -> Term -> Context Term
binding Delta
d Term
x Term
y =
  case (Term
x, Term
y) of
    (TVal Value
l, TVal Value
r) -> Id -> Int -> Builder -> Term
forall a. Quote a => Id -> Int -> a -> Term
quote Id
"<>" Int
0 (Builder -> Term) -> ReaderT Env Result Builder -> Context Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Builder -> Builder -> Builder)
-> ReaderT Env Result Builder
-> ReaderT Env Result Builder
-> ReaderT Env Result Builder
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
Monad.liftM2 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
(<>) (Delta -> Value -> ReaderT Env Result Builder
build Delta
d Value
l) (Delta -> Value -> ReaderT Env Result Builder
build Delta
d Value
r)
    (Term, Term)
_ -> Result Term -> Context Term
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Delta -> Term -> Term -> Result Term
qapply Delta
d Term
x Term
y)
{-# INLINEABLE binding #-}

build :: Delta -> Value -> Context Builder
build :: Delta -> Value -> ReaderT Env Result Builder
build Delta
_ Value
Null = Builder -> ReaderT Env Result Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
forall a. Monoid a => a
mempty
build Delta
_ (String Id
t) = Builder -> ReaderT Env Result Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> Builder
Text.Builder.fromText Id
t)
build Delta
_ (Bool Bool
True) = Builder -> ReaderT Env Result Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
"true"
build Delta
_ (Bool Bool
False) = Builder -> ReaderT Env Result Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
"false"
build Delta
_ (Number Scientific
n)
  | Scientific -> Bool
isFloating Scientific
n = Builder -> ReaderT Env Result Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FPFormat -> Maybe Int -> Scientific -> Builder
formatScientificBuilder FPFormat
Fixed Maybe Int
forall a. Maybe a
Nothing Scientific
n)
  | Bool
otherwise = Builder -> ReaderT Env Result Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FPFormat -> Maybe Int -> Scientific -> Builder
formatScientificBuilder FPFormat
Fixed (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) Scientific
n)
build Delta
d Value
x =
  Delta -> AnsiDoc -> ReaderT Env Result Builder
forall a. Delta -> AnsiDoc -> Context a
throwError Delta
d (AnsiDoc
"unable to render literal" AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp Value
x)
{-# INLINEABLE build #-}

-- FIXME: Add delta information to the thrown error document.
throwError :: Delta -> AnsiDoc -> Context a
throwError :: Delta -> AnsiDoc -> Context a
throwError Delta
d AnsiDoc
doc =
  Result a -> Context a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Result a -> Context a)
-> (AnsiDoc -> Result a) -> AnsiDoc -> Context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnsiDoc -> Result a
forall a. AnsiDoc -> Result a
Failure (AnsiDoc -> Context a) -> AnsiDoc -> Context a
forall a b. (a -> b) -> a -> b
$ Delta -> AnsiDoc
Trifecta.Delta.prettyDelta Delta
d AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc -> AnsiDoc
red AnsiDoc
"error:" AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
doc