module Data.EasyTpl (
Template
, TemplateToken
, Value(..)
, ByteString
, HashMap
, Vector
, compile
, render
, compile'
, render'
, parseTemplate
, parseTemplate'
, parseExpression
, defaultData
) where
import Data.Aeson (Value(..), ToJSON)
import qualified Data.Aeson as J
import qualified Data.Aeson.Parser as JP
import qualified Data.Aeson.Encode as JE
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 qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.Text.Encoding as TE
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.Expr
import qualified Data.Attoparsec.Text as AT
#ifdef WITH_REGEX
import Text.Regex (Regex)
import qualified Text.Regex as RE
#endif
import Data.Tuple (swap)
import Data.Fixed (mod')
import Prelude hiding (takeWhile)
import Control.Applicative ((<$>), (<*>), (<*), (*>), (<|>))
newtype Template = Template [TemplateToken]
deriving (Show, Eq)
data TemplateToken = ContentToken ByteString
| LiteralToken Expression
| ControlToken Control Template
deriving (Show, Eq)
data Control = Condition Expression
| Iteration (Text, Text) Expression
deriving (Show, Eq)
data Expression = Constant Value
| Variable Text
| Range Expression Expression Expression
#ifdef WITH_REGEX
| Regexp ByteString Bool Bool
#endif
| UnaryOperation UnaryOperator Expression
| BinaryOperation BinaryOperator Expression Expression
deriving (Show, Eq)
data UnaryOperator = GetLength
| Stringify
| Evaluate
| LogicNot
| Negate
| ToNumber
| NotNull
deriving (Show, Eq)
data BinaryOperator = LogicOr
| LogicAnd
| Equal
| NotEqual
| LessThan
| GreatThan
| LessEqual
| GreatEqual
| Substract
| Append
| Multiply
| Divide
| IntDivide
| Module
| Power
| GetField
#ifdef WITH_REGEX
| RegexTest
| RegexMatch
| RegexSplit
#endif
deriving (Show, Eq)
defaultData :: Value
defaultData = Object H.empty
compile' :: String -> Either String Template
compile' = compile . BSC.pack
compile :: ByteString -> Either String Template
compile = parseOnly parseTemplate
render' :: (ToJSON e) => Template -> e -> String
render' tpl = BSC.unpack . render tpl
render :: (ToJSON e) => Template -> e -> ByteString
render tpl env = renderTemplate tpl $ J.toJSON env
renderTemplate' :: Template -> HashMap Text Value -> ByteString
renderTemplate' tpl env = renderTemplate tpl $ Object env
renderTemplate :: Template -> Value -> ByteString
renderTemplate (Template tokens) env = BS.concat $ map (flip renderToken env) tokens
renderToken :: TemplateToken -> Value -> ByteString
renderToken (ContentToken text) _ = text
renderToken (LiteralToken expr) env = getString $ toString $ evalExpression expr env
where
getString (String text) = TE.encodeUtf8 text
getString _ = ""
renderToken (ControlToken ctl tpl) env = renderControl ctl tpl env
renderControl :: Control -> Template -> Value -> ByteString
renderControl (Condition expr) tpl env@(Object _) = applyCondition $ toBoolean $ evalExpression expr env
where
applyCondition :: Value -> ByteString
applyCondition (Bool True) = renderTemplate tpl env
applyCondition _ = ""
renderControl (Iteration (keyVar, valVar) expr) tpl env'@(Object henv) = BS.concat $ applyIteration $ evalExpression expr env'
where
applyIteration :: Value -> [ByteString]
applyIteration (Array list) = V.toList $ V.imap applyIndex list
applyIteration (Object hash) = map applyField $ H.toList hash
applyIteration _ = []
addLocal :: Text -> Value -> HashMap Text Value -> HashMap Text Value
addLocal var val env = if T.null var then env else H.insert var val env
applyElement :: Value -> Value -> ByteString
applyElement key val = renderTemplate' tpl $ addLocal keyVar key $ addLocal valVar val henv
applyIndex :: Int -> Value -> ByteString
applyIndex key val = applyElement (Number (fromIntegral key)) val
applyField :: (Text, Value) -> ByteString
applyField (key, val) = applyElement (String key) val
renderControl _ _ _ = ""
evalExpression :: Expression -> Value -> Value
evalExpression (Constant val) _ = val
evalExpression (Variable var) (Object henv) = maybe Null id $ H.lookup var henv
evalExpression (Variable _) _ = Null
evalExpression (Range from' to' step') env = genRange (toNumber $ evalExpression from' env)
(toNumber $ evalExpression to' env)
(toNumber $ evalExpression step' env)
where
genRange :: Value -> Value -> Value -> Value
genRange (Number from) (Number to) (Number step) =
Array $ V.fromList $ range from to step
genRange _ _ _ = Null
range from to step | from > to = []
| otherwise = Number from : range (from + step) to step
evalExpression (UnaryOperation op' a') env = unary op' (evalExpression a' env)
where
unary :: UnaryOperator -> Value -> Value
unary GetLength = getLength
unary Stringify = stringify
unary Evaluate = either (String . T.pack . ("Error: " ++)) (flip evalExpression env) . parseOnly parseExpression . toByteString
unary LogicNot = booleanOp not
unary Negate = numericOp (0 )
unary ToNumber = numericOp id
unary NotNull = Bool . notNull
notNull :: Value -> Bool
notNull Null = False
notNull _ = True
booleanOp :: (Bool -> Bool) -> Value -> Value
booleanOp op a = case toBoolean a of
Bool b -> Bool $ op b
_ -> Null
numericOp op a = case toNumber a of
Number n -> Number $ op n
_ -> Null
toByteString a = case toString a of
String s -> TE.encodeUtf8 s
_ -> ""
#ifdef WITH_REGEX
evalExpression (BinaryOperation op' a' (Regexp re ml cs)) env = apply op' $ toString $ evalExpression a' env
where
apply RegexTest (String s) = Bool $ maybe False (\_ -> True) $ match s
apply RegexMatch (String s) = maybe Null (Array . V.fromList . map (String . T.pack)) $ match s
apply RegexSplit (String s) = Array $ V.fromList $ map String $ split s
apply _ _ = Null
match :: Text -> Maybe [String]
match = RE.matchRegex regex . T.unpack
split :: Text -> [Text]
split = map T.pack . RE.splitRegex regex . T.unpack
regex :: Regex
regex = RE.mkRegexWithOpts (BSC.unpack re) ml cs
evalExpression (Regexp _ _ _) _ = Null
#endif
evalExpression (BinaryOperation op' a' b') env = binary op' (evalExpression a' env) (evalExpression b' env)
where
binary :: BinaryOperator -> Value -> Value -> Value
binary Equal a = Bool . (a ==)
binary NotEqual a = Bool . (a /=)
binary Append (String a) = applyToString $ String . T.append a
binary Multiply (String a) = applyToInteger $ String . flip T.replicate a
binary IntDivide (String a) = applyToString $ Array . V.fromList . map String . flip T.splitOn a
binary LessThan (String a) = applyToString $ Bool . (a <)
binary GreatThan (String a) = applyToString $ Bool . (a >)
binary LessEqual (String a) = applyToString $ Bool . (a <=)
binary GreatEqual (String a) = applyToString $ Bool . (a >=)
binary GetField (String s) = applyToInteger (\i -> if i >= 0 && i < T.length s then String $ T.singleton $ T.index s i else Null)
binary LessThan (Number a) = applyToNumber $ Bool . (a <)
binary GreatThan (Number a) = applyToNumber $ Bool . (a >)
binary LessEqual (Number a) = applyToNumber $ Bool . (a <=)
binary GreatEqual (Number a) = applyToNumber $ Bool . (a >=)
binary GetField (Array a) = applyToInteger (maybe Null id . (V.!?) a)
binary GetField (Object a) = applyToString (maybe Null id . flip H.lookup a)
binary op a = binary' op a
binary' LogicOr = booleanOp (||)
binary' LogicAnd = booleanOp (&&)
binary' Substract = numericOp ()
binary' Append = numericOp (+)
binary' Multiply = numericOp (*)
binary' Divide = numericOp (/)
binary' IntDivide = numericOp' (/)
binary' Module = numericOp mod'
binary' _ = \_ _ -> Null
numericOp op a b = case (toNumber a, toNumber b) of
(Number na, Number nb) -> Number $ op na nb
_ -> Null
numericOp' op a b = case (toNumber a, toNumber b) of
(Number na, Number nb) -> Number $ fromIntegral ((round $ op na nb) :: Integer)
_ -> Null
booleanOp op a b = case (toBoolean a, toBoolean b) of
(Bool ba, Bool bb) -> Bool $ op ba bb
_ -> Null
applyToString fn v = case toString v of
String s -> fn s
_ -> Null
applyToNumber fn v = case toNumber v of
Number n -> fn $ n
_ -> Null
applyToInteger fn = applyToNumber (fn . round)
getLength :: Value -> Value
getLength (String text) = Number $ fromIntegral $ T.length text
getLength (Array list) = Number $ fromIntegral $ V.length list
getLength (Object hash) = Number $ fromIntegral $ H.size hash
getLength _ = Null
toBoolean :: Value -> Value
toBoolean bool@(Bool _) = bool
toBoolean (Number val) = Bool $ val /= I 0
toBoolean (String text) = Bool $ not $ T.null text
toBoolean Null = Bool False
toBoolean (Object hash) = Bool $ not $ H.null hash
toBoolean (Array list) = Bool $ not $ V.null list
toNumber :: Value -> Value
toNumber val@(Number _) = val
toNumber (Bool bool) = Number $ if bool then 1 else 0
toNumber (String text) = getNumber' $ AT.parse AT.number text
where
getNumber' (AT.Done _ val) = Number val
getNumber' _ = Null
toNumber _ = Null
toString :: Value -> Value
toString text@(String _) = text
toString (Number val) = String $ T.pack $ show val
toString Null = String "[null]"
toString (Bool _) = String "[bool]"
toString (Object _) = String "[object]"
toString (Array _) = String "[array]"
stringify :: Value -> Value
stringify = String . LT.toStrict . LTB.toLazyText . JE.fromValue
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 <$> JP.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