{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Text.HSmarty.Render.Engine
  ( ParamMap,
    mkParam,
    SmartyCtx,
    SmartyError (..),
    prepareTemplate,
    prepareTemplates,
    applyTemplate,
    applyTemplateFromJson,
  )
where

import Control.Monad
import Control.Monad.Except
import Control.Monad.Identity
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as AK
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Lazy as BSL
import Data.Char (ord)
import qualified Data.HashMap.Strict as HM
import Data.Maybe
import Data.Scientific
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import Data.Vector ((!?))
import qualified Data.Vector as V
import Network.HTTP.Base (urlEncode)
import System.FilePath
import System.FilePath.Glob
import Text.HSmarty.Parser.Smarty
import Text.HSmarty.Types

data TemplateVar = TemplateVar
  { TemplateVar -> Value
tv_value :: A.Value,
    TemplateVar -> PropMap
tv_props :: PropMap
  }
  deriving (Int -> TemplateVar -> ShowS
[TemplateVar] -> ShowS
TemplateVar -> String
(Int -> TemplateVar -> ShowS)
-> (TemplateVar -> String)
-> ([TemplateVar] -> ShowS)
-> Show TemplateVar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TemplateVar] -> ShowS
$cshowList :: [TemplateVar] -> ShowS
show :: TemplateVar -> String
$cshow :: TemplateVar -> String
showsPrec :: Int -> TemplateVar -> ShowS
$cshowsPrec :: Int -> TemplateVar -> ShowS
Show, TemplateVar -> TemplateVar -> Bool
(TemplateVar -> TemplateVar -> Bool)
-> (TemplateVar -> TemplateVar -> Bool) -> Eq TemplateVar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TemplateVar -> TemplateVar -> Bool
$c/= :: TemplateVar -> TemplateVar -> Bool
== :: TemplateVar -> TemplateVar -> Bool
$c== :: TemplateVar -> TemplateVar -> Bool
Eq)

-- | Maps template variables to template params
type ParamMap = HM.HashMap T.Text A.Value

type PropMap = HM.HashMap T.Text A.Value

mkParam :: A.ToJSON a => a -> A.Value
mkParam :: a -> Value
mkParam = a -> Value
forall a. ToJSON a => a -> Value
A.toJSON

type EvalM m a = ExceptT SmartyError m a

newtype SmartyCtx = SmartyCtx
  { SmartyCtx -> HashMap String Smarty
unSmartyCtx :: HM.HashMap FilePath Smarty
  }
  deriving (Int -> SmartyCtx -> ShowS
[SmartyCtx] -> ShowS
SmartyCtx -> String
(Int -> SmartyCtx -> ShowS)
-> (SmartyCtx -> String)
-> ([SmartyCtx] -> ShowS)
-> Show SmartyCtx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SmartyCtx] -> ShowS
$cshowList :: [SmartyCtx] -> ShowS
show :: SmartyCtx -> String
$cshow :: SmartyCtx -> String
showsPrec :: Int -> SmartyCtx -> ShowS
$cshowsPrec :: Int -> SmartyCtx -> ShowS
Show, SmartyCtx -> SmartyCtx -> Bool
(SmartyCtx -> SmartyCtx -> Bool)
-> (SmartyCtx -> SmartyCtx -> Bool) -> Eq SmartyCtx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SmartyCtx -> SmartyCtx -> Bool
$c/= :: SmartyCtx -> SmartyCtx -> Bool
== :: SmartyCtx -> SmartyCtx -> Bool
$c== :: SmartyCtx -> SmartyCtx -> Bool
Eq)

data Env = Env
  { Env -> HashMap Text TemplateVar
e_var :: HM.HashMap T.Text TemplateVar,
    Env -> HashMap Text ([SmartyStmt], [(Text, Value)])
e_fun :: HM.HashMap T.Text ([SmartyStmt], [(T.Text, A.Value)]),
    Env -> SmartyCtx
e_ctx :: SmartyCtx
  }
  deriving (Int -> Env -> ShowS
[Env] -> ShowS
Env -> String
(Int -> Env -> ShowS)
-> (Env -> String) -> ([Env] -> ShowS) -> Show Env
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Env] -> ShowS
$cshowList :: [Env] -> ShowS
show :: Env -> String
$cshow :: Env -> String
showsPrec :: Int -> Env -> ShowS
$cshowsPrec :: Int -> Env -> ShowS
Show, Env -> Env -> Bool
(Env -> Env -> Bool) -> (Env -> Env -> Bool) -> Eq Env
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Env -> Env -> Bool
$c/= :: Env -> Env -> Bool
== :: Env -> Env -> Bool
$c== :: Env -> Env -> Bool
Eq)

newtype SmartyError = SmartyError {SmartyError -> Text
unSmartyError :: T.Text}
  deriving (Int -> SmartyError -> ShowS
[SmartyError] -> ShowS
SmartyError -> String
(Int -> SmartyError -> ShowS)
-> (SmartyError -> String)
-> ([SmartyError] -> ShowS)
-> Show SmartyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SmartyError] -> ShowS
$cshowList :: [SmartyError] -> ShowS
show :: SmartyError -> String
$cshow :: SmartyError -> String
showsPrec :: Int -> SmartyError -> ShowS
$cshowsPrec :: Int -> SmartyError -> ShowS
Show, SmartyError -> SmartyError -> Bool
(SmartyError -> SmartyError -> Bool)
-> (SmartyError -> SmartyError -> Bool) -> Eq SmartyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SmartyError -> SmartyError -> Bool
$c/= :: SmartyError -> SmartyError -> Bool
== :: SmartyError -> SmartyError -> Bool
$c== :: SmartyError -> SmartyError -> Bool
Eq)

wrapSmartyCapture :: A.Value -> PropMap -> TemplateVar
wrapSmartyCapture :: Value -> PropMap -> TemplateVar
wrapSmartyCapture Value
x = Value -> PropMap -> TemplateVar
TemplateVar (Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KM.singleton Key
"capture" Value
x)

updateSmartyCapture :: T.Text -> A.Value -> HM.HashMap T.Text TemplateVar -> HM.HashMap T.Text TemplateVar
updateSmartyCapture :: Text
-> Value -> HashMap Text TemplateVar -> HashMap Text TemplateVar
updateSmartyCapture Text
key Value
value HashMap Text TemplateVar
hm =
  let updatedVal :: TemplateVar
updatedVal =
        case Text -> HashMap Text TemplateVar -> Maybe TemplateVar
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"smarty" HashMap Text TemplateVar
hm of
          Maybe TemplateVar
Nothing -> Value -> PropMap -> TemplateVar
wrapSmartyCapture (Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KM.singleton (Text -> Key
AK.fromText Text
key) Value
value) PropMap
forall a. Monoid a => a
mempty
          Just (TemplateVar Value
existingCtx PropMap
oldProps) ->
            case Value
existingCtx of
              A.Object Object
oldContext ->
                Value -> PropMap -> TemplateVar
wrapSmartyCapture (Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (Text -> Key
AK.fromText Text
key) Value
value Object
oldContext) PropMap
oldProps
              Value
_ -> String -> TemplateVar
forall a. HasCallStack => String -> a
error String
"Smarty capture context is always a map!"
   in Text
-> TemplateVar
-> HashMap Text TemplateVar
-> HashMap Text TemplateVar
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
"smarty" TemplateVar
updatedVal HashMap Text TemplateVar
hm

rootMap :: HM.HashMap T.Text TemplateVar
rootMap :: HashMap Text TemplateVar
rootMap = Text -> TemplateVar -> HashMap Text TemplateVar
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton Text
"smarty" (Value -> PropMap -> TemplateVar
wrapSmartyCapture (Object -> Value
A.Object Object
forall a. Monoid a => a
mempty) PropMap
forall a. Monoid a => a
mempty)

