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

-- |
-- Module      : Text.EDE.Internal.Eval
-- Copyright   : (c) 2013-2022 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 (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 Data.Text (Text)
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 Prettyprinter ((<+>))
import qualified Prettyprinter as PP
import Text.EDE.Internal.Compat
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 -> Bool
_extends :: Bool,
    Env -> HashMap Id (Cofree ExpF Delta)
_templates :: HashMap Id (Exp Delta),
    Env -> HashMap Id Term
_quoted :: HashMap Id Term,
    Env -> HashMap Id Value
_values :: HashMap Id Value,
    Env -> HashMap Id (Cofree ExpF Delta)
_blocks :: HashMap Id (Exp Delta)
  }

type Context = ReaderT Env Result

render ::
  HashMap Id (Exp Delta) ->
  HashMap Id Term ->
  Exp Delta ->
  HashMap Id Value ->
  Result Builder
render :: HashMap Id (Cofree ExpF Delta)
-> HashMap Id Term
-> Cofree ExpF Delta
-> HashMap Id Value
-> Result Builder
render HashMap Id (Cofree ExpF Delta)
ts HashMap Id Term
fs Cofree ExpF 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 (Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
e Context Term
-> (Term -> ReaderT Env Result Builder)
-> ReaderT Env Result Builder
forall a b.
ReaderT Env Result a
-> (a -> ReaderT Env Result b) -> ReaderT Env Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Term -> ReaderT Env Result Builder
nf) (Bool
-> HashMap Id (Cofree ExpF Delta)
-> HashMap Id Term
-> HashMap Id Value
-> HashMap Id (Cofree ExpF Delta)
-> Env
Env Bool
False HashMap Id (Cofree ExpF 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 HashMap Id (Cofree ExpF Delta)
forall a. Monoid a => a
mempty)
  where
    nf :: Term -> ReaderT Env Result Builder
nf (TVal Value
v) = Delta -> Value -> ReaderT Env Result Builder
build (Cofree ExpF Delta -> Delta
forall t. HasDelta t => t -> Delta
Trifecta.Delta.delta Cofree ExpF Delta
e) Value
v
    nf Term
_ =
      Result Builder -> ReaderT Env Result Builder
forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
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
$
        Doc AnsiStyle -> Result Builder
forall a. Doc AnsiStyle -> Result a
Failure
          Doc AnsiStyle
"unable to evaluate partially applied template to normal form."

eval :: Exp Delta -> Context Term
eval :: Cofree ExpF Delta -> Context Term
eval (Delta
_ :< ELit Value
l) = Term -> Context Term
forall a. a -> ReaderT Env Result a
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 -> Doc AnsiStyle -> Context Term
forall a. Delta -> Doc AnsiStyle -> Context a
throwError Delta
d (Doc AnsiStyle -> Context Term) -> Doc AnsiStyle -> Context Term
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"filter" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
bold (Id -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp Id
i) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"doesn't exist.")
    Term -> Context Term
forall a. a -> ReaderT Env Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Maybe Term
q
eval (Delta
_ :< EApp (Delta
_ :< EFun Id
"defined") Cofree ExpF Delta
e) = Cofree ExpF Delta -> Context Term
predicate Cofree ExpF Delta
e
eval (Delta
d :< EApp Cofree ExpF Delta
a Cofree ExpF Delta
b) = do
  Term
x <- Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
a
  Term
y <- Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
b
  Delta -> Term -> Term -> Context Term
binding Delta
d Term
x Term
y
eval (Delta
d :< EOverrideBlock Id
i Cofree ExpF Delta
b Cofree ExpF Delta
e) =
  Bool -> Context Term -> Context Term
forall a. Bool -> Context a -> Context a
setExtended Bool
True (Context Term -> Context Term) -> Context Term -> Context Term
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Cofree ExpF Delta)
q <- Id -> HashMap Id (Cofree ExpF Delta) -> Maybe (Cofree ExpF Delta)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Id
i (HashMap Id (Cofree ExpF Delta) -> Maybe (Cofree ExpF Delta))
-> ReaderT Env Result (HashMap Id (Cofree ExpF Delta))
-> ReaderT Env Result (Maybe (Cofree ExpF Delta))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env -> HashMap Id (Cofree ExpF Delta))
-> ReaderT Env Result (HashMap Id (Cofree ExpF Delta))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks Env -> HashMap Id (Cofree ExpF Delta)
_blocks
    case Maybe (Cofree ExpF Delta)
