{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      : Slab.Evaluate
-- Description : Evaluate an AST (to a non-reducible AST)
--
-- @Slab.Evaluate@ implements the evaluation stage of Slab, following both the
-- parsing and pre-processing stages. This is responsible of reducing for
-- instance @1 + 2@ to @3@, or transforming a loop construct to an actual list
-- of HTML blocks.
--
-- Evaluation works on an abstract syntax tree (defined in "Slab.Syntax") and
-- currently reuses the sames types for its result.
--
-- The stage following evaluation is "Slab.Execute", responsible of running
-- external commands.
module Slab.Evaluate
  ( evaluateFile
  , evaluate
  , evalExpr
  , defaultEnv
  , simplify
  ) where

import Control.Monad (forM)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Data.List ((\\))
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Text qualified as T
import Slab.Error qualified as Error
import Slab.PreProcess qualified as PreProcess
import Slab.Syntax

--------------------------------------------------------------------------------

-- | Similar to `preprocessFile` but evaluate the template.
evaluateFile :: FilePath -> IO (Either Error.Error [Block])
evaluateFile :: FilePath -> IO (Either Error [Block])
evaluateFile = ExceptT Error IO [Block] -> IO (Either Error [Block])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Error IO [Block] -> IO (Either Error [Block]))
-> (FilePath -> ExceptT Error IO [Block])
-> FilePath
-> IO (Either Error [Block])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ExceptT Error IO [Block]
evaluateFileE

evaluateFileE :: FilePath -> ExceptT Error.Error IO [Block]
evaluateFileE :: FilePath -> ExceptT Error IO [Block]
evaluateFileE FilePath
path =
  FilePath -> ExceptT Error IO [Block]
PreProcess.preprocessFileE FilePath
path ExceptT Error IO [Block]
-> ([Block] -> ExceptT Error IO [Block])
-> ExceptT Error IO [Block]
forall a b.
ExceptT Error IO a
-> (a -> ExceptT Error IO b) -> ExceptT Error IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> [Text] -> [Block] -> ExceptT Error IO [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
defaultEnv [FilePath -> Text
T.pack FilePath
path]

--------------------------------------------------------------------------------
defaultEnv :: Env
defaultEnv :: Env
defaultEnv =
  [(Text, Expr)] -> Env
Env
    [ (Text
"true", Bool -> Expr
Bool Bool
True)
    , (Text
"false", Bool -> Expr
Bool Bool
False)
    , (Text
"show", Text -> Expr
BuiltIn Text
"show")
    , (Text
"null", Text -> Expr
BuiltIn Text
"null")
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"div" Elem
Div
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"html" Elem
Html
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"body" Elem
Body
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"span" Elem
Span
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"h1" Elem
H1
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"h2" Elem
H2
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"h3" Elem
H3
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"h4" Elem
H4
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"h5" Elem
H5
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"h6" Elem
H6
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"header" Elem
Header
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"head" Elem
Head
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"main" Elem
Main
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"audio" Elem
Audio
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"a" Elem
A
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"code" Elem
Code
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"iframe" Elem
IFrame
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"i" Elem
I
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"pre" Elem
Pre
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"p" Elem
P
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"em" Elem
Em
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"ul" Elem
Ul
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"li" Elem
Li
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"title" Elem
Title
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"table" Elem
Table
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"thead" Elem
Thead
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"tbody" Elem
Tbody
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"tr" Elem
Tr
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"td" Elem
Td
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"dl" Elem
Dl
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"dt" Elem
Dt
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"dd" Elem
Dd
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"footer" Elem
Footer
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"figure" Elem
Figure
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"form" Elem
Form
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"label" Elem
Label
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"blockquote" Elem
Blockquote
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"button" Elem
Button
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"figcaption" Elem
Figcaption
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"script" Elem
Script
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"style" Elem
Style
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"small" Elem
Small
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"svg" Elem
Svg
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"textarea" Elem
Textarea
    , Text -> Elem -> (Text, Expr)
forall {a}. a -> Elem -> (a, Expr)
mkElem Text
"canvas" Elem
Canvas
    , -- Elements with no content.
      (Text
"br", Block -> Expr
Block (Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
Br TrailingSym
NoSym [] []))
    , (Text
"hr", Block -> Expr
Block (Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
Hr TrailingSym
NoSym [] []))
    , (Text
"meta", Block -> Expr
Block (Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
Meta TrailingSym
NoSym [] []))
    , (Text
"link", Block -> Expr
Block (Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
Link TrailingSym
NoSym [] []))
    , (Text
"source", Block -> Expr
Block (Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
Source TrailingSym
NoSym [] []))
    , (Text
"img", Block -> Expr
Block (Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
Img TrailingSym
NoSym [] []))
    , (Text
"input", Block -> Expr
Block (Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
Input TrailingSym
NoSym [] []))
    ]
 where
  mkElem :: a -> Elem -> (a, Expr)
mkElem a
name Elem
el =
    (a
name, [Text] -> Env -> [Block] -> Expr
Frag [Text
"content"] Env
emptyEnv [Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
el TrailingSym
NoSym [] [Text -> [Block] -> Block
BlockDefault Text
"content" []]])

--------------------------------------------------------------------------------

-- Process mixin calls. This should be done after processing the include statement
-- since mixins may be defined in included files.
evaluate :: Monad m => Env -> [Text] -> [Block] -> ExceptT Error.Error m [Block]
evaluate :: forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
env [Text]
stack [Block]
nodes = do
  -- Note that we pass the environment that we are constructing, so that each
  -- definition sees all definitions (including later ones and itself).
  let vars :: [(Text, Expr)]
vars = Env -> [Block] -> [(Text, Expr)]
extractVariables Env
env' [Block]
nodes
      env' :: Env
env' = Env -> [(Text, Expr)] -> Env
augmentVariables Env
env [(Text, Expr)]
vars
  (Block -> ExceptT Error m Block)
-> [Block] -> ExceptT Error m [Block]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Env -> [Text] -> Block -> ExceptT Error m Block
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> Block -> ExceptT Error m Block
eval Env
env' [Text]
stack) [Block]
nodes

