Browse Source

Template compiler kinda working!

image-sizing
Logan McGrath 11 months ago
parent
commit
4af2d1f503
  1. 8
      hie.yaml
  2. 4
      site/contact.md
  3. 2
      site/resume.md
  4. 11
      src/Green/Template/Ast.hs
  5. 222
      src/Green/Template/Compiler.hs
  6. 181
      src/Green/Template/Context.hs
  7. 143
      src/Green/Template/Parser.hs
  8. 27
      test/Green/Template/ParserSpec.hs
  9. 6
      test/Green/Template/Structural.hs

8
hie.yaml

@ -1,13 +1,13 @@
cradle:
stack:
- path: "src"
- path: "./src"
component: "green:lib"
- path: "app/author"
- path: "./app/author/Main.hs"
component: "green:exe:author"
- path: "app/site"
- path: "./app/site/Main.hs"
component: "green:exe:site"
- path: "test"
- path: "./test"
component: "green:test:test"

4
site/contact.md

@ -1,3 +1,3 @@
I live in a tiramisù and have pudding in my ears. Please contact me via [$authorEmail$](mailto:$authorEmail$) and I shall free my eyes to read and reply heartily; my fingers typing though they have been soaking like biscuits in espresso and cream. I welcome conversations and questions about what I do and I might even ask a few questions of my own, but I do not know how I came to be floating in mascarpone.
I live in a tiramisù and have pudding in my ears. Please contact me via [{{ authorEmail }}](mailto:{{ authorEmail }}) and I shall free my eyes to read and reply heartily; my fingers typing though they have been soaking like biscuits in espresso and cream. I welcome conversations and questions about what I do and I might even ask a few questions of my own, but I do not know how I came to be floating in mascarpone.
$partial("_partials/employment.html")$
{{ partial "employment.html" }}

2
site/resume.md

@ -1 +1 @@
Please see my [LinkedIn profile]($linkedInProfile$) for my employment history.
Please see my [LinkedIn profile]({{ linkedInProfile }}) for my employment history.

11
src/Green/Template/Ast.hs