q of
      Maybe (Cofree ExpF Delta)
Nothing ->
        (HashMap Id (Cofree ExpF Delta) -> HashMap Id (Cofree ExpF Delta))
-> Context Term -> Context Term
forall a.
(HashMap Id (Cofree ExpF Delta) -> HashMap Id (Cofree ExpF Delta))
-> Context a -> Context a
bindBlock (Id
-> Cofree ExpF Delta
-> HashMap Id (Cofree ExpF Delta)
-> HashMap Id (Cofree ExpF Delta)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Id
i Cofree ExpF Delta
b) (Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
e)
      Just Cofree ExpF Delta
eb ->
        (HashMap Id (Cofree ExpF Delta) -> HashMap Id (Cofree ExpF Delta))
-> Context Term -> Context Term
forall a.
(HashMap Id (Cofree ExpF Delta) -> HashMap Id (Cofree ExpF Delta))
-> Context a -> Context a
bindBlock (Id
-> Cofree ExpF Delta
-> HashMap Id (Cofree ExpF Delta)
-> HashMap Id (Cofree ExpF Delta)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Id
i (Delta
d Delta -> ExpF (Cofree ExpF Delta) -> Cofree ExpF Delta
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Id
-> Cofree ExpF Delta
-> Cofree ExpF Delta
-> ExpF (Cofree ExpF Delta)
forall a. Id -> a -> a -> ExpF a
ELet Id
"super" Cofree ExpF Delta
b Cofree ExpF Delta
eb)) (Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
e)
eval (Delta
_ :< EBlock Id
i Cofree ExpF Delta
b) = do
  Bool
extends <- (Env -> Bool) -> ReaderT Env Result Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks Env -> Bool
_extends
  Maybe (Cofree ExpF Delta)
q <- Id -> HashMap Id (Cofree ExpF Delta) -> Maybe (Cofree ExpF Delta)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Id
i (HashMap Id (Cofree ExpF Delta) -> Maybe (Cofree ExpF Delta))
-> ReaderT Env Result (HashMap Id (Cofree ExpF Delta))
-> ReaderT Env Result (Maybe (Cofree ExpF Delta))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env -> HashMap Id (Cofree ExpF Delta))
-> ReaderT Env Result (HashMap Id (Cofree ExpF Delta))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks Env -> HashMap Id (Cofree ExpF Delta)
_blocks
  if Bool
extends then
    Term -> Context Term
forall a. a -> ReaderT Env Result a
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))
  else do
    Term
x <- Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
b
    Value
v <- Result Value -> ReaderT Env Result Value
forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
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
i Int
0 Term
x)
    Context Term
-> (Cofree ExpF Delta -> Context Term)
-> Maybe (Cofree ExpF Delta)
-> Context Term
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (Term -> Context Term
forall a. a -> ReaderT Env Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
x)
      ((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
"super" Value
v) (Context Term -> Context Term)
-> (Cofree ExpF Delta -> Context Term)
-> Cofree ExpF Delta
-> Context Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cofree ExpF Delta -> Context Term
eval)
      Maybe (Cofree ExpF Delta)
q
eval (Delta
_ :< ELet Id
k Cofree ExpF Delta
rhs Cofree ExpF Delta
bdy) = do
  Term
q <- Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
rhs
  Value
v <- Result Value -> ReaderT Env Result Value
forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
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) (Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
bdy)

-- FIXME: We have to recompute c everytime due to the predicate
eval (Delta
d :< ECase Cofree ExpF Delta
p [Alt (Cofree ExpF Delta)]
ws) = [Alt (Cofree ExpF Delta)] -> Context Term
go [Alt (Cofree ExpF Delta)]
ws
  where
    go :: [Alt (Cofree ExpF Delta)] -> Context Term
go [] = Term -> Context Term
forall a. a -> ReaderT Env Result a
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, Cofree ExpF Delta
e) : [Alt (Cofree ExpF Delta)]
as) =
      case Pat
a of
        Pat