mkEnv :: ParamMap -> SmartyCtx -> Env
mkEnv :: PropMap -> SmartyCtx -> Env
mkEnv PropMap
pm SmartyCtx
ctx =
  Env :: HashMap Text TemplateVar
-> HashMap Text ([SmartyStmt], [(Text, Value)]) -> SmartyCtx -> Env
Env
    { e_var :: HashMap Text TemplateVar
e_var = HashMap Text TemplateVar
rootMap HashMap Text TemplateVar
-> HashMap Text TemplateVar -> HashMap Text TemplateVar
forall a. Semigroup a => a -> a -> a
<> (Value -> TemplateVar) -> PropMap -> HashMap Text TemplateVar
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.map (\Value
init' -> Value -> PropMap -> TemplateVar
TemplateVar Value
init' PropMap
forall k v. HashMap k v
HM.empty) PropMap
pm,
      e_fun :: HashMap Text ([SmartyStmt], [(Text, Value)])
e_fun = HashMap Text ([SmartyStmt], [(Text, Value)])
forall k v. HashMap k v
HM.empty,
      e_ctx :: SmartyCtx
e_ctx = SmartyCtx
ctx
    }

-- | Parse and compile a template
prepareTemplate :: FilePath -> IO SmartyCtx
prepareTemplate :: String -> IO SmartyCtx
prepareTemplate String
fp =
  do
    Text
ct <- String -> IO Text
T.readFile String
fp
    HashMap String Smarty
tpl <- String -> Smarty -> HashMap String Smarty
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton String
fp (Smarty -> HashMap String Smarty)
-> IO Smarty -> IO (HashMap String Smarty)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Text -> IO Smarty
forall (m :: * -> *). MonadFail m => String -> Text -> m Smarty
parseSmarty String
fp Text
ct
    SmartyCtx -> IO SmartyCtx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SmartyCtx -> IO SmartyCtx) -> SmartyCtx -> IO SmartyCtx
forall a b. (a -> b) -> a -> b
$ HashMap String Smarty -> SmartyCtx
SmartyCtx HashMap String Smarty
tpl

-- | Parse and compiles templates matching a glob in a directiry
prepareTemplates :: String -> FilePath -> IO SmartyCtx
prepareTemplates :: String -> String -> IO SmartyCtx
prepareTemplates String
pat String
dir =
  do
    [String]
files <- Pattern -> String -> IO [String]
globDir1 (String -> Pattern
compile String
pat) String
dir
    let dirDropper :: ShowS
dirDropper =
          String -> ShowS
makeRelative String
dir
    HashMap String Smarty
ctx <-
      (HashMap String Smarty -> String -> IO (HashMap String Smarty))
-> HashMap String Smarty -> [String] -> IO (HashMap String Smarty)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
        ( \HashMap String Smarty
hm String
f ->
            do
              Smarty
ct <- String -> IO Text
T.readFile String
f IO Text -> (Text -> IO Smarty) -> IO Smarty
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Text -> IO Smarty
forall (m :: * -> *). MonadFail m => String -> Text -> m Smarty
parseSmarty String
f
              HashMap String Smarty -> IO (HashMap String Smarty)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Smarty -> HashMap String Smarty -> HashMap String Smarty
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (ShowS
dirDropper String
f) Smarty
ct HashMap String Smarty
hm)
        )
        HashMap String Smarty
forall a. Monoid a => a
mempty
        [String]
files
    SmartyCtx -> IO SmartyCtx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SmartyCtx -> IO SmartyCtx) -> SmartyCtx -> IO SmartyCtx
forall a b. (a -> b) -> a -> b
$ HashMap String Smarty -> SmartyCtx
SmartyCtx HashMap String Smarty
ctx

-- | Fill a template with values and print it as Text
applyTemplateFromJson :: A.ToJSON a => FilePath -> SmartyCtx -> a -> Either SmartyError T.Text
applyTemplateFromJson :: String -> SmartyCtx -> a -> Either SmartyError Text
applyTemplateFromJson String
a SmartyCtx
b a
c =
  case a -> Value
forall a. ToJSON a => a -> Value
A.toJSON a
c of
    A.Object Object
hm -> Identity (Either SmartyError Text) -> Either SmartyError Text
forall a. Identity a -> a
runIdentity (Identity (Either SmartyError Text) -> Either SmartyError Text)
-> Identity (Either SmartyError Text) -> Either SmartyError Text
forall a b. (a -> b) -> a -> b
$ ExceptT SmartyError Identity Text
-> Identity (Either SmartyError Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SmartyError Identity Text
 -> Identity (Either SmartyError Text))
-> ExceptT SmartyError Identity Text
-> Identity (Either SmartyError Text)
forall a b. (a -> b) -> a -> b
$ String -> SmartyCtx -> PropMap -> ExceptT SmartyError Identity Text
forall (m :: * -> *).
Monad m =>
String -> SmartyCtx -> PropMap -> ExceptT SmartyError m Text
applyTemplate' String
a SmartyCtx
b (PropMap -> ExceptT SmartyError Identity Text)
-> PropMap -> ExceptT SmartyError Identity Text
forall a b. (a -> b) -> a -> b
$ (Key -> Text) -> HashMap Key Value -> PropMap
forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
HM.mapKeys Key -> Text
AK.toText (HashMap Key Value -> PropMap) -> HashMap Key Value -> PropMap
forall a b. (a -> b) -> a -> b
$ [(Key, Value)] -> HashMap Key Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Key, Value)] -> HashMap Key Value)
-> [(Key, Value)] -> HashMap Key Value
forall a b. (a -> b) -> a -> b
$ Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
hm
    Value
x -> SmartyError -> Either SmartyError Text
forall a b. a -> Either a b
Left (Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Value -> String
forall a. Show a => a -> String
show Value
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a json object, need an object at top level")

-- | Fill a template with values and print it as Text
applyTemplate :: FilePath -> SmartyCtx -> ParamMap -> Either SmartyError T.Text
applyTemplate :: String -> SmartyCtx -> PropMap -> Either SmartyError Text
applyTemplate String
a SmartyCtx
b PropMap
c =
  Identity (Either SmartyError Text) -> Either SmartyError Text
forall a. Identity a -> a
runIdentity (Identity (Either SmartyError Text) -> Either SmartyError Text)
-> Identity (Either SmartyError Text) -> Either SmartyError Text
forall a b. (a -> b) -> a -> b
$ ExceptT SmartyError Identity Text
-> Identity (Either SmartyError Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SmartyError Identity Text
 -> Identity (Either SmartyError Text))
-> ExceptT SmartyError Identity Text
-> Identity (Either SmartyError Text)
forall a b. (a -> b) -> a -> b
$ String -> SmartyCtx -> PropMap -> ExceptT SmartyError Identity Text
forall (m :: * -> *).
Monad m =>
String -> SmartyCtx -> PropMap -> ExceptT SmartyError m Text
applyTemplate' String
a SmartyCtx
b PropMap
c

applyTemplate' :: Monad m => FilePath -> SmartyCtx -> ParamMap -> ExceptT SmartyError m T.Text
applyTemplate' :: String -> SmartyCtx -> PropMap -> ExceptT SmartyError m Text
applyTemplate' String
template SmartyCtx
ctx PropMap
mp =
  do
    Smarty
getTpl <-
      case String -> HashMap String Smarty -> Maybe Smarty
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup String
template (SmartyCtx -> HashMap String Smarty
unSmartyCtx SmartyCtx
ctx) of
        Just Smarty
ok -> Smarty -> ExceptT SmartyError m Smarty
forall (f :: * -> *) a. Applicative f => a -> f a
pure Smarty
ok
        Maybe Smarty
Nothing ->
          SmartyError -> ExceptT SmartyError m Smarty
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Template " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
template String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not compiled")
    Env -> Smarty -> ExceptT SmartyError m Text
forall (m :: * -> *). Monad m => Env -> Smarty -> EvalM m Text
evalTpl (PropMap -> SmartyCtx -> Env
mkEnv PropMap
mp SmartyCtx
ctx) Smarty
getTpl

txtPdHelper ::
  Monad m => Env -> Expr -> (T.Text -> T.Text) -> ExceptT SmartyError m Expr
txtPdHelper :: Env -> Expr -> (Text -> Text) -> ExceptT SmartyError m Expr
txtPdHelper Env
env Expr
expr Text -> Text
go =
  do
    Text
t <- Env -> Expr -> EvalM m Text
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Text
exprToText Env
env Expr
expr
    Expr -> ExceptT SmartyError m Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ExceptT SmartyError m Expr)
