{-| Module : Text.TemplateToolkit Description : Template Toolkit implementation for Haskell Copyright : (c) Dzianis Kabanau, 2018 Maintainer : kobargh@gmail.com This is a Haskell implementation of - the popular Perl template processing system. -} module Text.TemplateToolkit ( -- * Documentation TName ,TErr ,TConfig(..) ,evalTemplateFile -- $conf -- * Example -- $example ) where import Text.TemplateToolkitAST import Data.List import Data.Foldable (toList) import Control.Applicative ((<*)) import Control.Monad.Reader import Control.Monad.Except import System.Directory import qualified Data.HashTable.IO as HTIO import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.HashMap.Lazy as HashMap (toList) import Data.Char (toUpper,toLower,isDigit) import qualified Data.Text as T import qualified Data.Text.IO as TIO (readFile) import qualified Data.Text.Encoding as TE (decodeUtf8) import qualified Data.Text.Lazy as TL (fromStrict) import qualified Data.Text.Lazy.Encoding as TLE (encodeUtf8) import qualified Data.ByteString.Char8 as BS import Data.Scientific (floatingOrInteger) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime(..),secondsToDiffTime) import qualified Data.Aeson as Aeson import qualified Data.Binary as Bin import Text.Regex.PCRE import qualified Text.Regex.PCRE.ByteString.Utils as PCRE import qualified Network.URI.Encode as URI (encodeText) import Debug.Trace type EnvHash = HTIO.BasicHashTable String Val type Env = (EnvHash, EnvHash) type TErr = String type EvalWithExcept = ExceptT TErr (ReaderT Env IO) instance Eq Val where (==) (VFloat x) (VFloat y) = x == y (==) (VFloat x) (VInt y) = x == (fromInteger y) (==) (VInt x) (VFloat y) = (fromInteger x) == y (==) (VInt x) (VInt y) = x == y (==) x@(VFloat _) y = x == (toNum y) (==) x y@(VFloat _) = (toNum x) == y (==) x@(VInt _) y = x == (toNum y) (==) x y@(VInt _) = (toNum x) == y (==) (VString a) (VString b) = a == b instance Ord Val where compare (VFloat x) (VFloat y) = compare x y compare (VFloat x) (VInt y) = compare x (fromInteger y) compare (VInt x) (VFloat y) = compare (fromInteger x) y compare (VInt x) (VInt y) = compare x y compare (VString x) (VString y) = compare x y compare x@(VString _) y@(VFloat _) = compare (toNum x) y compare x@(VString _) y@(VInt _) = compare (toNum x) y compare x@(VFloat _) y@(VString _) = compare x (toNum y) compare x@(VInt _) y@(VString _) = compare x (toNum y) instance Num Val where (+) (VInt x) (VInt y) = VInt (x + y) (+) (VInt x) (VFloat y) = VFloat (fromInteger x + y) (+) (VFloat x) (VFloat y) = VFloat (x + y) (+) (VFloat x) (VInt y) = VFloat (x + fromInteger y) (+) x y = (toNum x) + (toNum y) (*) (VInt x) (VInt y) = VInt (x * y) (*) (VInt x) (VFloat y) = VFloat (fromInteger x * y) (*) (VFloat x) (VFloat y) = VFloat (x * y) (*) (VFloat x) (VInt y) = VFloat (x * fromInteger y) (*) x y = (toNum x) * (toNum y) abs (VInt x) = VInt (abs x) abs (VFloat x) = VFloat (abs x) abs x = abs (toNum x) signum (VInt x) = VInt (signum x) signum (VFloat x) = VFloat (signum x) signum x = signum (toNum x) fromInteger = VInt negate (VInt x) = VInt (negate x) negate (VFloat x) = VFloat (negate x) negate x = negate (toNum x) instance Fractional Val where fromRational = VFloat . fromRational (/) (VFloat x) (VFloat y) = VFloat (x / y) (/) (VFloat x) (VInt y) = VFloat (x / fromInteger y) (/) (VInt x) (VFloat y) = VFloat (fromInteger x / y) (/) (VInt x) (VInt y) = VFloat (fromInteger x / fromInteger y) (/) x y = (toNum x) / (toNum y) fromAeson :: Aeson.Value -> Expr fromAeson Aeson.Null = EVal Undef fromAeson (Aeson.Bool True) = EVal $ VInt 1 fromAeson (Aeson.Bool False) = EVal $ VInt 0 fromAeson (Aeson.Number x) = case floatingOrInteger x of (Left f) -> EVal . VFloat . realToFrac $ f (Right i) -> EVal . VInt . fromInteger $ i fromAeson (Aeson.String s) = EVal $ VString s fromAeson (Aeson.Array a) = EVal . VArray . (map fromAeson) . toList $ a fromAeson (Aeson.Object o) = EVal . VHash . (map (\(k,v) -> (T.unpack k,fromAeson v))) . HashMap.toList $ o refTableInsert :: Val -> EvalWithExcept String refTableInsert v = do (_,reft) <- lift ask size <- liftIO $ fmap length (HTIO.toList reft) let refId = reftype ++ "ref#" ++ show (size + 1) where reftype = case v of VHashV _ -> "hash" VArrayV _ -> "array" _ -> "" liftIO $ HTIO.insert reft refId v return refId refTableReplace :: String -> Val -> EvalWithExcept () refTableReplace r v = do (_,reft) <- lift ask liftIO $ HTIO.insert reft r v getFromHTIO :: String -> EnvHash -> EvalWithExcept Val getFromHTIO k h = liftIO $ do v <- HTIO.lookup h k case v of Nothing -> return Undef Just v' -> return v' getFromVars :: String -> EvalWithExcept Val getFromVars k = do (vars,_) <- lift ask getFromHTIO k vars getFromRefTable :: String -> EvalWithExcept Val getFromRefTable r = do (_,reft) <- lift ask getFromHTIO r reft getFromRefTableDef :: Val -> String -> EvalWithExcept Val getFromRefTableDef def r = do v <- getFromRefTable r case v of Undef -> return def _ -> return v getVal :: (String,Val) -> VarNode -> EvalWithExcept (String,Val) getVal (_,VRef r') k = do v <- getFromRefTable r' getVal (r',v) k getVal (r,VHashV h) (VarKey k) = do case Map.lookup k h of Nothing -> case lookup k vmethods of Nothing -> return (r,Undef) Just m -> m (VHashV h) [] r Just v -> return (r,v) getVal (r,VArrayV a) (VarIndex i) = return $ if Seq.length a <= (fromIntegral i) then (r,Undef) else (r,Seq.index a i) getVal (r,v) (VarMethod met pars) = case lookup met vmethods of -- Nothing -> return (r,VString . T.pack $ "Invalid method '" ++ met ++ "'") Nothing -> throwError ("Invalid method '" ++ met ++ "'") Just m -> m v pars r getVal (r,v) (VarKey k) = do case lookup k vmethods of Nothing -> return (r,Undef) Just m -> m v [] r getVal (r,_) _ = return (r,Undef) getVar :: Var -> EvalWithExcept (String,Val) getVar (Var ((VarKey k0):vs)) = do val <- getFromVars k0 getVar' ("",val) vs where getVar' (r,val) (v':vs') = do k' <- getNode v' (r',v') <- getVal (r,val) k' getVar' (r',v') vs' getVar' (r,val) [] = return (r,val) getNode (VarRef r) = do val <- getVar r case val of (_,VInt i) -> return $ VarIndex (fromIntegral i) (_,v) -> return $ VarKey (toString v) getNode n = return n getVarVal :: Var -> EvalWithExcept Val getVarVal var = do (_,val) <- getVar var case val of (VRef r) -> getFromRefTable r _ -> return val toNum :: Val -> Val toNum (VString s) = case reads (T.unpack s) :: [(Integer,String)] of [] -> case reads (T.unpack s) :: [(Double,String)] of [] -> VInt 0 (s',_):_ -> VFloat s' (s',_):_ -> VInt s' toNum v@(VInt _) = v toNum v@(VFloat _) = v toNum _ = VInt 0 toInt :: Val -> Int toInt (VFloat v) = fromIntegral . truncate $ v toInt (VInt v) = fromIntegral v toInt v = toInt . toNum $ v toString :: Val -> String toString (VString v) = T.unpack v toString (VInt v) = show v toString (VFloat v) = show v toString (VRef v) = v toString _ = "" toText :: Val -> T.Text toText (VString v) = v toText v = T.pack . toString $ v not' :: Val -> Val not' (VString s) = if (T.unpack s) == "" then VInt 1 else VInt 0 not' (VInt 0) = VInt 1 not' (VFloat 0.0) = VInt 1 not' (Undef) = VInt 1 not' _ = VInt 0 evalUnOp :: UnOp -> Expr -> EvalWithExcept Val evalUnOp Pos e = liftM toNum (evalExpr e) evalUnOp Neg e = liftM (negate . toNum) (evalExpr e) evalUnOp Not e = liftM not' (evalExpr e) isValTrue :: Val -> Bool isValTrue v = not' v == VInt 0 evalBinOp' :: (Val -> Val -> Val) -> Expr -> Expr -> EvalWithExcept Val evalBinOp' f e1 e2 = liftM2 f (evalExpr e1) (evalExpr e2) evalBinBoolOp' :: (Val -> Val -> Bool) -> Expr -> Expr -> EvalWithExcept Val evalBinBoolOp' f e1 e2 = do x' <- evalExpr e1 y' <- evalExpr e2 case f x' y' of True -> return $ VInt 1 False -> return $ VInt 0 evalBinOp :: BinOp -> Expr -> Expr -> EvalWithExcept Val evalBinOp Add = evalBinOp' (+) evalBinOp Sub = evalBinOp' (-) evalBinOp Mul = evalBinOp' (*) evalBinOp Div = div' where div' x y = do x' <- evalExpr x y' <- evalExpr y if (toInt y') == 0 then throwError "Division by zero" else return (x' / y') evalBinOp Mod = mod' where mod' x y = do x' <- evalExpr x y' <- evalExpr y mod'' x' y' mod'' :: Val -> Val -> EvalWithExcept Val mod'' (VInt x) (VInt y) = if y /= 0 then (return $ VInt (x `mod` y)) else throwError "Division by zero" mod'' _ _ = throwError "Not integer in 'mod' operation" evalBinOp Con = con' where con' x y = do x' <- evalExpr x y' <- evalExpr y return $ VString (toText x' `T.append` toText y') evalBinOp Gt = evalBinBoolOp' (>) evalBinOp Ge = evalBinBoolOp' (>=) evalBinOp Lt = evalBinBoolOp' (<) evalBinOp Le = evalBinBoolOp' (<=) evalBinOp Eq = evalBinBoolOp' (==) evalBinOp Ne = evalBinBoolOp' (/=) evalBinOp And = and' where and' e1 e2 = do v1' <- evalExpr e1 if isValTrue v1' then do v2' <- evalExpr e2 if isValTrue v2' then return v2' else return $ VInt 0 else return $ VInt 0 evalBinOp Or = or' where or' e1 e2 = do v1' <- evalExpr e1 if isValTrue v1' then return v1' else do v2' <- evalExpr e2 if isValTrue v2' then return v2' else return $ VInt 0 evalExpr :: Expr -> EvalWithExcept Val evalExpr (EVal (VArray xs)) = do xs' <- mapM evalExprWithRef xs return $ VArrayV $ Seq.fromList xs' evalExpr (EVal (VArrayRange e1 e2)) = do from' <- evalExpr e1 to' <- evalExpr e2 return $ VArrayV . Seq.fromList . (map (VInt . fromIntegral)) $ [(toInt from')..(toInt to')] evalExpr (EVal a@(VArrayV _)) = do return a evalExpr (EVal (VHash xs)) = do let (ks',es') = unzip xs vs' <- mapM evalExprWithRef es' return $ VHashV (Map.fromList (zip ks' vs')) evalExpr (EVal (VIString vs)) = do let getVIString (IString s) = return s getVIString (IVar v) = liftM (toText . snd) (getVar v) vs' <- mapM getVIString vs return $ VString (T.concat vs') evalExpr (EVal v) = return v evalExpr (EVar var) = do (_,val) <- getVar var return val evalExpr (EUnOp op e) = evalUnOp op e evalExpr (EBinOp op e1 e2) = evalBinOp op e1 e2 evalExpr (ETerOp e1 e2 e3) = do v1' <- evalExpr e1 if isValTrue v1' then evalExpr e2 else evalExpr e3 evalExprWithRef :: Expr -> EvalWithExcept Val evalExprWithRef e = do v <- evalExpr e case v of a@(VArrayV _) -> do id <- refTableInsert a return $ VRef id h@(VHashV _) -> do id <- refTableInsert h return $ VRef id x -> return x -- ----- statement evaluators -- fst3 :: (a,b,c) -> a fst3 (x,_,_) = x snd3 :: (a,b,c) -> b snd3 (_,x,_) = x trd3 :: (a,b,c) -> c trd3 (_,_,x) = x evalOrSkipStmt :: Stmt -> EvalWithExcept T.Text evalOrSkipStmt stmt = do (VHashV loops) <- getFromRefTableDef (VHashV Map.empty) "#loopcontrols" let (VInt breakCode) = Map.findWithDefault (VInt 0) (show . fst3 . sId $ stmt) loops if breakCode == 0 then evalStmt stmt else return T.empty evalStmt :: Stmt -> EvalWithExcept T.Text evalStmt (Seq ss stmtId _) = do ss' <- mapM evalOrSkipStmt ss return $ T.concat ss' evalStmt (SComment _ _) = return T.empty evalStmt (SText s stmtId _) = return s evalStmt (SExpr e stmtId _) = do val <- evalExpr e return $ toText val evalStmt assign@(SAssign (Var varPath@((VarKey k0):vs)) e stmtId lineN) = do val <- evalExprWithRef e if null vs then do (vars,_) <- lift ask liftIO $ HTIO.insert vars k0 val return T.empty else do var <- getVar (Var $ init varPath) updateRefTable var (last varPath) val where updateRefTable :: (String,Val) -> VarNode -> Val -> EvalWithExcept T.Text updateRefTable (r,VHashV h) (VarKey k) val = do refTableReplace r (VHashV $ Map.insert k val h) return T.empty updateRefTable (r,VHashV h) (VarMethod "item" (e':_)) val = do k' <- evalExpr e' refTableReplace r (VHashV $ Map.insert (toString k') val h) return T.empty updateRefTable (r,VArrayV a) (VarIndex i) val = do refTableReplace r (VArrayV $ updateArr' i val a) return T.empty where updateArr' i val a = if (Seq.length a > i) then (Seq.update i val a) else (a Seq.>< (Seq.replicate (i - Seq.length a) (Undef))) Seq.|> val updateRefTable (_,VRef r) vark val = do v <- getFromRefTable r updateRefTable (r,v) vark val return T.empty -- auto-vivification updateRefTable _ k@(VarKey _) _ = do evalStmt $ SAssign (Var $ init varPath) (EVal (VHashV Map.empty)) stmtId lineN evalStmt assign updateRefTable _ k@(VarMethod "item" _) _ = do evalStmt $ SAssign (Var $ init varPath) (EVal (VHashV Map.empty)) stmtId lineN evalStmt assign updateRefTable _ k@(VarIndex _) _ = do evalStmt $ SAssign (Var $ init varPath) (EVal (VArrayV Seq.empty)) stmtId lineN evalStmt assign -- otherwise updateRefTable v k val = throwError (show lineN ++ ": Variable assign error:\nvariable path: " ++ (show varPath) ++ "\nvalue: " ++ (show val) ++ "\n") evalStmt (SIf cond body maybeElse stmtId _) = do v' <- evalExpr cond if isValTrue v' then evalOrSkipStmt body else evalElse' maybeElse where evalElse' Nothing = return T.empty evalElse' (Just (Elsif cond' body' maybeElse')) = do v'' <- evalExpr cond' if isValTrue v'' then evalOrSkipStmt body' else evalElse' maybeElse' evalElse' (Just (Else body'')) = evalOrSkipStmt body'' evalStmt whileStmt@(SWhile cond body stmtId _) = do isSkip <- loopStart (snd3 . sId $ whileStmt) val <- evalExpr cond if isValTrue val && (not isSkip) then do v' <- evalOrSkipStmt body v'' <- evalOrSkipStmt whileStmt return $ T.append v' v'' else return T.empty evalStmt foreachStmt@(SForeach var expr body stmtId lineN) = do isSkip <- loopStart (snd3 . sId $ foreachStmt) val <- evalExpr expr foreach' val isSkip <* loopEnd (sId foreachStmt) where foreach' :: Val -> Bool -> EvalWithExcept T.Text foreach' (VRef r') False = do v <- getFromRefTable r' foreach' v False foreach' (VArrayV a') False = case toList a' of [] -> return T.empty (x:xs) -> do evalIterator (snd3 stmtId) a' (+1) evalStmt (SAssign var (EVal x) stmtId lineN) v' <- evalStmt body isSkip' <- loopStart (snd3 . sId $ foreachStmt) v'' <- foreach' (VArrayV $ Seq.fromList xs) isSkip' return $ T.append v' v'' foreach' x False = foreach' (VArrayV $ Seq.singleton x) False foreach' _ True = return T.empty evalStmt (SBlock name body stmtId _) = do (VHashV coderefs) <- getFromRefTableDef (VHashV Map.empty) "#coderefs" let coderefs' = Map.insert name (VCode body) coderefs refTableReplace "#coderefs" (VHashV coderefs') return T.empty evalStmt (SProcess name assigns stmtId _) = do mapM evalOrSkipStmt assigns (VString name') <- evalExpr (EVal (VIString [name])) evalNamedBlock (T.unpack name',stmtId) evalStmt (SWrapper name assigns body stmtId lineN) = do (VString name') <- evalExpr (EVal (VIString [name])) mapM evalOrSkipStmt assigns >> return T.empty content <- evalOrSkipStmt body evalStmt $ SAssign (Var [VarKey "content"]) (EVal (VString content)) (0,0,0) lineN evalNamedBlock (T.unpack name',stmtId) evalStmt (SFilter name exprs body stmtId _) = do v <- evalStmt body case lookup name filters of Nothing -> throwError ("Invalid filter '" ++ name ++ "'") Just f -> f exprs v evalStmt (SLast (parent,_,_) _) = do evalLastNext parent (-1) evalStmt (SNext (parent,_,_) _) = do evalLastNext parent 1 evalNamedBlock :: (String,StmtId) -> EvalWithExcept T.Text evalNamedBlock (name,stmtId) = do (VHashV coderefs) <- getFromRefTableDef (VHashV Map.empty) "#coderefs" case Map.lookup name coderefs of (Just (VCode body)) -> evalOrSkipStmt body Nothing -> do (tStmtOrText, filename) <- readTemplateFile name let stmtId' = (fst3 stmtId, (trd3 stmtId) + 1, (trd3 stmtId) + 1) case tStmtOrText of Left cache -> evalOrSkipStmt cache Right ttext -> case parseTemplateWithStmtId ttext name stmtId' of Left err -> throwError (name ++ ": " ++ (show err)) Right stmt -> do evalStmt (SBlock filename stmt stmtId' 0) catchError evalAndCache (\e -> throwError (name ++ ": " ++ e)) where evalAndCache = do t <- evalOrSkipStmt stmt cacheDir <- getVarVal (Var [VarKey "_CONFIG", VarKey "CACHE_DIR"]) >>= \d -> return $ toString d liftIO $ if cacheDir /= "" then writeCache (cacheDir,name,stmt) else return () return t writeCache (cacheDir,name,stmt) = do createDirectoryIfMissing True cacheDir Bin.encodeFile (cacheDir ++ "/" ++ name) stmt readTemplateFile :: String -> EvalWithExcept (Either Stmt T.Text, String) readTemplateFile name = do t <- getVarVal (Var [VarKey "_CONFIG", VarKey "TEMPLATES", VarKey name]) case t of Undef -> throwError ("\"" ++ name ++ "\" not found") tfn -> do cacheDir <- getVarVal (Var [VarKey "_CONFIG", VarKey "CACHE_DIR"]) >>= \d -> return $ toString d let filename = toString tfn liftIO $ if cacheDir /= "" then do let filenameCache = cacheDir ++ "/" ++ name fTime <- getModificationTime filename cfTime <- doesFileExist filenameCache >>= \ok -> if ok then getModificationTime filenameCache else return $ UTCTime (fromGregorian 1900 01 01) (secondsToDiffTime 0) if fTime > cfTime then TIO.readFile filename >>= \ttext -> return (Right ttext, filename) else ((Bin.decodeFile filenameCache) :: IO Stmt) >>= \cache -> return (Left cache, filename) else TIO.readFile filename >>= \ttext -> return (Right ttext, filename) evalLastNext :: Int -> Int -> EvalWithExcept T.Text evalLastNext parent breakCode = do (VHashV loops) <- getFromRefTableDef (VHashV Map.empty) "#loopcontrols" let loops' = Map.insert (show parent) (VInt $ fromIntegral breakCode) loops refTableReplace "#loopcontrols" (VHashV loops') return T.empty loopStart :: Int -> EvalWithExcept Bool loopStart loopId = do (VHashV loops) <- getFromRefTableDef (VHashV Map.empty) "#loopcontrols" let (VInt breakCode) = Map.findWithDefault (VInt 0) (show loopId) loops loops' = Map.insert (show loopId) (VInt $ if breakCode /= (-1) then 0 else (-1)) loops refTableReplace "#loopcontrols" (VHashV loops') return $ if breakCode == (-1) then True else False loopEnd :: StmtId -> EvalWithExcept () loopEnd loopId = do (vars,reft) <- lift ask liftIO $ HTIO.delete reft ("#foreacharr" ++ (show $ snd3 loopId)) liftIO $ HTIO.delete reft ("#foreach" ++ (show $ snd3 loopId)) (VHashV loops) <- getFromRefTableDef (VHashV Map.empty) "#loopcontrols" let loops' = Map.insert (show $ snd3 loopId) (VInt 0) loops refTableReplace "#loopcontrols" (VHashV loops') (VArrayV outer) <- getFromRefTableDef (VArrayV Seq.empty) ("#foreacharr" ++ (show $ fst3 loopId)) if Seq.null outer then liftIO $ HTIO.delete vars "loop" else evalIterator (fst3 loopId) outer id evalIterator :: Int -> Array -> (Val -> Val) -> EvalWithExcept () evalIterator loopId arr iterFunc = do (vars,_) <- lift ask let l' = fromIntegral $ Seq.length arr start = [("size",VInt l') ,("max",VInt $ l' - 1) ,("index",VInt (-1)) ] (VHashV h') <- getFromRefTableDef (VHashV $ Map.fromList start) ("#foreach" ++ show loopId) (VArrayV a') <- getFromRefTableDef (VArrayV arr) ("#foreacharr" ++ show loopId) let (VInt i) = iterFunc (h' Map.! "index") (VInt iMax) = h' Map.! "max" h = flip Map.union h' (Map.fromList [("index",VInt i) ,("count",VInt i+1) ,("first",if i == 0 then VInt 1 else VInt 0) ,("last",if i == iMax then VInt 1 else VInt 0) ,("prev",if i == 0 then Undef else (a' `Seq.index` (fromIntegral i - 1))) ,("next",if i == iMax then Undef else (a' `Seq.index` (fromIntegral i + 1))) ,("odd",if (i + 1) `mod` 2 == 0 then VInt 0 else VInt 1) ,("even",if (i + 1) `mod` 2 == 0 then VInt 1 else VInt 0) ]) refTableReplace ("#foreach" ++ show loopId) (VHashV h) refTableReplace ("#foreacharr" ++ show loopId) (VArrayV a') liftIO $ HTIO.insert vars "loop" (VHashV h) return () -- ----- /statement evaluators -- -- ----- common functions for vmethods and filters -- _changefirst' s change = case T.unpack s of x:xs -> T.pack $ (change x):xs [] -> T.empty _Lcfirst' s = _changefirst' s toLower _Lower' = T.toLower _Ucfirst' s = _changefirst' s toUpper _Upper' = T.toUpper _Replace' s re su = case PCRE.substituteCompile' (BS.pack re) (BS.pack . T.unpack $ s) (BS.pack su) of Left err -> error err Right bs -> TE.decodeUtf8 $ bs _Trim' s = _Replace' s "(^\\s+|\\s+$)" "" _Collapse' s = _Trim' $ _Replace' s "\\s+" " " -- ----- /common functions for vmethods and filters -- -- ----- vmethods -- vmethods = [("collapse",_collapse) ,("defined",_defined) ,("delete",_delete) ,("each",_values) ,("first",_first) ,("grep",_grep) ,("import",_import) ,("item",_item) ,("join",_join) ,("keys",_keys) ,("last",_last) ,("lcfirst",_lcfirst) ,("length",_length) ,("lower",_lower) ,("match",_match) ,("nsort",_nsort) ,("pairs",_pairs) ,("pop",_pop) ,("push",_push) ,("remove",_remove) ,("replace",_replace) ,("reverse",_reverse) ,("shift",_shift) ,("size",_size) ,("slice",_slice) ,("sort",_sort) ,("splice",_splice) ,("split",_split) ,("trim",_trim) ,("ucfirst",_ucfirst) ,("unique",_unique) ,("unshift",_unshift) ,("upper",_upper) ,("values",_values) ] where getter v _ r = return (r,v) _match' :: Val -> String -> [Val] _match' v re = map (VString . TE.decodeUtf8) matches where bs = (BS.pack . toString $ v) =~ re :: AllTextSubmatches [] BS.ByteString matches = case getAllTextSubmatches bs of [] -> [] (full:[]) -> [full] (_:subs) -> subs _matchGlobal' :: Val -> String -> [Val] _matchGlobal' v re = case _match' (VString $ T.pack re) "\\(.+\\)" of [] -> matches _ -> concat $ map (\m' -> _match' m' re) matches where matches = map (VString . TE.decodeUtf8) $ getAllTextMatches ((BS.pack . toString $ v) =~ re :: AllTextMatches [] BS.ByteString) _size' (VArrayV a) = fromIntegral $ Seq.length a _splice' a offs leng arr = (Seq.take offs'' a) Seq.>< arr Seq.>< (Seq.drop (offs'' + leng'') a) where l = Seq.length a offs' = if offs < 0 then l + offs + 1 else offs offs'' = if offs' < 0 then 0 else offs' leng' = if leng < 0 then (l - offs'' + leng) else leng leng'' = if leng' < 0 then 0 else leng' _collapse s _ r = return (r, VString . _Collapse' . toText $ s) _defined h@(VHashV _) (k:_) r = do k' <- evalExpr k (r',v) <- getVal (r,h) (VarKey . toString $ k') _defined v [] r _defined a@(VArrayV _) (i:_) r = do i' <- evalExpr i (r',v) <- getVal (r,a) (VarIndex . toInt $ i') _defined v [] r _defined Undef _ r = return (r,VInt 0) _defined _ _ r = return (r,VInt 1) _delete _ [] r = return (r,Undef) _delete (VHashV h) (e:es) r = do k <- evalExpr e let vh = VHashV $ Map.delete (toString k) h refTableReplace r vh _delete vh es r _each (VHashV h) _ r = do return (r,arr) where arr = VArrayV . Seq.fromList . concat . map (\(k,v) -> [(VString . T.pack $ k),v]) $ (Map.toList h) _each _ _ r = return (r,Undef) _first a@(VArrayV a') [] r = if (_size' a) > 0 then return (r,a' `Seq.index` 0) else return (r,Undef) _first (VArrayV a) (e:_) r = do i <- evalExpr e return (r, VArrayV $ Seq.take (toInt i) a) _first _ _ r = return (r,Undef) _grep (VArrayV a) (re:_) r = do re' <- liftM toString (evalExpr re) let a' = filter (\v -> not . null $ _match' v re') (toList a) return (r, VArrayV . Seq.fromList $ a') _import (VHashV h) (e:es) r = do v <- evalExpr e case v of (VRef r') -> do v' <- getFromRefTable r' _import (VHashV h) ((EVal v'):es) r (VHashV h') -> do let vh = VHashV $ Map.union h' h refTableReplace r vh _import vh es r _ -> _import (VHashV h) es r _import (VArrayV a) (e:es) r = do v <- evalExpr e case v of (VRef r') -> do v' <- getFromRefTable r' _import (VArrayV a) ((EVal v'):es) r (VArrayV a') -> do let va = VArrayV $ a Seq.>< a' refTableReplace r va _import va es r _ -> _import (VArrayV a) es r _import _ _ r = return (r,Undef) _item h@(VHashV _) (e:_) r = do k <- evalExpr e (_,v) <- getVal (r,h) (VarKey .toString $ k) return (r,v) _item _ _ r = return (r,Undef) _join (VArrayV a) (e:_) r = do delim <- evalExpr e return(r,VString . T.pack . (intercalate $ toString delim) . (map toString) . toList $ a) _join a@(VArrayV _) [] r = _join a [(EVal . VString . T.pack $ ",")] r _join _ _ r = return (r,Undef) _keys (VHashV h) _ r = do return (r,arr) where arr = VArrayV . Seq.fromList . map (VString . T.pack) $ (Map.keys h) _keys _ _ r = return (r,Undef) _last a@(VArrayV a') [] r = if (_size' a) > 0 then return (r,a' `Seq.index` ((_size' a) - 1)) else return (r,Undef) _last (VArrayV a) (e:_) r = do i <- evalExpr e return (r, VArrayV . Seq.reverse $ Seq.take (toInt i) (Seq.reverse a)) _last _ _ r = return (r,Undef) _lcfirst s = getter $ VString (_Lcfirst' . toText $ s) _length s = getter $ VInt (fromIntegral . length . toString $ s) _lower s = getter $ VString (_Lower' . toText $ s) _match v (re:gl:_) r = do re' <- liftM toString (evalExpr re) gl' <- evalExpr gl let matcher = if isValTrue gl' then _matchGlobal' else _match' case matcher v re' of [] -> return (r,Undef) ms -> do return (r,VArrayV . Seq.fromList $ ms) _match v (re:[]) r = _match v [re, EVal . VInt $ 0] r _match _ _ r = return (r,Undef) _nsort (VArrayV a) _ r = do return (r,arr) where arr = VArrayV . Seq.fromList . sort . (map toNum) . toList $ a _nsort _ _ r = return (r,Undef) _pairs (VHashV h) _ r = do return (r,arr) where arr = VArrayV . Seq.fromList . map (\(k,v) -> VHashV . Map.fromList $ [("key",VString . T.pack $ k),("value",v)]) $ Map.toList h _pairs _ _ r = return (r,Undef) _pop (VArrayV a) [] r = do (_,v) <- _last (VArrayV a) [] r let a' = VArrayV $ _splice' a (-2) 1 Seq.empty refTableReplace r a' return (r,v) _pop _ _ r = return (r,Undef) _push (VArrayV a) exs r = do vxs <- mapM evalExpr exs let a' = VArrayV $ _splice' a (-1) 0 (Seq.fromList vxs) refTableReplace r a' return (r,Undef) _push _ _ r = return (r,Undef) _remove v (re:_) r = _replace v [re] r _remove _ _ r = return (r,Undef) _replace v (re:su:_) r = do re' <- liftM toString (evalExpr re) su' <- liftM toString (evalExpr su) let v' = _Replace' (toText v) re' su' return (r,VString v') _replace v (re:_) r = _replace v [re, EVal . VString $ T.empty] r _replace _ _ r = return (r,Undef) _reverse (VArrayV a) [] r = do return (r,VArrayV . Seq.reverse $ a) _reverse _ _ r = return (r,Undef) _shift (VArrayV a) [] r = do (_,v) <- _first (VArrayV a) [] r let a' = VArrayV $ _splice' a 0 1 Seq.empty refTableReplace r a' return (r,v) _shift _ _ r = return (r,Undef) _size (VHashV h) _ r = return (r,VInt . fromIntegral . length . toList $ h) _size a@(VArrayV _) _ r = return (r,VInt (_size' a)) _size _ _ r = return (r,VInt 0) _slice (VArrayV a) (fr:to:_) r = do fr' <- liftM toInt (evalExpr fr) to' <- liftM toInt (evalExpr to) let l = Seq.length a fr'' = if fr' < 0 then l + fr' else fr' to'' = if to' < 0 then l + to' else to' a' = if fr'' < 0 || to'' < 0 || fr'' > to'' || fr'' > l || to'' > l then Seq.empty else (Seq.take (to'' - fr'' + 1)) . (Seq.drop fr'') $ a return (r,VArrayV a') _slice (VArrayV a) (fr:_) r = _slice (VArrayV a) [fr,EVal . VInt $ (-1)] r _slice _ _ r = _slice (VArrayV Seq.empty) (map (EVal . VInt) [0,0]) r _sort (VArrayV a) _ r = do return (r,arr) where arr = VArrayV . Seq.fromList . sort . (map (VString . T.pack . toString)) . toList $ a _sort _ _ r = return (r,Undef) _splice (VArrayV a) (eo:el:exs) r = do offs <- liftM toInt (evalExpr eo) leng <- liftM toInt (evalExpr el) vxs <- mapM evalExpr exs arr <- mapM mkArrEl vxs let arr' = VArrayV $ _splice' a offs leng (Seq.fromList $ concat arr) refTableReplace r arr' return (r,Undef) where mkArrEl :: Val -> EvalWithExcept [Val] mkArrEl (VRef r') = do v <- getFromRefTable r' mkArrEl v mkArrEl (VArrayV a') = return (toList a') mkArrEl v = return [v] _splice a@(VArrayV a') (eo:[]) r = _splice a [eo,(EVal . VInt . fromIntegral . Seq.length $ a')] r _splice a@(VArrayV a') [] r = _splice a [EVal (VInt 0)] r _splice _ _ r = return (r,Undef) _split v (re:_) r = do re' <- liftM toString (evalExpr re) let a = case PCRE.splitCompile' (BS.pack re') (BS.pack . toString $ v) of Left err -> error err Right vs -> VArrayV . Seq.fromList . (map (VString . TE.decodeUtf8)) $ vs return (r,a) _split v _ r = return (r,VArrayV . Seq.singleton . VString . toText $ v) _trim s _ r = return (r, VString . _Trim' . toText $ s) _ucfirst s = getter $ VString (_Ucfirst' . toText $ s) _unique (VArrayV a) _ r = do return (r,arr) where arr = VArrayV . Seq.fromList . (nubBy (\x y -> toString x == toString y)) . toList $ a _unshift (VArrayV a) exs r = do vxs <- mapM evalExpr exs let a' = VArrayV $ _splice' a 0 0 (Seq.fromList vxs) refTableReplace r a' return (r,Undef) _unshift _ _ r = return (r,Undef) _upper s = getter $ VString (_Upper' . toText $ s) _values (VHashV h) _ r = do return (r, VArray . map EVal $ (Map.elems h)) _values _ _ r = return (r,Undef) -- ----- /vmethods -- -- ----- filters -- filters = [("collapse",_collapse) ,("html",_html) ,("lcfirst",_lcfirst) ,("lower",_lower) ,("null",_null) ,("replace",_replace) ,("trim",_trim) ,("ucfirst",_ucfirst) ,("upper",_upper) ,("uri",_uri) ] where _collapse _ v = return $ _Collapse' v _html _ s = return $ foldl' (\s' (re,su) -> _Replace' s' re su) s [("&","&"),("<","<"),(">",">"),("\"",""")] _lcfirst _ v = return $ _Lcfirst' v _lower _ v = return $ _Lower' v _null _ _ = return T.empty _replace [] v = return v _replace (re:[]) v = _replace [re, EVal . VString $ T.empty] v _replace (re:su:_) v = do re' <- liftM toString (evalExpr re) su' <- liftM toString (evalExpr su) let v' = _Replace' v re' su' return v' _trim _ v = return $ _Trim' v _ucfirst _ v = return $ _Ucfirst' v _upper _ v = return $ _Upper' v _uri _ v = return $ URI.encodeText v -- ----- /filters -- data TConfig = AesonObject Aeson.Value | JSONstring T.Text evalTemplateFile :: TName -- ^ Template filename to process -> TConfig -- ^ Template config and initial variables (either aeson object or JSON object string) -> IO (Either TErr T.Text) -- ^ Result of template evaluation - either error or text evalTemplateFile t cfg = do case cfg of (JSONstring json) -> case Aeson.decode (TLE.encodeUtf8 . TL.fromStrict $ json) of (Just aeson) -> evalTemplateFile t (AesonObject aeson) _ -> return $ Left "Invalid JSON string" (AesonObject aeson) -> case fromAeson aeson of (EVal (VHash h)) -> do vars <- HTIO.new reft <- HTIO.new runReaderT (runExceptT (evalTemplateFile' t h)) (vars,reft) _ -> return $ Left "Aeson 'object' expected as a second parameter" evalTemplateFile' :: TName -> [(String,Expr)] -> EvalWithExcept T.Text evalTemplateFile' t cfg = do let assignVar (k,e) = evalStmt (SAssign (Var [VarKey k]) e (0,0,0) 0) mapM_ assignVar cfg vDirs <- getVarVal (Var [VarKey "_CONFIG", VarKey "INCLUDE_PATH"]) let dirs = case vDirs of (VArrayV a) -> toList a s@(VString _) -> [s] _ -> [] getFilesPaths d = do f' <- (listDirectory d) >>= mapM (\f_ -> do {dabs_ <- makeAbsolute (d ++ "/" ++ f_); return (f_,dabs_)}) f'' <- filterM (doesFileExist . snd) f' return f'' files <- mapM (liftIO . getFilesPaths) (map toString dirs) let files' = map (\(k,v) -> (k, VString . T.pack $ v)) (concat files) evalStmt $ SAssign (Var [VarKey "_CONFIG", VarKey "TEMPLATES"]) (EVal (VHashV . Map.fromList $ files')) (0,0,0) 0 evalStmt $ SProcess (IString $ T.pack t) [] (0,0,0) 0 {-$conf All variables in initial 'TConfig' object are passed to the parsed template. Special /__\_CONFIG__/ variable is an object that contains settings passed to the template evaluator: /__INCLUDE_PATH__/ - list of directories where evaluator will look for template files. /__CACHE_DIR__/ - path to cache templates to. -} {-$example Template Toolkit language manual: "Text.TemplateToolkitLang". Below is a simple example of using this module: === template-toolkit-example.hs @ import Text.TemplateToolkit import qualified Data.Text.IO as TIO (readFile) import qualified Data.Text as T main = do cfg <- TIO.readFile "./conf.json" s <- evalTemplateFile "template.tt" (JSONstring cfg) case s of (Right txt) -> putStr . T.unpack $ txt (Left err) -> putStr ("ERROR! " ++ err) @ === conf.json @ { \"_CONFIG\":{ \"INCLUDE_PATH\":[\".\"] }, \"users\":{ \"Foo\": 13, \"Bar\": 3.14, \"Baz\": \"bazzz\" } } @ === template.tt @ \ \ \

Template Toolkit for Haskell\

\

Count 1-10:\

[% FOREACH i = [1..10] -%] [% i; (!loop.last) ? \', \' : \'.\' %] [%- END %] \

Users hash:\

[% FOREACH user = users.pairs %] \

[% user.key %]: [% user.value %] [% END %] \

External template:\

[% PROCESS template2.tt words = [\'dog\',\'cat\',\'pig\'] %] \ \ @ === template2.tt @ \

[% words.sort.reverse.join(\'|\') %] @ -}