HSmarty 0.1.1.0 → 0.2.0.0
raw patch · 15 files changed
+774/−902 lines, 15 filesdep +attoparsec-expr
Dependencies added: attoparsec-expr
Files
- HSmarty.cabal +15/−5
- Tests.hs +0/−8
- Text/HSmarty.hs +0/−5
- Text/HSmarty/Parser/Expr.hs +0/−164
- Text/HSmarty/Parser/Smarty.hs +0/−190
- Text/HSmarty/Parser/Util.hs +0/−65
- Text/HSmarty/Render/Engine.hs +0/−388
- Text/HSmarty/Types.hs +0/−77
- src/Tests.hs +8/−0
- src/Text/HSmarty.hs +5/−0
- src/Text/HSmarty/Parser/Smarty.hs +200/−0
- src/Text/HSmarty/Parser/Util.hs +74/−0
- src/Text/HSmarty/Render/Engine.hs +394/−0
- src/Text/HSmarty/Types.hs +77/−0
- test.tpl +1/−0
HSmarty.cabal view
@@ -1,20 +1,22 @@ name: HSmarty-version: 0.1.1.0+version: 0.2.0.0 synopsis: Haskell implementation of a subset of the PHP-Smarty template language--- description: +Homepage: https://github.com/agrafix/HSmarty+Bug-reports: https://github.com/agrafix/HSmarty/issues license: BSD3 license-file: LICENSE author: Alexander Thiemann <mail@agrafix.net> maintainer: mail@agrafix.net-copyright: (c) 2013 by Alexander Thiemann+copyright: (c) 2013 - 2014 by Alexander Thiemann category: Text build-type: Simple cabal-version: >=1.8 extra-source-files: test.tpl Library+ hs-source-dirs: src exposed-modules: Text.HSmarty- other-modules: Text.HSmarty.Parser.Smarty, Text.HSmarty.Parser.Expr, Text.HSmarty.Parser.Util, + other-modules: Text.HSmarty.Parser.Smarty, Text.HSmarty.Parser.Util, Text.HSmarty.Render.Engine, Text.HSmarty.Types build-depends: base ==4.6.*, vector ==0.10.*,@@ -22,11 +24,14 @@ unordered-containers ==0.2.*, aeson ==0.6.*, attoparsec ==0.10.*,+ attoparsec-expr ==0.1.1, mtl ==2.1.*, HTTP, HTF -Executable TestHSmarty+Test-Suite TestHSmarty+ hs-source-dirs: src+ Type: exitcode-stdio-1.0 Main-Is: Tests.hs Ghc-Options: -Wall build-depends: base ==4.6.*,@@ -35,6 +40,11 @@ unordered-containers ==0.2.*, aeson ==0.6.*, attoparsec ==0.10.*,+ attoparsec-expr ==0.1.1, mtl ==2.1.*, HTTP, HTF++source-repository head+ type: git+ location: git://github.com/agrafix/HSmarty.git
− Tests.hs
@@ -1,8 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Main where--import Test.Framework-import {-@ HTF_TESTS @-} Text.HSmarty.Parser.Smarty--main :: IO ()-main = htfMain htf_importedTests
− Text/HSmarty.hs
@@ -1,5 +0,0 @@-module Text.HSmarty- (module Text.HSmarty.Render.Engine)-where--import Text.HSmarty.Render.Engine
− Text/HSmarty/Parser/Expr.hs
@@ -1,164 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Text.Parsec.Expr--- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007--- License : BSD-style (see the LICENSE file)------ Author : derek.a.elkins@gmail.com--- Ported by : Sebastiaan Visser <haskell@fvisser.nl>--- Stability : provisional--- Portability : non-portable------ A helper module to parse \"expressions\".--- Builds a parser given a table of operators and associativities.-----------------------------------------------------------------------------------module Text.HSmarty.Parser.Expr- ( Assoc(..), Operator(..), OperatorTable- , buildExpressionParser- ) where--import Control.Applicative-import Data.Monoid-import Data.Attoparsec.Combinator-import Data.Attoparsec.Types---------------------------------------------------------------- Assoc and OperatorTable---------------------------------------------------------------- | This data type specifies the associativity of operators: left, right--- or none.--data Assoc = AssocNone- | AssocLeft- | AssocRight---- | This data type specifies operators that work on values of type @a@.--- An operator is either binary infix or unary prefix or postfix. A--- binary operator has also an associated associativity.--data Operator t a = Infix (Parser t (a -> a -> a)) Assoc- | Prefix (Parser t (a -> a))- | Postfix (Parser t (a -> a))---- | An @OperatorTable@ is a list of @Operator@--- lists. The list is ordered in descending--- precedence. All operators in one list have the same precedence (but--- may have a different associativity).--type OperatorTable t a = [[Operator t a]]---------------------------------------------------------------- Convert an OperatorTable and basic term parser into--- a full fledged expression parser---------------------------------------------------------------- | @buildExpressionParser table term@ builds an expression parser for--- terms @term@ with operators from @table@, taking the associativity--- and precedence specified in @table@ into account. Prefix and postfix--- operators of the same precedence can only occur once (i.e. @--2@ is--- not allowed if @-@ is prefix negate). Prefix and postfix operators--- of the same precedence associate to the left (i.e. if @++@ is--- postfix increment, than @-2++@ equals @-1@, not @-3@).------ The @buildExpressionParser@ takes care of all the complexity--- involved in building expression parser. Here is an example of an--- expression parser that handles prefix signs, postfix increment and--- basic arithmetic.------ > expr = buildExpressionParser table term--- > <?> "expression"--- >--- > term = parens expr--- > <|> natural--- > <?> "simple expression"--- >--- > table = [ [prefix "-" negate, prefix "+" id ]--- > , [postfix "++" (+1)]--- > , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ]--- > , [binary "+" (+) AssocLeft, binary "-" (-) AssocLeft ]--- > ]--- >--- > binary name fun assoc = Infix (do{ reservedOp name; return fun }) assoc--- > prefix name fun = Prefix (do{ reservedOp name; return fun })--- > postfix name fun = Postfix (do{ reservedOp name; return fun })--buildExpressionParser :: Monoid t => [[Operator t b]] -> Parser t b -> Parser t b-buildExpressionParser operators simpleExpr- = foldl makeParser simpleExpr operators- where- makeParser term ops- = let (rassoc,lassoc,nassoc- ,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops-- rassocOp = choice rassoc- lassocOp = choice lassoc- nassocOp = choice nassoc- prefixOp = choice prefix- postfixOp = choice postfix-- ambigious assoc op= do{ _ <- op; fail ("ambiguous use of a " ++ assoc- ++ " associative operator")- }-- ambigiousRight = ambigious "right" rassocOp- ambigiousLeft = ambigious "left" lassocOp- ambigiousNon = ambigious "non" nassocOp-- termP = do{ pre <- prefixP- ; x <- term- ; post <- postfixP- ; return (post (pre x))- }-- postfixP = postfixOp <|> return id-- prefixP = prefixOp <|> return id-- rassocP x = do{ f <- rassocOp- ; y <- do{ z <- termP; rassocP1 z }- ; return (f x y)- }- <|> ambigiousLeft- <|> ambigiousNon- -- <|> return x-- rassocP1 x = rassocP x <|> return x-- lassocP x = do{ f <- lassocOp- ; y <- termP- ; lassocP1 (f x y)- }- <|> ambigiousRight- <|> ambigiousNon- -- <|> return x-- lassocP1 x = lassocP x <|> return x-- nassocP x = do{ f <- nassocOp- ; y <- termP- ; ambigiousRight- <|> ambigiousLeft- <|> ambigiousNon- <|> return (f x y)- }- -- <|> return x-- in do{ x <- termP- ; rassocP x <|> lassocP x <|> nassocP x <|> return x- }--- splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix)- = case assoc of- AssocNone -> (rassoc,lassoc,op:nassoc,prefix,postfix)- AssocLeft -> (rassoc,op:lassoc,nassoc,prefix,postfix)- AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix)-- splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix)- = (rassoc,lassoc,nassoc,op:prefix,postfix)-- splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix)- = (rassoc,lassoc,nassoc,prefix,op:postfix)
− Text/HSmarty/Parser/Smarty.hs
@@ -1,190 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-{-# OPTIONS_GHC -fwarn-unused-imports -fwarn-incomplete-patterns #-}-{-# LANGUAGE OverloadedStrings #-}-module Text.HSmarty.Parser.Smarty- ( parseSmarty- , htf_thisModulesTests- )-where--import Text.HSmarty.Types-import Text.HSmarty.Parser.Util-import qualified Text.HSmarty.Parser.Expr as E--import Data.Attoparsec.Text-import Data.Char-import Control.Applicative-import Test.Framework-import qualified Data.Aeson as A-import qualified Data.Text as T--parseSmarty :: Monad m => FilePath -> T.Text -> m Smarty-parseSmarty fp t =- either fail mk $ parseOnly pRoot t- where- mk exprs =- return $ Smarty fp exprs--pRoot =- (stripSpace $ many1 pStmt) <* endOfInput--pStmt :: Parser SmartyStmt-pStmt =- SmartyComment <$> pComment <|>- SmartyText <$> pLiteral <|>- SmartyIf <$> pIf <|>- SmartyForeach <$> pForeach <|>- braced (char '{') (char '}') (SmartyPrint <$> pExpr <*> many pPrintDirective) <|>- SmartyText <$> (takeWhile1 (/='{'))--pPrintDirective :: Parser PrintDirective-pPrintDirective =- char '|' *> pName--pExpr :: Parser Expr-pExpr =- E.buildExpressionParser opTable pValExpr--pValExpr :: Parser Expr-pValExpr =- braced (char '(') (char ')') pExpr <|>- ExprVar <$> pVar <|>- ExprLit <$> pLit <|>- ExprFun <$> pFunCall--pLit :: Parser A.Value-pLit =- A.String <$> stringP <|>- A.Bool <$> boolP <|>- A.Number <$> number--pVar :: Parser Variable-pVar =- Variable <$> (char '$' *> pName) <*> many pVarPath <*> optional pVarIndex <*> optional pVarProp- where- pVarProp =- char '@' *> pName- pVarIndex =- braced (char '[') (char ']') pExpr- pVarPath =- char '.' *> pName--pName :: Parser T.Text-pName =- identP isAlpha isAlphaNum--pLiteral :: Parser T.Text-pLiteral =- (pOpen "literal") *> (T.pack <$> manyTill anyChar (pClose "literal"))--pComment :: Parser T.Text-pComment =- (string "{*") *> (T.pack <$> manyTill anyChar (string "*}"))--pFunCall :: Parser FunctionCall-pFunCall =- FunctionCall <$> pName <*> many1 pArg- where- pArg =- (,) <$> (space_ *> pName <* (stripSpace $ char '='))- <*> pExpr--pOpen :: T.Text -> Parser T.Text-pOpen t =- string $ T.concat [ "{", t, "}" ]--pOpenExpr :: T.Text -> Parser Expr-pOpenExpr t =- (string (T.concat [ "{", t]) *> space_) *> pExpr <* char '}'--pClose :: T.Text -> Parser T.Text-pClose t =- string $ T.concat [ "{/", t, "}" ]--pIf :: Parser If-pIf =- If <$> pBranches <*> optional (pOpen "else" *> many pStmt)- <* pClose "if"- where- pBranch ty = (,) <$> pOpenExpr ty <*> many pStmt- pBranches =- (:) <$> pBranch "if" <*> (many $ pBranch "elseif")--pForeach :: Parser Foreach-pForeach =- Foreach <$> ((string "{foreach" *> space_) *> pExpr <* (space_ <* (string "as") <* space_))- <*> optional (char '$' *> pName <* (stripSpace $ string "=>"))- <*> ((stripSpace (char '$' *> pName)) <* char '}')- <*> many pStmt- <*> optional (pOpen "foreachelse" *> many pStmt)- <* pClose "foreach"--opTable =- [ [ prefix (string "not" *> space_) $ arg1 BinNot- , prefix (char '!') $ arg1 BinNot- ]- , [ sym "*" (arg2 BinMul) E.AssocLeft- , sym "/" (arg2 BinDiv) E.AssocLeft- ]- , [ sym "+" (arg2 BinPlus) E.AssocLeft- , sym "-" (arg2 BinMinus) E.AssocLeft- ]- , [ sym "<" (arg2 BinSmaller) E.AssocNone- , sym ">" (arg2 BinLarger) E.AssocNone- , sym "<=" (arg2 BinSmallerEq) E.AssocNone- , sym ">=" (arg2 BinLargerEq) E.AssocNone- ]- , [ sym "==" (arg2 BinEq) E.AssocNone- , sym "!=" (arg2 (\x y ->- BinNot $ ExprBin $ BinEq x y- )) E.AssocNone- ]- , [ wsym "and" (arg2 BinAnd) E.AssocLeft- , wsym "or" (arg2 BinOr) E.AssocLeft- , sym "&&" (arg2 BinAnd) E.AssocLeft- , sym "||" (arg2 BinOr) E.AssocLeft- ]- ]- where- arg1 fun x = ExprBin $ fun x- arg2 fun x y = ExprBin $ fun x y-- binary op fun assoc =- E.Infix (fun <$ op <* optSpace_) assoc- prefix op fun =- E.Prefix (fun <$ op <* optSpace_)- sym s =- binary (stripSpace $ string s)- wsym w =- binary (between optSpace_ space_ $ string w)---- tests-parserTest parser input expected =- either fail comp $ parseOnly parser input- where- comp x =- assertEqual x expected--test_literalParser =- parserTest pLiteral "{literal}abc{/literal}" "abc"--test_commentParser =- parserTest pComment "{* some comment *}" " some comment "--test_varParser =- parserTest pVar "$hallo.sub@prop" (Variable "hallo" ["sub"] Nothing (Just "prop"))--test_rootParser =- parserTest pRoot "{if true}{include file='hallo.tpl' var1=23}{else}Nothing{/if}" expect- where- expect = [SmartyIf- (If{if_cases =- [(ExprLit (A.Bool True),- [SmartyPrint- (ExprFun- (FunctionCall{f_name = "include",- f_args =- [("file", ExprLit (A.String "hallo.tpl")),- ("var1", ExprLit (A.Number 23))]}))- []])],- if_else = Just [SmartyText "Nothing"]})]
− Text/HSmarty/Parser/Util.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text.HSmarty.Parser.Util where--import Control.Applicative-import Data.Attoparsec.Text-import Data.Char-import Numeric (readHex)-import Prelude hiding (takeWhile)-import qualified Data.Text as T--eolP :: Parser T.Text-eolP =- "\n" <$ (string "\r\n" <|> string "\n" <|> string "\r") <|>- "" <$ endOfInput--boolP :: Parser Bool-boolP =- const True <$> string "true" <|>- const False <$> string "false"--stringP :: Parser T.Text-stringP = (quotedString '"' <|> quotedString '\'') <?> "stringP"--identP :: (Char -> Bool) -> (Char -> Bool) -> Parser T.Text-identP first rest =- (T.cons <$> satisfy first <*> takeWhile rest) <?> "identP"--stripSpace = between optSpace_ optSpace_--space_ = skipWhile1 isSpace-optSpace_ = skipWhile isSpace--between :: Parser a -> Parser b -> Parser c -> Parser c-between left right main = left *> main <* right--skipWhile1 pred = (() <$ takeWhile1 pred) <?> "skipWhile1"--quotedString :: Char -> Parser T.Text-quotedString c = T.pack <$> between (char c) (char c) (many innerChar)- where innerChar = char '\\' *> (escapeSeq <|> unicodeSeq)- <|> satisfy (`notElem` [c,'\\'])--escapeSeq :: Parser Char-escapeSeq = choice (zipWith decode "bnfrt\\\"'" "\b\n\f\r\t\\\"'")- where decode c r = r <$ char c--unicodeSeq :: Parser Char-unicodeSeq = char 'u' *> (intToChar <$> decodeHexUnsafe <$> count 4 hexDigit)- where intToChar = toEnum . fromIntegral--decodeHexUnsafe :: String -> Integer-decodeHexUnsafe hex = (head $ map fst $ readHex hex)--hexDigitUpper = satisfy (inClass "0-9A-F")-hexDigit = satisfy (inClass "0-9a-fA-F")--braced :: Parser l -> Parser r -> Parser a -> Parser a-braced l r =- between (l *> optSpace_) (optSpace_ *> r)--listLike :: Parser l -> Parser r -> Parser s -> Parser a -> Parser [a]-listLike l r sep inner = braced l r (sepBy inner (stripSpace sep))--tupleP :: Parser p -> Parser [p]-tupleP = listLike (char '(') (char ')') (char ',')
− Text/HSmarty/Render/Engine.hs
@@ -1,388 +0,0 @@-{-# OPTIONS_GHC -fwarn-unused-imports -fwarn-incomplete-patterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DoAndIfThenElse #-}-module Text.HSmarty.Render.Engine- ( renderTemplate, mkParam, TemplateParam )-where--import Text.HSmarty.Types-import Text.HSmarty.Parser.Smarty--import Control.Applicative-import Control.Monad.Error-import Data.Attoparsec.Text (Number(..))-import Data.Char (ord)-import Data.Maybe-import Data.Vector ((!?))-import Network.HTTP.Base (urlEncode)-import qualified Data.Aeson as A-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Vector as V--newtype TemplateParam- = TemplateParam { unTemplateParam :: A.Value }- deriving (Show, Eq)--data TemplateVar- = TemplateVar- { tv_value :: A.Value- , tv_props :: PropMap- }- deriving (Show, Eq)--type Env = HM.HashMap T.Text TemplateVar-type ParamMap = HM.HashMap T.Text TemplateParam-type PropMap = HM.HashMap T.Text A.Value--type EvalM a = ErrorT T.Text IO a--instance Error T.Text where- strMsg = T.pack--mkParam :: A.ToJSON a => a -> TemplateParam-mkParam = TemplateParam . A.toJSON--mkEnv :: ParamMap -> Env-mkEnv =- HM.map (\init -> TemplateVar (unTemplateParam init) HM.empty)--renderTemplate :: FilePath -> ParamMap -> IO (Either T.Text T.Text)-renderTemplate fp mp =- do ct <- T.readFile fp- tpl <- parseSmarty fp ct- runErrorT $ evalTpl (mkEnv mp) tpl--applyPrintDirective :: T.Text -> PrintDirective -> EvalM T.Text-applyPrintDirective t "urlencode" =- return $ T.pack $ urlEncode $ T.unpack t-applyPrintDirective t "nl2br" =- return $ T.replace "\n" "<br />" t-applyPrintDirective t "escape" =- return $ T.pack $ htmlEscape $ T.unpack t- where- forbidden = "<&\">'/"- htmlEscape :: String -> String- htmlEscape [] = []- htmlEscape (x:xs) =- if x `elem` forbidden- then concat [ "&#" ++ show (ord x) ++ ";"- , htmlEscape xs- ]- else x : htmlEscape xs-applyPrintDirective _ pd =- throwError $ T.concat [ "Unknown print directive `"- , pd- , "`"- ]--evalTpl :: Env -> Smarty -> EvalM T.Text-evalTpl env (Smarty filename tpl) =- evalBody env tpl--evalStmt :: Env -> SmartyStmt -> EvalM T.Text-evalStmt _ (SmartyText t) = return t-evalStmt _ (SmartyComment _) = return T.empty-evalStmt env (SmartyPrint expr directives) =- do t <- exprToText env expr- foldM applyPrintDirective t directives-evalStmt env (SmartyIf (If cases elseBody)) =- do evaledCases <- mapM (\(cond, body) ->- do r <- evalExpr env cond- b <- evalBody env body- case r of- (A.Bool True) ->- return $ Just b- _ ->- return Nothing- ) cases- case catMaybes evaledCases of- (x:_) ->- return x- _ ->- case elseBody of- Just elseB ->- evalBody env elseB- Nothing ->- return T.empty--evalStmt env (SmartyForeach (Foreach source mKey val body elseBody)) =- do evaledSource <- evalExpr env source- (preparedSource, size) <- mkForeachInput evaledSource- if size == 0- then case elseBody of- Just b -> evalBody env b- Nothing -> return T.empty- else do runs <- mapM (evalForeachBody env mKey val body) preparedSource- return $ T.concat runs--evalBody :: Env -> [SmartyStmt] -> EvalM T.Text-evalBody env stmt =- do b <- mapM (evalStmt env) stmt- return $ T.concat b--exprToText :: Env -> Expr -> EvalM T.Text-exprToText env expr =- do evaled <- evalExpr env expr- case evaled of- A.String t -> return t- A.Number n -> return $ T.pack $ show n- A.Null -> return "null"- A.Bool b ->- return (if b then "true" else "false")- A.Object o ->- return $ T.pack $ show o- A.Array a ->- return $ T.pack $ show a--evalForeachBody :: Env -> Maybe T.Text -> T.Text -> [ SmartyStmt ] -> ( A.Value, A.Value, PropMap ) -> EvalM T.Text-evalForeachBody env mKey item body (keyVal, itemVal, props) =- let env' = HM.insert item (TemplateVar itemVal props) env- env'' =- case mKey of- Just key -> HM.insert key (TemplateVar keyVal HM.empty) env'- Nothing -> env'- in evalBody env'' body---mkForeachInput :: A.Value -> EvalM ( [ ( A.Value, A.Value, PropMap ) ], Int)-mkForeachInput (A.Array vec) =- return $ ( V.toList $ V.imap (\idx elem ->- ( A.Number (I $ fromIntegral idx)- , elem- , mkForeachMap idx fSize- )- ) vec- , fSize- )- where- fSize = V.length vec-mkForeachInput (A.Object hm) =- let (_, input) =- HM.foldlWithKey' (\(idx, out) key elem ->- let newElem = ( A.String key- , elem- , mkForeachMap idx hSize- )- in (idx+1, newElem : out)- ) (0, []) hm- in return $ (reverse input, hSize)- where- hSize = HM.size hm-mkForeachInput _ =- throwError "Tried to iterate over non traversable type."--mkForeachMap :: Int -> Int -> PropMap-mkForeachMap idx' size' =- HM.fromList [ ("index", A.Number (I idx))- , ("iteration", A.Number (I $ 1 + idx))- , ("first", A.Bool $ idx == 0)- , ("last", A.Bool $ (idx+1) == size)- , ("total", A.Number (I size))- ]- where- size = fromIntegral size'- idx = fromIntegral idx'--str :: T.Text -> A.Value -> EvalM T.Text-str _ (A.String x) = return x-str desc _ = throwError $ T.concat [ "`", desc, "` is not a string!" ]--int :: T.Text -> A.Value -> EvalM Int-int _ (A.Number (I x)) = return (fromIntegral x)-int desc _ = throwError $ T.concat [ "`", desc, "` is not an integer!" ]--dbl :: T.Text -> A.Value -> EvalM Double-dbl _ (A.Number (D x)) = return x-dbl desc _ = throwError $ T.concat [ "`", desc, "` is not a double!" ]--ifExists :: (Eq a, Show a) => T.Text -> a -> [(a, A.Value)] -> (A.Value -> EvalM b) -> EvalM b-ifExists msg key env fun =- case lookup key env of- Just x -> fun x- Nothing ->- throwError $ T.concat [ "`", T.pack $ show key, "` is not given. ", msg]--lookupStr :: T.Text -> T.Text -> [(T.Text, A.Value)] -> EvalM T.Text-lookupStr funName key env =- ifExists (T.concat ["Param for `", funName, "`"]) key env (str key)--evalFunCall :: Env -> T.Text -> [ (T.Text, Expr) ] -> EvalM A.Value-evalFunCall env "include" args =- do evaledArgs <- mapM (\(k, expr) ->- do val <- evalExpr env expr- return (k, val)- ) args- filename <- lookupStr "include" "file" evaledArgs- let otherArgs = filter (\arg@(k, _) ->- not $ k `elem` [ "include" ]- ) evaledArgs- asTplParams = HM.fromList $ map (\(k, v) -> (k, TemplateParam v)) otherArgs- content <- liftIO $ renderTemplate (T.unpack filename) asTplParams- case content of- Right c ->- return $ A.String c- Left e ->- throwError $ T.concat ["Include failed. Error: ", e]-evalFunCall env fname _ =- throwError $ T.concat [ "Call to undefined function "- , fname- ]---evalExpr :: Env -> Expr -> EvalM A.Value-evalExpr _ (ExprLit v) = return v-evalExpr env (ExprBin op) =- evalBinOp env op-evalExpr env (ExprFun funCall) =- evalFunCall env (f_name funCall) (f_args funCall)-evalExpr env (ExprVar v) =- case HM.lookup varName env of- Just tplVar ->- case v of- (Variable { v_prop = Just propReq }) ->- case HM.lookup propReq (tv_props tplVar) of- Just val -> return val- Nothing -> throwError $ T.concat [ "Property `"- , propReq- , "` is not defined for variable `"- , varName- , "`"- ]- (Variable { v_path = path, v_index = mIdx }) ->- let pathName = T.concat [ varName- , if (length path > 0) then "." else T.empty- , T.intercalate "." path- ]- idxWalk val =- case mIdx of- Just eIdx ->- do res <- evalExpr env eIdx- walkIndex pathName res val- Nothing ->- return val-- in do pathRes <- walkPath varName path $ tv_value tplVar- idxWalk pathRes--- Nothing ->- throwError $ T.concat [ "Variable `"- , varName- , "` is not defined"- ]- where- varName = v_name v--walkIndex :: T.Text -> A.Value -> A.Value -> EvalM A.Value-walkIndex vname (A.Number (I idx)) (A.Array arr) =- case arr !? (fromIntegral idx) of- Just val -> return val- Nothing ->- throwError $ T.concat [ "Out of bounds. `"- , vname- , "["- , T.pack $ show idx- , "]` not defined."- ]-walkIndex vname idx _ =- throwError $ T.concat [ "Can't access `"- , T.pack $ show idx- , "` in `"- , vname- , "`. Index is not an integer or value not an array!"- ]--walkPath :: T.Text -> [T.Text] -> A.Value -> EvalM A.Value-walkPath vname [] val = return val-walkPath vname (path:xs) (A.Object obj) =- case HM.lookup path obj of- Just val -> walkPath (T.concat [vname, ".", path]) xs val- Nothing ->- throwError $ T.concat [ "Variable `"- , vname- , "` doesn't have the key `"- , path- , "`"- ]-walkPath vname (path:xs) _ =- throwError $ T.concat [ "Variable `"- , vname- , "` is not a map! Can't lookup `"- , path- , "`"- ]--evalBinOp :: Env -> BinOp -> EvalM A.Value-evalBinOp env (BinEq a b) =- boolResOp (\x y -> return $ x == y) (a, b) env-evalBinOp env (BinNot e) =- do e' <- evalExpr env e- case e' of- A.Bool a ->- return (A.Bool $ not a)- _ ->- throwError "Tried to evaluate a NOT on a non boolean value"-evalBinOp env (BinOr x y) =- boolOp "Or" (||) (x, y) env-evalBinOp env (BinAnd x y) =- boolOp "And" (&&) (x, y) env-evalBinOp env (BinLarger x y) =- numOp "Larger" (>) (x, y) env-evalBinOp env (BinLargerEq x y) =- numOp "LargerEq" (>=) (x, y) env-evalBinOp env (BinSmaller x y) =- numOp "Smaller" (<) (x, y) env-evalBinOp env (BinSmallerEq x y) =- numOp "SmallerEq" (<=) (x, y) env-evalBinOp env (BinPlus x y) =- calcOp "Plus" (+) (x, y) env-evalBinOp env (BinMinus x y) =- calcOp "Minus" (-) (x, y) env-evalBinOp env (BinMul x y) =- calcOp "Mul" (*) (x, y) env-evalBinOp env (BinDiv x y) =- calcOp "Div" (/) (x, y) env---boolOp :: T.Text -> (Bool -> Bool -> Bool) -> (Expr, Expr) -> Env -> EvalM A.Value-boolOp d op exprs env =- boolResOp bOp exprs env- where- bOp (A.Bool a) (A.Bool b) =- return $ a `op` b- bOp _ _ = throwError $ T.concat [ "Tried ", d, "Op and on two non boolean values" ]--numOp :: T.Text -> (Number -> Number -> Bool) -> (Expr, Expr) -> Env -> EvalM A.Value-numOp =- numGenOp boolResOp--calcOp :: T.Text -> (Number -> Number -> Number) -> (Expr, Expr) -> Env -> EvalM A.Value-calcOp =- numGenOp numResOp--numGenOp :: ((A.Value -> A.Value -> EvalM a)- -> (Expr, Expr) -> Env -> EvalM A.Value)- -> T.Text -> (Number -> Number -> a) -> (Expr, Expr) -> Env -> EvalM A.Value-numGenOp fun d op exprs env =- fun nOp exprs env- where- nOp (A.Number a) (A.Number b) =- return $ a `op` b- nOp _ _ = throwError $ T.concat [ "Tried ", d, "Op and on two non numeric values" ]--numResOp :: (A.Value -> A.Value -> EvalM Number)- -> (Expr, Expr) -> Env -> EvalM A.Value-numResOp fun (a, b) env =- do a' <- evalExpr env a- b' <- evalExpr env b- A.Number <$> fun a' b'--boolResOp :: (A.Value -> A.Value -> EvalM Bool)- -> (Expr, Expr) -> Env -> EvalM A.Value-boolResOp fun (a, b) env =- do a' <- evalExpr env a- b' <- evalExpr env b- A.Bool <$> fun a' b'
− Text/HSmarty/Types.hs
@@ -1,77 +0,0 @@-{-# OPTIONS_GHC -fwarn-unused-imports -fwarn-incomplete-patterns #-}-{-# LANGUAGE OverloadedStrings #-}-module Text.HSmarty.Types where--import qualified Data.Text as T-import qualified Data.Aeson as A--data Smarty- = Smarty- { s_name :: FilePath- , s_template :: [ SmartyStmt ]- } deriving (Eq, Show)--type PrintDirective = T.Text--data SmartyStmt- = SmartyText T.Text- | SmartyComment T.Text- | SmartyIf If- | SmartyForeach Foreach- | SmartyPrint Expr [ PrintDirective ]- deriving (Eq, Show)--data Expr- = ExprVar Variable- | ExprLit A.Value- | ExprFun FunctionCall- | ExprBin BinOp- deriving (Eq, Show)--data Variable- = Variable- { v_name :: T.Text- , v_path :: [T.Text]- , v_index :: Maybe Expr- , v_prop :: Maybe T.Text- }- deriving (Eq, Show)--data FunctionCall- = FunctionCall- { f_name :: T.Text- , f_args :: [ (T.Text, Expr) ]- }- deriving (Eq, Show)--data BinOp- = BinEq Expr Expr- | BinNot Expr- | BinAnd Expr Expr- | BinOr Expr Expr- | BinLarger Expr Expr- | BinSmaller Expr Expr- | BinLargerEq Expr Expr- | BinSmallerEq Expr Expr- | BinPlus Expr Expr- | BinMinus Expr Expr- | BinMul Expr Expr- | BinDiv Expr Expr- deriving (Eq, Show)--data If- = If- { if_cases :: [ (Expr, [SmartyStmt]) ]- , if_else :: Maybe [SmartyStmt]- }- deriving (Eq, Show)--data Foreach- = Foreach- { f_source :: Expr- , f_key :: Maybe T.Text- , f_item :: T.Text- , f_body :: [SmartyStmt]- , f_else :: Maybe [SmartyStmt]- }- deriving (Eq, Show)
+ src/Tests.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++import Test.Framework+import {-@ HTF_TESTS @-} Text.HSmarty.Parser.Smarty++main :: IO ()+main = htfMain htf_importedTests
+ src/Text/HSmarty.hs view
@@ -0,0 +1,5 @@+module Text.HSmarty+ (module Text.HSmarty.Render.Engine)+where++import Text.HSmarty.Render.Engine
+ src/Text/HSmarty/Parser/Smarty.hs view
@@ -0,0 +1,200 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+{-# OPTIONS_GHC -fwarn-unused-imports -fwarn-incomplete-patterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module Text.HSmarty.Parser.Smarty+ ( parseSmarty+ , htf_thisModulesTests+ )+where++import Text.HSmarty.Types+import Text.HSmarty.Parser.Util+++import Data.Attoparsec.Text+import Data.Char+import Control.Applicative+import Test.Framework+import qualified Data.Aeson as A+import qualified Data.Attoparsec.Expr as E+import qualified Data.Text as T++parseSmarty :: Monad m => FilePath -> T.Text -> m Smarty+parseSmarty fp t =+ either fail mk $ parseOnly pRoot t+ where+ mk exprs =+ return $ Smarty fp exprs++pRoot :: Parser [SmartyStmt]+pRoot =+ (stripSpace $ many1 pStmt) <* endOfInput++pStmt :: Parser SmartyStmt+pStmt =+ SmartyComment <$> pComment <|>+ SmartyText <$> pLiteral <|>+ SmartyIf <$> pIf <|>+ SmartyForeach <$> pForeach <|>+ braced (char '{') (char '}') (SmartyPrint <$> pExpr <*> many pPrintDirective) <|>+ SmartyText <$> (takeWhile1 (/='{'))++pPrintDirective :: Parser PrintDirective+pPrintDirective =+ char '|' *> pName++pExpr :: Parser Expr+pExpr =+ E.buildExpressionParser opTable pValExpr++pValExpr :: Parser Expr+pValExpr =+ braced (char '(') (char ')') pExpr <|>+ ExprVar <$> pVar <|>+ ExprLit <$> pLit <|>+ ExprFun <$> pFunCall++pLit :: Parser A.Value+pLit =+ A.String <$> stringP <|>+ A.Bool <$> boolP <|>+ A.Number <$> number++pVar :: Parser Variable+pVar =+ Variable <$> (char '$' *> pName) <*> many pVarPath <*> optional pVarIndex <*> optional pVarProp+ where+ pVarProp =+ char '@' *> pName+ pVarIndex =+ braced (char '[') (char ']') pExpr+ pVarPath =+ char '.' *> pName++pName :: Parser T.Text+pName =+ identP isAlpha isAlphaNum++pLiteral :: Parser T.Text+pLiteral =+ (pOpen "literal") *> (T.pack <$> manyTill anyChar (pClose "literal"))++pComment :: Parser T.Text+pComment =+ (string "{*") *> (T.pack <$> manyTill anyChar (string "*}"))++pFunCall :: Parser FunctionCall+pFunCall =+ FunctionCall <$> pName <*> many1 pArg+ where+ pArg =+ (,) <$> (space_ *> pName <* (stripSpace $ char '='))+ <*> pExpr++pOpen :: T.Text -> Parser T.Text+pOpen t =+ string $ T.concat [ "{", t, "}" ]++pOpenExpr :: T.Text -> Parser Expr+pOpenExpr t =+ (string (T.concat [ "{", t]) *> space_) *> pExpr <* char '}'++pClose :: T.Text -> Parser T.Text+pClose t =+ string $ T.concat [ "{/", t, "}" ]++pIf :: Parser If+pIf =+ If <$> pBranches <*> optional (pOpen "else" *> many pStmt)+ <* pClose "if"+ where+ pBranch ty = (,) <$> pOpenExpr ty <*> many pStmt+ pBranches =+ (:) <$> pBranch "if" <*> (many $ pBranch "elseif")++pForeach :: Parser Foreach+pForeach =+ Foreach <$> ((string "{foreach" *> space_) *> pExpr <* (space_ <* (string "as") <* space_))+ <*> optional (char '$' *> pName <* (stripSpace $ string "=>"))+ <*> ((stripSpace (char '$' *> pName)) <* char '}')+ <*> many pStmt+ <*> optional (pOpen "foreachelse" *> many pStmt)+ <* pClose "foreach"++opTable :: [[E.Operator T.Text Expr]]+opTable =+ [ [ prefix (string "not" *> space_) $ arg1 BinNot+ , prefix (char '!') $ arg1 BinNot+ ]+ , [ sym "*" (arg2 BinMul) E.AssocLeft+ , sym "/" (arg2 BinDiv) E.AssocLeft+ ]+ , [ sym "+" (arg2 BinPlus) E.AssocLeft+ , sym "-" (arg2 BinMinus) E.AssocLeft+ ]+ , [ sym "<" (arg2 BinSmaller) E.AssocNone+ , sym ">" (arg2 BinLarger) E.AssocNone+ , sym "<=" (arg2 BinSmallerEq) E.AssocNone+ , sym ">=" (arg2 BinLargerEq) E.AssocNone+ ]+ , [ sym "==" (arg2 BinEq) E.AssocNone+ , sym "!=" (arg2 (\x y ->+ BinNot $ ExprBin $ BinEq x y+ )) E.AssocNone+ ]+ , [ wsym "and" (arg2 BinAnd) E.AssocLeft+ , wsym "or" (arg2 BinOr) E.AssocLeft+ , sym "&&" (arg2 BinAnd) E.AssocLeft+ , sym "||" (arg2 BinOr) E.AssocLeft+ ]+ ]+ where+ arg1 fun x = ExprBin $ fun x+ arg2 fun x y = ExprBin $ fun x y++ binary op fun assoc =+ E.Infix (fun <$ op <* optSpace_) assoc+ prefix op fun =+ E.Prefix (fun <$ op <* optSpace_)+ sym s =+ binary (stripSpace $ string s)+ wsym w =+ binary (between optSpace_ space_ $ string w)++-- tests+parserTest :: forall b. (Eq b, Show b)+ => Parser b -> T.Text -> b -> IO ()+parserTest parser input expected =+ either fail comp $ parseOnly parser input+ where+ comp x =+ assertEqual x expected++test_literalParser :: IO ()+test_literalParser =+ parserTest pLiteral "{literal}abc{/literal}" "abc"++test_commentParser :: IO ()+test_commentParser =+ parserTest pComment "{* some comment *}" " some comment "++test_varParser :: IO ()+test_varParser =+ parserTest pVar "$hallo.sub@prop" (Variable "hallo" ["sub"] Nothing (Just "prop"))++test_rootParser :: IO ()+test_rootParser =+ parserTest pRoot "{if true}{include file='hallo.tpl' var1=23}{else}Nothing{/if}" expect+ where+ expect = [SmartyIf+ (If{if_cases =+ [(ExprLit (A.Bool True),+ [SmartyPrint+ (ExprFun+ (FunctionCall{f_name = "include",+ f_args =+ [("file", ExprLit (A.String "hallo.tpl")),+ ("var1", ExprLit (A.Number 23))]}))+ []])],+ if_else = Just [SmartyText "Nothing"]})]
+ src/Text/HSmarty/Parser/Util.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module Text.HSmarty.Parser.Util where++import Control.Applicative+import Data.Attoparsec.Text+import Data.Char+import Numeric (readHex)+import Prelude hiding (takeWhile)+import qualified Data.Text as T++eolP :: Parser T.Text+eolP =+ "\n" <$ (string "\r\n" <|> string "\n" <|> string "\r") <|>+ "" <$ endOfInput++boolP :: Parser Bool+boolP =+ const True <$> string "true" <|>+ const False <$> string "false"++stringP :: Parser T.Text+stringP = (quotedString '"' <|> quotedString '\'') <?> "stringP"++identP :: (Char -> Bool) -> (Char -> Bool) -> Parser T.Text+identP first rest =+ (T.cons <$> satisfy first <*> takeWhile rest) <?> "identP"++stripSpace :: forall c. Parser c -> Parser c+stripSpace = between optSpace_ optSpace_++space_ :: Parser ()+space_ = skipWhile1 isSpace++optSpace_ :: Parser ()+optSpace_ = skipWhile isSpace++between :: Parser a -> Parser b -> Parser c -> Parser c+between left right main = left *> main <* right++skipWhile1 :: (Char -> Bool) -> Parser ()+skipWhile1 p = (() <$ takeWhile1 p) <?> "skipWhile1"++quotedString :: Char -> Parser T.Text+quotedString c = T.pack <$> between (char c) (char c) (many innerChar)+ where innerChar = char '\\' *> (escapeSeq <|> unicodeSeq)+ <|> satisfy (`notElem` [c,'\\'])++escapeSeq :: Parser Char+escapeSeq = choice (zipWith decode "bnfrt\\\"'" "\b\n\f\r\t\\\"'")+ where decode c r = r <$ char c++unicodeSeq :: Parser Char+unicodeSeq = char 'u' *> (intToChar <$> decodeHexUnsafe <$> count 4 hexDigit)+ where intToChar = toEnum . fromIntegral++decodeHexUnsafe :: String -> Integer+decodeHexUnsafe hex = (head $ map fst $ readHex hex)++hexDigitUpper :: Parser Char+hexDigitUpper = satisfy (inClass "0-9A-F")++hexDigit :: Parser Char+hexDigit = satisfy (inClass "0-9a-fA-F")++braced :: Parser l -> Parser r -> Parser a -> Parser a+braced l r =+ between (l *> optSpace_) (optSpace_ *> r)++listLike :: Parser l -> Parser r -> Parser s -> Parser a -> Parser [a]+listLike l r sep inner = braced l r (sepBy inner (stripSpace sep))++tupleP :: Parser p -> Parser [p]+tupleP = listLike (char '(') (char ')') (char ',')
+ src/Text/HSmarty/Render/Engine.hs view
@@ -0,0 +1,394 @@+{-# OPTIONS_GHC -fwarn-unused-imports -fwarn-incomplete-patterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DoAndIfThenElse #-}+module Text.HSmarty.Render.Engine+ ( renderTemplate, mkParam, TemplateParam, ParamMap )+where++import Text.HSmarty.Types+import Text.HSmarty.Parser.Smarty++import Control.Applicative+import Control.Monad.Error+import Data.Attoparsec.Text (Number(..))+import Data.Char (ord)+import Data.Maybe+import Data.Vector ((!?))+import Network.HTTP.Base (urlEncode)+import qualified Data.Aeson as A+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Vector as V++-- | An template param, construct using 'mkParam'+newtype TemplateParam+ = TemplateParam { unTemplateParam :: A.Value }+ deriving (Show, Eq)++data TemplateVar+ = TemplateVar+ { tv_value :: A.Value+ , tv_props :: PropMap+ }+ deriving (Show, Eq)++type Env = HM.HashMap T.Text TemplateVar++-- | Maps template variables to template params+type ParamMap = HM.HashMap T.Text TemplateParam+type PropMap = HM.HashMap T.Text A.Value++type EvalM a = ErrorT T.Text IO a++instance Error T.Text where+ strMsg = T.pack++-- | Pack a value as a template param+mkParam :: A.ToJSON a => a -> TemplateParam+mkParam = TemplateParam . A.toJSON++mkEnv :: ParamMap -> Env+mkEnv =+ HM.map (\init -> TemplateVar (unTemplateParam init) HM.empty)++-- | Render a template using the specified ParamMap.+-- Results in either an error-message or the rendered template+renderTemplate :: FilePath -> ParamMap -> IO (Either T.Text T.Text)+renderTemplate fp mp =+ do ct <- T.readFile fp+ tpl <- parseSmarty fp ct+ runErrorT $ evalTpl (mkEnv mp) tpl++applyPrintDirective :: T.Text -> PrintDirective -> EvalM T.Text+applyPrintDirective t "urlencode" =+ return $ T.pack $ urlEncode $ T.unpack t+applyPrintDirective t "nl2br" =+ return $ T.replace "\n" "<br />" t+applyPrintDirective t "escape" =+ return $ T.pack $ htmlEscape $ T.unpack t+ where+ forbidden = "<&\">'/"+ htmlEscape :: String -> String+ htmlEscape [] = []+ htmlEscape (x:xs) =+ if x `elem` forbidden+ then concat [ "&#" ++ show (ord x) ++ ";"+ , htmlEscape xs+ ]+ else x : htmlEscape xs+applyPrintDirective _ pd =+ throwError $ T.concat [ "Unknown print directive `"+ , pd+ , "`"+ ]++evalTpl :: Env -> Smarty -> EvalM T.Text+evalTpl env (Smarty filename tpl) =+ evalBody env tpl++evalStmt :: Env -> SmartyStmt -> EvalM T.Text+evalStmt _ (SmartyText t) = return t+evalStmt _ (SmartyComment _) = return T.empty+evalStmt env (SmartyPrint expr directives) =+ do t <- exprToText env expr+ foldM applyPrintDirective t directives+evalStmt env (SmartyIf (If cases elseBody)) =+ do evaledCases <- mapM (\(cond, body) ->+ do r <- evalExpr env cond+ b <- evalBody env body+ case r of+ (A.Bool True) ->+ return $ Just b+ _ ->+ return Nothing+ ) cases+ case catMaybes evaledCases of+ (x:_) ->+ return x+ _ ->+ case elseBody of+ Just elseB ->+ evalBody env elseB+ Nothing ->+ return T.empty++evalStmt env (SmartyForeach (Foreach source mKey val body elseBody)) =+ do evaledSource <- evalExpr env source+ (preparedSource, size) <- mkForeachInput evaledSource+ if size == 0+ then case elseBody of+ Just b -> evalBody env b+ Nothing -> return T.empty+ else do runs <- mapM (evalForeachBody env mKey val body) preparedSource+ return $ T.concat runs++evalBody :: Env -> [SmartyStmt] -> EvalM T.Text+evalBody env stmt =+ do b <- mapM (evalStmt env) stmt+ return $ T.concat b++exprToText :: Env -> Expr -> EvalM T.Text+exprToText env expr =+ do evaled <- evalExpr env expr+ case evaled of+ A.String t -> return t+ A.Number n -> return $ T.pack $ show n+ A.Null -> return "null"+ A.Bool b ->+ return (if b then "true" else "false")+ A.Object o ->+ return $ T.pack $ show o+ A.Array a ->+ return $ T.pack $ show a++evalForeachBody :: Env -> Maybe T.Text -> T.Text -> [ SmartyStmt ] -> ( A.Value, A.Value, PropMap ) -> EvalM T.Text+evalForeachBody env mKey item body (keyVal, itemVal, props) =+ let env' = HM.insert item (TemplateVar itemVal props) env+ env'' =+ case mKey of+ Just key -> HM.insert key (TemplateVar keyVal HM.empty) env'+ Nothing -> env'+ in evalBody env'' body+++mkForeachInput :: A.Value -> EvalM ( [ ( A.Value, A.Value, PropMap ) ], Int)+mkForeachInput (A.Array vec) =+ return $ ( V.toList $ V.imap (\idx elem ->+ ( A.Number (I $ fromIntegral idx)+ , elem+ , mkForeachMap idx fSize+ )+ ) vec+ , fSize+ )+ where+ fSize = V.length vec+mkForeachInput (A.Object hm) =+ let (_, input) =+ HM.foldlWithKey' (\(idx, out) key elem ->+ let newElem = ( A.String key+ , elem+ , mkForeachMap idx hSize+ )+ in (idx+1, newElem : out)+ ) (0, []) hm+ in return $ (reverse input, hSize)+ where+ hSize = HM.size hm+mkForeachInput _ =+ throwError "Tried to iterate over non traversable type."++mkForeachMap :: Int -> Int -> PropMap+mkForeachMap idx' size' =+ HM.fromList [ ("index", A.Number (I idx))+ , ("iteration", A.Number (I $ 1 + idx))+ , ("first", A.Bool $ idx == 0)+ , ("last", A.Bool $ (idx+1) == size)+ , ("total", A.Number (I size))+ ]+ where+ size = fromIntegral size'+ idx = fromIntegral idx'++str :: T.Text -> A.Value -> EvalM T.Text+str _ (A.String x) = return x+str desc _ = throwError $ T.concat [ "`", desc, "` is not a string!" ]++int :: T.Text -> A.Value -> EvalM Int+int _ (A.Number (I x)) = return (fromIntegral x)+int desc _ = throwError $ T.concat [ "`", desc, "` is not an integer!" ]++dbl :: T.Text -> A.Value -> EvalM Double+dbl _ (A.Number (D x)) = return x+dbl desc _ = throwError $ T.concat [ "`", desc, "` is not a double!" ]++ifExists :: (Eq a, Show a) => T.Text -> a -> [(a, A.Value)] -> (A.Value -> EvalM b) -> EvalM b+ifExists msg key env fun =+ case lookup key env of+ Just x -> fun x+ Nothing ->+ throwError $ T.concat [ "`", T.pack $ show key, "` is not given. ", msg]++lookupStr :: T.Text -> T.Text -> [(T.Text, A.Value)] -> EvalM T.Text+lookupStr funName key env =+ ifExists (T.concat ["Param for `", funName, "`"]) key env (str key)++evalFunCall :: Env -> T.Text -> [ (T.Text, Expr) ] -> EvalM A.Value+evalFunCall env "include" args =+ do evaledArgs <- mapM (\(k, expr) ->+ do val <- evalExpr env expr+ return (k, val)+ ) args+ filename <- lookupStr "include" "file" evaledArgs+ let otherArgs = filter (\arg@(k, _) ->+ not $ k `elem` [ "include" ]+ ) evaledArgs+ asTplParams = HM.fromList $ map (\(k, v) -> (k, TemplateParam v)) otherArgs+ content <- liftIO $ renderTemplate (T.unpack filename) asTplParams+ case content of+ Right c ->+ return $ A.String c+ Left e ->+ throwError $ T.concat ["Include failed. Error: ", e]+evalFunCall env fname _ =+ throwError $ T.concat [ "Call to undefined function "+ , fname+ ]+++evalExpr :: Env -> Expr -> EvalM A.Value+evalExpr _ (ExprLit v) = return v+evalExpr env (ExprBin op) =+ evalBinOp env op+evalExpr env (ExprFun funCall) =+ evalFunCall env (f_name funCall) (f_args funCall)+evalExpr env (ExprVar v) =+ case HM.lookup varName env of+ Just tplVar ->+ case v of+ (Variable { v_prop = Just propReq }) ->+ case HM.lookup propReq (tv_props tplVar) of+ Just val -> return val+ Nothing -> throwError $ T.concat [ "Property `"+ , propReq+ , "` is not defined for variable `"+ , varName+ , "`"+ ]+ (Variable { v_path = path, v_index = mIdx }) ->+ let pathName = T.concat [ varName+ , if (length path > 0) then "." else T.empty+ , T.intercalate "." path+ ]+ idxWalk val =+ case mIdx of+ Just eIdx ->+ do res <- evalExpr env eIdx+ walkIndex pathName res val+ Nothing ->+ return val++ in do pathRes <- walkPath varName path $ tv_value tplVar+ idxWalk pathRes+++ Nothing ->+ throwError $ T.concat [ "Variable `"+ , varName+ , "` is not defined"+ ]+ where+ varName = v_name v++walkIndex :: T.Text -> A.Value -> A.Value -> EvalM A.Value+walkIndex vname (A.Number (I idx)) (A.Array arr) =+ case arr !? (fromIntegral idx) of+ Just val -> return val+ Nothing ->+ throwError $ T.concat [ "Out of bounds. `"+ , vname+ , "["+ , T.pack $ show idx+ , "]` not defined."+ ]+walkIndex vname idx _ =+ throwError $ T.concat [ "Can't access `"+ , T.pack $ show idx+ , "` in `"+ , vname+ , "`. Index is not an integer or value not an array!"+ ]++walkPath :: T.Text -> [T.Text] -> A.Value -> EvalM A.Value+walkPath vname [] val = return val+walkPath vname (path:xs) (A.Object obj) =+ case HM.lookup path obj of+ Just val -> walkPath (T.concat [vname, ".", path]) xs val+ Nothing ->+ throwError $ T.concat [ "Variable `"+ , vname+ , "` doesn't have the key `"+ , path+ , "`"+ ]+walkPath vname (path:xs) _ =+ throwError $ T.concat [ "Variable `"+ , vname+ , "` is not a map! Can't lookup `"+ , path+ , "`"+ ]++evalBinOp :: Env -> BinOp -> EvalM A.Value+evalBinOp env (BinEq a b) =+ boolResOp (\x y -> return $ x == y) (a, b) env+evalBinOp env (BinNot e) =+ do e' <- evalExpr env e+ case e' of+ A.Bool a ->+ return (A.Bool $ not a)+ _ ->+ throwError "Tried to evaluate a NOT on a non boolean value"+evalBinOp env (BinOr x y) =+ boolOp "Or" (||) (x, y) env+evalBinOp env (BinAnd x y) =+ boolOp "And" (&&) (x, y) env+evalBinOp env (BinLarger x y) =+ numOp "Larger" (>) (x, y) env+evalBinOp env (BinLargerEq x y) =+ numOp "LargerEq" (>=) (x, y) env+evalBinOp env (BinSmaller x y) =+ numOp "Smaller" (<) (x, y) env+evalBinOp env (BinSmallerEq x y) =+ numOp "SmallerEq" (<=) (x, y) env+evalBinOp env (BinPlus x y) =+ calcOp "Plus" (+) (x, y) env+evalBinOp env (BinMinus x y) =+ calcOp "Minus" (-) (x, y) env+evalBinOp env (BinMul x y) =+ calcOp "Mul" (*) (x, y) env+evalBinOp env (BinDiv x y) =+ calcOp "Div" (/) (x, y) env+++boolOp :: T.Text -> (Bool -> Bool -> Bool) -> (Expr, Expr) -> Env -> EvalM A.Value+boolOp d op exprs env =+ boolResOp bOp exprs env+ where+ bOp (A.Bool a) (A.Bool b) =+ return $ a `op` b+ bOp _ _ = throwError $ T.concat [ "Tried ", d, "Op and on two non boolean values" ]++numOp :: T.Text -> (Number -> Number -> Bool) -> (Expr, Expr) -> Env -> EvalM A.Value+numOp =+ numGenOp boolResOp++calcOp :: T.Text -> (Number -> Number -> Number) -> (Expr, Expr) -> Env -> EvalM A.Value+calcOp =+ numGenOp numResOp++numGenOp :: ((A.Value -> A.Value -> EvalM a)+ -> (Expr, Expr) -> Env -> EvalM A.Value)+ -> T.Text -> (Number -> Number -> a) -> (Expr, Expr) -> Env -> EvalM A.Value+numGenOp fun d op exprs env =+ fun nOp exprs env+ where+ nOp (A.Number a) (A.Number b) =+ return $ a `op` b+ nOp _ _ = throwError $ T.concat [ "Tried ", d, "Op and on two non numeric values" ]++numResOp :: (A.Value -> A.Value -> EvalM Number)+ -> (Expr, Expr) -> Env -> EvalM A.Value+numResOp fun (a, b) env =+ do a' <- evalExpr env a+ b' <- evalExpr env b+ A.Number <$> fun a' b'++boolResOp :: (A.Value -> A.Value -> EvalM Bool)+ -> (Expr, Expr) -> Env -> EvalM A.Value+boolResOp fun (a, b) env =+ do a' <- evalExpr env a+ b' <- evalExpr env b+ A.Bool <$> fun a' b'
+ src/Text/HSmarty/Types.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -fwarn-unused-imports -fwarn-incomplete-patterns #-}+{-# LANGUAGE OverloadedStrings #-}+module Text.HSmarty.Types where++import qualified Data.Text as T+import qualified Data.Aeson as A++data Smarty+ = Smarty+ { s_name :: FilePath+ , s_template :: [ SmartyStmt ]+ } deriving (Eq, Show)++type PrintDirective = T.Text++data SmartyStmt+ = SmartyText T.Text+ | SmartyComment T.Text+ | SmartyIf If+ | SmartyForeach Foreach+ | SmartyPrint Expr [ PrintDirective ]+ deriving (Eq, Show)++data Expr+ = ExprVar Variable+ | ExprLit A.Value+ | ExprFun FunctionCall+ | ExprBin BinOp+ deriving (Eq, Show)++data Variable+ = Variable+ { v_name :: T.Text+ , v_path :: [T.Text]+ , v_index :: Maybe Expr+ , v_prop :: Maybe T.Text+ }+ deriving (Eq, Show)++data FunctionCall+ = FunctionCall+ { f_name :: T.Text+ , f_args :: [ (T.Text, Expr) ]+ }+ deriving (Eq, Show)++data BinOp+ = BinEq Expr Expr+ | BinNot Expr+ | BinAnd Expr Expr+ | BinOr Expr Expr+ | BinLarger Expr Expr+ | BinSmaller Expr Expr+ | BinLargerEq Expr Expr+ | BinSmallerEq Expr Expr+ | BinPlus Expr Expr+ | BinMinus Expr Expr+ | BinMul Expr Expr+ | BinDiv Expr Expr+ deriving (Eq, Show)++data If+ = If+ { if_cases :: [ (Expr, [SmartyStmt]) ]+ , if_else :: Maybe [SmartyStmt]+ }+ deriving (Eq, Show)++data Foreach+ = Foreach+ { f_source :: Expr+ , f_key :: Maybe T.Text+ , f_item :: T.Text+ , f_body :: [SmartyStmt]+ , f_else :: Maybe [SmartyStmt]+ }+ deriving (Eq, Show)
test.tpl view
@@ -1,3 +1,4 @@+{* test *} <html> <head> <title>{$title}</title>