-> Expr -> ExceptT SmartyError m Expr
forall a b. (a -> b) -> a -> b
$ Value -> Expr
ExprLit (Value -> Expr) -> Value -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Text
go Text
t

applyPrintDirective :: Monad m => Env -> Expr -> PrintDirective -> EvalM m Expr
applyPrintDirective :: Env -> Expr -> Text -> EvalM m Expr
applyPrintDirective Env
env Expr
expr Text
"json" =
  do
    Value
evaled <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
expr
    Expr -> EvalM m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> EvalM m Expr) -> Expr -> EvalM m Expr
forall a b. (a -> b) -> a -> b
$ Value -> Expr
ExprLit (Value -> Expr) -> Value -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode Value
evaled
applyPrintDirective Env
env Expr
expr Text
"urlencode" =
  Env -> Expr -> (Text -> Text) -> EvalM m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> (Text -> Text) -> ExceptT SmartyError m Expr
txtPdHelper Env
env Expr
expr (String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
urlEncode ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
applyPrintDirective Env
env Expr
expr Text
"nl2br" =
  Env -> Expr -> (Text -> Text) -> EvalM m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> (Text -> Text) -> ExceptT SmartyError m Expr
txtPdHelper Env
env Expr
expr (Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"<br />")
applyPrintDirective Env
env Expr
expr Text
"escape" =
  Env -> Expr -> (Text -> Text) -> EvalM m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> (Text -> Text) -> ExceptT SmartyError m Expr
txtPdHelper Env
env Expr
expr (String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
htmlEscape ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
  where
    forbidden :: String
    forbidden :: String
forbidden = String
"<&\">'/"
    htmlEscape :: String -> String
    htmlEscape :: ShowS
htmlEscape [] = []
    htmlEscape (Char
x : String
xs) =
      if Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
forbidden
        then
          [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"&#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Char -> Int
ord Char
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";",
              ShowS
htmlEscape String
xs
            ]
        else Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
htmlEscape String
xs
applyPrintDirective Env
_ Expr
_ Text
pd =
  SmartyError -> EvalM m Expr
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Expr) -> SmartyError -> EvalM m Expr
forall a b. (a -> b) -> a -> b
$
    Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
T.concat
        [ Text
"Unknown print directive `",
          Text
pd,
          Text
"`"
        ]

evalTpl :: Monad m => Env -> Smarty -> EvalM m T.Text
evalTpl :: Env -> Smarty -> EvalM m Text
evalTpl Env
env (Smarty String
_ [SmartyStmt]
tpl) =
  (Env, Text) -> Text
forall a b. (a, b) -> b
snd ((Env, Text) -> Text)
-> ExceptT SmartyError m (Env, Text) -> EvalM m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> [SmartyStmt] -> ExceptT SmartyError m (Env, Text)
forall (m :: * -> *).
Monad m =>
Env -> [SmartyStmt] -> EvalM m (Env, Text)
seqStmts Env
env [SmartyStmt]
tpl

evalStmt :: Monad m => Env -> SmartyStmt -> EvalM m (Env, T.Text)
evalStmt :: Env -> SmartyStmt -> EvalM m (Env, Text)
evalStmt Env
env (SmartyScope Scope
sc) =
  do
    (Env
_, Text
body) <- Env -> [SmartyStmt] -> EvalM m (Env, Text)
forall (m :: * -> *).
Monad m =>
Env -> [SmartyStmt] -> EvalM m (Env, Text)
seqStmts Env
env (Scope -> [SmartyStmt]
s_stmts Scope
sc)
    (Env, Text) -> EvalM m (Env, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env, Text
body)
evalStmt Env
env (SmartyFun FunctionDef
fd) =
  do
    [(Text, Value)]
args <-
      [(Text, Expr)]
-> ((Text, Expr) -> ExceptT SmartyError m (Text, Value))
-> ExceptT SmartyError m [(Text, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (FunctionDef -> [(Text, Expr)]
fd_defArgs FunctionDef
fd) (((Text, Expr) -> ExceptT SmartyError m (Text, Value))
 -> ExceptT SmartyError m [(Text, Value)])
-> ((Text, Expr) -> ExceptT SmartyError m (Text, Value))
-> ExceptT SmartyError m [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ \(Text
n, Expr
expr) ->
        do
          Value
r <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
expr
          (Text, Value) -> ExceptT SmartyError m (Text, Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
n, Value
r)
    let fun :: HashMap Text ([SmartyStmt], [(Text, Value)])
fun =
          Text
-> ([SmartyStmt], [(Text, Value)])
-> HashMap Text ([SmartyStmt], [(Text, Value)])
-> HashMap Text ([SmartyStmt], [(Text, Value)])
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (FunctionDef -> Text
fd_name FunctionDef
fd) (FunctionDef -> [SmartyStmt]
fd_body FunctionDef
fd, [(Text, Value)]
args) (Env -> HashMap Text ([SmartyStmt], [(Text, Value)])
e_fun Env
env)
    (Env, Text) -> EvalM m (Env, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env {e_fun :: HashMap Text ([SmartyStmt], [(Text, Value)])
e_fun = HashMap Text ([SmartyStmt], [(Text, Value)])
fun}, Text
T.empty)
evalStmt Env
env (SmartyCapture Capture
cap) =
  do
    (Env
_, Text
body) <- Env -> [SmartyStmt] -> EvalM m (Env, Text)
forall (m :: * -> *).
Monad m =>
Env -> [SmartyStmt] -> EvalM m (Env, Text)
seqStmts Env
env (Capture -> [SmartyStmt]
c_stmts Capture
cap)
    let varBody :: TemplateVar
varBody = Value -> PropMap -> TemplateVar
TemplateVar (Text -> Value
A.String Text
body) PropMap
forall a. Monoid a => a
mempty
        capture :: HashMap Text TemplateVar -> HashMap Text TemplateVar
capture =
          Text
-> Value -> HashMap Text TemplateVar -> HashMap Text TemplateVar
updateSmartyCapture (Capture -> Text
c_name Capture
cap) (Text -> Value
A.String Text
body)
        assignment :: HashMap Text TemplateVar -> HashMap Text TemplateVar
assignment =
          case Capture -> Maybe Text
c_assign Capture
cap of
            Maybe Text
Nothing -> HashMap Text TemplateVar -> HashMap Text TemplateVar
forall a. Monoid a => a
mempty
            Just Text
x -> Text
-> TemplateVar
-> HashMap Text TemplateVar
-> HashMap Text TemplateVar
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
x TemplateVar
varBody
        eVars :: HashMap Text TemplateVar
eVars = HashMap Text TemplateVar -> HashMap Text TemplateVar
capture (HashMap Text TemplateVar -> HashMap Text TemplateVar)
-> (HashMap Text TemplateVar -> HashMap Text TemplateVar)
-> HashMap Text TemplateVar
-> HashMap Text TemplateVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text TemplateVar -> HashMap Text TemplateVar
assignment (HashMap Text TemplateVar -> HashMap Text TemplateVar)
-> HashMap Text TemplateVar -> HashMap Text TemplateVar
forall a b. (a -> b) -> a -> b
$ Env -> HashMap Text TemplateVar
e_var Env
env
    (Env, Text) -> EvalM m (Env, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env {e_var :: HashMap Text TemplateVar
e_var = HashMap Text TemplateVar
eVars}, Text
T.empty)
evalStmt Env
env (SmartyLet Let
l) =
  do
    Value
r <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env (Let -> Expr
l_expr Let
l)
    let eVars :: HashMap Text TemplateVar
eVars =
          Text
-> TemplateVar
-> HashMap Text TemplateVar
-> HashMap Text TemplateVar
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (Let -> Text
l_name Let
l) (Value -> PropMap -> TemplateVar
TemplateVar Value
r PropMap
forall a. Monoid a => a
mempty) (Env -> HashMap Text TemplateVar
e_var Env
env)
    (Env, Text) -> EvalM m (Env, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env {e_var :: HashMap Text TemplateVar
e_var = HashMap Text TemplateVar
eVars}, Text
T.empty)
evalStmt Env
env (SmartyText Text
t) = (Env, Text) -> EvalM m (Env, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
env, Text
t)
evalStmt Env
env (SmartyComment Text
_) = (Env, Text) -> EvalM m (Env, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
env, Text
T.empty)
evalStmt Env
env (SmartyPrint Expr
expr [Text]
directives) =
  do
    Expr
e <- (Expr -> Text -> ExceptT SmartyError m Expr)
-> Expr -> [Text] -> ExceptT SmartyError m Expr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Env -> Expr -> Text -> ExceptT SmartyError m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> Text -> EvalM m Expr
applyPrintDirective Env
env) Expr
expr [Text]
directives
    (,) (Env -> Text -> (Env, Text))
-> ExceptT SmartyError m Env
-> ExceptT SmartyError m (Text -> (Env, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExceptT SmartyError m Env
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env ExceptT SmartyError m (Text -> (Env, Text))
-> ExceptT SmartyError m Text -> EvalM m (Env, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Env -> Expr -> ExceptT SmartyError m Text
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Text
exprToText Env
env Expr
e
evalStmt Env
env (SmartyIf (If [(Expr, [SmartyStmt])]
cases Maybe [SmartyStmt]
elseBody)) =
  do
    [Maybe Text]
evaledCases <-
      ((Expr, [SmartyStmt]) -> ExceptT SmartyError m (Maybe Text))
-> [(Expr, [SmartyStmt])] -> ExceptT SmartyError m [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
        ( \(Expr
cond, [SmartyStmt]
body) ->
            do
              Value
r <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
cond
              (Env
_, Text
b) <- Env -> [SmartyStmt] -> EvalM m (Env, Text)
forall (m :: * -> *).
Monad m =>
Env -> [SmartyStmt] -> EvalM m (Env, Text)
seqStmts Env
env [SmartyStmt]
body
              case Value
r of
                (A.Bool Bool
False) ->
                  Maybe Text -> ExceptT SmartyError m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                Value
A.Null -> Maybe Text -> ExceptT SmartyError m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                (A.Array Array
v) | Array -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Array
v -> Maybe Text -> ExceptT SmartyError m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                Value
_ ->
                  Maybe Text -> ExceptT SmartyError m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> ExceptT SmartyError m (Maybe Text))
-> Maybe Text -> ExceptT SmartyError m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
b
        )
        [(Expr, [SmartyStmt])]
cases
    case [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text]
evaledCases of
      (Text
x : [Text]
_) ->
        (Env, Text) -> EvalM m (Env, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
env, Text
x)
      [Text]
_ ->
        case Maybe [SmartyStmt]
elseBody of
          Just [SmartyStmt]
elseB ->
            (,) (Env -> Text -> (Env, Text))
-> ExceptT SmartyError m Env
-> ExceptT SmartyError m (Text -> (Env, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExceptT SmartyError m Env
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env ExceptT SmartyError m (Text -> (Env, Text))
-> ExceptT SmartyError m Text -> EvalM m (Env, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Env, Text) -> Text
forall a b. (a, b) -> b
snd ((Env, Text) -> Text)
-> EvalM m (Env, Text) -> ExceptT SmartyError m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> [SmartyStmt] -> EvalM m (Env, Text)
forall (m :: * -> *).
Monad m =>
Env -> [SmartyStmt] -> EvalM m (Env, Text)
seqStmts Env
env [SmartyStmt]
elseB)
          Maybe [SmartyStmt]
Nothing ->
            (Env, Text) -> EvalM m (Env, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
env, Text
T.empty)
evalStmt Env
env (SmartyForeach (Foreach Expr
source Maybe Text
mKey Text
val [SmartyStmt]
body Maybe [SmartyStmt]
elseBody)) =
  do
    Value
evaledSource <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
source
    ([(Value, Value, PropMap)]
preparedSource, Int
size) <- Value -> EvalM m ([(Value, Value, PropMap)], Int)
forall (m :: * -> *).
Monad m =>
Value -> EvalM m ([(Value, Value, PropMap)], Int)
mkForeachInput Value
evaledSource
    if Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then case Maybe [SmartyStmt]
elseBody of
        Just [SmartyStmt]
b -> (,) (Env -> Text -> (Env, Text))
-> ExceptT SmartyError m Env
-> ExceptT SmartyError m (Text -> (Env, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExceptT SmartyError m Env
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env ExceptT SmartyError m (Text -> (Env, Text))
-> ExceptT SmartyError m Text -> EvalM m (Env, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Env, Text) -> Text
forall a b. (a, b) -> b
snd ((Env, Text) -> Text)
-> EvalM m (Env, Text) -> ExceptT SmartyError m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> [SmartyStmt] -> EvalM m (Env, Text)
forall (m :: * -> *).
Monad m =>
Env -> [SmartyStmt] -> EvalM m (Env, Text)
seqStmts Env
env [SmartyStmt]
b)
        Maybe [SmartyStmt]
Nothing -> (Env, Text) -> EvalM m (Env, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
env, Text
T.empty)
      else do
        [Text]
runs <- ((Value, Value, PropMap) -> ExceptT SmartyError m Text)
-> [(Value, Value, PropMap)] -> ExceptT SmartyError m [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env
-> Maybe Text
-> Text
-> [SmartyStmt]
-> (Value, Value, PropMap)
-> ExceptT SmartyError m Text
forall (m :: * -> *).
Monad m =>
Env
-> Maybe Text
-> Text
-> [SmartyStmt]
-> (Value, Value, PropMap)
-> EvalM m Text
evalForeachBody Env
env Maybe Text
mKey Text
val [SmartyStmt]
body) [(Value, Value, PropMap)]
preparedSource
        (Env, Text) -> EvalM m (Env, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
env, [Text] -> Text
T.concat [Text]
runs)

seqStmts :: Monad m => Env -> [SmartyStmt] -> EvalM m (Env, T.Text)
seqStmts :: Env -> [SmartyStmt] -> EvalM m (Env, Text)
seqStmts Env
env [SmartyStmt]
stmt =
  do
    let go :: (Env, Builder)
-> SmartyStmt -> ExceptT SmartyError m (Env, Builder)
go (Env
ebase, Builder
tb) SmartyStmt
st =
          do
            (Env
e, Text
t) <- Env -> SmartyStmt -> EvalM m (Env, Text)
forall (m :: * -> *).
Monad m =>
Env -> SmartyStmt -> EvalM m (Env, Text)
evalStmt Env
ebase SmartyStmt
st
            (Env, Builder) -> ExceptT SmartyError m (Env, Builder)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
e, Builder
tb Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TLB.fromText Text
t)
    (Env
e', Builder
tb) <-
      ((Env, Builder)
 -> SmartyStmt -> ExceptT SmartyError m (Env, Builder))
-> (Env, Builder)
-> [SmartyStmt]
-> ExceptT SmartyError m (Env, Builder)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Env, Builder)
-> SmartyStmt -> ExceptT SmartyError m (Env, Builder)
forall (m :: * -> *).
Monad m =>
(Env, Builder)
-> SmartyStmt -> ExceptT SmartyError m (Env, Builder)
go (Env
env, Builder
forall a. Monoid a => a
mempty) [SmartyStmt]
stmt
    (Env, Text) -> EvalM m (Env, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
e', Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
TLB.toLazyText Builder
tb)

exprToText :: Monad m => Env -> Expr -> EvalM m T.Text
exprToText :: Env -> Expr -> EvalM m Text
exprToText Env
env Expr
expr =
  do
    Value
evaled <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
expr
    case Value
evaled of
      A.String Text
t -> Text -> EvalM m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
      A.Number Scientific
n -> Text -> EvalM m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> EvalM m Text) -> Text -> EvalM m Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Scientific -> String
forall a. Show a => a -> String
show Scientific
n
      Value
A.Null -> Text -> EvalM m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"null"
      A.Bool Bool
b ->
        Text -> EvalM m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
b then Text
"true" else Text
"false")
      A.Object Object
o ->
        Text -> EvalM m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> EvalM m Text) -> Text -> EvalM m Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Object -> String
forall a. Show a => a -> String
show Object
o
      A.Array Array
a ->
        Text -> EvalM m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> EvalM m Text) -> Text -> EvalM m Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Array -> String
forall a. Show a => a -> String
show Array
a

evalForeachBody ::
  Monad m =>
  Env ->
  Maybe T.Text ->
  T.Text ->
  [SmartyStmt] ->
  (A.Value, A.Value, PropMap) ->
  EvalM m T.Text
evalForeachBody :: Env
-> Maybe Text
-> Text
-> [SmartyStmt]
-> (Value, Value, PropMap)
-> EvalM m Text
evalForeachBody Env
envFull Maybe Text
mKey Text
item [SmartyStmt]
body (Value
keyVal, Value
itemVal, PropMap
props) =
  let env :: HashMap Text TemplateVar
env = Env -> HashMap Text TemplateVar
e_var Env
envFull
      env' :: HashMap Text TemplateVar
env' = Text
-> TemplateVar
-> HashMap Text TemplateVar
-> HashMap Text TemplateVar
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
item (Value -> PropMap -> TemplateVar
TemplateVar Value
itemVal PropMap
props) HashMap Text TemplateVar
env
      env'' :: HashMap Text TemplateVar
env'' =
        case Maybe Text
mKey of
          Just Text
key -> Text
-> TemplateVar
-> HashMap Text TemplateVar
-> HashMap Text TemplateVar
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (Value -> PropMap -> TemplateVar
TemplateVar Value
keyVal PropMap
forall k v. HashMap k v
HM.empty) HashMap Text TemplateVar
env'
          Maybe Text
Nothing -> HashMap Text TemplateVar
env'
   in (Env, Text) -> Text
forall a b. (a, b) -> b
snd ((Env, Text) -> Text)
-> ExceptT SmartyError m (Env, Text) -> EvalM m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> [SmartyStmt] -> ExceptT SmartyError m (Env, Text)
forall (m :: * -> *).
Monad m =>
Env -> [SmartyStmt] -> EvalM m (Env, Text)
seqStmts (Env
envFull {e_var :: HashMap Text TemplateVar
e_var = HashMap Text TemplateVar
env''}) [SmartyStmt]
body

mkForeachInput :: Monad m => A.Value -> EvalM m ([(A.Value, A.Value, PropMap)], Int)
mkForeachInput :: Value -> EvalM m ([(Value, Value, PropMap)], Int)
mkForeachInput (A.Array Array
vec) =
  ([(Value, Value, PropMap)], Int)
-> EvalM m ([(Value, Value, PropMap)], Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (([(Value, Value, PropMap)], Int)
 -> EvalM m ([(Value, Value, PropMap)], Int))
-> ([(Value, Value, PropMap)], Int)
-> EvalM m ([(Value, Value, PropMap)], Int)
forall a b. (a -> b) -> a -> b
$
    ( Vector (Value, Value, PropMap) -> [(Value, Value, PropMap)]
forall a. Vector a -> [a]
V.toList (Vector (Value, Value, PropMap) -> [(Value, Value, PropMap)])
-> Vector (Value, Value, PropMap) -> [(Value, Value, PropMap)]
forall a b. (a -> b) -> a -> b
$
        (Int -> Value -> (Value, Value, PropMap))
-> Array -> Vector (Value, Value, PropMap)
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap
          ( \Int
idx Value
el ->
              ( Scientific -> Value
A.Number (Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx),
                Value
el,
                Int -> Int -> PropMap
mkForeachMap Int
idx Int
fSize
              )
          )
          Array
vec,
      Int
fSize
    )
  where
    fSize :: Int
fSize = Array -> Int
forall a. Vector a -> Int
V.length Array
vec
mkForeachInput (A.Object Object
hm) =
  let (Int
_, [(Value, Value, PropMap)]
input) =
        ((Int, [(Value, Value, PropMap)])
 -> Key -> Value -> (Int, [(Value, Value, PropMap)]))
-> (Int, [(Value, Value, PropMap)])
-> HashMap Key Value
-> (Int, [(Value, Value, PropMap)])
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
HM.foldlWithKey'
          ( \(Int
idx, [(Value, Value, PropMap)]
out) Key
key Value
el ->
              let newElem :: (Value, Value, PropMap)
newElem =
                    ( Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Text
AK.toText Key
key,
                      Value
el,
                      Int -> Int -> PropMap
mkForeachMap Int
idx Int
hSize
                    )
               in (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, (Value, Value, PropMap)
newElem (Value, Value, PropMap)
-> [(Value, Value, PropMap)] -> [(Value, Value, PropMap)]
forall a. a -> [a] -> [a]
: [(Value, Value, PropMap)]
out)
          )
          (Int
0, [])
          ([(Key, Value)] -> HashMap Key Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Key, Value)] -> HashMap Key Value)
-> [(Key, Value)] -> HashMap Key Value
forall a b. (a -> b) -> a -> b
$ Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
hm)
   in ([(Value, Value, PropMap)], Int)
