{-# LANGUAGE RecordWildCards #-}

module Slab.Evaluate
  ( evaluateFile
  , evaluate
  , 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 [Text
"toplevel"]

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

-- 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 = \case
  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 [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
    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 -> [Expr] -> [Block] -> Block
BlockFragmentCall Text
name [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
"+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 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
      SingleQuoteString Text
s
        | Bool -> Bool
not (Text -> Bool
T.null Text
s) -> 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' []
      Int Int
n
        | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 -> 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' []
      Expr
_ -> 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'
  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 [Text]
names Env
capturedEnv [Block]
body) -> do
      [(Text, Expr)]
env' <- ((Text, ([Text], [Block])) -> (Text, Expr))
-> [(Text, ([Text], [Block]))] -> [(Text, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
a, ([Text]
as, [Block]
b)) -> (Text
a, [Text] -> Env -> [Block] -> Expr
Frag [Text]
as Env
env [Block]
b)) ([(Text, ([Text], [Block]))] -> [(Text, Expr)])
-> ExceptT Error m [(Text, ([Text], [Block]))]
-> ExceptT Error m [(Text, Expr)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block] -> ExceptT Error m [(Text, ([Text], [Block]))]
forall (m :: * -> *).
Monad m =>
[Block] -> ExceptT Error m [(Text, ([Text], [Block]))]
namedBlocks [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. 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'
    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
"\""

defaultEnv :: Env
defaultEnv :: Env
defaultEnv = [(Text, Expr)] -> Env
Env [(Text
"true", Int -> Expr
Int Int
1), (Text
"false", Int -> Expr
Int Int
0)]

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}

namedBlocks :: Monad m => [Block] -> ExceptT Error.Error m [(Text, ([Text], [Block]))]
namedBlocks :: forall (m :: * -> *).
Monad m =>
[Block] -> ExceptT Error m [(Text, ([Text], [Block]))]
namedBlocks [Block]
nodes = do
  [(Text, ([Text], [Block]))]
named <- [[(Text, ([Text], [Block]))]] -> [(Text, ([Text], [Block]))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Text, ([Text], [Block]))]] -> [(Text, ([Text], [Block]))])
-> ExceptT Error m [[(Text, ([Text], [Block]))]]
-> ExceptT Error m [(Text, ([Text], [Block]))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> ExceptT Error m [(Text, ([Text], [Block]))])
-> [Block] -> ExceptT Error m [[(Text, ([Text], [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 Block -> ExceptT Error m [(Text, ([Text], [Block]))]
forall (m :: * -> *).
Monad m =>
Block -> ExceptT Error m [(Text, ([Text], [Block]))]
namedBlock [Block]
nodes
  [Block]
unnamed <- [[Block]] -> [Block]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Block]] -> [Block])
-> ExceptT Error m [[Block]] -> ExceptT Error m [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 Block -> ExceptT Error m [Block]
forall (m :: * -> *). Monad m => Block -> ExceptT Error m [Block]
unnamedBlock [Block]
nodes
  let content :: [(Text, ([a], [Block]))]
content = if [Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
unnamed then [] else [(Text
"content", ([], [Block]
unnamed))]
  if Maybe ([Text], [Block]) -> Bool
forall a. Maybe a -> Bool
isJust (Text -> [(Text, ([Text], [Block]))] -> Maybe ([Text], [Block])
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"content" [(Text, ([Text], [Block]))]
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, ([Text], [Block]))]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m [(Text, ([Text], [Block]))])
-> Error -> ExceptT Error m [(Text, ([Text], [Block]))]
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, ([Text], [Block]))]
-> ExceptT Error m [(Text, ([Text], [Block]))]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, ([Text], [Block]))]
 -> ExceptT Error m [(Text, ([Text], [Block]))])
-> [(Text, ([Text], [Block]))]
-> ExceptT Error m [(Text, ([Text], [Block]))]
forall a b. (a -> b) -> a -> b
$ [(Text, ([Text], [Block]))]
named [(Text, ([Text], [Block]))]
-> [(Text, ([Text], [Block]))] -> [(Text, ([Text], [Block]))]
forall a. Semigroup a => a -> a -> a
<> [(Text, ([Text], [Block]))]
forall {a}. [(Text, ([a], [Block]))]
content

