{-|
Module      : Text.TemplateToolkit
Description : Template Toolkit implementation for Haskell
Copyright   : (c) Dzianis Kabanau, 2018
Maintainer  : kobargh@gmail.com

This is a Haskell implementation of <http://www.template-toolkit.org Template Toolkit> - 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 [("&","&amp;"),("<","&lt;"),(">","&gt;"),("\"","&quot;")]
    _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
@
\<html>
  \<body>
    \<h1>Template Toolkit for Haskell\</h1>
    \<h2>Count 1-10:\</h2>
    [% FOREACH i = [1..10] -%]
      [% i; (!loop.last) ? \', \' : \'.\' %]
    [%- END %]
    \<h2>Users hash:\</h2>
    [% FOREACH user = users.pairs %]
      \<p>[% user.key %]: [% user.value %]
    [% END %]
    \<h2>External template:\</h2>
    [% PROCESS template2.tt words = [\'dog\',\'cat\',\'pig\'] %]
  \</body>
\</html>
@

=== template2.tt
@
\<p>[% words.sort.reverse.join(\'|\') %]
@
-}