eval :: Monad m => Env -> [Text] -> Block -> ExceptT Error.Error m Block
eval :: forall (m :: * -> *).
Monad m =>
Env -> [Text] -> Block -> ExceptT Error m Block
eval Env
env [Text]
stack Block
b
  | [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
stack Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
100 =
      Error -> ExceptT Error m Block
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Block) -> Error -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$
        Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$
          Text
"Stack overflow. Is there an infinite loop?"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([Text] -> FilePath
forall a. Show a => a -> FilePath
show ([Text] -> FilePath) -> [Text] -> FilePath
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
stack)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Env -> Text
displayEnv Env
env
eval Env
env [Text]
stack Block
bl = case Block
bl of
  node :: Block
node@Block
BlockDoctype -> Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
  BlockElem Elem
name TrailingSym
mdot [Attr]
attrs [Block]
nodes -> do
    [Attr]
attrs' <- Env -> [Text] -> [Attr] -> ExceptT Error m [Attr]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Attr] -> ExceptT Error m [Attr]
evalAttrs Env
env [Text]
stack [Attr]
attrs
    [Block]
nodes' <- Env -> [Text] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
env [Text]
stack [Block]
nodes
    Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
name TrailingSym
mdot [Attr]
attrs' [Block]
nodes'
  BlockText TextSyntax
syn [Inline]
template -> do
    [Inline]
template' <- Env -> [Inline] -> ExceptT Error m [Inline]
forall (m :: * -> *).
Monad m =>
Env -> [Inline] -> ExceptT Error m [Inline]
evalTemplate Env
env [Inline]
template
    Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ TextSyntax -> [Inline] -> Block
BlockText TextSyntax
syn [Inline]
template'
  BlockInclude Maybe Text
mname FilePath
path Maybe [Block]
mnodes -> do
    case Maybe [Block]
mnodes of
      Just [Block]
nodes -> do
        [Block]
nodes' <- Env -> [Text] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
env (Text
"include" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
stack) [Block]
nodes
        Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Maybe Text -> FilePath -> Maybe [Block] -> Block
BlockInclude Maybe Text
mname FilePath
path ([Block] -> Maybe [Block]
forall a. a -> Maybe a
Just [Block]
nodes')
      Maybe [Block]
Nothing ->
        Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Maybe Text -> FilePath -> Maybe [Block] -> Block
BlockInclude Maybe Text
mname FilePath
path Maybe [Block]
forall a. Maybe a
Nothing
  node :: Block
node@(BlockFragmentDef DefinitionUse
_ Text
_ [Text]
_ [Block]
_) -> Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
  BlockFragmentCall Text
name TrailingSym
mdot [Attr]
attrs [Expr]
values [Block]
args -> do
    [Attr]
attrs' <- Env -> [Text] -> [Attr] -> ExceptT Error m [Attr]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Attr] -> ExceptT Error m [Attr]
evalAttrs Env
env [Text]
stack [Attr]
attrs
    [Block]
body <- Env
-> [Text] -> Text -> [Expr] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env
-> [Text] -> Text -> [Expr] -> [Block] -> ExceptT Error m [Block]
call Env
env [Text]
stack Text
name [Expr]
values [Block]
args
    let body' :: [Block]
body' = [Attr] -> [Block] -> [Block]
setAttrs [Attr]
attrs' [Block]
body
    Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Text -> TrailingSym -> [Attr] -> [Expr] -> [Block] -> Block
BlockFragmentCall Text
name TrailingSym
mdot [Attr]
attrs' [Expr]
values [Block]
body'
  BlockFor Text
name Maybe Text
mindex Expr
values [Block]
nodes -> do
    -- Re-use BlockFor to construct a single node to return.
    let zero :: Int
        zero :: Int
zero = Int
0
    Expr
values' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
values
    [(Expr, Expr)]
collection <- case Expr
values' of
      List [Expr]
xs -> [(Expr, Expr)] -> ExceptT Error m [(Expr, Expr)]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Expr, Expr)] -> ExceptT Error m [(Expr, Expr)])
-> [(Expr, Expr)] -> ExceptT Error m [(Expr, Expr)]
forall a b. (a -> b) -> a -> b
$ [Expr] -> [Expr] -> [(Expr, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr]
xs ([Expr] -> [(Expr, Expr)]) -> [Expr] -> [(Expr, Expr)]
forall a b. (a -> b) -> a -> b
$ (Int -> Expr) -> [Int] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Expr
Int [Int
zero ..]
      Object [(Expr, Expr)]
xs -> [(Expr, Expr)] -> ExceptT Error m [(Expr, Expr)]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Expr, Expr)] -> ExceptT Error m [(Expr, Expr)])
-> [(Expr, Expr)] -> ExceptT Error m [(Expr, Expr)]
forall a b. (a -> b) -> a -> b
$ ((Expr, Expr) -> (Expr, Expr)) -> [(Expr, Expr)] -> [(Expr, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Expr
k, Expr
v) -> (Expr
v, Expr
k)) [(Expr, Expr)]
xs
      Expr