-> EvalM m ([(Value, Value, PropMap)], Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Value, Value, PropMap)] -> [(Value, Value, PropMap)]
forall a. [a] -> [a]
reverse [(Value, Value, PropMap)]
input, Int
hSize)
  where
    hSize :: Int
hSize = Object -> Int
forall v. KeyMap v -> Int
KM.size Object
hm
mkForeachInput Value
_ =
  SmartyError -> EvalM m ([(Value, Value, PropMap)], Int)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m ([(Value, Value, PropMap)], Int))
-> SmartyError -> EvalM m ([(Value, Value, PropMap)], Int)
forall a b. (a -> b) -> a -> b
$ Text -> SmartyError
SmartyError Text
"Tried to iterate over non traversable type."

mkForeachMap :: Int -> Int -> PropMap
mkForeachMap :: Int -> Int -> PropMap
mkForeachMap Int
idx' Int
size' =
  [(Text, Value)] -> PropMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
    [ (Text
"index", Scientific -> Value
A.Number Scientific
idx),
      (Text
"iteration", Scientific -> Value
A.Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Scientific
1 Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
+ Scientific
idx),
      (Text
"first", Bool -> Value
A.Bool (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Scientific
idx Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
0),
      (Text
"last", Bool -> Value
A.Bool (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ (Scientific
idx Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
+ Scientific
1) Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
size),
      (Text
"total", Scientific -> Value
A.Number Scientific
size)
    ]
  where
    size :: Scientific
size = Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size'
    idx :: Scientific
idx = Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx'

str :: Monad m => T.Text -> A.Value -> EvalM m T.Text
str :: Text -> Value -> EvalM m Text
str Text
_ (A.String Text
x) = Text -> EvalM m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
x
str Text
desc Value
_ = SmartyError -> EvalM m Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Text) -> SmartyError -> EvalM m Text
forall a b. (a -> b) -> a -> b
$ Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"`", Text
desc, Text
"` is not a string!"]

