{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Text.Haiji.Syntax.AST ( AST(..) , Loaded(..) , parser ) where import Prelude hiding (takeWhile) import Control.Applicative import Control.Monad import Control.Monad.State.Strict import Data.Attoparsec.Text import Data.Char import Data.Maybe import qualified Data.Text as T #if MIN_VERSION_base(4,9,0) import Data.Kind #define STAR Type #else #define STAR * #endif import Text.Haiji.Syntax.Identifier import Text.Haiji.Syntax.Expression -- $setup -- >>> :set -XOverloadedStrings -- >>> import Control.Arrow (left) -- >>> let execHaijiParser p = snd <$> runHaijiParser p type Scoped = Bool type Base = Bool data Loaded = Fully | Partially data AST :: Loaded -> STAR where Literal :: T.Text -> AST a Eval :: Expression -> AST a Condition :: Expression -> [AST a] -> Maybe [AST a] -> AST a Foreach :: Identifier -> Expression -> [AST a] -> Maybe [AST a] -> AST a Include :: FilePath -> AST 'Partially Raw :: String -> AST a Extends :: FilePath -> AST 'Partially Base :: [AST 'Fully] -> AST 'Fully Block :: Base -> Identifier -> Scoped -> [AST a] -> AST a Super :: AST a Comment :: String -> AST a Set :: Identifier -> Expression -> [AST a] -> AST a deriving instance Eq (AST a) instance Show (AST a) where show (Literal l) = T.unpack l show (Eval v) = "{{ " ++ shows v " }}" show (Condition p ts mfs) = "{% if " ++ show p ++ " %}" ++ concatMap show ts ++ maybe "" (\fs -> "{% else %}" ++ concatMap show fs) mfs ++ "{% endif %}" show (Foreach x xs loopBody elseBody) = "{% for " ++ show x ++ " in " ++ show xs ++ " %}" ++ concatMap show loopBody ++ maybe "" (("{% else %}" ++) . concatMap show) elseBody ++ "{% endfor %}" show (Include file) = "{% include \"" ++ file ++ "\" %}" show (Raw content) = "{% raw %}" ++ content ++ "{% endraw %}" show (Extends file) = "{% extends \"" ++ file ++ "\" %}" show (Base asts) = concatMap show asts show (Block _ name scoped body) = "{% block " ++ show name ++ (if scoped then " scoped" else "") ++" %}" ++ concatMap show body ++ "{% endblock %}" show Super = "{{ super() }}" show (Comment c) = "{#" ++ c ++ "#}" show (Set lhs rhs scopes) = "{% set " ++ show lhs ++ " = " ++ show rhs ++ " %}" ++ concatMap show scopes data ParserState = ParserState { parserStateLeadingSpaces :: Maybe (AST 'Partially) , parserStateInBaseTemplate :: Bool } deriving (Eq, Show) defaultParserState :: ParserState defaultParserState = ParserState { parserStateLeadingSpaces = Nothing , parserStateInBaseTemplate = True } #if MIN_VERSION_base(4,13,0) newtype HaijiParser a = HaijiParser { unHaijiParser :: StateT ParserState Parser a } deriving (Functor, Applicative, Alternative, Monad, MonadState ParserState, MonadFail) #else newtype HaijiParser a = HaijiParser { unHaijiParser :: StateT ParserState Parser a } deriving (Functor, Applicative, Alternative, Monad, MonadState ParserState) #endif runHaijiParser :: HaijiParser a -> Parser (a, ParserState) runHaijiParser p = runStateT (unHaijiParser p) defaultParserState evalHaijiParser :: HaijiParser a -> Parser a evalHaijiParser p = fst <$> runHaijiParser p liftParser :: Parser a -> HaijiParser a liftParser = HaijiParser . lift saveLeadingSpaces :: HaijiParser () saveLeadingSpaces = liftParser leadingSpaces >>= setLeadingSpaces where leadingSpaces = option Nothing (Just . Literal <$> takeWhile1 isSpace) withLeadingSpacesOf :: HaijiParser a -> (a -> HaijiParser b) -> HaijiParser b withLeadingSpacesOf p q = do a <- p getLeadingSpaces >>= (q a <*) . setLeadingSpaces setLeadingSpaces :: Maybe (AST 'Partially) -> HaijiParser () setLeadingSpaces ss = modify (\s -> s { parserStateLeadingSpaces = ss }) resetLeadingSpaces :: HaijiParser () resetLeadingSpaces = setLeadingSpaces Nothing getLeadingSpaces :: HaijiParser (Maybe (AST 'Partially)) getLeadingSpaces = gets parserStateLeadingSpaces setWhetherBaseTemplate :: Bool -> HaijiParser () setWhetherBaseTemplate x = modify (\s -> s { parserStateInBaseTemplate = x }) getWhetherBaseTemplate :: HaijiParser Bool getWhetherBaseTemplate = gets parserStateInBaseTemplate parser :: Parser [AST 'Partially] parser = evalHaijiParser (haijiParser <* liftParser endOfInput) haijiParser :: HaijiParser [AST 'Partially] haijiParser = concat <$> many (resetLeadingSpaces *> choice (map toList parsers)) where parsers = [ literal , evaluation , condition , foreach , include , raw , extends , block , super , comment , set ] toList p = do b <- p a <- getLeadingSpaces return $ maybe id (:) a [b] -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser literal) -- >>> eval "テスト{test" -- Right テスト{test -- >>> eval "テスト{{test" -- Right テスト -- >>> eval " テスト {test" -- Right テスト {test -- >>> eval " テスト {{test" -- Right テスト -- >>> eval " テスト {%-test" -- Right テスト -- >>> eval " テスト テスト {%-test" -- Right テスト テスト -- >>> eval "main() { }" -- Right main() { } -- literal :: HaijiParser (AST 'Partially) literal = liftParser $ Literal . T.concat <$> many1 go where go = do sp <- takeTill (not . isSpace) pc <- peekChar case pc of Nothing -> if T.null sp then fail "literal" else return sp Just '{' -> do x <- try $ sequence [char '{', satisfy (`notElem` ("{%#" :: String))] T.append (sp `T.append` T.pack x) <$> takeWhile (\c -> c /= '{' && not (isSpace c)) _ -> T.append sp <$> takeWhile1 (\c -> c /= '{' && not (isSpace c)) -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser evaluation) -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser evaluation) -- >>> eval "{{ foo }}" -- Right {{ foo }} -- >>> exec "{{ foo }}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> eval "{{bar}}" -- Right {{ bar }} -- >>> eval "{{ baz}}" -- Right {{ baz }} -- >>> eval " {{ foo }}" -- Right {{ foo }} -- >>> exec " {{ foo }}" -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = True}) -- >>> eval "{ { foo }}" -- Left "parse error" -- >>> eval "{{ foo } }" -- Left "parse error" -- >>> eval "{{ foo }} " -- Right {{ foo }} -- evaluation :: HaijiParser (AST 'Partially) evaluation = saveLeadingSpaces *> liftParser deref where deref = Eval <$> ((string "{{" >> skipSpace) *> expression <* (skipSpace >> string "}}")) -- | -- -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser $ statement $ return ()) -- >>> exec "{%%}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> exec "{% %}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> exec " {% %} " -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = True}) -- >>> exec " {%- -%} " -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- statement :: Parser a -> HaijiParser a statement f = start "{%" <|> (start "{%-" <* resetLeadingSpaces) where start s = saveLeadingSpaces *> liftParser ((string s >> skipSpace) *> f <* (skipSpace >> end)) end = string "%}" <|> (string "-%}" <* skipSpace) -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser condition) -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser condition) -- >>> eval "{% if foo %}テスト{% endif %}" -- Right {% if foo %}テスト{% endif %} -- >>> exec "{% if foo %}テスト{% endif %}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> eval "{%if foo%}テスト{%endif%}" -- Right {% if foo %}テスト{% endif %} -- >>> eval "{% iffoo %}テスト{% endif %}" -- Left "parse error" -- >>> eval "{% if foo %}真{% else %}偽{% endif %}" -- Right {% if foo %}真{% else %}偽{% endif %} -- >>> eval "{%if foo%}{%if bar%}{%else%}{%endif%}{%else%}{%if baz%}{%else%}{%endif%}{%endif%}" -- Right {% if foo %}{% if bar %}{% else %}{% endif %}{% else %}{% if baz %}{% else %}{% endif %}{% endif %} -- >>> eval " {% if foo %}テスト{% endif %}" -- Right {% if foo %}テスト{% endif %} -- >>> exec " {% if foo %}テスト{% endif %}" -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = True}) -- >>> eval " {%- if foo -%} テスト {%- endif -%} " -- Right {% if foo %}テスト{% endif %} -- >>> exec " {%- if foo -%} テスト {%- endif -%} " -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> eval "{% if foo %}テスト{% elif bar %}hoge{% endif %}" -- Right {% if foo %}テスト{% else %}{% if bar %}hoge{% endif %}{% endif %} -- >>> eval "{% if foo %} テスト {% elif bar %} hoge {% endif %}" -- Right {% if foo %} テスト {% else %}{% if bar %} hoge {% endif %}{% endif %} -- >>> eval "{% if foo -%} テスト {%- elif bar -%} hoge {%- endif %}" -- Right {% if foo %}テスト{% else %}{% if bar %}hoge{% endif %}{% endif %} -- condition :: HaijiParser (AST 'Partially) condition = withLeadingSpacesOf (start "if") rest where start kwd = statement $ string kwd >> skipMany1 space >> expression rest cond = do ifPart <- haijiParser mElifPart <- option Nothing (Just <$> withLeadingSpacesOf (start "elif") rest) case mElifPart of Just elif -> do leadingElifSpaces <- getLeadingSpaces return $ Condition cond (ifPart ++ maybeToList leadingElifSpaces) (Just [elif]) Nothing -> do mElsePart <- mayElse leadingElseSpaces <- getLeadingSpaces _ <- statement $ string "endif" leadingEndIfSpaces <- getLeadingSpaces return $ case mElsePart of Nothing -> Condition cond (ifPart ++ maybeToList leadingEndIfSpaces) Nothing Just elsePart -> Condition cond (ifPart ++ maybeToList leadingElseSpaces ) (Just $ elsePart ++ maybeToList leadingEndIfSpaces) mayElse :: HaijiParser (Maybe [AST 'Partially]) mayElse = option Nothing (Just <$> elseParser) where elseParser = withLeadingSpacesOf (statement (string "else")) $ const haijiParser -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser foreach) -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser foreach) -- >>> eval "{% for _ in foo %}loop{% endfor %}" -- Right {% for _ in foo %}loop{% endfor %} -- >>> exec "{% for _ in foo %}loop{% endfor %}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> eval "{%for _ in foo%}loop{%endfor%}" -- Right {% for _ in foo %}loop{% endfor %} -- >>> eval "{% for_ in foo %}loop{% endfor %}" -- Left "parse error" -- >>> eval "{% for _in foo %}loop{% endfor %}" -- Left "parse error" -- >>> eval "{% for _ infoo %}loop{% endfor %}" -- Left "parse error" -- >>> eval "{% for _ in foo %}loop{% else %}else block{% endfor %}" -- Right {% for _ in foo %}loop{% else %}else block{% endfor %} -- >>> eval "{%for _ in foo%}loop{%else%}else block{%endfor%}" -- Right {% for _ in foo %}loop{% else %}else block{% endfor %} -- >>> eval " {% for _ in foo %} loop {% endfor %} " -- Right {% for _ in foo %} loop {% endfor %} -- >>> exec " {% for _ in foo %} loop {% endfor %} " -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = True}) -- >>> eval " {%- for _ in foo -%} loop {%- endfor -%} " -- Right {% for _ in foo %}loop{% endfor %} -- >>> exec " {%- for _ in foo -%} loop {%- endfor -%} " -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- foreach :: HaijiParser (AST 'Partially) foreach = withLeadingSpacesOf start rest where start = statement $ Foreach <$> (string "for" >> skipMany1 space >> identifier) <*> (skipMany1 space >> string "in" >> skipMany1 space >> expression) rest f = do loopPart <- haijiParser mElsePart <- mayElse leadingElseSpaces <- getLeadingSpaces _ <- statement (string "endfor") leadingEndForSpaces <- getLeadingSpaces return $ case mElsePart of Nothing -> f (loopPart ++ maybeToList leadingEndForSpaces) Nothing Just elsePart -> f (loopPart ++ maybeToList leadingElseSpaces ) (Just $ elsePart ++ maybeToList leadingEndForSpaces) -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser include) -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser include) -- >>> eval "{% include \"foo.tmpl\" %}" -- Right {% include "foo.tmpl" %} -- >>> exec "{% include \"foo.tmpl\" %}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> eval "{%include\"foo.tmpl\"%}" -- Right {% include "foo.tmpl" %} -- >>> eval "{% include 'foo.tmpl' %}" -- Right {% include "foo.tmpl" %} -- >>> eval " {% include \"foo.tmpl\" %}" -- Right {% include "foo.tmpl" %} -- >>> exec " {% include \"foo.tmpl\" %}" -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = True}) -- >>> eval " {%- include \"foo.tmpl\" -%} " -- Right {% include "foo.tmpl" %} -- >>> exec " {%- include \"foo.tmpl\" -%} " -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- include :: HaijiParser (AST 'Partially) include = statement $ string "include" >> skipSpace >> Include . T.unpack <$> (quotedBy '"' <|> quotedBy '\'') where quotedBy c = char c *> takeTill (== c) <* char c -- TODO: ここもっとマジメにやらないと -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser raw) -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser raw) -- >>> eval "{% raw %}test{% endraw %}" -- Right {% raw %}test{% endraw %} -- >>> exec "{% raw %}test{% endraw %}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> eval "{%raw%}test{%endraw%}" -- Right {% raw %}test{% endraw %} -- >>> eval "{% raw %}{{ test }}{% endraw %}" -- Right {% raw %}{{ test }}{% endraw %} -- >>> eval " {% raw %} test {% endraw %}" -- Right {% raw %} test {% endraw %} -- >>> exec " {% raw %} test {% endraw %}" -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = True}) -- >>> eval " {%- raw -%} test {%- endraw -%} " -- Right {% raw %}test{% endraw %} -- >>> exec " {%- raw -%} test {%- endraw -%} " -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- raw :: HaijiParser (AST 'Partially) raw = withLeadingSpacesOf start rest where start = statement $ string "raw" rest _ = do (content, leadingEndRawSpaces) <- till (liftParser anyChar) (statement (string "endraw") >> getLeadingSpaces) return $ Raw $ content ++ maybe "" show leadingEndRawSpaces where till :: Alternative f => f a -> f b -> f ([a], b) till p end = go where go = ((,) [] <$> end) <|> ((\a (as,b) -> (a:as, b)) <$> p <*> go) -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser extends) -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser extends) -- >>> eval "{% extends \"foo.tmpl\" %}" -- Right {% extends "foo.tmpl" %} -- >>> exec "{% extends \"foo.tmpl\" %}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = False}) -- >>> eval "{%extends\"foo.tmpl\"%}" -- Right {% extends "foo.tmpl" %} -- >>> eval "{% extends 'foo.tmpl' %}" -- Right {% extends "foo.tmpl" %} -- >>> eval " {% extends \"foo.tmpl\" %}" -- Right {% extends "foo.tmpl" %} -- >>> exec " {% extends \"foo.tmpl\" %}" -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = False}) -- >>> eval " {%- extends \"foo.tmpl\" -%} " -- Right {% extends "foo.tmpl" %} -- >>> exec " {%- extends \"foo.tmpl\" -%} " -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = False}) -- extends :: HaijiParser (AST 'Partially) extends = do base <- getWhetherBaseTemplate unless base $ fail "extends" go <* setWhetherBaseTemplate False where go = statement $ string "extends" >> skipSpace >> Extends . T.unpack <$> (quotedBy '"' <|> quotedBy '\'') quotedBy c = char c *> takeTill (== c) <* char c -- TODO: ここもっとマジメにやらないと -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser block) -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser block) -- >>> eval "{% block foo %}テスト{% endblock %}" -- Right {% block foo %}テスト{% endblock %} -- >>> exec "{% block foo %}テスト{% endblock %}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> eval "{% block foo %}テスト{% endblock foo %}" -- Right {% block foo %}テスト{% endblock %} -- >>> eval "{% block foo %}テスト{% endblock bar %}" -- Left "parse error" -- >>> eval "{%block foo%}テスト{%endblock%}" -- Right {% block foo %}テスト{% endblock %} -- >>> eval "{% blockfoo %}テスト{% endblock %}" -- Left "parse error" -- >>> eval " {% block foo %}テスト{% endblock %}" -- Right {% block foo %}テスト{% endblock %} -- >>> exec " {% block foo %}テスト{% endblock %}" -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = True}) -- >>> eval " {%- block foo -%} テスト {%- endblock -%} " -- Right {% block foo %}テスト{% endblock %} -- >>> exec " {%- block foo -%} テスト {%- endblock -%} " -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- block :: HaijiParser (AST 'Partially) block = withLeadingSpacesOf start rest where start = statement $ string "block" >> skipMany1 space >> identifier rest name = do body <- haijiParser mayEndName <- statement $ string "endblock" >> option Nothing (Just <$> (skipMany1 space >> identifier)) leadingEndBlockSpaces <- getLeadingSpaces base <- getWhetherBaseTemplate if maybe True (name ==) mayEndName then return $ Block base name False (body ++ maybeToList leadingEndBlockSpaces) else fail "block" super :: HaijiParser (AST 'Partially) super = do saveLeadingSpaces _ <- liftParser ((string "{{" *> skipSpace) *> (string "super" *> skipSpace >> char '(' >> skipSpace >> char ')') <* (skipSpace *> string "}}")) return Super -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser comment) -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser comment) -- >>> eval "{# comment #}" -- Right {# comment #} -- >>> exec "{# comment #}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> eval " {# comment #}" -- Right {# comment #} -- >>> exec " {# comment #}" -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = True}) -- comment :: HaijiParser (AST 'Partially) comment = saveLeadingSpaces *> liftParser (string "{#" >> Comment <$> manyTill anyChar (string "#}")) -- | -- -- >>> let eval = left (const "parse error") . parseOnly (evalHaijiParser set) -- >>> let exec = left (const "parse error") . parseOnly (execHaijiParser set) -- >>> eval "{% set lhs = rhs %}" -- Right {% set lhs = rhs %} -- >>> exec "{% set lhs = rhs %}" -- Right (ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}) -- >>> eval " {% set lhs = rhs %}" -- Right {% set lhs = rhs %} -- >>> exec " {% set lhs = rhs %}" -- Right (ParserState {parserStateLeadingSpaces = Just , parserStateInBaseTemplate = True}) -- set :: HaijiParser (AST 'Partially) set = withLeadingSpacesOf start rest where start = statement $ Set <$> (string "set" >> skipMany1 space >> identifier) <*> (skipMany1 space >> string "=" >> skipMany1 space >> expression) rest f = f <$> haijiParser