_ -> Error -> ExceptT Error m [(Expr, Expr)]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m [(Expr, Expr)])
-> Error -> ExceptT Error m [(Expr, Expr)]
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Iterating on something that is not a collection"
    [[Block]]
nodes' <- [(Expr, Expr)]
-> ((Expr, Expr) -> ExceptT Error m [Block])
-> ExceptT Error m [[Block]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Expr, Expr)]
collection (((Expr, Expr) -> ExceptT Error m [Block])
 -> ExceptT Error m [[Block]])
-> ((Expr, Expr) -> ExceptT Error m [Block])
-> ExceptT Error m [[Block]]
forall a b. (a -> b) -> a -> b
$ \(Expr
value, Expr
index) -> do
      let env' :: Env
env' = case Maybe Text
mindex of
            Just Text
idxname -> Env -> [(Text, Expr)] -> Env
augmentVariables Env
env [(Text
name, Expr
value), (Text
idxname, Expr
index)]
            Maybe Text
Nothing -> Env -> [(Text, Expr)] -> Env
augmentVariables Env
env [(Text
name, Expr
value)]
      Env -> [Text] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
env' (Text
"each" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
stack) [Block]
nodes
    Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Expr -> [Block] -> Block
BlockFor Text
name Maybe Text
mindex Expr
values ([Block] -> Block) -> [Block] -> Block
forall a b. (a -> b) -> a -> b
$ [[Block]] -> [Block]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Block]]
nodes'
  node :: Block
node@(BlockComment CommentType
_ Text
_) -> Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
  node :: Block
node@(BlockFilter Text
_ Text
_) -> Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
  node :: Block
node@(BlockRawElem Text
_ [Block]
_) -> Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
  BlockDefault Text
name [Block]
nodes -> do
    -- If the fragment is not given as an argument, we return the default block,
    -- but recursively trying to replace the blocks found within its own body.
    case Text -> Env -> Maybe Expr
lookupVariable Text
name Env
env of
      Maybe Expr
Nothing -> do
        [Block]
nodes' <- Env -> [Text] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
env (Text
"?block" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
stack) [Block]
nodes
        Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Text -> [Block] -> Block
BlockDefault Text
name [Block]
nodes'
      Just (Frag [Text]
_ Env
capturedEnv [Block]
nodes') -> do
        [Block]
nodes'' <- Env -> [Text] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
capturedEnv (Text
"default block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
stack) [Block]
nodes'
        Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Text -> [Block] -> Block
BlockDefault Text
name [Block]
nodes''
      Just Expr
_ -> Error -> ExceptT Error m Block
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Block) -> Error -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Calling something that is not a fragment \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([Text] -> FilePath
forall a. Show a => a -> FilePath
show [Text]
stack)
  BlockImport FilePath
path Maybe [Block]
_ [Block]
args -> do
    [Block]
body <- Env
-> [Text] -> Text -> [Expr] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env
-> [Text] -> Text -> [Expr] -> [Block] -> ExceptT Error m [Block]
call Env
env [Text]
stack (FilePath -> Text
T.pack FilePath
path) [] [Block]
args
    Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe [Block] -> [Block] -> Block
BlockImport FilePath
path ([Block] -> Maybe [Block]
forall a. a -> Maybe a
Just [Block]
body) [Block]
args
  node :: Block
node@(BlockRun Text
_ Maybe Text
_ Maybe [Block]
_) -> Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
  node :: Block
node@(BlockAssignVars [(Text, Expr)]
_) -> Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
  BlockIf Expr
cond [Block]
as [Block]
bs -> do
    Expr
cond' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
cond
    case Expr
cond' of
      Bool Bool
True -> do
        [Block]
as' <- Env -> [Text] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
env (Text
"then" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
stack) [Block]
as
        Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Expr -> [Block] -> [Block] -> Block
BlockIf Expr
cond [Block]
as' []
      Bool Bool
False -> do
        [Block]
bs' <- Env -> [Text] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
env (Text
"else" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
stack) [Block]
bs
        Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Expr -> [Block] -> [Block] -> Block
BlockIf Expr
cond [] [Block]
bs'
      Expr
_ ->
        Error -> ExceptT Error m Block
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Block)
-> (Text -> Error) -> Text -> ExceptT Error m Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
Error.EvaluateError (Text -> ExceptT Error m Block) -> Text -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$
          Text
"Conditional is not a boolean: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show Expr
cond')
  BlockList [Block]
nodes -> do
    [Block]
nodes' <- Env -> [Text] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
env [Text]
stack [Block]
nodes
    Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ [Block] -> Block
BlockList [Block]
nodes'
  BlockCode Expr
code -> do
    Expr
code' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
code
    Block -> ExceptT Error m Block
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error m Block) -> Block -> ExceptT Error m Block
forall a b. (a -> b) -> a -> b
$ Expr -> Block
BlockCode Expr
code'

call :: Monad m => Env -> [Text] -> Text -> [Expr] -> [Block] -> ExceptT Error.Error m [Block]
call :: forall (m :: * -> *).
Monad m =>
Env
-> [Text] -> Text -> [Expr] -> [Block] -> ExceptT Error m [Block]
call Env
env [Text]
stack Text
name [Expr]
values [Block]
args =
  case Text -> Env -> Maybe Expr
lookupVariable Text
name Env
env of
    Just frag :: Expr