ifExists :: (Eq a, Show a, Monad m) => T.Text -> a -> [(a, A.Value)] -> (A.Value -> EvalM m b) -> EvalM m b
ifExists :: Text -> a -> [(a, Value)] -> (Value -> EvalM m b) -> EvalM m b
ifExists Text
msg a
key [(a, Value)]
env Value -> EvalM m b
fun =
  case a -> [(a, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
key [(a, Value)]
env of
    Just Value
x -> Value -> EvalM m b
fun Value
x
    Maybe Value
Nothing ->
      SmartyError -> EvalM m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m b) -> SmartyError -> EvalM m b
forall a b. (a -> b) -> a -> b
$ Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"`", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
key, Text
"` is not given. ", Text
msg]

lookupStr :: Monad m => T.Text -> T.Text -> [(T.Text, A.Value)] -> EvalM m T.Text
lookupStr :: Text -> Text -> [(Text, Value)] -> EvalM m Text
lookupStr Text
funName Text
key [(Text, Value)]
env =
  Text
-> Text
-> [(Text, Value)]
-> (Value -> EvalM m Text)
-> EvalM m Text
forall a (m :: * -> *) b.
(Eq a, Show a, Monad m) =>
Text -> a -> [(a, Value)] -> (Value -> EvalM m b) -> EvalM m b
ifExists ([Text] -> Text
T.concat [Text
"Param for `", Text
funName, Text
"`"]) Text
key [(Text, Value)]
env (Text -> Value -> EvalM m Text
forall (m :: * -> *). Monad m => Text -> Value -> EvalM m Text
str Text
key)

