{-#LANGUAGE FlexibleContexts #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE TupleSections #-}
{-#LANGUAGE TypeSynonymInstances #-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE ScopedTypeVariables #-}
{-#LANGUAGE LambdaCase #-}
module Text.Ginger.Run
(
easyRenderM
, easyRender
, easyContext
, runGingerT
, runGinger
, makeContext
, makeContextM
, makeContext'
, makeContextM'
, makeContextExM'
, makeContextHtml
, makeContextHtmlM
, makeContextHtmlExM
, makeContextText
, makeContextTextM
, makeContextTextExM
, GingerContext
, Run, liftRun, liftRun2
, extractArgs, extractArgsT, extractArgsL, extractArgsDefL
, hoistContext
, hoistRun
, hoistNewlines
, hoistRunState
, RuntimeError (..)
, runtimeErrorWhat
, runtimeErrorWhere
, runtimeErrorMessage
)
where
import Prelude ( (.), ($), (==), (/=)
, (>), (<), (>=), (<=)
, (+), (-), (*), (/), div, (**), (^)
, (||), (&&)
, (++)
, Show, show
, undefined, otherwise
, Maybe (..)
, Bool (..)
, Int, Integer, String
, fromIntegral, floor, round
, not
, show
, uncurry
, seq
, fst, snd
, maybe
, Either (..)
, id
)
import qualified Prelude
import Data.Maybe (fromMaybe, isJust, isNothing)
import qualified Data.List as List
import Text.Ginger.AST
import Text.Ginger.Html
import Text.Ginger.GVal
import Text.Ginger.Run.Type
import Text.Ginger.Run.Builtins
import Text.Ginger.Run.FuncUtils
import Text.Ginger.Run.VM
import Text.Printf
import Text.PrintfA
import Text.Ginger.Parse (parseGinger, ParserError)
import Control.Monad.Except (runExceptT, throwError, catchError)
import Data.Text (Text)
import Data.String (fromString)
import qualified Data.Text as Text
import qualified Data.ByteString.UTF8 as UTF8
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.State
import Control.Applicative
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap)
import Data.Scientific (Scientific, formatScientific)
import qualified Data.Scientific as Scientific
import Data.Default (def)
import Safe (readMay, lastDef, headMay)
import Network.HTTP.Types (urlEncode)
import Debug.Trace (trace)
import Data.List (lookup, zipWith, unzip)
import Data.Aeson as JSON
defaultScope :: forall m h p
. ( Monoid h
, Monad m
, ToGVal (Run p m h) h
, ToGVal (Run p m h) p
)
=> [(Text, GVal (Run p m h))]
defaultScope =
[ ("raw", fromFunction gfnRawHtml)
, ("abs", fromFunction . unaryNumericFunc 0 $ Prelude.abs)
, ("any", fromFunction gfnAny)
, ("all", fromFunction gfnAll)
, ("apply", fromFunction gfnApply)
, ("capitalize", fromFunction . variadicStringFunc $ mconcat . Prelude.map capitalize)
, ("ceil", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.ceiling)
, ("center", fromFunction gfnCenter)
, ("compose", fromFunction gfnCompose)
, ("concat", fromFunction gfnConcat)
, ("contains", fromFunction gfnContains)
, ("d", fromFunction gfnDefault)
, ("date", fromFunction gfnDateFormat)
, ("dateformat", fromFunction gfnDateFormat)
, ("default", fromFunction gfnDefault)
, ("dictsort", fromFunction gfnDictsort)
, ("difference", fromFunction . variadicNumericFunc 0 $ difference)
, ("divisibleby", fromFunction gfnDivisibleBy)
, ("e", fromFunction gfnEscape)
, ("eq", fromFunction gfnEquals)
, ("equals", fromFunction gfnEquals)
, ("equalto", fromFunction gfnEquals)
, ("escape", fromFunction gfnEscape)
, ("eval", fromFunction gfnEval)
, ("even", fromFunction gfnEven)
, ("filesizeformat", fromFunction gfnFileSizeFormat)
, ("filter", fromFunction gfnFilter)
, ("floor", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.floor)
, ("format", fromFunction gfnPrintf)
, ("ge", fromFunction gfnGreaterEquals)
, ("gt", fromFunction gfnGreater)
, ("greater", fromFunction gfnGreater)
, ("greaterthan", fromFunction gfnGreater)
, ("greaterEquals", fromFunction gfnGreaterEquals)
, ("int", fromFunction . unaryFunc $ toGVal . fmap (Prelude.truncate :: Scientific -> Int) . asNumber)
, ("int_ratio", fromFunction . variadicNumericFunc 1 $ fromIntegral . intRatio . Prelude.map Prelude.floor)
, ("is_lt", fromFunction gfnLess)
, ("iterable", fromFunction . unaryFunc $ toGVal . (\x -> isList x || isDict x))
, ("json", fromFunction gfnJSON)
, ("length", fromFunction gfnLength)
, ("le", fromFunction gfnLessEquals)
, ("less", fromFunction gfnLess)
, ("lessthan", fromFunction gfnLess)
, ("lessEquals", fromFunction gfnLessEquals)
, ("lt", fromFunction gfnLess)
, ("map", fromFunction gfnMap)
, ("modulo", fromFunction . variadicNumericFunc 1 $ fromIntegral . modulo . Prelude.map Prelude.floor)
, ("ne", fromFunction gfnNEquals)
, ("nequals", fromFunction gfnNEquals)
, ("num", fromFunction . unaryFunc $ toGVal . asNumber)
, ("odd", fromFunction gfnOdd)
, ("partial", fromFunction gfnPartial)
, ("printf", fromFunction gfnPrintf)
, ("product", fromFunction . variadicNumericFunc 1 $ Prelude.product)
, ("ratio", fromFunction . variadicNumericFunc 1 $ Scientific.fromFloatDigits . ratio . Prelude.map Scientific.toRealFloat)
, ("replace", fromFunction gfnReplace)
, ("round", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.round)
, ("show", fromFunction . unaryFunc $ fromString . show)
, ("slice", fromFunction gfnSlice)
, ("sort", fromFunction gfnSort)
, ("split", fromFunction gfnSplit)
, ("str", fromFunction . unaryFunc $ toGVal . asText)
, ("sum", fromFunction . variadicNumericFunc 0 $ Prelude.sum)
, ("truncate", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.truncate)
, ("urlencode", fromFunction gfnUrlEncode)
, ("upper", fromFunction . variadicStringFunc $ mconcat . Prelude.map Text.toUpper)
, ("lower", fromFunction . variadicStringFunc $ mconcat . Prelude.map Text.toLower)
, ("throw", fromFunction gfnThrow)
, ("zip", fromFunction gfnZip)
, ("zipwith", fromFunction gfnZipWith)
, ("in", fromFunction gfnIn)
, ("escaped", fromFunction gfnEscaped)
, ("regex", gfoRegex)
]
easyRenderM :: ( Monad m
, ContextEncodable h
, Monoid h
, ToGVal (Run p m h) v
, ToGVal (Run p m h) h
, ToGVal (Run p m h) p
)
=> (h -> m ())
-> v
-> Template p
-> m (Either (RuntimeError p) (GVal (Run p m h)))
easyRenderM emit context template =
runGingerT (easyContext emit context) template
easyRender :: ( ContextEncodable h
, Monoid h
, ToGVal (Run p (Writer h) h) v
, ToGVal (Run p (Writer h) h) h
, ToGVal (Run p (Writer h) h) p
)
=> v
-> Template p
-> h
easyRender context template =
execWriter $ easyRenderM tell context template
runGinger :: ( ToGVal (Run p (Writer h) h) h
, ToGVal (Run p (Writer h) h) p
, Monoid h
)
=> GingerContext p (Writer h) h
-> Template p
-> h
runGinger context template =
execWriter $ runGingerT context template
runGingerT :: ( ToGVal (Run p m h) h
, ToGVal (Run p m h) p
, Monoid h
, Monad m
, Applicative m
, Functor m
)
=> GingerContext p m h
-> Template p
-> m (Either (RuntimeError p) (GVal (Run p m h)))
runGingerT context tpl =
runReaderT (evalStateT (runExceptT (runTemplate tpl)) (defRunState tpl)) context
baseTemplate :: Template p -> Template p
baseTemplate t =
case templateParent t of
Nothing -> t
Just p -> baseTemplate p
runTemplate :: ( ToGVal (Run p m h) h
, ToGVal (Run p m h) p
, Monoid h
, Monad m
, Applicative m
, Functor m
)
=> Template p
-> Run p m h (GVal (Run p m h))
runTemplate =
runStatement . templateBody . baseTemplate
withTemplate :: (Monad m, Applicative m, Functor m)
=> Template p
-> Run p m h a
-> Run p m h a
withTemplate tpl a = do
oldTpl <- gets rsCurrentTemplate
oldBlockName <- gets rsCurrentBlockName
modify (\s -> s { rsCurrentTemplate = tpl, rsCurrentBlockName = Nothing })
result <- withSourcePos (annotation tpl) a
modify (\s -> s { rsCurrentTemplate = oldTpl, rsCurrentBlockName = oldBlockName })
return result
withBlockName :: (Monad m, Applicative m, Functor m)
=> VarName
-> Run p m h a
-> Run p m h a
withBlockName blockName a = do
oldBlockName <- gets rsCurrentBlockName
modify (\s -> s { rsCurrentBlockName = Just blockName })
result <- a
modify (\s -> s { rsCurrentBlockName = oldBlockName })
return result
lookupBlock :: (Monad m, Applicative m, Functor m) => VarName -> Run p m h (Block p)
lookupBlock blockName = do
tpl <- gets rsCurrentTemplate
let blockMay = resolveBlock blockName tpl
case blockMay of
Nothing -> throwHere $ UndefinedBlockError blockName
Just block -> return block
where
resolveBlock :: VarName -> Template p -> Maybe (Block p)
resolveBlock name tpl =
case HashMap.lookup name (templateBlocks tpl) of
Just block ->
return block
Nothing ->
templateParent tpl >>= resolveBlock name
runStatement :: forall m h p
. ( ToGVal (Run p m h) h
, ToGVal (Run p m h) p
, Monoid h
, Monad m
, Functor m
)
=> Statement p
-> Run p m h (GVal (Run p m h))
runStatement stmt =
withSourcePos
(annotation stmt)
(runStatement' stmt)
runStatement' :: forall m h p
. ( ToGVal (Run p m h) h
, ToGVal (Run p m h) p
, Monoid h
, Monad m
, Functor m
)
=> Statement p
-> Run p m h (GVal (Run p m h))
runStatement' (NullS _) =
return def
runStatement' (MultiS _ xs) =
forM xs runStatement >>= \case
[] -> return def
rvals -> return $ List.last rvals
runStatement' (LiteralS _ html) =
echo (toGVal html) >> return def
runStatement' (InterpolationS _ expr) =
runExpression expr >>= echo >> return def
runStatement' (ExpressionS _ expr) =
runExpression expr
runStatement' (IfS _ condExpr true false) = do
cond <- runExpression condExpr
runStatement $ if toBoolean cond then true else false
runStatement' (IndentS _ expr body) = do
i <- runExpression expr
encode <- asks contextEncode
let istr = encode i
indented istr $ runStatement body
runStatement' (SwitchS _ pivotExpr cases defBranch) = do
pivot <- runExpression pivotExpr
let branches =
[ \cont -> do
cond <- runExpression condExpr
if pivot `looseEquals` cond
then runStatement body
else cont
| (condExpr, body)
<- cases
] ++
[ Prelude.const $ runStatement defBranch ]
go branches
where
go :: [ Run p m h (GVal (Run p m h)) -> Run p m h (GVal (Run p m h)) ]
-> Run p m h (GVal (Run p m h))
go [] = return def
go (x:xs) = x (go xs)
runStatement' (SetVarS _ name valExpr) = do
val <- runExpression valExpr
setVar name val
return def
runStatement' (DefMacroS _ name macro) = do
let val = macroToGVal macro
setVar name val
return def
runStatement' (BlockRefS _ blockName) = do
block <- lookupBlock blockName
withBlockName blockName $
runStatement (blockBody block)
runStatement' (ScopedS _ body) = withLocalScope runInner
where
runInner :: (Functor m, Monad m) => Run p m h (GVal (Run p m h))
runInner = runStatement body
runStatement' (ForS _ varNameIndex varNameValue itereeExpr body) = do
let go :: Int -> GVal (Run p m h) -> Run p m h (GVal (Run p m h))
go recursionDepth iteree = do
iterPairs <- if isJust (asDictItems iteree)
then return [ (toGVal k, v) | (k, v) <- fromMaybe [] (asDictItems iteree) ]
else case asList iteree of
Just items -> return $ Prelude.zip (Prelude.map toGVal ([0..] :: [Int])) items
Nothing -> do
warn $ TypeError ["list", "dictionary"] (Just $ tshow iteree)
return []
let numItems :: Int
numItems = Prelude.length iterPairs
cycle :: Int -> [(Maybe Text, GVal (Run p m h))] -> Run p m h (GVal (Run p m h))
cycle index args = return
. fromMaybe def
. headMay
. Prelude.drop (index `Prelude.mod` Prelude.length args)
. fmap snd
$ args
loop :: [(Maybe Text, GVal (Run p m h))] -> Run p m h (GVal (Run p m h))
loop [] = throwHere $ ArgumentsError (Just "loop") "at least one argument is required"
loop ((_, loopee):_) = go (Prelude.succ recursionDepth) loopee
iteration :: (Int, (GVal (Run p m h), GVal (Run p m h)))
-> Run p m h (GVal (Run p m h))
iteration (index, (key, value)) = do
setVar varNameValue value
setVar "loop" $
(dict [ "index" ~> Prelude.succ index
, "index0" ~> index
, "revindex" ~> (numItems - index)
, "revindex0" ~> (numItems - index - 1)
, "depth" ~> Prelude.succ recursionDepth
, "depth0" ~> recursionDepth
, "first" ~> (index == 0)
, "last" ~> (Prelude.succ index == numItems)
, "length" ~> numItems
, "cycle" ~> fromFunction (cycle index)
])
{ asFunction = Just loop }
case varNameIndex of
Nothing -> return def
Just n -> setVar n key
runStatement body
(withLocalScope $ forM (Prelude.zip [0..] iterPairs) iteration) >>= \case
[] -> return def
rvals -> return $ List.last rvals
runExpression itereeExpr >>= go 0
runStatement' (PreprocessedIncludeS _ tpl) =
withTemplate tpl $ runTemplate tpl
runStatement' (TryCatchS _ tryS catchesS finallyS) = do
result <- (runStatement tryS) `catchError` handle catchesS
runStatement finallyS
return result
where
handle [] e = return def
handle ((Catch whatMay varNameMay catchS):catches) e = do
let what = runtimeErrorWhat e
if whatMay == Just what || whatMay == Nothing
then
withLocalScope $ do
case varNameMay of
Nothing -> return ()
Just varName -> setVar varName (toGVal e)
runStatement catchS
else
handle catches e
macroToGVal :: forall m h p
. ( ToGVal (Run p m h) h
, ToGVal (Run p m h) p
, Monoid h
, Functor m
, Monad m
) => Macro p -> GVal (Run p m h)
macroToGVal (Macro argNames body) =
fromFunction f
where
f :: Function (Run p m h)
f args =
withLocalState . local (\c -> c { contextWrite = appendCapture }) $ do
clearCapture
forM_ (HashMap.toList matchedArgs) (uncurry setVar)
setVar "varargs" . toGVal $ positionalArgs
setVar "kwargs" . toGVal $ namedArgs
runStatement body
toGVal <$> fetchCapture
where
matchArgs' :: [(Maybe Text, GVal (Run p m h))] -> (HashMap Text (GVal (Run p m h)), [GVal (Run p m h)], HashMap Text (GVal (Run p m h)))
matchArgs' = matchFuncArgs argNames
(matchedArgs, positionalArgs, namedArgs) = matchArgs' args
runExpression expr =
withSourcePos
(annotation expr)
(runExpression' expr)
runExpression' (StringLiteralE _ str) = return . toGVal $ str
runExpression' (NumberLiteralE _ n) = return . toGVal $ n
runExpression' (BoolLiteralE _ b) = return . toGVal $ b
runExpression' (NullLiteralE _) = return def
runExpression' (VarE _ key) = getVar key
runExpression' (ListE _ xs) = toGVal <$> forM xs runExpression
runExpression' (ObjectE _ xs) = do
items <- forM xs $ \(a, b) -> do
l <- asText <$> runExpression a
r <- runExpression b
return (l, r)
return . toGVal . HashMap.fromList $ items
runExpression' (MemberLookupE _ baseExpr indexExpr) = do
base <- runExpression baseExpr
index <- runExpression indexExpr
warnFromMaybe (IndexError $ tshow (asText index)) def $
lookupLoose index base
runExpression' (CallE _ funcE argsEs) = do
args <- forM argsEs $
\(argName, argE) -> (argName,) <$> runExpression argE
e <- runExpression funcE
let func = toFunction e
case func of
Nothing -> do
warn NotAFunctionError
return def
Just f -> f args
runExpression' (LambdaE _ argNames body) = do
let fn args = withLocalScope $ do
forM_ (Prelude.zip argNames (fmap snd args)) $ uncurry setVar
runExpression body
return $ fromFunction fn
runExpression' (TernaryE _ condition yes no) = do
condVal <- runExpression condition
let expr = if asBoolean condVal then yes else no
runExpression expr
runExpression' (DoE _ stmt) =
runStatement stmt
echo :: (Monad m, Applicative m, Functor m, Monoid h)
=> GVal (Run p m h) -> Run p m h ()
echo src = do
e <- asks contextEncode
p <- asks contextWrite
asks contextNewlines >>= \case
Nothing ->
p . e $ src
Just newlines -> do
indentation <- fromMaybe [] <$> gets rsIndentation
let ls = splitLines newlines $ e src
indent = mconcat . List.reverse $ indentation
forM_ ls $ \l -> do
atLineStart <- gets rsAtLineStart
if atLineStart
then p $ indent <> l
else p l
modify $ \state -> state {
rsAtLineStart = endsWithNewline newlines l
}
indented :: (Monad m, Applicative m, Functor m, Monoid h)
=> h
-> Run p m h a
-> Run p m h a
indented i action = do
pushIndent i *> action <* popIndent
pushIndent :: (Monad m, Applicative m, Functor m, Monoid h)
=> h
-> Run p m h ()
pushIndent i =
modify $ \state ->
state { rsIndentation = increaseIndent i (rsIndentation state) }
popIndent :: (Monad m, Applicative m, Functor m, Monoid h)
=> Run p m h ()
popIndent =
modify $ \state ->
state { rsIndentation = decreaseIndent (rsIndentation state) }
increaseIndent :: a -> Maybe [a] -> Maybe [a]
increaseIndent _ Nothing = Just []
increaseIndent x (Just xs) = Just (x:xs)
decreaseIndent :: Maybe [a] -> Maybe [a]
decreaseIndent Nothing = Nothing
decreaseIndent (Just []) = Nothing
decreaseIndent (Just (x:xs)) = Just xs
defRunState :: forall m h p
. ( ToGVal (Run p m h) h
, ToGVal (Run p m h) p
, Monoid h
, Monad m
)
=> Template p
-> RunState p m h
defRunState tpl =
RunState
{ rsScope = HashMap.fromList defaultScope
, rsCapture = mempty
, rsCurrentTemplate = tpl
, rsCurrentBlockName = Nothing
, rsIndentation = Nothing
, rsAtLineStart = True
, rsCurrentSourcePos = annotation tpl
}
gfnThrow :: ( Monad m
, Monoid h
, ToGVal (Run p m h) h
, ToGVal (Run p m h) p
)
=> Function (Run p m h)
gfnThrow args =
throwHere (RuntimeError . mconcat . fmap (asText . snd) $ args)
gfnEval :: ( Monad m
, Monoid h
, ToGVal (Run p m h) h
, ToGVal (Run p m h) p
)
=> Function (Run p m h)
gfnEval args =
let extracted =
extractArgsDefL
[ ("src", def)
, ("context", def)
]
args
in case extracted of
Left _ -> throwHere $ ArgumentsError (Just "eval") "expected: (src, context)"
Right [gSrc, gContext] -> do
result' <- parseGinger
(Prelude.const . return $ Nothing)
Nothing
(Text.unpack . asText $ gSrc)
pos <- gets rsCurrentSourcePos
let result = fmap (Prelude.const pos) <$> result'
tpl <- case result of
Left err -> throwHere $ EvalParseError err
Right t -> return t
let localLookup varName = return $
lookupLooseDef def (toGVal varName) gContext
localContext c = c
{ contextWrite = appendCapture
, contextLookup = localLookup
}
withLocalState $ do
put $ defRunState tpl
local localContext $ do
clearCapture
runStatement $ templateBody tpl
toGVal <$> fetchCapture