PWild -> Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
e
        PVar Var
v -> Cofree ExpF Delta -> Context Term
eval (Delta
d Delta -> ExpF (Cofree ExpF Delta) -> Cofree ExpF Delta
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Var -> ExpF (Cofree ExpF Delta)
forall a. Var -> ExpF a
EVar Var
v) Context Term -> (Term -> Context Term) -> Context Term
forall a b.
ReaderT Env Result a
-> (a -> ReaderT Env Result b) -> ReaderT Env Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cofree ExpF Delta
-> [Alt (Cofree ExpF Delta)] -> Term -> Context Term
cond Cofree ExpF Delta
e [Alt (Cofree ExpF Delta)]
as
        PLit Value
l -> Cofree ExpF Delta -> Context Term
eval (Delta
d Delta -> ExpF (Cofree ExpF Delta) -> Cofree ExpF Delta
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Value -> ExpF (Cofree ExpF Delta)
forall a. Value -> ExpF a
ELit Value
l) Context Term -> (Term -> Context Term) -> Context Term
forall a b.
ReaderT Env Result a
-> (a -> ReaderT Env Result b) -> ReaderT Env Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cofree ExpF Delta
-> [Alt (Cofree ExpF Delta)] -> Term -> Context Term
cond Cofree ExpF Delta
e [Alt (Cofree ExpF Delta)]
as

    cond :: Cofree ExpF Delta
-> [Alt (Cofree ExpF Delta)] -> Term -> Context Term
cond Cofree ExpF Delta
e [Alt (Cofree ExpF Delta)]
as y :: Term
y@(TVal Bool {}) = do
      Term
x <- Cofree ExpF Delta -> Context Term
predicate Cofree ExpF Delta
p
      if Term
x Term -> Term -> Bool
`eq` Term
y
        then Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
e
        else [Alt (Cofree ExpF Delta)] -> Context Term
go [Alt (Cofree ExpF Delta)]
as
    cond Cofree ExpF Delta
e [Alt (Cofree ExpF Delta)]
as y :: Term
y@TVal {} = do
      Term
x <- Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
p
      if Term
x Term -> Term -> Bool
`eq` Term
y
        then Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
e
        else [Alt (Cofree ExpF Delta)] -> Context Term
go [Alt (Cofree ExpF Delta)]
as
    cond Cofree ExpF Delta
_ [Alt (Cofree ExpF Delta)]
as Term
_ = [Alt (Cofree ExpF Delta)] -> Context Term
go [Alt (Cofree ExpF 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 Cofree ExpF Delta
v Cofree ExpF Delta
bdy) = Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
v Context Term
-> (Term -> ReaderT Env Result Collection)
-> ReaderT Env Result Collection
forall a b.
ReaderT Env Result a
-> (a -> ReaderT Env Result b) -> ReaderT Env Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result Collection -> ReaderT Env Result Collection
forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
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 a b.
ReaderT Env Result a
-> (a -> ReaderT Env Result b) -> ReaderT Env Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Collection -> Context Term
loop
  where
    d :: Delta
d = Cofree ExpF Delta -> Delta
forall t. HasDelta t => t -> Delta
Trifecta.Delta.delta Cofree ExpF 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)) (Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
bdy)
          Term
r <- Delta -> Term -> Term -> Context Term
binding Delta
d Term
p Term
q
          (Int, Term) -> ReaderT Env Result (Int, Term)
forall a. a -> ReaderT Env Result a
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 a. a -> ReaderT Env Result a
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 -> Doc AnsiStyle -> ReaderT Env Result ()
forall a. Delta -> Doc AnsiStyle -> Context a
throwError Delta
d (Doc AnsiStyle -> ReaderT Env Result ())
-> Doc AnsiStyle -> ReaderT Env Result ()
forall a b. (a -> b) -> a -> b
$
            Doc AnsiStyle
"variable"
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
bold (Id -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp Id
i)
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"shadows"
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp Value
x
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"in"
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Id -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp (Int -> Id
forall a. Integral a => a -> Id
toOrdinal Int
n)
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"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
$
            [ Key
"value" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
x,
              Key
"length" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
l,
              Key
"index" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
n,
              Key
"index0" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1),
              Key
"remainder" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n),
              Key