frag@(Frag [Text]
_ Env
_ [Block]
_) -> Env
-> [Text]
-> Text
-> [Expr]
-> [Block]
-> Expr
-> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env
-> [Text]
-> Text
-> [Expr]
-> [Block]
-> Expr
-> ExceptT Error m [Block]
evalFrag Env
env [Text]
stack Text
name [Expr]
values [Block]
args Expr
frag
    Just (Block Block
x) -> [Block] -> ExceptT Error m [Block]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Block
x]
    Just Expr
_ -> Error -> ExceptT Error m [Block]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m [Block])
-> Error -> ExceptT Error m [Block]
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Calling something that is not a fragment \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([Text] -> FilePath
forall a. Show a => a -> FilePath
show [Text]
stack)
    Maybe Expr
Nothing -> Error -> ExceptT Error m [Block]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m [Block])
-> Error -> ExceptT Error m [Block]
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Can't find fragment \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" while evaluating " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([Text] -> FilePath
forall a. Show a => a -> FilePath
show ([Text] -> FilePath) -> [Text] -> FilePath
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
stack) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with environment " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Env -> Text
displayEnv Env
env

lookupVariable :: Text -> Env -> Maybe Expr
lookupVariable :: Text -> Env -> Maybe Expr
lookupVariable Text
name Env {[(Text, Expr)]
envVariables :: [(Text, Expr)]
envVariables :: Env -> [(Text, Expr)]
..} = Text -> [(Text, Expr)] -> Maybe Expr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name [(Text, Expr)]
envVariables

augmentVariables :: Env -> [(Text, Expr)] -> Env
augmentVariables :: Env -> [(Text, Expr)] -> Env
augmentVariables Env {[(Text, Expr)]
envVariables :: Env -> [(Text, Expr)]
envVariables :: [(Text, Expr)]
..} [(Text, Expr)]
xs = Env {envVariables :: [(Text, Expr)]
envVariables = [(Text, Expr)]
xs [(Text, Expr)] -> [(Text, Expr)] -> [(Text, Expr)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Expr)]
envVariables}

evalFrag :: Monad m => Env -> [Text] -> Text -> [Expr] -> [Block] -> Expr -> ExceptT Error.Error m [Block]
evalFrag :: forall (m :: * -> *).
Monad m =>
Env
-> [Text]
-> Text
-> [Expr]
-> [Block]
-> Expr
-> ExceptT Error m [Block]
evalFrag Env
env [Text]
stack Text
name [Expr]
values [Block]
args (Frag [Text]
names Env
capturedEnv [Block]
body) = do
  [(Text, Expr)]
env' <- Env -> [Block] -> ExceptT Error m [(Text, Expr)]
forall (m :: * -> *).
Monad m =>
Env -> [Block] -> ExceptT Error m [(Text, Expr)]
extractVariables' Env
env [Block]
args
  case ((Text, Expr) -> Text) -> [(Text, Expr)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Expr) -> Text
forall a b. (a, b) -> a
fst [(Text, Expr)]
env' [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
names of
    [] -> () -> ExceptT Error m ()
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Text
"content"] -> () -> ExceptT Error m ()
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Text]
ns -> Error -> ExceptT Error m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m ())
-> (Text -> Error) -> Text -> ExceptT Error m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
Error.EvaluateError (Text -> ExceptT Error m ()) -> Text -> ExceptT Error m ()
forall a b. (a -> b) -> a -> b
$
      Text
"Unnecessary arguments to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([Text] -> FilePath
forall a. Show a => a -> FilePath
show [Text]
ns)
  let env'' :: Env
env'' = Env -> [(Text, Expr)] -> Env
augmentVariables ([Text] -> Env -> Env
forall {t :: * -> *}. Foldable t => t Text -> Env -> Env
removeFormalParams [Text]
names Env
capturedEnv) [(Text, Expr)]
env'
      arguments :: [(Text, Expr)]
