{-# 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.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Aeson.Key
import Data.Aeson.KeyMap qualified as Aeson.KeyMap
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Vector qualified as V
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 :: [Char] -> 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]))
-> ([Char] -> ExceptT Error IO [Block])
-> [Char]
-> IO (Either Error [Block])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ExceptT Error IO [Block]
evaluateFileE

evaluateFileE :: FilePath -> ExceptT Error.Error IO [Block]
evaluateFileE :: [Char] -> ExceptT Error IO [Block]
evaluateFileE [Char]
path =
  [Char] -> ExceptT Error IO [Block]
PreProcess.preprocessFileE [Char]
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 [[Char] -> Text
T.pack [Char]
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
"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
<> [Char] -> Text
T.pack ([Text] -> [Char]
forall a. Show a => a -> [Char]
show ([Text] -> [Char]) -> [Text] -> [Char]
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
    [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 [Char]
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 -> [Char] -> Maybe [Block] -> Block
BlockInclude Maybe Text
mname [Char]
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 -> [Char] -> Maybe [Block] -> Block
BlockInclude Maybe Text
mname [Char]
path Maybe [Block]
forall a. Maybe a
Nothing
  node :: Block
node@(BlockFragmentDef 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
    [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
<> [Char] -> Text
T.pack ([Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
stack)
  BlockImport [Char]
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 ([Char] -> Text
T.pack [Char]
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
$ [Char] -> Maybe [Block] -> [Block] -> Block
BlockImport [Char]
path ([Block] -> Maybe [Block]
forall a. a -> Maybe a
Just [Block]
body) [Block]
args
  node :: Block
node@(BlockRun 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@(BlockReadJson Text
_ [Char]
_ Maybe Value
_) -> 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@(BlockAssignVar 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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack ([Text] -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack ([Text] -> [Char]
forall a. Show a => a -> [Char]
show ([Text] -> [Char]) -> [Text] -> [Char]
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
  let env'' :: Env
env'' = Env -> [(Text, Expr)] -> Env
augmentVariables 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'

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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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)
-> ([Char] -> Expr) -> [Char] -> ExceptT Error m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Expr
SingleQuoteString (Text -> Expr) -> ([Char] -> Text) -> [Char] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> ExceptT Error m Expr) -> [Char] -> ExceptT Error m Expr
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
T.pack (Expr -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char] -> ExceptT Error m Inline
forall a. HasCallStack => [Char] -> a
error ([Char] -> ExceptT Error m Inline)
-> [Char] -> ExceptT Error m Inline
forall a b. (a -> b) -> a -> b
$ [Char]
"evalInline: unhandled value: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Expr -> [Char]
forall a. Show a => a -> [Char]
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)]
      vars :: [(Text, Expr)]
vars = [(Text, Expr)]
named [(Text, Expr)] -> [(Text, Expr)] -> [(Text, Expr)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Expr)]
content
      env' :: Env
env' = Env -> [(Text, Expr)] -> Env
augmentVariables Env
env [(Text, Expr)]
named -- Note we don't add the implicit "content" entry.
  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)]
named) 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 [Char]
path Maybe [Block]
_ [Block]
args) = [Text -> TrailingSym -> [Attr] -> [Expr] -> [Block] -> Block
BlockFragmentCall ([Char] -> Text
T.pack [Char]
path) TrailingSym
NoSym [] [] [Block]
args]
unnamedBlock (BlockFragmentDef 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
_ [Char]
_ 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 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 [Char]
path (Just [Block]
body) [Block]
_) -> [([Char] -> Text
T.pack [Char]
path, [Text] -> Env -> [Block] -> Expr
Frag [] Env
env [Block]
body)]
  (BlockImport [Char]
_ Maybe [Block]
_ [Block]
_) -> []
  (BlockRun Text
_ Maybe [Block]
_) -> []
  (BlockReadJson Text
name [Char]
_ (Just Value
val)) -> [(Text
name, Value -> Expr
jsonToExpr Value
val)]
  (BlockReadJson Text
_ [Char]
_ Maybe Value
Nothing) -> []
  (BlockAssignVar Text
name Expr
val) -> [(Text
name, Expr
val)]
  (BlockIf Expr
_ [Block]
_ [Block]
_) -> []
  (BlockList [Block]
_) -> []
  (BlockCode Expr
_) -> []

jsonToExpr :: Aeson.Value -> Expr
jsonToExpr :: Value -> Expr
jsonToExpr = \case
  Aeson.String Text
s -> Text -> Expr
SingleQuoteString Text
s
  Aeson.Array Array
xs ->
    [Expr] -> Expr
List ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ (Value -> Expr) -> [Value] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Expr
jsonToExpr (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
xs)
  Aeson.Object Object
kvs ->
    let f :: (Key, Value) -> (Expr, Expr)
f (Key
k, Value
v) = (Text -> Expr
SingleQuoteString (Text -> Expr) -> Text -> Expr
forall a b. (a -> b) -> a -> b
$ Key -> Text
Aeson.Key.toText Key
k, Value -> Expr
jsonToExpr Value
v)
     in [(Expr, Expr)] -> Expr
Object ([(Expr, Expr)] -> Expr) -> [(Expr, Expr)] -> Expr
forall a b. (a -> b) -> a -> b
$ ((Key, Value) -> (Expr, Expr)) -> [(Key, Value)] -> [(Expr, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Value) -> (Expr, Expr)
f (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
Aeson.KeyMap.toList Object
kvs)
  Value
x -> [Char] -> Expr
forall a. HasCallStack => [Char] -> a
error ([Char] -> Expr) -> [Char] -> Expr
forall a b. (a -> b) -> a -> b
$ [Char]
"jsonToExpr: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Value -> [Char]
forall a. Show a => a -> [Char]
show Value
x

--------------------------------------------------------------------------------
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
_ [Char]
_ Maybe [Block]
mnodes -> [Block] -> ([Block] -> [Block]) -> Maybe [Block] -> [Block]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [Block]
simplify Maybe [Block]
mnodes
  BlockFragmentDef 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 [Char]
_ 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 [Block]
mbody -> [Block] -> ([Block] -> [Block]) -> Maybe [Block] -> [Block]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [Block]
simplify Maybe [Block]
mbody
  BlockReadJson Text
_ [Char]
_ Maybe Value
_ -> []
  BlockAssignVar 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]