"remainder0" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> 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),
              Key
"first" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1),
              Key
"last" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l),
              Key
"odd" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> 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),
              Key
"even" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> 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 {e} {a} {v}. (KeyValue e a, ToJSON v) => Maybe v -> [a]
key Maybe Id
k

        key :: Maybe v -> [a]
key (Just v
k) = [Key
"key" Key -> v -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
k]
        key Maybe v
Nothing = []
eval (Delta
d :< EIncl Id
i) = do
  HashMap Id (Cofree ExpF Delta)
ts <- (Env -> HashMap Id (Cofree ExpF Delta))
-> ReaderT Env Result (HashMap Id (Cofree ExpF Delta))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks Env -> HashMap Id (Cofree ExpF Delta)
_templates
  case Id -> HashMap Id (Cofree ExpF Delta) -> Maybe (Cofree ExpF Delta)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Id
i HashMap Id (Cofree ExpF Delta)
ts of
    Just Cofree ExpF Delta
e ->
      -- Don't inherit any blocks declared so far.
      Bool -> Context Term -> Context Term
forall a. Bool -> Context a -> Context a
setExtended Bool
False (Context Term -> Context Term) -> Context Term -> Context Term
forall a b. (a -> b) -> a -> b
$
        (HashMap Id (Cofree ExpF Delta) -> HashMap Id (Cofree ExpF Delta))
-> Context Term -> Context Term
forall a.
(HashMap Id (Cofree ExpF Delta) -> HashMap Id (Cofree ExpF Delta))
-> Context a -> Context a
bindBlock (\HashMap Id (Cofree ExpF Delta)
_ -> HashMap Id (Cofree ExpF Delta)
forall a. Monoid a => a
mempty) (Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
e)
    Maybe (Cofree ExpF Delta)
Nothing ->
      Delta -> Doc AnsiStyle -> Context Term
forall a. Delta -> Doc AnsiStyle -> Context a
throwError Delta
d (Doc AnsiStyle -> Context Term) -> Doc AnsiStyle -> Context Term
forall a b. (a -> b) -> a -> b
$
        Doc AnsiStyle
"template"
          Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
bold (Id -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp Id
i)
          Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is not in scope:"
          Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
PP.brackets (Id -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp (Id -> [Id] -> Id
Text.intercalate Id
"," ([Id] -> Id) -> [Id] -> Id
forall a b. (a -> b) -> a -> b
$ HashMap Id (Cofree ExpF Delta) -> [Id]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap Id (Cofree ExpF Delta)
ts))
eval (Delta
d :< EExt Id
i) = do
  HashMap Id (Cofree ExpF Delta)
ts <- (Env -> HashMap Id (Cofree ExpF Delta))
-> ReaderT Env Result (HashMap Id (Cofree ExpF Delta))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.asks Env -> HashMap Id (Cofree ExpF Delta)
_templates
  case Id -> HashMap Id (Cofree ExpF Delta) -> Maybe (Cofree ExpF Delta)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Id
i HashMap Id (Cofree ExpF Delta)
ts of
    Just Cofree ExpF Delta
e ->
      Bool -> Context Term -> Context Term
forall a. Bool -> Context a -> Context a
setExtended Bool
False (Cofree ExpF Delta -> Context Term
eval Cofree ExpF Delta
e)
    Maybe (Cofree ExpF Delta)
Nothing ->
      Delta -> Doc AnsiStyle -> Context Term
forall a. Delta -> Doc AnsiStyle -> Context a
throwError Delta
d (Doc AnsiStyle -> Context Term) -> Doc AnsiStyle -> Context Term
forall a b. (a -> b) -> a -> b
$
        Doc AnsiStyle
"template"
          Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
bold (Id -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp Id
i)
          Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is not in scope:"
          Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
