module Data.EasyTpl.Parser where
import Data.Aeson (Value(..))
import Data.Aeson.Parser (value')
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Text (Text)
import qualified Data.Text as T
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.Expr
import Data.Tuple (swap)
import Control.Applicative ((<$>), (<*>), (<*), (*>), (<|>))
import Data.EasyTpl.Types
parseTemplate :: Parser Template
parseTemplate = Template <$> parseTokens
where
parseTokens = do
end <- atEnd
case end of
True -> return []
_ -> (:) <$> parseToken <*> parseTokens
parseTemplate' :: Parser Template
parseTemplate' = Template <$> many' parseToken
parseToken :: Parser TemplateToken
parseToken = parseControl <|> parseLiteral <|> parseContent
parseControl :: Parser TemplateToken
parseControl = ControlToken <$> blockOpen <*> parseTemplate' <* blockClose
where
blockOpen = "<%" *> spaces *> parseAction <* spaces <* "%>"
blockClose = "<%" >> spaces >> "end" >> spaces >> "%>"
parseAction = parseCondition <|> parseIteration
parseLiteral :: Parser TemplateToken
parseLiteral = LiteralToken <$> ("<%=" *> parseExpression <* "%>") <?> "Invalid literal"
parseContent :: Parser TemplateToken
parseContent = many1' getChunk >>= return . ContentToken . BS.concat
where
getChunk :: Parser ByteString
getChunk = (takeWhile1 (/= '<')) <|>
((cat2 <$> char '<' <*> notChar '%') <|>
(cat2 <$> char '<' <* char '\\' <*> char '%') >>=
return . BSC.pack)
cat2 a b = a:[b]
parseCondition :: Parser Control
parseCondition = Condition <$> ("if" *> spaces1 *> parseExpression)
parseIteration :: Parser Control
parseIteration = Iteration <$> ("for" *> spaces1 *> (valueIndex <|> fieldValue))
<*> (spaces1 *> parseExpression)
where
valueIndex = swap <$> pair <* spaces1 <* "in"
fieldValue = pair <* spaces1 <* "of"
pair = (,) <$> option "" parseIdentifier
<*> option "" (spaces *> char ',' *> spaces *> parseIdentifier)
parseExpression :: Parser Expression
parseExpression = spaces *> buildExpressionParser operatorTable parsePrimary <* spaces
where
operatorTable :: OperatorTable ByteString Expression
operatorTable = [
[ unary '?' True NotNull
]
, [ unary '#' False GetLength
, unary '!' False LogicNot
, unary '-' False Negate
, unary '+' False ToNumber
]
, [ binary '^' AssocRight Power
]
, [ binary '*' AssocLeft Multiply
, binary '/' AssocLeft Divide
, binary ':' AssocLeft IntDivide
, binary '%' AssocLeft Module
]
, [ binary '-' AssocLeft Substract
, binary '+' AssocLeft Append
]
, [ binary' "~>" AssocNone RegexMatch
, binary' "~:" AssocNone RegexSplit
, binary '~' AssocNone RegexTest
]
, [ binary' "==" AssocLeft Equal
, binary' "!=" AssocLeft NotEqual
, binary' "<=" AssocLeft LessEqual
, binary' ">=" AssocLeft GreatEqual
, binary '<' AssocLeft LessThan
, binary '>' AssocLeft GreatThan
]
, [ binary' "||" AssocLeft LogicOr
, binary' "&&" AssocLeft LogicAnd
]
, [ unary '=' True Evaluate
]
, [ unary '@' False Stringify
]
]
unary :: Char -> Bool -> UnaryOperator -> Operator ByteString Expression
unary op po tp = (if po then Postfix else Prefix)
(spaces >> char op >> spaces >>
return (UnaryOperation tp))
binary :: Char -> Assoc -> BinaryOperator -> Operator ByteString Expression
binary op ac tp = Infix (spaces >> char op >> spaces >>
return (BinaryOperation tp)) ac
binary' :: Parser ByteString -> Assoc -> BinaryOperator -> Operator ByteString Expression
binary' op ac tp = Infix (spaces >> op >> spaces >>
return (BinaryOperation tp)) ac
parsePrimary :: Parser Expression
parsePrimary = ((parseParens
<|> parseVariable
<|> parseRange
<|> parseConstant) >>= parseFields)
#ifdef WITH_REGEX
<|> parseRegex
#endif
parseParens :: Parser Expression
parseParens = char '(' *> parseExpression <* char ')'
parseVariable :: Parser Expression
parseVariable = Variable <$> parseIdentifier
parseFields :: Expression -> Parser Expression
parseFields prev = option prev ((parseField <|> parseIndex) >>= parseFields . BinaryOperation GetField prev)
where
parseField :: Parser Expression
parseField = spaces *> char '.' *> parseIdentifier <* spaces >>= return . Constant . String
parseIndex :: Parser Expression
parseIndex = spaces *> char '[' *> parseExpression <* char ']' <* spaces
parseRange :: Parser Expression
parseRange = char '[' *> (Range <$> option defaultFrom parseExpression <* ".." <*>
parseExpression <*> option defaultStep (char ',' *> parseExpression)) <* char ']'
where
defaultFrom = Constant $ Number 0
defaultStep = Constant $ Number 1
#ifdef WITH_REGEX
parseRegex :: Parser Expression
parseRegex = Regexp <$> (char '/' *> regexpBody <* char '/') <*> caseSensitive <*> multiLine
where
regexpBody :: Parser ByteString
regexpBody = many1' getChunk >>= return . BS.concat
getChunk :: Parser ByteString
getChunk = (takeWhile1 (\c -> c /= '/' && c /= '\\')) <|>
(char '\\' >> char '/' >> return "/") <|>
(char '\\' >> return "\\")
caseSensitive :: Parser Bool
caseSensitive = option True $ char 'i' >> return False
multiLine :: Parser Bool
multiLine = option False $ char 'm' >> return True
#endif
parseConstant :: Parser Expression
parseConstant = Constant <$> value'
parseIdentifier :: Parser Text
parseIdentifier = do
first <- firstChar
rest <- many' otherChar
return $ T.pack $ first : rest
where
firstChar = satisfy isAlpha_ascii <|> satisfy (inClass "_$")
otherChar = firstChar <|> satisfy isDigit
spaces :: Parser ()
spaces = skipWhile isSpace
spaces1 :: Parser ()
spaces1 = skipSpace >> spaces