diff --git a/HSmarty.cabal b/HSmarty.cabal --- a/HSmarty.cabal +++ b/HSmarty.cabal @@ -1,49 +1,53 @@ name: HSmarty -version: 0.2.0.2 -synopsis: Haskell implementation of a subset of the PHP-Smarty template language +version: 0.2.0.3 +synopsis: Small template engine +description: Haskell implementation of a subset of the PHP-Smarty template language 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 - 2014 by Alexander Thiemann +author: Alexander Thiemann +maintainer: Alexander Thiemann +copyright: (c) 2013 - 2015 by Alexander Thiemann category: Text build-type: Simple cabal-version: >=1.8 -extra-source-files: test.tpl +data-dir: data +data-files: test.tpl Library hs-source-dirs: src - exposed-modules: Text.HSmarty - other-modules: Text.HSmarty.Parser.Smarty, Text.HSmarty.Parser.Util, - Text.HSmarty.Render.Engine, Text.HSmarty.Types - build-depends: base >= 4 && < 5, - vector ==0.10.*, - text, - unordered-containers ==0.2.*, - aeson ==0.6.*, - attoparsec ==0.11.*, - attoparsec-expr ==0.1.1, - mtl ==2.1.*, + exposed-modules: Text.HSmarty, + Text.HSmarty.Parser.Smarty, + Text.HSmarty.Parser.Util, + Text.HSmarty.Types + other-modules: Text.HSmarty.Render.Engine + Ghc-Options: -Wall + build-depends: HTTP, - HTF >=0.12.2.2 && <0.13 + aeson >=0.8, + attoparsec >=0.11, + attoparsec-expr >=0.1.1, + base >= 4 && < 5, + mtl >=2.2, + scientific >=0.3, + text >=1.2, + unordered-containers >=0.2, + vector >=0.10 Test-Suite TestHSmarty - hs-source-dirs: src + hs-source-dirs: test + other-modules: Text.HSmarty.Parser.SmartyTest Type: exitcode-stdio-1.0 Main-Is: Tests.hs Ghc-Options: -Wall - build-depends: base >= 4 && < 5, - vector ==0.10.*, - text, - unordered-containers ==0.2.*, - aeson ==0.6.*, - attoparsec ==0.11.*, - attoparsec-expr ==0.1.1, - mtl ==2.1.*, - HTTP, - HTF >=0.12.2.2 && <0.13 + build-depends: + HSmarty, + HTF, + aeson >=0.8, + attoparsec >=0.11, + base >= 4 && < 5, + text >=1.2 source-repository head type: git diff --git a/data/test.tpl b/data/test.tpl new file mode 100644 --- /dev/null +++ b/data/test.tpl @@ -0,0 +1,12 @@ +{* test *} + + + {$title} + + +{foreach $list as $item} +
  • {$item}
    • +
  • {$item@last}
    • +{/foreach} + + diff --git a/src/Tests.hs b/src/Tests.hs deleted file mode 100644 --- a/src/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/src/Text/HSmarty/Parser/Smarty.hs b/src/Text/HSmarty/Parser/Smarty.hs --- a/src/Text/HSmarty/Parser/Smarty.hs +++ b/src/Text/HSmarty/Parser/Smarty.hs @@ -1,21 +1,14 @@ -{-# 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 +module Text.HSmarty.Parser.Smarty 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 @@ -59,7 +52,7 @@ pLit = A.String <$> stringP <|> A.Bool <$> boolP <|> - A.Number <$> number + A.Number <$> scientific pVar :: Parser Variable pVar = @@ -161,40 +154,3 @@ 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/Render/Engine.hs b/src/Text/HSmarty/Render/Engine.hs --- a/src/Text/HSmarty/Render/Engine.hs +++ b/src/Text/HSmarty/Render/Engine.hs @@ -1,17 +1,21 @@ -{-# OPTIONS_GHC -fwarn-unused-imports -fwarn-incomplete-patterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DoAndIfThenElse #-} module Text.HSmarty.Render.Engine - ( renderTemplate, mkParam, TemplateParam, ParamMap ) + ( TemplateParam, ParamMap + , mkParam + , SmartyCtx, SmartyError(..) + , prepareTemplate, applyTemplate + , renderTemplate + ) where import Text.HSmarty.Types import Text.HSmarty.Parser.Smarty +import Data.Scientific import Control.Applicative -import Control.Monad.Error -import Data.Attoparsec.Text (Number(..)) +import Control.Monad.Except import Data.Char (ord) import Data.Maybe import Data.Vector ((!?)) @@ -40,26 +44,42 @@ type ParamMap = HM.HashMap T.Text TemplateParam type PropMap = HM.HashMap T.Text A.Value -type EvalM a = ErrorT T.Text IO a +type EvalM a = ExceptT SmartyError IO a -instance Error T.Text where - strMsg = T.pack +newtype SmartyCtx + = SmartyCtx { _unSmartyCtx :: Smarty } + deriving (Show, Eq) +newtype SmartyError + = SmartyError { unSmartyError :: T.Text } + deriving (Show, Eq) + -- | 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) + HM.map (\init' -> TemplateVar (unTemplateParam init') HM.empty) +-- | Parse and compile a template +prepareTemplate :: FilePath -> IO SmartyCtx +prepareTemplate fp = + do ct <- T.readFile fp + SmartyCtx <$> parseSmarty fp ct + +-- | Fill a template with values and print it as Text +applyTemplate :: SmartyCtx -> ParamMap -> IO (Either SmartyError T.Text) +applyTemplate (SmartyCtx ctx) mp = + runExceptT $ evalTpl (mkEnv mp) ctx + -- | 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) +-- Results in either an error-message or the rendered template. +-- DO NOT USE IN Production. Use `prepareTemplate` and `applyTemplate` instead. +renderTemplate :: FilePath -> ParamMap -> IO (Either SmartyError T.Text) renderTemplate fp mp = - do ct <- T.readFile fp - tpl <- parseSmarty fp ct - runErrorT $ evalTpl (mkEnv mp) tpl + do ctx <- prepareTemplate fp + applyTemplate ctx mp applyPrintDirective :: T.Text -> PrintDirective -> EvalM T.Text applyPrintDirective t "urlencode" = @@ -79,13 +99,14 @@ ] else x : htmlEscape xs applyPrintDirective _ pd = - throwError $ T.concat [ "Unknown print directive `" - , pd - , "`" - ] + throwError $ SmartyError $ + T.concat [ "Unknown print directive `" + , pd + , "`" + ] evalTpl :: Env -> Smarty -> EvalM T.Text -evalTpl env (Smarty filename tpl) = +evalTpl env (Smarty _ tpl) = evalBody env tpl evalStmt :: Env -> SmartyStmt -> EvalM T.Text @@ -155,9 +176,9 @@ 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 + return $ ( V.toList $ V.imap (\idx el -> + ( A.Number (fromIntegral idx) + , el , mkForeachMap idx fSize ) ) vec @@ -167,9 +188,9 @@ fSize = V.length vec mkForeachInput (A.Object hm) = let (_, input) = - HM.foldlWithKey' (\(idx, out) key elem -> + HM.foldlWithKey' (\(idx, out) key el -> let newElem = ( A.String key - , elem + , el , mkForeachMap idx hSize ) in (idx+1, newElem : out) @@ -178,15 +199,15 @@ where hSize = HM.size hm mkForeachInput _ = - throwError "Tried to iterate over non traversable type." + throwError $ SmartyError "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)) + HM.fromList [ ("index", A.Number idx) + , ("iteration", A.Number $ 1 + idx) , ("first", A.Bool $ idx == 0) , ("last", A.Bool $ (idx+1) == size) - , ("total", A.Number (I size)) + , ("total", A.Number size) ] where size = fromIntegral size' @@ -194,22 +215,28 @@ str :: T.Text -> A.Value -> EvalM T.Text str _ (A.String x) = return x -str desc _ = throwError $ T.concat [ "`", desc, "` is not a string!" ] +str desc _ = throwError $ SmartyError $ 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!" ] +int desc (A.Number x) = + case floatingOrInteger x of + Left _ -> throwError $ SmartyError $ T.concat [ "`", desc, "` is not an integer!" ] + Right x' -> return x' +int desc _ = throwError $ SmartyError $ 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!" ] +dbl desc (A.Number x) = + case floatingOrInteger x of + Left x' -> return x' + Right _ -> throwError $ SmartyError $ T.concat [ "`", desc, "` is not a double!" ] +dbl desc _ = throwError $ SmartyError $ 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] + throwError $ SmartyError $ 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 = @@ -222,7 +249,7 @@ return (k, val) ) args filename <- lookupStr "include" "file" evaledArgs - let otherArgs = filter (\arg@(k, _) -> + let otherArgs = filter (\(k, _) -> not $ k `elem` [ "include" ] ) evaledArgs asTplParams = HM.fromList $ map (\(k, v) -> (k, TemplateParam v)) otherArgs @@ -231,11 +258,12 @@ 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 - ] + throwError $ SmartyError $ T.concat ["Include failed. Error: ", unSmartyError e] +evalFunCall _ fname _ = + throwError $ SmartyError $ + T.concat [ "Call to undefined function " + , fname + ] evalExpr :: Env -> Expr -> EvalM A.Value @@ -251,12 +279,15 @@ (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 - , "`" - ] + Nothing -> + throwError $ + SmartyError $ + 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 @@ -275,51 +306,59 @@ Nothing -> - throwError $ T.concat [ "Variable `" - , varName - , "` is not defined" - ] + throwError $ + SmartyError $ + 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 +walkIndex vname (A.Number idx) (A.Array arr) = + case arr !? (fromJust $ toBoundedInteger idx) of Just val -> return val Nothing -> - throwError $ T.concat [ "Out of bounds. `" - , vname - , "[" - , T.pack $ show idx - , "]` not defined." - ] + throwError $ + SmartyError $ + 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!" - ] + throwError $ + SmartyError $ + 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 _ [] 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 - , "`" - ] + throwError $ SmartyError $ + T.concat [ "Variable `" + , vname + , "` doesn't have the key `" + , path + , "`" + ] +walkPath vname (path:_) _ = + throwError $ SmartyError $ + T.concat [ "Variable `" + , vname + , "` is not a map! Can't lookup `" + , path + , "`" + ] evalBinOp :: Env -> BinOp -> EvalM A.Value evalBinOp env (BinEq a b) = @@ -330,7 +369,7 @@ A.Bool a -> return (A.Bool $ not a) _ -> - throwError "Tried to evaluate a NOT on a non boolean value" + throwError $ SmartyError "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) = @@ -359,27 +398,27 @@ 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" ] + bOp _ _ = throwError $ SmartyError $ T.concat [ "Tried ", d, "Op and on two non boolean values" ] -numOp :: T.Text -> (Number -> Number -> Bool) -> (Expr, Expr) -> Env -> EvalM A.Value +numOp :: T.Text -> (Scientific -> Scientific -> Bool) -> (Expr, Expr) -> Env -> EvalM A.Value numOp = numGenOp boolResOp -calcOp :: T.Text -> (Number -> Number -> Number) -> (Expr, Expr) -> Env -> EvalM A.Value +calcOp :: T.Text -> (Scientific -> Scientific -> Scientific) -> (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 + -> T.Text -> (Scientific -> Scientific -> 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" ] + nOp _ _ = throwError $ SmartyError $ T.concat [ "Tried ", d, "Op and on two non numeric values" ] -numResOp :: (A.Value -> A.Value -> EvalM Number) +numResOp :: (A.Value -> A.Value -> EvalM Scientific) -> (Expr, Expr) -> Env -> EvalM A.Value numResOp fun (a, b) env = do a' <- evalExpr env a diff --git a/test.tpl b/test.tpl deleted file mode 100644 --- a/test.tpl +++ /dev/null @@ -1,12 +0,0 @@ -{* test *} - - - {$title} - - -{foreach $list as $item} -
  • {$item}
    • -
  • {$item@last}
    • -{/foreach} - - diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Main where + +import Test.Framework +import {-@ HTF_TESTS @-} Text.HSmarty.Parser.SmartyTest + +main :: IO () +main = htfMain htf_importedTests diff --git a/test/Text/HSmarty/Parser/SmartyTest.hs b/test/Text/HSmarty/Parser/SmartyTest.hs new file mode 100644 --- /dev/null +++ b/test/Text/HSmarty/Parser/SmartyTest.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +module Text.HSmarty.Parser.SmartyTest where + +import Data.Attoparsec.Text +import Paths_HSmarty +import Test.Framework +import Text.HSmarty.Parser.Smarty +import Text.HSmarty.Types +import qualified Data.Aeson as A +import qualified Data.Text as T +import qualified Data.Text.IO as T + +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 + +readDataFile :: String -> IO T.Text +readDataFile name = + do fp <- getDataFileName name + T.readFile fp + +test_complex :: IO () +test_complex = + do testData <- readDataFile "test.tpl" + case parseOnly pRoot testData of + Left errMsg -> + fail errMsg + Right _ -> + return () + + +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"]})]