namedBlock :: Monad m => Block -> ExceptT Error.Error m [(Text, ([Text], [Block]))]
namedBlock :: forall (m :: * -> *).
Monad m =>
Block -> ExceptT Error m [(Text, ([Text], [Block]))]
namedBlock (BlockImport [Char]
path (Just [Block]
body) [Block]
_) = [(Text, ([Text], [Block]))]
-> ExceptT Error m [(Text, ([Text], [Block]))]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [([Char] -> Text
T.pack [Char]
path, ([], [Block]
body))]
namedBlock (BlockFragmentDef Text
name [Text]
names [Block]
content) = [(Text, ([Text], [Block]))]
-> ExceptT Error m [(Text, ([Text], [Block]))]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Text
name, ([Text]
names, [Block]
content))]
namedBlock Block
_ = [(Text, ([Text], [Block]))]
-> ExceptT Error m [(Text, ([Text], [Block]))]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

unnamedBlock :: Monad m => Block -> ExceptT Error.Error m [Block]
unnamedBlock :: forall (m :: * -> *). Monad m => Block -> ExceptT Error m [Block]
unnamedBlock (BlockImport [Char]
path Maybe [Block]
_ [Block]
args) =
  [Block] -> ExceptT Error m [Block]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> [Expr] -> [Block] -> Block
BlockFragmentCall ([Char] -> Text
T.pack [Char]
path) [] [Block]
args]
unnamedBlock (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 []
unnamedBlock Block
node = [Block] -> ExceptT Error m [Block]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Block
node]

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
$ Text -> Expr
Variable Text
"false"
      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
      (Int Int
i, 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)
-> (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
$ [Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
      (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
Add 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
Add 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
Add 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
  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

-- After evaluation, the template should be either empty or contain a single literal.
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 = do
  Text
t <- [Text] -> Text
T.concat ([Text] -> Text) -> ExceptT Error m [Text] -> ExceptT Error m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inline -> ExceptT Error m Text)
-> [Inline] -> ExceptT Error m [Text]
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 Text
forall (m :: * -> *).
Monad m =>
Env -> Inline -> ExceptT Error m Text
evalInline Env
env) [Inline]
inlines
  [Inline] -> ExceptT Error m [Inline]
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> Inline
Lit Text
t]

evalInline :: Monad m => Env -> Inline -> ExceptT Error.Error m Text
evalInline :: forall (m :: * -> *).
Monad m =>
Env -> Inline -> ExceptT Error m Text
evalInline Env
env = \case
  Lit Text
s -> Text -> ExceptT Error m Text
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
s -> Text -> ExceptT Error m Text
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
      Int Int
x -> Text -> ExceptT Error m Text
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ExceptT Error m Text)
-> ([Char] -> Text) -> [Char] -> ExceptT Error m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> ExceptT Error m Text) -> [Char] -> ExceptT Error m Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x
      -- Variable x -> context x -- Should not happen after evalExpr
      Expr
x -> [Char] -> ExceptT Error m Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> ExceptT Error m Text) -> [Char] -> ExceptT Error m Text
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

-- Extract both fragments and assignments.
-- TODO This should be merged with namedBlocks.
-- 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 Block -> [(Text, Expr)]
f
 where
  f :: Block -> [(Text, Expr)]
f Block
BlockDoctype = []
  f (BlockElem Elem
_ TrailingSym
_ [Attr]
_ [Block]
_) = []
  f (BlockText TextSyntax
_ [Inline]
_) = []
  f (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
  f (BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
_) = []
  f (BlockFragmentDef Text
name [Text]
names [Block]
children) = [(Text
name, [Text] -> Env -> [Block] -> Expr
Frag [Text]
names Env
env [Block]
children)]
  f (BlockFragmentCall Text
_ [Expr]
_ [Block]
_) = []
  f (BlockComment CommentType
_ Text
_) = []
  f (BlockFilter Text
_ Text
_) = []
  f (BlockRawElem Text
_ [Block]
_) = []
  f (BlockDefault Text
_ [Block]
_) = []
  f (BlockImport [Char]
path (Just [Block]
body) [Block]
_) = [([Char] -> Text
T.pack [Char]
path, [Text] -> Env -> [Block] -> Expr
Frag [] Env
env [Block]
body)]
  f (BlockImport [Char]
_ Maybe [Block]
_ [Block]
_) = []
  f (BlockRun Text
_ Maybe [Block]
_) = []
  f (BlockReadJson Text
name [Char]
_ (Just Value
val)) = [(Text
name, Value -> Expr
jsonToExpr Value
val)]
  f (BlockReadJson Text
_ [Char]
_ Maybe Value
Nothing) = []
  f (BlockAssignVar Text
name Expr
val) = [(Text
name, Expr
val)]
  f (BlockIf Expr
_ [Block]
_ [Block]
_) = []
  f (BlockList [Block]
_) = []
  f (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
_ [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]