evalFunCall :: Monad m => Env -> T.Text -> [(T.Text, Expr)] -> EvalM m A.Value
evalFunCall :: Env -> Text -> [(Text, Expr)] -> EvalM m Value
evalFunCall Env
env Text
"include" [(Text, Expr)]
args =
  do
    [(Text, Value)]
evaledArgs <-
      ((Text, Expr) -> ExceptT SmartyError m (Text, Value))
-> [(Text, Expr)] -> ExceptT SmartyError m [(Text, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
        ( \(Text
k, Expr
expr) ->
            do
              Value
val <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
expr
              (Text, Value) -> ExceptT SmartyError m (Text, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
k, Value
val)
        )
        [(Text, Expr)]
args
    Text
filename <- Text -> Text -> [(Text, Value)] -> EvalM m Text
forall (m :: * -> *).
Monad m =>
Text -> Text -> [(Text, Value)] -> EvalM m Text
lookupStr Text
"include" Text
"file" [(Text, Value)]
evaledArgs
    let otherArgs :: [(Text, Value)]
otherArgs =
          ((Text, Value) -> Bool) -> [(Text, Value)] -> [(Text, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter
            ( \(Text
k, Value
_) ->
                Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"include"]
            )
            [(Text, Value)]
evaledArgs
        asTplParams :: PropMap
asTplParams = [(Text, Value)] -> PropMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Value)] -> PropMap) -> [(Text, Value)] -> PropMap
forall a b. (a -> b) -> a -> b
$ ((Text, Value) -> (Text, Value))
-> [(Text, Value)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, Value
v) -> (Text
k, Value
v)) [(Text, Value)]
otherArgs
    Text -> Value
A.String (Text -> Value) -> EvalM m Text -> EvalM m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> SmartyCtx -> PropMap -> EvalM m Text
forall (m :: * -> *).
Monad m =>
String -> SmartyCtx -> PropMap -> ExceptT SmartyError m Text
applyTemplate' (Text -> String
T.unpack Text
filename) (Env -> SmartyCtx
e_ctx Env
env) PropMap
asTplParams
evalFunCall Env
env Text
fname [(Text, Expr)]
args =
  case Text
-> HashMap Text ([SmartyStmt], [(Text, Value)])
-> Maybe ([SmartyStmt], [(Text, Value)])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
fname (Env -> HashMap Text ([SmartyStmt], [(Text, Value)])
e_fun Env
env) of
    Just ([SmartyStmt]
fBody, [(Text, Value)]
fDefArgs) ->
      do
        [(Text, Value)]
localArgs <-
          [(Text, Expr)]
-> ((Text, Expr) -> ExceptT SmartyError m (Text, Value))
-> ExceptT SmartyError m [(Text, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, Expr)]
args (((Text, Expr) -> ExceptT SmartyError m (Text, Value))
 -> ExceptT SmartyError m [(Text, Value)])
-> ((Text, Expr) -> ExceptT SmartyError m (Text, Value))
-> ExceptT SmartyError m [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ \(Text
n, Expr
expr) ->
            do
              Value
r <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
expr
              (Text, Value) -> ExceptT SmartyError m (Text, Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
n, Value
r)
        let myArgs :: HashMap Text TemplateVar
myArgs =
              (Value -> TemplateVar) -> PropMap -> HashMap Text TemplateVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Value
v -> Value -> PropMap -> TemplateVar
TemplateVar Value
v PropMap
forall a. Monoid a => a
mempty) (PropMap -> HashMap Text TemplateVar)
-> PropMap -> HashMap Text TemplateVar
forall a b. (a -> b) -> a -> b
$
                [(Text, Value)] -> PropMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, Value)]
localArgs PropMap -> PropMap -> PropMap
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` [(Text, Value)] -> PropMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, Value)]
fDefArgs
            callEnv :: HashMap Text TemplateVar
callEnv =
              HashMap Text TemplateVar
myArgs HashMap Text TemplateVar
-> HashMap Text TemplateVar -> HashMap Text TemplateVar
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` Env -> HashMap Text TemplateVar
e_var Env
env
        (Env
_, Text
res) <- Env -> [SmartyStmt] -> EvalM m (Env, Text)
forall (m :: * -> *).
Monad m =>
Env -> [SmartyStmt] -> EvalM m (Env, Text)
seqStmts (Env
env {e_var :: HashMap Text TemplateVar
e_var = HashMap Text TemplateVar
callEnv}) [SmartyStmt]
fBody
        Value -> EvalM m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Value
A.String Text
res)
    Maybe ([SmartyStmt], [(Text, Value)])
Nothing ->
      SmartyError -> EvalM m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Value) -> SmartyError -> EvalM m Value
forall a b. (a -> b) -> a -> b
$
        Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
T.concat
            [ Text
"Call to undefined function ",
              Text
fname
            ]

evalExpr :: Monad m => Env -> Expr -> EvalM m A.Value
evalExpr :: Env -> Expr -> EvalM m Value
evalExpr Env
_ (ExprLit Value
v) = Value -> EvalM m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
evalExpr Env
env (ExprBin BinOp
op) =
  Env -> BinOp -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> BinOp -> EvalM m Value
evalBinOp Env
env BinOp
op
evalExpr Env
env (ExprFun FunctionCall
funCall) =
  Env -> Text -> [(Text, Expr)] -> EvalM m Value
