diff --git a/HSmarty.cabal b/HSmarty.cabal --- a/HSmarty.cabal +++ b/HSmarty.cabal @@ -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 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 diff --git a/Tests.hs b/Tests.hs deleted file mode 100644 --- a/Tests.hs +++ /dev/null @@ -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 diff --git a/Text/HSmarty.hs b/Text/HSmarty.hs deleted file mode 100644 --- a/Text/HSmarty.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Text.HSmarty - (module Text.HSmarty.Render.Engine) -where - -import Text.HSmarty.Render.Engine diff --git a/Text/HSmarty/Parser/Expr.hs b/Text/HSmarty/Parser/Expr.hs deleted file mode 100644 --- a/Text/HSmarty/Parser/Expr.hs +++ /dev/null @@ -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 --- 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) diff --git a/Text/HSmarty/Parser/Smarty.hs b/Text/HSmarty/Parser/Smarty.hs deleted file mode 100644 --- a/Text/HSmarty/Parser/Smarty.hs +++ /dev/null @@ -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"]})] diff --git a/Text/HSmarty/Parser/Util.hs b/Text/HSmarty/Parser/Util.hs deleted file mode 100644 --- a/Text/HSmarty/Parser/Util.hs +++ /dev/null @@ -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 ',') diff --git a/Text/HSmarty/Render/Engine.hs b/Text/HSmarty/Render/Engine.hs deleted file mode 100644 --- a/Text/HSmarty/Render/Engine.hs +++ /dev/null @@ -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" "
" 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' diff --git a/Text/HSmarty/Types.hs b/Text/HSmarty/Types.hs deleted file mode 100644 --- a/Text/HSmarty/Types.hs +++ /dev/null @@ -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) diff --git a/src/Tests.hs b/src/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Tests.hs @@ -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 diff --git a/src/Text/HSmarty.hs b/src/Text/HSmarty.hs new file mode 100644 --- /dev/null +++ b/src/Text/HSmarty.hs @@ -0,0 +1,5 @@ +module Text.HSmarty + (module Text.HSmarty.Render.Engine) +where + +import Text.HSmarty.Render.Engine diff --git a/src/Text/HSmarty/Parser/Smarty.hs b/src/Text/HSmarty/Parser/Smarty.hs new file mode 100644 --- /dev/null +++ b/src/Text/HSmarty/Parser/Smarty.hs @@ -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"]})] diff --git a/src/Text/HSmarty/Parser/Util.hs b/src/Text/HSmarty/Parser/Util.hs new file mode 100644 --- /dev/null +++ b/src/Text/HSmarty/Parser/Util.hs @@ -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 ',') diff --git a/src/Text/HSmarty/Render/Engine.hs b/src/Text/HSmarty/Render/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Text/HSmarty/Render/Engine.hs @@ -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" "
" 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' diff --git a/src/Text/HSmarty/Types.hs b/src/Text/HSmarty/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/HSmarty/Types.hs @@ -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) diff --git a/test.tpl b/test.tpl --- a/test.tpl +++ b/test.tpl @@ -1,3 +1,4 @@ +{* test *} {$title}