arguments = [Text] -> [Expr] -> [(Text, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
names ((Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Env -> Expr -> Expr
thunk Env
env) [Expr]
values)
      env''' :: Env
env''' = Env -> [(Text, Expr)] -> Env
augmentVariables Env
env'' [(Text, Expr)]
arguments
  [Block]
body' <- Env -> [Text] -> [Block] -> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
evaluate Env
env''' (Text
"frag " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
stack) [Block]
body
  [Block] -> ExceptT Error m [Block]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Block]
body'

removeFormalParams :: t Text -> Env -> Env
removeFormalParams t Text
names Env {[(Text, Expr)]
envVariables :: Env -> [(Text, Expr)]
envVariables :: [(Text, Expr)]
..} = Env { envVariables :: [(Text, Expr)]
envVariables = [(Text, Expr)]
vars' }
 where
  vars' :: [(Text, Expr)]
vars' = ((Text, Expr) -> Bool) -> [(Text, Expr)] -> [(Text, Expr)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Text, Expr) -> Bool) -> (Text, Expr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> t Text -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Text
names) (Text -> Bool) -> ((Text, Expr) -> Text) -> (Text, Expr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Expr) -> Text
forall a b. (a, b) -> a
fst) [(Text, Expr)]
envVariables

evalAttrs :: Monad m => Env -> [Text] -> [Attr] -> ExceptT Error.Error m [Attr]
evalAttrs :: forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Attr] -> ExceptT Error m [Attr]
evalAttrs Env
env [Text]
stack [Attr]
attrs = (Attr -> ExceptT Error m Attr) -> [Attr] -> ExceptT Error m [Attr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Attr -> ExceptT Error m Attr
forall {m :: * -> *}. Monad m => Attr -> ExceptT Error m Attr
f [Attr]
attrs
 where
  f :: Attr -> ExceptT Error m Attr
f (Attr Text
a Expr
b) = do
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    Attr -> ExceptT Error m Attr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attr -> ExceptT Error m Attr) -> Attr -> ExceptT Error m Attr
forall a b. (a -> b) -> a -> b
$ Text -> Expr -> Attr
Attr Text
a Expr
b'
  f Attr
attr = Attr -> ExceptT Error m Attr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attr
attr

evalExpr :: Monad m => Env -> Expr -> ExceptT Error.Error m Expr
evalExpr :: forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env = \case
  Variable Text
name ->
    case Text -> Env -> Maybe Expr
lookupVariable Text
name Env
env of
      Just Expr
val -> Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
val
      Maybe Expr
Nothing -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Can't find variable \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
  Lookup Text
name Expr
key ->
    case Text -> Env -> Maybe Expr
lookupVariable Text
name Env
env of
      Just (Object [(Expr, Expr)]
obj) -> do
        -- key' <- evalExpr env key
        case Expr -> [(Expr, Expr)] -> Maybe Expr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Expr
key [(Expr, Expr)]
obj of
          Just Expr
val -> Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
val
          Maybe Expr
Nothing -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr) -> Expr -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Bool -> Expr
Bool Bool
False -- TODO Either crash, or we have to implement on option type.
      Just Expr
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Variable \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" is not an object"
      Maybe Expr
Nothing -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Can't find variable \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
  Add Expr
a Expr
b -> do
    Expr
a' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
a
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    case (Expr
a', Expr
b') of
      (Int Int
i, Int Int
j) -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Int -> Expr) -> Int -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expr
Int (Int -> ExceptT Error m Expr) -> Int -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j
      (SingleQuoteString Text
s, SingleQuoteString Text
t) ->
        Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Text -> Expr) -> Text -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Expr
SingleQuoteString (Text -> ExceptT Error m Expr) -> Text -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
      (Block Block
a, Block Block
b) ->
        Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Block -> Expr) -> Block -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Expr
Block (Block -> ExceptT Error m Expr) -> Block -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Block -> Block -> Block
pasteBlocks Block
a Block
b
      (Expr, Expr)
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Unimplemented (add): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show (Expr -> Expr -> Expr
Add Expr
a' Expr
b'))
  Sub Expr
a Expr
b -> do
    Expr
a' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
a
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    case (Expr
a', Expr
b') of
      (Int Int
i, Int Int
j) -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Int -> Expr) -> Int -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expr
Int (Int -> ExceptT Error m Expr) -> Int -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j
      (Expr, Expr)
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Unimplemented (sub): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show (Expr -> Expr -> Expr
Sub Expr
a' Expr
b'))
  Times Expr
a Expr
b -> do
    Expr
a' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
a
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    case (Expr
a', Expr
b') of
      (Int Int
i, Int Int
j) -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Int -> Expr) -> Int -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expr
Int (Int -> ExceptT Error m Expr) -> Int -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
j
      (Expr, Expr)
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Unimplemented (times): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show (Expr -> Expr -> Expr
Times Expr
a' Expr
b'))
  Divide Expr
a Expr
b -> do
    Expr
a' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
a
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    case (Expr
a', Expr
b') of
      (Int Int
i, Int Int
j) -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Int -> Expr) -> Int -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expr
Int (Int -> ExceptT Error m Expr) -> Int -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
j
      (Expr, Expr)
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Unimplemented (divide): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show (Expr -> Expr -> Expr
Divide Expr
a' Expr
b'))
  GreaterThan Expr
a Expr
b -> do
    Expr
a' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
a
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    case (Expr
a', Expr
b') of
      (Int Int
i, Int Int
j) -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Bool -> Expr) -> Bool -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Expr
Bool (Bool -> ExceptT Error m Expr) -> Bool -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
j
      (Expr, Expr)
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Unimplemented (greater-than): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show (Expr -> Expr -> Expr
GreaterThan Expr
a' Expr
b'))
  LesserThan Expr
a Expr
b -> do
    Expr
a' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
a
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    case (Expr
a', Expr
b') of
      (Int Int
i, Int Int
j) -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Bool -> Expr) -> Bool -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Expr
Bool (Bool -> ExceptT Error m Expr) -> Bool -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j
      (Expr, Expr)
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Unimplemented (lesser-than): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show (Expr -> Expr -> Expr
LesserThan Expr
a' Expr
b'))
  Equal Expr
a Expr
b -> do
    Expr
a' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
a
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    case (Expr
a', Expr
b') of
      (Bool Bool
i, Bool Bool
j) -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Bool -> Expr) -> Bool -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Expr
Bool (Bool -> ExceptT Error m Expr) -> Bool -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Bool
i Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
j
      (Int Int
i, Int Int
j) -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Bool -> Expr) -> Bool -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Expr
Bool (Bool -> ExceptT Error m Expr) -> Bool -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j
      (SingleQuoteString Text
s, SingleQuoteString Text
t) -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Bool -> Expr) -> Bool -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Expr
Bool (Bool -> ExceptT Error m Expr) -> Bool -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t
      (Expr, Expr)
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Unimplemented (equal): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show (Expr -> Expr -> Expr
Equal Expr
a' Expr
b'))
  Cons Expr
a Expr
b -> do
    Expr
a' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
a
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    case (Expr
a', Expr
b') of
      (Block Block
bl, Block Block
c) ->
        Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Block -> Expr) -> Block -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Expr
Block (Block -> ExceptT Error m Expr) -> Block -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ [Block] -> Block -> Block
setContent [Block
c] Block
bl
      (Block Block
bl, SingleQuoteString Text
s) ->
        Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Block -> Expr) -> Block -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Expr
Block (Block -> ExceptT Error m Expr) -> Block -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ [Block] -> Block -> Block
setContent [TextSyntax -> [Inline] -> Block
BlockText TextSyntax
Normal [Text -> Inline
Lit Text
s]] Block
bl
      (Expr, Expr)
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Unimplemented (cons): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show (Expr -> Expr -> Expr
Cons Expr
a' Expr
b'))
  Application Expr
a Expr
b -> do
    Expr
a' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
a
    Expr
b' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
b
    Env -> Expr -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> Expr -> ExceptT Error m Expr
evalApplication Env
env Expr
a' Expr
b'
  Thunk Env
capturedEnv Expr
code ->
    Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
capturedEnv Expr
code
  frag :: Expr
frag@(Frag [Text]
_ Env
_ [Block]
_) -> do
    [Block]
blocks <- Env
-> [Text]
-> Text
-> [Expr]
-> [Block]
-> Expr
-> ExceptT Error m [Block]
forall (m :: * -> *).
Monad m =>
Env
-> [Text]
-> Text
-> [Expr]
-> [Block]
-> Expr
-> ExceptT Error m [Block]
evalFrag Env
env [Text
"frag"] Text
"-" [] [] Expr
frag
    case [Block]
blocks of
      [Block
bl] -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr) -> Expr -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Block -> Expr
Block Block
bl
      [Block]
_ -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Block -> Expr) -> Block -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Expr
Block (Block -> ExceptT Error m Expr) -> Block -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ [Block] -> Block
BlockList [Block]
blocks
  Block Block
b -> do
    Block
b' <- Env -> [Text] -> Block -> ExceptT Error m Block
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> Block -> ExceptT Error m Block
eval Env
env [Text
"block"] Block
b
    Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr) -> Expr -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Block -> Expr
Block Block
b'
  Expr
code -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
code

evalApplication :: Monad m => Env -> Expr -> Expr -> ExceptT Error.Error m Expr
evalApplication :: forall (m :: * -> *).
Monad m =>
Env -> Expr -> Expr -> ExceptT Error m Expr
evalApplication Env
env Expr
a Expr
b =
  case Expr
a of
    BuiltIn Text
"show" -> case Expr
b of
      Int Int
i -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (FilePath -> Expr) -> FilePath -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Expr
SingleQuoteString (Text -> Expr) -> (FilePath -> Text) -> FilePath -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> ExceptT Error m Expr)
-> FilePath -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i
      Expr
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Cannot apply show to: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show Expr
b)
    BuiltIn Text
"null" -> case Expr
b of
      SingleQuoteString Text
s -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Bool -> Expr) -> Bool -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Expr
Bool (Bool -> ExceptT Error m Expr) -> Bool -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
s
      -- TODO Lookup returns False when the key is not present,
      -- but I have this code around:
      --   if null entry['journal']
      -- We need something like:
      --   if 'journal' in entry
      --   if elem 'journal' (keys entry)
      --   ...
      Bool Bool
False -> Expr -> ExceptT Error m Expr
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ExceptT Error m Expr)
-> (Bool -> Expr) -> Bool -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Expr
Bool (Bool -> ExceptT Error m Expr) -> Bool -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Bool
True
      Expr
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Cannot apply null to: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show Expr
b)
    Expr
_ -> Error -> ExceptT Error m Expr
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m Expr) -> Error -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Cannot apply: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Expr -> FilePath
forall a. Show a => a -> FilePath
show Expr
a)

evalTemplate :: Monad m => Env -> [Inline] -> ExceptT Error.Error m [Inline]
evalTemplate :: forall (m :: * -> *).
Monad m =>
Env -> [Inline] -> ExceptT Error m [Inline]
evalTemplate Env
env [Inline]
inlines =
  (Inline -> ExceptT Error m Inline)
-> [Inline] -> ExceptT Error m [Inline]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Env -> Inline -> ExceptT Error m Inline
forall (m :: * -> *).
Monad m =>
Env -> Inline -> ExceptT Error m Inline
evalInline Env
env) [Inline]
inlines

evalInline :: Monad m => Env -> Inline -> ExceptT Error.Error m Inline
evalInline :: forall (m :: * -> *).
Monad m =>
Env -> Inline -> ExceptT Error m Inline
evalInline Env
env = \case
  Lit Text
s -> Inline -> ExceptT Error m Inline
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> ExceptT Error m Inline)
-> Inline -> ExceptT Error m Inline
forall a b. (a -> b) -> a -> b
$ Text -> Inline
Lit Text
s
  Place Expr
code -> do
    Expr
code' <- Env -> Expr -> ExceptT Error m Expr
forall (m :: * -> *).
Monad m =>
Env -> Expr -> ExceptT Error m Expr
evalExpr Env
env Expr
code
    case Expr
code' of
      SingleQuoteString Text
_ -> Inline -> ExceptT Error m Inline
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> ExceptT Error m Inline)
-> Inline -> ExceptT Error m Inline
forall a b. (a -> b) -> a -> b
$ Expr -> Inline
Place Expr
code'
      Bool Bool
_ -> Inline -> ExceptT Error m Inline
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> ExceptT Error m Inline)
-> Inline -> ExceptT Error m Inline
forall a b. (a -> b) -> a -> b
$ Expr -> Inline
Place Expr
code'
      Int Int
_ -> Inline -> ExceptT Error m Inline
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> ExceptT Error m Inline)
-> Inline -> ExceptT Error m Inline
forall a b. (a -> b) -> a -> b
$ Expr -> Inline
Place Expr
code'
      Block Block
_ -> Inline -> ExceptT Error m Inline
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> ExceptT Error m Inline)
-> Inline -> ExceptT Error m Inline
forall a b. (a -> b) -> a -> b
$ Expr -> Inline
Place Expr
code'
      -- Variable x -> context x -- Should not happen after evalExpr
      Expr
x -> FilePath -> ExceptT Error m Inline
forall a. HasCallStack => FilePath -> a
error (FilePath -> ExceptT Error m Inline)
-> FilePath -> ExceptT Error m Inline
forall a b. (a -> b) -> a -> b
$ FilePath
"evalInline: unhandled value: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Expr -> FilePath
forall a. Show a => a -> FilePath
show Expr
x

-- | Same as `extractVariables` plus an implicit @content@ block.
-- Note that unlike `extractVariables`, this version takes also care of
-- passing the environment being constructed to each definition.
extractVariables' :: Monad m => Env -> [Block] -> ExceptT Error.Error m [(Text, Expr)]
extractVariables' :: forall (m :: * -> *).
Monad m =>
Env -> [Block] -> ExceptT Error m [(Text, Expr)]
extractVariables' Env
env [Block]
nodes = do
  let named :: [(Text, Expr)]
named = Env -> [Block] -> [(Text, Expr)]
extractVariables Env
env' [Block]
nodes
      unnamed :: [Block]
unnamed = (Block -> [Block]) -> [Block] -> [Block]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [Block]
unnamedBlock [Block]
nodes
      content :: [(Text, Expr)]
content = if [Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
unnamed then [] else [(Text
"content", [Text] -> Env -> [Block] -> Expr
Frag [] Env
env' [Block]
unnamed)]
      env' :: Env
env' = Env -> [(Text, Expr)] -> Env
augmentVariables Env
env [(Text, Expr)]
named -- Note we don't add the implicit "content" entry.
      args :: [(Text, Expr)]
args = Env -> [Block] -> [(Text, Expr)]
extractArguments Env
env' [Block]
nodes
      vars :: [(Text, Expr)]
vars = [(Text, Expr)]
args [(Text, Expr)] -> [(Text, Expr)] -> [(Text, Expr)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Expr)]
content
  if Maybe Expr -> Bool
forall a. Maybe a -> Bool
isJust (Text -> [(Text, Expr)] -> Maybe Expr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"content" [(Text, Expr)]
args) Bool -> Bool -> Bool
&& Bool -> Bool
not ([Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
unnamed)
    then
      Error -> ExceptT Error m [(Text, Expr)]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m [(Text, Expr)])
-> Error -> ExceptT Error m [(Text, Expr)]
forall a b. (a -> b) -> a -> b
$
        Text -> Error
Error.EvaluateError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$
          Text
"A block of content and a content argument are provided"
    else [(Text, Expr)] -> ExceptT Error m [(Text, Expr)]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Text, Expr)]
vars

unnamedBlock :: Block -> [Block]
unnamedBlock :: Block -> [Block]
unnamedBlock (BlockImport FilePath
path Maybe [Block]
_ [Block]
args) = [Text -> TrailingSym -> [Attr] -> [Expr] -> [Block] -> Block
BlockFragmentCall (FilePath -> Text
T.pack FilePath
path) TrailingSym
NoSym [] [] [Block]
args]
unnamedBlock (BlockFragmentDef DefinitionUse
DefinitionArg Text
_ [Text]
_ [Block]
_) = []
unnamedBlock Block
node = [Block
node]

-- Extract both fragments and assignments.
-- TODO This should be merged with extractVariables'.
-- TODO We could filter the env, keeping only the free variables that appear
-- in the bodies.
extractVariables :: Env -> [Block] -> [(Text, Expr)]
extractVariables :: Env -> [Block] -> [(Text, Expr)]
extractVariables Env
env = (Block -> [(Text, Expr)]) -> [Block] -> [(Text, Expr)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Env -> Block -> [(Text, Expr)]
extractVariable Env
env)

extractVariable :: Env -> Block -> [(Text, Expr)]
extractVariable :: Env -> Block -> [(Text, Expr)]
extractVariable Env
env = \case
  Block
BlockDoctype -> []
  (BlockElem Elem
_ TrailingSym
_ [Attr]
_ [Block]
_) -> []
  (BlockText TextSyntax
_ [Inline]
_) -> []
  (BlockInclude Maybe Text
_ FilePath
_ Maybe [Block]
children) -> [(Text, Expr)]
-> ([Block] -> [(Text, Expr)]) -> Maybe [Block] -> [(Text, Expr)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Env -> [Block] -> [(Text, Expr)]
extractVariables Env
env) Maybe [Block]
children
  (BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
_) -> []
  (BlockFragmentDef DefinitionUse
DefinitionNormal Text
name [Text]
names [Block]
children) ->
    [(Text
name, [Text] -> Env -> [Block] -> Expr
Frag [Text]
names Env
env [Block]
children)]
  (BlockFragmentDef DefinitionUse
DefinitionArg Text
name [Text]
names [Block]
children) ->
    []
  (BlockFragmentCall Text
_ TrailingSym
_ [Attr]
_ [Expr]
_ [Block]
_) -> []
  (BlockComment CommentType
_ Text
_) -> []
  (BlockFilter Text
_ Text
_) -> []
  (BlockRawElem Text
_ [Block]
_) -> []
  (BlockDefault Text
_ [Block]
_) -> []
  (BlockImport FilePath
path (Just [Block]
body) [Block]
_) -> [(FilePath -> Text
T.pack FilePath
path, [Text] -> Env -> [Block] -> Expr
Frag [] Env
env [Block]
body)]
  (BlockImport FilePath
_ Maybe [Block]
_ [Block]
_) -> []
  (BlockRun Text
_ Maybe Text
_ Maybe [Block]
_) -> []
  (BlockAssignVars [(Text, Expr)]
pairs) -> [(Text, Expr)]
pairs
  (BlockIf Expr
_ [Block]
_ [Block]
_) -> []
  (BlockList [Block]
_) -> []
  (BlockCode Expr
_) -> []

-- Extract fragments used as arguments of fragment calls.
extractArguments :: Env -> [Block] -> [(Text, Expr)]
extractArguments :: Env -> [Block] -> [(Text, Expr)]
extractArguments Env
env = (Block -> [(Text, Expr)]) -> [Block] -> [(Text, Expr)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Env -> Block -> [(Text, Expr)]
extractArgument Env
env)

extractArgument :: Env -> Block -> [(Text, Expr)]
extractArgument :: Env -> Block -> [(Text, Expr)]
extractArgument Env
env = \case
  Block
BlockDoctype -> []
  (BlockElem Elem
_ TrailingSym
_ [Attr]
_ [Block]
_) -> []
  (BlockText TextSyntax
_ [Inline]
_) -> []
  (BlockInclude Maybe Text
_ FilePath
_ Maybe [Block]
_) -> []
  (BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
_) -> []
  (BlockFragmentDef DefinitionUse
DefinitionNormal Text
_ [Text]
_ [Block]
_) ->
    []
  (BlockFragmentDef DefinitionUse
DefinitionArg Text
name [Text]
names [Block]
children) ->
    [(Text
name, [Text] -> Env -> [Block] -> Expr
Frag [Text]
names Env
env [Block]
children)]
  (BlockFragmentCall Text
_ TrailingSym
_ [Attr]
_ [Expr]
_ [Block]
_) -> []
  (BlockComment CommentType
_ Text
_) -> []
  (BlockFilter Text
_ Text
_) -> []
  (BlockRawElem Text
_ [Block]
_) -> []
  (BlockDefault Text
_ [Block]
_) -> []
  (BlockImport FilePath
_ Maybe [Block]
_ [Block]
_) -> []
  (BlockRun Text
_ Maybe Text
_ Maybe [Block]
_) -> []
  (BlockAssignVars [(Text, Expr)]
_) -> []
  (BlockIf Expr
_ [Block]
_ [Block]
_) -> []
  (BlockList [Block]
_) -> []
  (BlockCode Expr
_) -> []

--------------------------------------------------------------------------------
simplify :: [Block] -> [Block]
simplify :: [Block] -> [Block]
simplify = (Block -> [Block]) -> [Block] -> [Block]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [Block]
simplify'

simplify' :: Block -> [Block]
simplify' :: Block -> [Block]
simplify' = \case
  node :: Block
node@Block
BlockDoctype -> [Block
node]
  BlockElem Elem
name TrailingSym
mdot [Attr]
attrs [Block]
nodes -> [Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
name TrailingSym
mdot [Attr]
attrs ([Block] -> Block) -> [Block] -> Block
forall a b. (a -> b) -> a -> b
$ [Block] -> [Block]
simplify [Block]
nodes]
  node :: Block
node@(BlockText TextSyntax
_ [Inline]
_) -> [Block
node]
  BlockInclude Maybe Text
mfilter FilePath
path Maybe [Block]
mnodes -> [Maybe Text -> FilePath -> Maybe [Block] -> Block
BlockInclude Maybe Text
mfilter FilePath
path (Maybe [Block] -> Block) -> Maybe [Block] -> Block
forall a b. (a -> b) -> a -> b
$ [Block] -> [Block]
simplify ([Block] -> [Block]) -> Maybe [Block] -> Maybe [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Block]
mnodes]
  BlockFragmentDef DefinitionUse
_ Text
_ [Text]
_ [Block]
_ -> []
  BlockFragmentCall Text
_ TrailingSym
_ [Attr]
_ [Expr]
_ [Block]
args -> [Block] -> [Block]
simplify [Block]
args
  BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
nodes -> [Block] -> [Block]
simplify [Block]
nodes
  node :: Block
node@(BlockComment CommentType
_ Text
_) -> [Block
node]
  node :: Block
node@(BlockFilter Text
_ Text
_) -> [Block
node]
  node :: Block
node@(BlockRawElem Text
_ [Block]
_) -> [Block
node]
  BlockDefault Text
_ [Block]
nodes -> [Block] -> [Block]
simplify [Block]
nodes
  BlockImport FilePath
_ Maybe [Block]
mbody [Block]
_ -> [Block] -> ([Block] -> [Block]) -> Maybe [Block] -> [Block]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [Block]
simplify Maybe [Block]
mbody
  BlockRun Text
_ Maybe Text
_ Maybe [Block]
mbody -> [Block] -> ([Block] -> [Block]) -> Maybe [Block] -> [Block]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [Block]
simplify Maybe [Block]
mbody
  BlockAssignVars [(Text, Expr)]
_ -> []
  BlockIf Expr
_ [] [Block]
bs -> [Block] -> [Block]
simplify [Block]
bs
  BlockIf Expr
_ [Block]
as [Block]
_ -> [Block] -> [Block]
simplify [Block]
as
  BlockList [Block]
nodes -> [Block] -> [Block]
simplify [Block]
nodes
  node :: Block
node@(BlockCode Expr
_) -> [Block
node]