forall (m :: * -> *).
Monad m =>
Env -> Text -> [(Text, Expr)] -> EvalM m Value
evalFunCall Env
env (FunctionCall -> Text
f_name FunctionCall
funCall) (FunctionCall -> [(Text, Expr)]
f_args FunctionCall
funCall)
evalExpr Env
env (ExprVar Variable
v) =
  case Text -> HashMap Text TemplateVar -> Maybe TemplateVar
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
varName (Env -> HashMap Text TemplateVar
e_var Env
env) of
    Just TemplateVar
tplVar ->
      case Variable
v of
        (Variable {v_prop :: Variable -> Maybe Text
v_prop = Just Text
propReq}) ->
          case Text -> PropMap -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
propReq (TemplateVar -> PropMap
tv_props TemplateVar
tplVar) of
            Just Value
val -> Value -> EvalM m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
val
            Maybe Value
Nothing ->
              SmartyError -> EvalM m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Value) -> SmartyError -> EvalM m Value
forall a b. (a -> b) -> a -> b
$
                Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$
                  [Text] -> Text
T.concat
                    [ Text
"Property `",
                      Text
propReq,
                      Text
"` is not defined for variable `",
                      Text
varName,
                      Text
"`"
                    ]
        (Variable {v_path :: Variable -> [Text]
v_path = [Text]
path, v_index :: Variable -> Maybe Expr
v_index = Maybe Expr
mIdx}) ->
          let pathName :: Text
pathName =
                [Text] -> Text
T.concat
                  [ Text
varName,
                    if ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
path Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) then Text
"." else Text
T.empty,
                    Text -> [Text] -> Text
T.intercalate Text
"." [Text]
path
                  ]
              idxWalk :: Value -> ExceptT SmartyError m Value
idxWalk Value
val =
                case Maybe Expr
mIdx of
                  Just Expr
eIdx ->
                    do
                      Value
res <- Env -> Expr -> ExceptT SmartyError m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
eIdx
                      Text -> Value -> Value -> ExceptT SmartyError m Value
forall (m :: * -> *).
Monad m =>
Text -> Value -> Value -> EvalM m Value
walkIndex Text
pathName Value
res Value
val
                  Maybe Expr
Nothing ->
                    Value -> ExceptT SmartyError m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
val
           in do
                Value
pathRes <- Text -> [Text] -> Value -> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text -> [Text] -> Value -> EvalM m Value
walkPath Text
varName [Text]
path (Value -> EvalM m Value) -> Value -> EvalM m Value
forall a b. (a -> b) -> a -> b
$ TemplateVar -> Value
tv_value TemplateVar
tplVar
                Value -> EvalM m Value
forall (m :: * -> *).
Monad m =>
Value -> ExceptT SmartyError m Value
idxWalk Value
pathRes
    Maybe TemplateVar
Nothing ->
      SmartyError -> EvalM m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Value) -> SmartyError -> EvalM m Value
forall a b. (a -> b) -> a -> b
$
        Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
T.concat
            [ Text
"Variable `",
              Text
varName,
              Text
"` is not defined"
            ]
  where
    varName :: Text
varName = Variable -> Text
v_name Variable
v

walkIndex :: Monad m => T.Text -> A.Value -> A.Value -> EvalM m A.Value
walkIndex :: Text -> Value -> Value -> EvalM m Value
walkIndex Text
vname (A.Number Scientific
idx) (A.Array Array
arr) =
  case Array
arr Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
!? (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
idx) of
    Just Value
val -> Value -> EvalM m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
val
    Maybe Value
Nothing ->
      SmartyError -> EvalM m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Value) -> SmartyError -> EvalM m Value
forall a b. (a -> b) -> a -> b
$
        Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
T.concat
            [ Text
"Out of bounds. `",
              Text
vname,
              Text
"[",
              String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Scientific -> String
forall a. Show a => a -> String
show Scientific
idx,
              Text
"]` not defined."
            ]
walkIndex Text
vname Value
idx Value
_ =
  SmartyError -> EvalM m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Value) -> SmartyError -> EvalM m Value
forall a b. (a -> b) -> a -> b
$
    Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
T.concat
        [ Text
"Can't access `",
          String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Value -> String
forall a. Show a => a -> String
show Value
idx,
          Text
"` in `",
          Text
vname,
          Text
"`. Index is not an integer or value not an array!"
        ]

walkPath :: Monad m => T.Text -> [T.Text] -> A.Value -> EvalM m A.Value
walkPath :: Text -> [Text] -> Value -> EvalM m Value
walkPath Text
_ [] Value
val = Value -> EvalM m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
val
walkPath Text
vname (Text
path : [Text]
xs) (A.Object Object
obj) =
  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
AK.fromText Text
path) Object
obj of
    Just Value
val -> Text -> [Text] -> Value -> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text -> [Text] -> Value -> EvalM m Value
walkPath ([Text] -> Text
T.concat [Text
vname, Text
".", Text
path]) [Text]
xs Value
val
    Maybe Value
Nothing ->
      SmartyError -> EvalM m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Value) -> SmartyError -> EvalM m Value
forall a b. (a -> b) -> a -> b
$
        Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
T.concat
            [ Text
"Variable `",
              Text
vname,
              Text
"` doesn't have the key `",
              Text
path,
              Text
"`"
            ]
walkPath Text
vname (Text
path : [Text]
_) Value
_ =
  SmartyError -> EvalM m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Value) -> SmartyError -> EvalM m Value
forall a b. (a -> b) -> a -> b
$
    Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
T.concat
        [ Text
"Variable `",
          Text
vname,
          Text
"` is not a map! Can't lookup `",
          Text
path,
          Text
"`"
        ]

evalBinOp :: Monad m => Env -> BinOp -> EvalM m A.Value
evalBinOp :: Env -> BinOp -> EvalM m Value
evalBinOp Env
env (BinEq Expr
a Expr
b) =
  (Value -> Value -> EvalM m Bool)
-> (Expr, Expr) -> Env -> EvalM m Value
forall (m :: * -> *).
Monad m =>
(Value -> Value -> EvalM m Bool)
-> (Expr, Expr) -> Env -> EvalM m Value
boolResOp (\Value
x Value
y -> Bool -> EvalM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> EvalM m Bool) -> Bool -> EvalM m Bool
forall a b. (a -> b) -> a -> b
$ Value
x Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
y) (Expr
a, Expr
b) Env
env
evalBinOp Env
env (BinNot Expr
e) =
  do
    Value
e' <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
e
    case Value
e' of
      A.Bool Bool
a ->
        Value -> EvalM m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
A.Bool (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
a)
      Value
_ ->
        SmartyError -> EvalM m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> EvalM m Value) -> SmartyError -> EvalM m Value
forall a b. (a -> b) -> a -> b
$ Text -> SmartyError
SmartyError Text
"Tried to evaluate a NOT on a non boolean value"
evalBinOp Env
env (BinOr Expr
x Expr
y) =
  Text
-> (Bool -> Bool -> Bool) -> (Expr, Expr) -> Env -> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Bool -> Bool -> Bool) -> (Expr, Expr) -> Env -> EvalM m Value
boolOp Text
"Or" Bool -> Bool -> Bool
(||) (Expr
x, Expr
y) Env
env
evalBinOp Env
env (BinAnd Expr
x Expr
y) =
  Text
-> (Bool -> Bool -> Bool) -> (Expr, Expr) -> Env -> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Bool -> Bool -> Bool) -> (Expr, Expr) -> Env -> EvalM m Value
boolOp Text
"And" Bool -> Bool -> Bool
(&&) (Expr
x, Expr
y) Env
env
evalBinOp Env
env (BinLarger Expr
x Expr
y) =
  Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
