{-# LANGUAGE RecordWildCards #-}
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
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
,
(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" []]])
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
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
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
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
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
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
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'
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
extractVariables' :: Monad m => Env -> [Block] -> ExceptT Error.Error m [(Text, Expr)]
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
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]
extractVariables :: Env -> [Block] -> [(Text, Expr)]
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)]
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]