PP.brackets (Id -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp (Id -> [Id] -> Id
Text.intercalate Id
"," ([Id] -> Id) -> [Id] -> Id
forall a b. (a -> b) -> a -> b
$ HashMap Id (Cofree ExpF Delta) -> [Id]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap Id (Cofree ExpF Delta)
ts))
{-# INLINEABLE eval #-}

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

bindBlock :: (HashMap Id (Exp Delta) -> HashMap Id (Exp Delta)) -> Context a -> Context a
bindBlock :: forall a.
(HashMap Id (Cofree ExpF Delta) -> HashMap Id (Cofree ExpF Delta))
-> Context a -> Context a
bindBlock HashMap Id (Cofree ExpF Delta) -> HashMap Id (Cofree ExpF Delta)
f = (Env -> Env) -> ReaderT Env Result a -> ReaderT Env Result a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
Reader.withReaderT (\Env
x -> Env
x {_blocks = f (_blocks x)})
{-# INLINEABLE bindBlock #-}

setExtended :: Bool -> Context a -> Context a
setExtended :: forall a. Bool -> Context a -> Context a
setExtended Bool
extends =
  (Env -> Env) -> ReaderT Env Result a -> ReaderT Env Result a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
Reader.withReaderT (\Env
x -> Env
x { _extends = extends })
{-# INLINEABLE setExtended #-}

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 a b.
ReaderT Env Result a
-> (a -> ReaderT Env Result b) -> ReaderT Env Result b
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
. Object -> Value
Object (Object -> Value)
-> (HashMap Id Value -> Object) -> HashMap Id Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Id Value -> Object
forall v. HashMap Id v -> KeyMap v
fromHashMapText
  where
    go :: [Id] -> [Id] -> Value -> ReaderT Env Result Value
go [] [Id]
_ Value
v = Value -> ReaderT Env Result Value
forall a. a -> ReaderT Env Result a
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 -> Doc AnsiStyle -> ReaderT Env Result Value
forall a. Delta -> Doc AnsiStyle -> Context a
throwError Delta
d (Doc AnsiStyle -> ReaderT Env Result Value)
-> Doc AnsiStyle -> ReaderT Env Result Value
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"variable" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc AnsiStyle
forall a. AnsiPretty a => a -> Doc AnsiStyle
apretty Var
cur Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"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 (HashMap Text Value)
        nest :: Value -> ReaderT Env Result (HashMap Id Value)
nest (Object Object
o) = HashMap Id Value -> ReaderT Env Result (HashMap Id Value)
forall a. a -> ReaderT Env Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> HashMap Id Value
forall v. KeyMap v -> HashMap Id v
toHashMapText Object
o)
        nest Value
x =
          Delta -> Doc AnsiStyle -> ReaderT Env Result (HashMap Id Value)
forall a. Delta -> Doc AnsiStyle -> Context a
throwError Delta
d (Doc AnsiStyle -> ReaderT Env Result (HashMap Id Value))
-> Doc AnsiStyle -> ReaderT Env Result (HashMap Id Value)
forall a b. (a -> b) -> a -> b
$
            Doc AnsiStyle
"variable"
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc AnsiStyle
forall a. AnsiPretty a => a -> Doc AnsiStyle
apretty Var
cur
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"::"
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp Value
x
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"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 :: Cofree ExpF Delta -> Context Term
predicate Cofree ExpF Delta
x =
  Context Term -> Env -> Result Term
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT (Cofree ExpF Delta -> Context Term
eval Cofree ExpF 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 a b.
ReaderT Env Result a
-> (a -> ReaderT Env Result b) -> ReaderT Env Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result Term -> Context Term
forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
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 Doc AnsiStyle
_
        | Delta
_ :< EVar {} <- Cofree ExpF 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 Doc AnsiStyle
e -> Doc AnsiStyle -> Result Term
forall a. Doc AnsiStyle -> Result a
Failure Doc AnsiStyle
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 (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
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 a. a -> ReaderT Env Result a
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 a. a -> ReaderT Env Result a
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 a. a -> ReaderT Env Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
"true"
build Delta
_ (Bool Bool
False) = Builder -> ReaderT Env Result Builder
forall a. a -> ReaderT Env Result a
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 a. a -> ReaderT Env Result a
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 a. a -> ReaderT Env Result a
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 -> Doc AnsiStyle -> ReaderT Env Result Builder
forall a. Delta -> Doc AnsiStyle -> Context a
throwError Delta
d (Doc AnsiStyle
"unable to render literal" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc AnsiStyle
forall a. AnsiPretty (PP a) => a -> Doc AnsiStyle
pp Value
x)
{-# INLINEABLE build #-}

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