numOp Text
"Larger" Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
(>) (Expr
x, Expr
y) Env
env
evalBinOp Env
env (BinLargerEq Expr
x Expr
y) =
  Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
numOp Text
"LargerEq" Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
(>=) (Expr
x, Expr
y) Env
env
evalBinOp Env
env (BinSmaller Expr
x Expr
y) =
  Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
numOp Text
"Smaller" Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
(<) (Expr
x, Expr
y) Env
env
evalBinOp Env
env (BinSmallerEq Expr
x Expr
y) =
  Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
numOp Text
"SmallerEq" Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
(<=) (Expr
x, Expr
y) Env
env
evalBinOp Env
env (BinPlus Expr
x Expr
y) =
  Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
calcOp Text
"Plus" Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
(+) (Expr
x, Expr
y) Env
env
evalBinOp Env
env (BinMinus Expr
x Expr
y) =
  Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
calcOp Text
"Minus" (-) (Expr
x, Expr
y) Env
env
evalBinOp Env
env (BinMul Expr
x Expr
y) =
  Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
calcOp Text
"Mul" Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
(*) (Expr
x, Expr
y) Env
env
evalBinOp Env
env (BinDiv Expr
x Expr
y) =
  Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *).
Monad m =>
Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
calcOp Text
"Div" Scientific -> Scientific -> Scientific
forall a. Fractional a => a -> a -> a
(/) (Expr
x, Expr
y) Env
env

boolOp :: Monad m => T.Text -> (Bool -> Bool -> Bool) -> (Expr, Expr) -> Env -> EvalM m A.Value
boolOp :: Text
-> (Bool -> Bool -> Bool) -> (Expr, Expr) -> Env -> EvalM m Value
boolOp Text
d Bool -> Bool -> Bool
op (Expr, Expr)
exprs Env
env =
  (Value -> Value -> EvalM m Bool)
-> (Expr, Expr) -> Env -> EvalM m Value
forall (m :: * -> *).
Monad m =>
(Value -> Value -> EvalM m Bool)
-> (Expr, Expr) -> Env -> EvalM m Value
boolResOp Value -> Value -> EvalM m Bool
forall (m :: * -> *).
MonadError SmartyError m =>
Value -> Value -> m Bool
bOp (Expr, Expr)
exprs Env
env
  where
    bOp :: Value -> Value -> m Bool
bOp (A.Bool Bool
a) (A.Bool Bool
b) =
      Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool
a Bool -> Bool -> Bool
`op` Bool
b
    bOp Value
_ Value
_ = SmartyError -> m Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> m Bool) -> SmartyError -> m Bool
forall a b. (a -> b) -> a -> b
$ Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Tried ", Text
d, Text
"Op and on two non boolean values"]

numOp :: Monad m => T.Text -> (Scientific -> Scientific -> Bool) -> (Expr, Expr) -> Env -> EvalM m A.Value
numOp :: Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
numOp =
  ((Value -> Value -> EvalM m Bool)
 -> (Expr, Expr) -> Env -> EvalM m Value)
-> Text
-> (Scientific -> Scientific -> Bool)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *) a.
Monad m =>
((Value -> Value -> EvalM m a)
 -> (Expr, Expr) -> Env -> EvalM m Value)
-> Text
-> (Scientific -> Scientific -> a)
-> (Expr, Expr)
-> Env
-> EvalM m Value
numGenOp (Value -> Value -> EvalM m Bool)
-> (Expr, Expr) -> Env -> EvalM m Value
forall (m :: * -> *).
Monad m =>
(Value -> Value -> EvalM m Bool)
-> (Expr, Expr) -> Env -> EvalM m Value
boolResOp

calcOp :: Monad m => T.Text -> (Scientific -> Scientific -> Scientific) -> (Expr, Expr) -> Env -> EvalM m A.Value
calcOp :: Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
calcOp =
  ((Value -> Value -> EvalM m Scientific)
 -> (Expr, Expr) -> Env -> EvalM m Value)
-> Text
-> (Scientific -> Scientific -> Scientific)
-> (Expr, Expr)
-> Env
-> EvalM m Value
forall (m :: * -> *) a.
Monad m =>
((Value -> Value -> EvalM m a)
 -> (Expr, Expr) -> Env -> EvalM m Value)
-> Text
-> (Scientific -> Scientific -> a)
-> (Expr, Expr)
-> Env
-> EvalM m Value
numGenOp (Value -> Value -> EvalM m Scientific)
-> (Expr, Expr) -> Env -> EvalM m Value
forall (m :: * -> *).
Monad m =>
(Value -> Value -> EvalM m Scientific)
-> (Expr, Expr) -> Env -> EvalM m Value
numResOp

numGenOp ::
  Monad m =>
  ( (A.Value -> A.Value -> EvalM m a) ->
    (Expr, Expr) ->
    Env ->
    EvalM m A.Value
  ) ->
  T.Text ->
  (Scientific -> Scientific -> a) ->
  (Expr, Expr) ->
  Env ->
  EvalM m A.Value
numGenOp :: ((Value -> Value -> EvalM m a)
 -> (Expr, Expr) -> Env -> EvalM m Value)
-> Text
-> (Scientific -> Scientific -> a)
-> (Expr, Expr)
-> Env
-> EvalM m Value
numGenOp (Value -> Value -> EvalM m a)
-> (Expr, Expr) -> Env -> EvalM m Value
fun Text
d Scientific -> Scientific -> a
op (Expr, Expr)
exprs Env
env =
  (Value -> Value -> EvalM m a)
-> (Expr, Expr) -> Env -> EvalM m Value
fun Value -> Value -> EvalM m a
forall (m :: * -> *).
MonadError SmartyError m =>
Value -> Value -> m a
nOp (Expr, Expr)
exprs Env
env
  where
    nOp :: Value -> Value -> m a
nOp (A.Number Scientific
a) (A.Number Scientific
b) =
      a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ Scientific
a Scientific -> Scientific -> a
`op` Scientific
b
    nOp Value
_ Value
_ = SmartyError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SmartyError -> m a) -> SmartyError -> m a
forall a b. (a -> b) -> a -> b
$ Text -> SmartyError
SmartyError (Text -> SmartyError) -> Text -> SmartyError
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Tried ", Text
d, Text
"Op and on two non numeric values"]

numResOp ::
  Monad m =>
  (A.Value -> A.Value -> EvalM m Scientific) ->
  (Expr, Expr) ->
  Env ->
  EvalM m A.Value
numResOp :: (Value -> Value -> EvalM m Scientific)
-> (Expr, Expr) -> Env -> EvalM m Value
numResOp Value -> Value -> EvalM m Scientific
fun (Expr
a, Expr
b) Env
env =
  do
    Value
a' <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
a
    Value
b' <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
b
    Scientific -> Value
A.Number (Scientific -> Value) -> EvalM m Scientific -> EvalM m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Value -> EvalM m Scientific
fun Value
a' Value
b'

boolResOp ::
  Monad m =>
  (A.Value -> A.Value -> EvalM m Bool) ->
  (Expr, Expr) ->
  Env ->
  EvalM m A.Value
boolResOp :: (Value -> Value -> EvalM m Bool)
-> (Expr, Expr) -> Env -> EvalM m Value
boolResOp Value -> Value -> EvalM m Bool
fun (Expr
a, Expr
b) Env
env =
  do
    Value
a' <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
a
    Value
b' <- Env -> Expr -> EvalM m Value
forall (m :: * -> *). Monad m => Env -> Expr -> EvalM m Value
evalExpr Env
env Expr
b
    Bool -> Value
A.Bool (Bool -> Value) -> EvalM m Bool -> EvalM m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Value -> EvalM m Bool
fun Value
a' Value
b'