@ -28,9 +28,9 @@ data Block
| CommentBlock String SourcePos -- {{! this comment }}
| LayoutBlock Expression SourcePos -- {{@ include "this/file.md" }}
| TemplateStartBlock Expression SourcePos -- {{# expression }}
| TemplateNextBlock Expression SourcePos -- {{# else expression }}
| TemplateElseBlock SourcePos -- {{# else }}
| TemplateEndBlock SourcePos -- {{# end }}
| TemplateNextBlock Expression SourcePos -- {{ else expression }}
| TemplateElseBlock SourcePos -- {{ else }}
| TemplateEndBlock SourcePos -- {{ end }}
| LayoutApplyBlock Expression Template SourcePos
| TemplateBlock (NonEmpty TemplateApplyBlock) (Maybe TemplateDefaultBlock) SourcePos
deriving stock (Show, Generic)
@ -151,6 +151,7 @@ data Expression
| AccessExpression Expression Expression SourcePos -- target.field
| FilterExpression Expression Expression SourcePos -- arg | fn
| ContextExpression [(String, Expression)] SourcePos -- { name0: value0, name1: value1 }
| ListExpression [Expression] SourcePos -- [a, b, c]
deriving stock (Show, Generic)
getExpressionPos :: Expression -> SourcePos
@ -164,6 +165,7 @@ getExpressionPos = \case
AccessExpression _ _ pos -> pos
FilterExpression _ _ pos -> pos
ContextExpression _ pos -> pos
ListExpression _ pos -> pos
getExpressionTag :: Expression -> Int
getExpressionTag = \case
@ -176,6 +178,7 @@ getExpressionTag = \case
AccessExpression {} -> 7
FilterExpression {} -> 8
ContextExpression {} -> 9
ListExpression {} -> 10
instance Binary Expression where
get = do
@ -190,6 +193,7 @@ instance Binary Expression where
7 -> AccessExpression <$> get <*> get
8 -> FilterExpression <$> get <*> get
9 -> ContextExpression <$> get
10 -> ListExpression <$> get
_ -> error $ "Unrecognized expression tag " ++ show tag
binaryPos <- get :: Get BinaryPos
return $ f (unBinaryPos binaryPos)
@ -206,4 +210,5 @@ instance Binary Expression where
AccessExpression target field _ -> put target >> put field
FilterExpression arg fn _ -> put arg >> put fn
ContextExpression pairs _ -> put pairs
ListExpression values _ -> put values
put $ BinaryPos (getExpressionPos expression)

222
src/Green/Template/Compiler.hs

@ -1,92 +1,168 @@
module Green.Template.Compiler where
import Control.Monad.Except
import Data.Foldable (foldlM)
import Data.List (intercalate)
import Data.Maybe
import Data.Traversable
import Green.Template.Ast
import Green.Template.Context
import Green.Template.Parser (parseTemplate)
import Hakyll
( Compiler,
Identifier,
Item (..),
MonadMetadata (..),
cached,
debugCompiler,
getResourceBody,
getUnderlying,
makeItem,
toFilePath,
withItemBody,
)
import Text.Parsec
import Prelude hiding (exp, filter, lookup)
import Hakyll hiding (Context, Template, applyTemplate, compileTemplateItem, field)
import Text.Parsec (SourcePos, sourceName)
import Prelude hiding (lookup)
isTruthy :: (MonadFail m) => ContextValue -> m Bool
isTruthy = \case
ContextValue _ -> return True
ListValue values -> return $ not (null values)
ErrorValue {} -> return False
UndefinedValue {} -> return False
BoolValue value -> return value
StringValue value -> return $ not (null value)
DoubleValue value -> return $ value /= 0
IntValue value -> return $ value /= 0
NameValue name -> fail $ "Unevaluated name " ++ show name
FunctionValue {} -> return True
TemplateValue (Template blocks _) -> return $ not (null blocks)
UnitValue {} -> return False
isFalsy :: (MonadFail m) => ContextValue -> m Bool
isFalsy = fmap not . isTruthy
templateCompiler :: Compiler (Item Template)
templateCompiler = cached "Green.Template.Compiler.templateCompiler" do
id' <- getUnderlying
item <- getResourceBody
debugCompiler $ "Compiling template from " ++ show id'
withItemBody (compileTemplateFile id') item
templateCompiler =
cached "Green.Template.Compiler.templateCompiler" $
getResourceBody
>>= compileTemplateItem
>>= makeItem
applyTemplate :: Template -> Context -> Item String -> Compiler (Item String)
applyTemplate (Template blocks pos) _context item = do
debugCompiler $ "Applying template " ++ show (sourceName pos) ++ " to " ++ show (itemIdentifier item)
sequence (goBlock <$> blocks)
>>= fmap mconcat . mapM render
>>= makeItem
where
goBlock block =
case block of
CommentBlock _ _ -> return $ StringValue ""
TextBlock value _ -> return $ StringValue value
_ -> undefined
compileTemplateItem :: Item String -> Compiler Template
compileTemplateItem item = do
filePath <- getResourceFilePath
debugCompiler $ "Compiling template from " ++ show filePath
either (fail . show) return (parseTemplate filePath (itemBody item))
applyAsTemplate :: Context -> Item String -> Compiler (Item String)
applyAsTemplate context item = do
debugCompiler $ "Applying " ++ show (itemIdentifier item) ++ " as template"
template <- compileTemplateFile (itemIdentifier item) (itemBody item)
template <- compileTemplateItem item
applyTemplate template context item
compileTemplateFile :: Identifier -> String -> Compiler Template
compileTemplateFile id' input = do
debugCompiler $ "Compiling template file " ++ show id'
case parseTemplate (toFilePath id') input of
Right template -> do
debugCompiler $ "Parsed template from file " ++ show id'
return template
Left e -> do
debugCompiler $ "Failed to parse template file " ++ show id' ++ ": " ++ show e
fail (show e)
applyTemplate :: Template -> Context -> Item String -> Compiler (Item String)
applyTemplate template context item = do
let (Template blocks pos) = template
let id' = itemIdentifier item
debugCompiler $ "Applying template " ++ show (sourceName pos) ++ " to item " ++ show id'
context' <- (context <>) <$> getContext (itemIdentifier item)
makeItem =<< applyBlocks context' blocks item
render :: (MonadFail m) => ContextValue -> m String
render = \case
StringValue value -> return value
BoolValue value -> return $ show value
DoubleValue value -> return $ show value
IntValue value -> return $ show value
ListValue values -> mconcat <$> sequence (render <$> values)
ErrorValue message -> fail message
UndefinedValue name -> fail $ "Tried to render undefined value identified by " ++ show name
TemplateValue template -> fail $ "Tried to render template value " ++ show (sourceName (getTemplatePos template))
NameValue name -> fail $ "Tried to render unresolved name value " ++ show name
ContextValue {} -> fail "Tried to render context value"
FunctionValue {} -> fail "Tried to render function value"
applyBlocks :: Context -> [Block] -> Item String -> Compiler String
applyBlocks context (block : rest) item = do
thisResult <- applyBlock context block item
restResults <- applyBlocks context rest item
return (thisResult ++ restResults)
applyBlocks _ [] _ = return ""
getContext :: Identifier -> Compiler Context
getContext = fmap contextFromMetadata . getMetadata
applyBlock :: Context -> Block -> Item String -> Compiler String
applyBlock context block item = case block of
TextBlock value _ -> return value
ExpressionBlock expression _ -> stringify <$> eval context expression item
CommentBlock _ _ -> return ""
LayoutApplyBlock expression template _ -> snd <$> applyGuard expression template
TemplateBlock blocks defaultBlocks _ ->
foldlM applyTemplateBlocks (False, "") blocks >>= \case
(True, result) -> return result
_ -> applyDefaultBlocks
where
applyTemplateBlocks result@(stop, _) (TemplateApplyBlock expression template _)
| stop = return result
| otherwise = applyGuard expression template
applyDefaultBlocks =
case defaultBlocks of
Just (TemplateDefaultBlock (Template blocks' _) _) -> applyBlocks context blocks' item
Nothing -> return ""
_ -> fail $ "Unexpected block in " ++ show (getBlockPos block)
where
stringify = \case
StringValue value -> value
IntValue value -> show value
DoubleValue value -> show value
BoolValue value -> show value
ListValue values -> intercalate "" (stringify <$> values)
x -> show x
applyGuard guardExp template@(Template blocks _) =
eval context guardExp item >>= \case
FunctionValue f -> do
result <- f (TemplateValue template) context item
truthy <- isTruthy result
return (truthy, stringify result)
guard@(ContextValue context') ->
isTruthy guard >>= \case
True -> (True,) <$> applyBlocks (context' <> context) blocks item
False -> return (False, "")
guard ->
isTruthy guard >>= \case
True -> (True,) <$> applyBlocks context blocks item
False -> return (False, "")
defaultContext :: Context
defaultContext = undefined
eval :: Context -> Expression -> Item String -> Compiler ContextValue
eval context expression item = case expression of
StringExpression value _ -> return $ StringValue value
IntExpression value _ -> return $ IntValue value
DoubleExpression value _ -> return $ DoubleValue value
BoolExpression value _ -> return $ BoolValue value
--
ApplyExpression f x pos -> apply f x pos context item
FilterExpression x f pos -> apply f x pos context item
--
ListExpression values _ -> do
let eval' e = eval context e item
ListValue <$> mapM eval' values
--
ContextExpression expKeyVals _ -> do
let evalKV k v = (k,) <$> eval context v item
keyVals <- mapM (uncurry evalKV) expKeyVals
return $ ContextValue (intoContext keyVals)
--
NameExpression name pos -> do
maybeVal <- lookup name context item
maybe (undefinedValue name pos) return maybeVal
--
AccessExpression targetExp fieldExp pos ->
eval context targetExp item >>= \case
ContextValue target ->
case fieldExp of
NameExpression field _ -> do
result <- lookup field target item
maybe (undefinedValue field pos) return result
_ ->
eval context fieldExp item >>= \case
StringValue field -> do
result <- lookup field target item
maybe (undefinedValue field pos) return result
_ -> fail $ "Can't access field from context in " ++ show pos
ListValue list ->
eval context fieldExp item >>= \case
IntValue index
| index < length list -> return $ list !! index
| otherwise -> fail $ "Index " ++ show index ++ " out of bounds in " ++ show pos
val -> fail $ "Can't index into list with " ++ show val ++ " in " ++ show pos
_ -> fail $ "Can't access field from expression in " ++ show pos
contextFn :: (ContextValue -> Context -> Item String -> Compiler ContextValue) -> ContextValue
contextFn = FunctionValue
apply :: Expression -> Expression -> SourcePos -> Context -> Item String -> Compiler ContextValue
apply fExp xExp pos context item =
eval context fExp item >>= \case
FunctionValue f' -> do
x <- eval context xExp item
f' x context item
x -> fail $ "Can't apply " ++ show x ++ " as function in " ++ show pos
contextFn2 :: (ContextValue -> ContextValue -> Context -> Item String -> Compiler ContextValue) -> ContextValue
contextFn2 f2 = FunctionValue f1
where
f1 arg1 _ _ = return $ FunctionValue (f2 arg1)
asString :: Expression -> Compiler String
asString = \case
StringExpression value _ -> return value
IntExpression value _ -> return $ show value
DoubleExpression value _ -> return $ show value
BoolExpression value _ -> return $ show value
e -> fail $ "Unevaluated " ++ show e ++ " in " ++ show (getExpressionPos e)
contextFn3 :: (ContextValue -> ContextValue -> ContextValue -> Context -> Item String -> Compiler ContextValue) -> ContextValue
contextFn3 f3 = FunctionValue f1
where
f1 arg1 _ _ = return $ FunctionValue (f2 arg1)
f2 arg1 arg2 _ _ = return $ FunctionValue (f3 arg1 arg2)
undefinedValue :: String -> SourcePos -> Compiler a
undefinedValue name pos = fail $ "Undefined value " ++ show name ++ " in " ++ show pos

181
src/Green/Template/Context.hs

@ -6,13 +6,64 @@ import Data.Either
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import qualified Data.Scientific as Scientific
import Data.Scientific
import qualified Data.Text as T
import qualified Data.Vector as Vector
import Green.Template.Ast
import Hakyll (Compiler, Item (..), Metadata)
import Hakyll (Compiler, Item (..))
import qualified Hakyll as H
import Prelude hiding (lookup)
data Context
= MapContext MapContext
| FunctionContext FunctionContext
type MapContext = HashMap String ContextValue
type FunctionContext = String -> Item String -> Compiler (Maybe ContextValue)
singleton :: String -> ContextValue -> Context
singleton name value = MapContext (HashMap.singleton name value)
lookup :: String -> Context -> Item String -> Compiler (Maybe ContextValue)
lookup name (MapContext m) _ = return $ HashMap.lookup name m
lookup name (FunctionContext f) item = f name item
insert :: String -> ContextValue -> Context -> Context
insert name value = \case
MapContext m -> MapContext (HashMap.insert name value m)
f@FunctionContext {} -> singleton name value <> f
getContext :: H.Identifier -> Compiler Context
getContext id' = intoContext <$> H.getMetadata id'
defaultContext :: Context
defaultContext = metadataField
metadataField :: Context
metadataField = FunctionContext f
where
f name item = do
context <- getContext (itemIdentifier item)
lookup name context item
functionField :: String -> (Item String -> Compiler (Maybe ContextValue)) -> Context
functionField name f = FunctionContext f'
where
f' receivedName item
| receivedName == name = f item
| otherwise = return Nothing
instance Semigroup Context where
f <> g = FunctionContext h
where
h name item =
let lookup' = flip (lookup name) item
in (<|>) <$> lookup' f <*> lookup' g
instance Monoid Context where
mempty = MapContext HashMap.empty
data ContextValue
= ContextValue Context
| ListValue [ContextValue]
@ -23,99 +74,45 @@ data ContextValue
| DoubleValue Double
| IntValue Int
| NameValue String
| FunctionValue (ContextValue -> Context -> Item String -> Compiler ContextValue)
| FunctionValue FunctionValue
| TemplateValue Template
| UnitValue
trueValue :: ContextValue
trueValue = BoolValue True
falseValue :: ContextValue
falseValue = BoolValue False
type FunctionValue = ContextValue -> Context -> Item String -> Compiler ContextValue
instance Show ContextValue where
show = \case
ContextValue {} -> "(ContextValue)"
ListValue values -> "(ListValue " ++ show values ++ ")"
ErrorValue e -> "(ErrorValue " ++ show e ++ ")"
UndefinedValue name -> "(UndefinedValue " ++ show name ++ ")"
NameValue name -> "(NameValue " ++ show name ++ ")"
BoolValue b -> "(BoolValue " ++ show b ++ ")"
StringValue t -> "(StringValue " ++ show t ++ ")"
DoubleValue d -> "(DoubleValue " ++ show d ++ ")"
IntValue i -> "(IntValue " ++ show i ++ ")"
FunctionValue {} -> "(FunctionValue)"
TemplateValue template -> "(TemplateValue " ++ show template ++ ")"
isTruthy :: ContextValue -> Bool
isTruthy = \case
ContextValue _ -> True
NameValue _ -> True
FunctionValue _ -> True
BoolValue bool -> bool
DoubleValue double -> double > 0.0
IntValue int -> int > 0
StringValue value -> not (null value)
ListValue values -> not (null values)
TemplateValue (Template blocks _) -> not (null blocks)
_ -> False
isFalsy :: ContextValue -> Bool
isFalsy = not . isTruthy
data LookupResult
= LookupFound ContextValue
| LookupMissing String
deriving stock (Show)
lookupToValue :: LookupResult -> ContextValue
lookupToValue = \case
LookupFound value -> value
LookupMissing name -> UndefinedValue name
lookupFound :: (Monad m) => ContextValue -> m LookupResult
lookupFound = return . LookupFound
lookupMissing :: (Monad m) => String -> m LookupResult
lookupMissing = return . LookupMissing
data Context
= MapContext (HashMap String ContextValue)
| FunctionContext (String -> Item String -> Compiler LookupResult)
instance Semigroup Context where
f <> g = FunctionContext h
ContextValue {} -> "ContextValue"
ListValue values -> "ListValue (" ++ show values ++ ")"
ErrorValue e -> "ErrorValue " ++ show e
UndefinedValue name -> "UndefinedValue " ++ show name
NameValue name -> "NameValue " ++ show name
BoolValue b -> "BoolValue " ++ show b
StringValue t -> "StringValue " ++ show t
DoubleValue d -> "DoubleValue " ++ show d
IntValue i -> "IntValue " ++ show i
FunctionValue {} -> "FunctionValue"
TemplateValue template -> "TemplateValue (" ++ show template ++ ")"
UnitValue -> "Unit"
class IntoContext a where
intoContext :: a -> Context
instance IntoContext [(String, ContextValue)] where
intoContext = intoContext . HashMap.fromList
instance IntoContext (HashMap String ContextValue) where
intoContext = MapContext
instance IntoContext Object where
intoContext = intoContext . HashMap.mapKeys T.unpack . HashMap.map go
where
h name item = (verify =<< lookup f name item) <|> lookup g name item
verify = \case
x@LookupFound {} -> return x
LookupMissing name -> error $ "Did not find " ++ name ++ " in context"
instance Monoid Context where
mempty = FunctionContext (const . lookupMissing)
lookup :: Context -> String -> Item String -> Compiler LookupResult
lookup (MapContext m) name _ = maybe (lookupMissing name) lookupFound (HashMap.lookup name m)
lookup (FunctionContext f) name item = f name item
contextFromList :: [(String, ContextValue)] -> Context
contextFromList keyVals = contextFromMap (HashMap.fromList keyVals)
contextFromMap :: HashMap String ContextValue -> Context
contextFromMap = MapContext
contextFromMetadata :: Metadata -> Context
contextFromMetadata = contextFromObject
{-# INLINE contextFromMetadata #-}
contextFromObject :: Object -> Context
contextFromObject o = contextFromMap $ HashMap.mapKeys T.unpack (HashMap.map go o)
where
go = \case
Object o' -> ContextValue $ contextFromObject o'
Array a -> ListValue $ Vector.toList $ Vector.map go a
String t -> StringValue $ T.unpack t
Number n
| Scientific.isInteger n -> IntValue $ fromJust $ Scientific.toBoundedInteger n
| otherwise -> DoubleValue $ fromRight 0.0 $ Scientific.toBoundedRealFloat n
Bool b -> BoolValue b
Null -> UndefinedValue "null"
go = \case
Object o -> ContextValue $ intoContext o
Array a -> ListValue $ Vector.toList $ Vector.map go a
String t -> StringValue $ T.unpack t
Number n
| isInteger n -> IntValue $ fromJust $ toBoundedInteger n
| otherwise -> DoubleValue $ fromRight 0.0 $ toBoundedRealFloat n
Bool b -> BoolValue b
Null -> UndefinedValue "null"

143
src/Green/Template/Parser.hs

@ -7,7 +7,7 @@ import Data.List.NonEmpty as NEL
import Data.Maybe
import Data.Scientific
import Green.Template.Ast
import Text.Parsec hiding (runParser, runParserT, token, tokens, (<?>))
import Text.Parsec hiding (runParser, token, (<?>))
import qualified Text.Parsec as P
import Text.Parsec.Pos
@ -88,34 +88,26 @@ type TokenParser a = Parsec [Token] ParserState a
type Lexer a = Parsec String ParserState a
runParser :: (Stream s Identity t) => Parsec s ParserState a -> SourceName -> s -> Either ParseError a
runParser = runParserWith state
where
state = def
debugRunParser :: (Stream s Identity t) => Parsec s ParserState a -> SourceName -> s -> Either ParseError a
debugRunParser p = P.runParser p state
debugRunParser = runParserWith state
where
state = def {parserStateIsDebugging = True}
runParser :: (Stream s Identity t) => Parsec s ParserState a -> SourceName -> s -> Either ParseError a
runParser p = P.runParser p state
where
state = def
runParserWith :: (Stream s Identity t) => ParserState -> Parsec s ParserState a -> SourceName -> s -> Either ParseError a
runParserWith state p = P.runParser p state
parseTemplate :: SourceName -> String -> Either ParseError Template
parseTemplate origin =
runParser tokens origin
>=> runParser blocks origin
>=> fmap intoTemplate . runParser (structures <* eof) origin
runParser (many token <* eof) origin
>=> runParser (many block <* eof) origin
>=> fmap intoTemplate . runParser (many structure <* eof) origin
where
intoTemplate blocks' = Template blocks' (initialPos origin)
debugParseTemplate :: SourceName -> String -> Either ParseError Template
debugParseTemplate origin =
runParser tokens origin
>=> runParser blocks origin
>=> fmap intoTemplate . debugRunParser (structures <* eof) origin
where
intoTemplate blocks' = Template blocks' (initialPos origin)
structures :: BlockParser [Block]
structures = many structure
intoTemplate blocks = Template blocks (initialPos origin)
structure :: BlockParser Block
structure =
@ -139,7 +131,7 @@ appliedLayout = p <?> "AppliedLayoutStructure"
expression' <- withBlock \case
LayoutBlock e _ -> Just e
_ -> Nothing
structure' <- Template <$> structures
structure' <- Template <$> many structure
return \pos -> LayoutApplyBlock expression' (structure' pos) pos
appliedTemplate :: BlockParser Block
@ -204,9 +196,6 @@ withBlock = P.token showToken tokenPos
showToken = show
tokenPos = getBlockPos
blocks :: TokenParser [Block]
blocks = many block <* eof
block :: TokenParser Block
block = tryOne [templateBlock, textBlock]
@ -361,7 +350,8 @@ simpleExpression =
boolExpression,
nameExpression,
parensExpression,
contextExpression
contextExpression,
listExpression
]
stringExpression :: TokenParser Expression
@ -400,34 +390,28 @@ nameExpression = p <?> "Name"
_ -> Nothing
parensExpression :: TokenParser Expression
parensExpression = p <?> "ParensExpression"
where
p = do
withToken \case
OpenParenToken {} -> Just ()
_ -> Nothing
expression' <- expression
withToken \case
CloseParenToken {} -> Just ()
_ -> Nothing
return expression'
parensExpression = do
withToken \case
OpenParenToken {} -> Just ()
_ -> Nothing
expression' <- expression
withToken \case
CloseParenToken {} -> Just ()
_ -> Nothing
return expression'
contextExpression :: TokenParser Expression
contextExpression = p <?> "ContextLiteral"
where
p = do
pos <- withToken \case
OpenBraceToken pos -> Just pos
p = withPosition do
withToken \case
OpenBraceToken {} -> Just ()
_ -> Nothing
pairs <- contextKeyValue `sepBy` comma
withToken \case
CloseBraceToken {} -> Just ()
_ -> Nothing
return $ ContextExpression pairs pos
where
comma = withToken \case
CommaToken {} -> Just ()
_ -> Nothing
return $ ContextExpression pairs
contextKeyValue :: TokenParser (String, Expression)
contextKeyValue = p <?> "Pair"
@ -442,6 +426,25 @@ contextKeyValue = p <?> "Pair"
value <- expression
return (key, value)
listExpression :: TokenParser Expression
listExpression = p <?> "ListLiteral"
where
p = withPosition do
withToken \case
OpenBracketToken {} -> Just ()
_ -> Nothing
values <- expression `sepEndBy` comma
withToken \case
CloseBracketToken {} -> Just ()
_ -> Nothing
return $ ListExpression values
comma :: TokenParser ()
comma =
() <$ withToken \case
CommaToken {} -> Just ()
_ -> Nothing
requireText :: TokenParser (String, SourcePos)
requireText = withToken f <?> "Text"
where
@ -452,9 +455,6 @@ requireText = withToken f <?> "Text"
withToken :: (Token -> Maybe a) -> Parsec [Token] u a
withToken = P.token show getTokenPos
tokens :: Parsec String ParserState [Token]
tokens = many token <* eof <?> "Tokens"
token :: Lexer Token
token =
getLexerMode >>= \case
@ -554,21 +554,26 @@ text = p <?> "TextBody"
symbolToken :: Lexer Token
symbolToken =
withPosition $
tryOne
[ ws (OpenBraceToken <$ openBraceChar <?> "OpenBraceToken '{'"),
ws (CloseBraceToken <$ closeBraceChar <?> "CloseBraceToken '}'"),
ws (OpenParenToken <$ char '(' <?> "OpenParenToken '('"),
ws (CloseParenToken <$ char ')' <?> "CloseParenToken ')'"),
ws (OpenBlockToken <$ string "{{" <?> "OpenBlockToken '{{'"),
CloseBlockToken <$ string "}}" <?> "CloseBlockToken '}}'",
ws (OpenTemplateToken <$ char '#' <?> "TemplateBlockToken '#'"),
ws (OpenLayoutToken <$ char '@' <?> "LayoutBlockToken '@'"),
OpenCommentToken <$ char '!' <?> "CommentBlockToken '!'",
ws (PipeToken <$ char '|' <?> "PipeToken '|'"),
ws (ColonToken <$ char ':' <?> "ColonToken ':'"),
ws (DotToken <$ char '.' <?> "DotToken '.'"),
ws (CommaToken <$ char ',' <?> "CommaToken ','")
withPosition $ tryOne (fmap ws trimmed ++ untrimmed)
where
untrimmed =
[ CloseBlockToken <$ string "}}" <?> "CloseBlockToken '}}'",
OpenCommentToken <$ char '!' <?> "CommentBlockToken '!'"
]
trimmed =
[ OpenParenToken <$ char '(' <?> "OpenParenToken '('",
CloseParenToken <$ char ')' <?> "CloseParenToken ')'",
OpenBraceToken <$ openBraceChar <?> "OpenBraceToken '{'",
CloseBraceToken <$ closeBraceChar <?> "CloseBraceToken '}'",
OpenBracketToken <$ char '[' <?> "OpenBracketToken '['",
CloseBracketToken <$ char ']' <?> "OpenBracketToken ']'",
OpenBlockToken <$ string "{{" <?> "OpenBlockToken '{{'",
OpenTemplateToken <$ char '#' <?> "TemplateBlockToken '#'",
OpenLayoutToken <$ char '@' <?> "LayoutBlockToken '@'",
PipeToken <$ char '|' <?> "PipeToken '|'",
ColonToken <$ char ':' <?> "ColonToken ':'",
DotToken <$ char '.' <?> "DotToken '.'",
CommaToken <$ char ',' <?> "CommaToken ','"
]
expectBlockOpen :: Lexer ()
@ -704,10 +709,12 @@ data Token
| OpenLayoutToken SourcePos -- "@"
| OpenTemplateToken SourcePos -- "#"
| OpenCommentToken SourcePos -- "!"
| OpenParenToken SourcePos -- "("
| CloseParenToken SourcePos -- ")"
| OpenBracketToken SourcePos -- "["
| CloseBracketToken SourcePos -- "]"
| OpenBraceToken SourcePos -- "{"
| CloseBraceToken SourcePos -- "}"
| OpenParenToken SourcePos -- '('
| CloseParenToken SourcePos -- ')'
| PipeToken SourcePos -- "|"
| CommaToken SourcePos -- ","
| DotToken SourcePos -- "."
@ -729,10 +736,12 @@ getTokenPos = \case
OpenLayoutToken pos -> pos
OpenTemplateToken pos -> pos
OpenCommentToken pos -> pos
OpenBraceToken pos -> pos
CloseBraceToken pos -> pos
OpenParenToken pos -> pos
CloseParenToken pos -> pos
OpenBracketToken pos -> pos
CloseBracketToken pos -> pos
OpenBraceToken pos -> pos
CloseBraceToken pos -> pos
PipeToken pos -> pos
CommaToken pos -> pos
DotToken pos -> pos

27
test/Green/Template/ParserSpec.hs

@ -4,7 +4,7 @@ import Data.List.NonEmpty as NEL
import Green.Template
import Green.Template.Structural
import Green.TestSupport
import Text.Parsec hiding (runParser, runParserT, tokens)
import Text.Parsec hiding (runParser, runParserT, token, tokens)
spec :: Spec
spec = do
@ -178,6 +178,17 @@ spec = do
)
)
]
"{{ [1, 2, 3] }}"
`produces` [ ExpressionBlock'
( ListExpression'
[ IntExpression' 1,
IntExpression' 2,
IntExpression' 3
]
)
]
"{{ [] }}"
`produces` [ExpressionBlock' (ListExpression' [])]
context "comment blocks" do
"{{! this is a comment }}"
@ -370,6 +381,15 @@ spec = do
TextBlock' "\n"
]
tokens :: Lexer [Token]
tokens = many token <* eof
blocks :: TokenParser [Block]
blocks = many block <* eof
structures :: BlockParser [Block]
structures = many structure <* eof
type TestParser s a = s -> Either ParseError a
withParser :: String -> (String -> TestParser s a) -> SpecWith (TestParser s a) -> Spec
@ -386,6 +406,11 @@ readingFromTokens p source =
runParser tokens source
>=> runParser p source
debugReadingFromTokens :: TokenParser a -> String -> TestParser String a
debugReadingFromTokens p source =
runParser tokens source
>=> debugRunParser p source
readingFromBlocks :: BlockParser a -> String -> TestParser String a
readingFromBlocks p source =
runParser tokens source

6
test/Green/Template/Structural.hs

@ -70,6 +70,7 @@ data Expression'
| AccessExpression' Expression' Expression'
| FilterExpression' Expression' Expression'
| ContextExpression' [(String, Expression')]
| ListExpression' [Expression']
deriving stock (Eq, Show)
instance Structural Expression Expression' where
@ -83,6 +84,7 @@ instance Structural Expression Expression' where
AccessExpression t f _ -> AccessExpression' (toStructure t) (toStructure f)
FilterExpression x f _ -> FilterExpression' (toStructure x) (toStructure f)
ContextExpression xs _ -> ContextExpression' (second toStructure <$> xs)
ListExpression xs _ -> ListExpression' (toStructure <$> xs)
data Token'
= OpenBlockToken'
@ -92,6 +94,8 @@ data Token'
| OpenCommentToken'
| OpenBraceToken'
| CloseBraceToken'
| OpenBracketToken'
| CloseBracketToken'
| OpenParenToken'
| CloseParenToken'
| PipeToken'
@ -117,6 +121,8 @@ instance Structural Token Token' where
OpenCommentToken _ -> OpenCommentToken'
OpenBraceToken _ -> OpenBraceToken'
CloseBraceToken _ -> CloseBraceToken'
OpenBracketToken _ -> OpenBracketToken'
CloseBracketToken _ -> CloseBracketToken'
OpenParenToken _ -> OpenParenToken'
CloseParenToken _ -> CloseParenToken'
PipeToken _ -> PipeToken'

Loading…
Cancel
Save