module Text.Strapped.Render
( combineBuckets
, varBucket
, bucketLookup
, bucketFromList
, emptyBucket
, render
, defaultConfig
, reduceExpression
, putBucket
, getBucket
, getConfig
, getState
, putState
) where
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
import Blaze.ByteString.Builder.Int
import Control.Monad
import qualified Data.Map.Strict as M
import Data.Foldable (foldlM)
import Data.List (intersperse)
import Data.Monoid ((<>), mempty, mconcat)
import Control.Monad.Except
import Control.Monad.State.Strict
import Control.Monad.Writer
import Control.Monad.IO.Class
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Text.Strapped.Types
import Text.Parsec.Pos
import Debug.Trace
instance Renderable Builder where
renderOutput _ = id
instance Renderable Literal where
renderOutput (StrappedConfig _ _ ef) (LitText s) = fromText $ ef s
renderOutput _ (LitSafe s) = fromText s
renderOutput _ (LitInteger i) = fromShow i
renderOutput rc (LitDouble i) = fromShow i
renderOutput rc (LitBool i) = fromShow i
renderOutput _ (LitBuilder b) = b
renderOutput rc (LitList l) = (fromChar '[') <>
(mconcat $ intersperse (fromChar ',') (map (renderOutput rc) l)) <>
(fromChar ']')
renderOutput rc (LitDyn r) = renderOutput rc r
defaultConfig :: StrappedConfig
defaultConfig = StrappedConfig [] (\_ -> return Nothing) id
varBucket :: String -> Input m -> InputBucket m
varBucket varName o = bucketFromList [(varName, o)]
combineBuckets :: InputBucket m -> InputBucket m -> InputBucket m
combineBuckets (InputBucket a) (InputBucket b) = InputBucket (a ++ b)
emptyBucket :: InputBucket m
emptyBucket = InputBucket []
bucketLookup :: String -> InputBucket m -> Maybe (Input m)
bucketLookup v (InputBucket []) = Nothing
bucketLookup v (InputBucket (m:ms)) = maybe (bucketLookup v (InputBucket ms)) Just (M.lookup v m)
bucketFromList :: [(String, Input m)] -> InputBucket m
bucketFromList l = InputBucket [M.fromList l]
getOrThrow :: (Monad m) => String -> RenderT m (Input m)
getOrThrow v = do
getter <- getBucket
maybe (throwError $ InputNotFound v) return (bucketLookup v getter)
reduceExpression :: (Monad m) => ParsedExpression -> RenderT m Literal
reduceExpression (ParsedExpression exp pos) = convert exp
where convert (LiteralExpression i) = return $ i
convert (Multipart []) = return $ LitEmpty
convert (Multipart (f:[])) = reduceExpression f
convert (Multipart ((ParsedExpression (LookupExpression func) ipos):args)) = do
val <- getOrThrow func
case val of
(Func f) -> convert (Multipart args) >>= f
_ -> throwParser $ "`" ++ func ++ "` is not a function but has args: " ++ (show args)
convert (Multipart v) = throwParser $ "`" ++ (show v) ++ "` cannot be reduced."
convert (ListExpression args) = mapM reduceExpression args >>= (return . LitList)
convert (LookupExpression f) = do
val <- getOrThrow f
inputToLiteral val
inputToLiteral inp = case inp of
(Func f) -> f LitEmpty
(LitVal v) -> return v
putPos :: Monad m => SourcePos -> RenderT m ()
putPos a = RenderT $ modify (\i -> i { position=a })
putBucket :: Monad m => (InputBucket m) -> RenderT m ()
putBucket a = RenderT $ modify (\i -> i { bucket=a })
getPos :: Monad m => RenderT m SourcePos
getPos = liftM position getState
getBucket :: Monad m => RenderT m (InputBucket m)
getBucket = liftM bucket getState
getConfig :: Monad m => RenderT m StrappedConfig
getConfig = liftM renderConfig getState
getBlocks :: Monad m => RenderT m BlockMap
getBlocks = liftM blocks getState
putBlocks :: Monad m => BlockMap -> RenderT m ()
putBlocks a = RenderT $ lift $ modify (\i -> i { blocks=a })
getState :: Monad m => RenderT m (RenderState m)
getState = RenderT $ get
putState :: Monad m => RenderState m -> RenderT m ()
putState = RenderT . put
throwParser :: (Monad m) => String -> RenderT m b
throwParser s = throwError $ StrapError s
instance Block Piece where
process (StaticPiece s) = return s
process (BlockPiece n default_content) = do
blks <- getBlocks
maybe (buildContent default_content) (buildContent) (M.lookup n blks)
process (ForPiece n exp c) = do
var <- reduceExpression exp
curState <- getState
curBucket <- getBucket
ret <- case var of
LitList l -> foldlM (\acc obj -> putBucket (combineBuckets (varBucket n $ LitVal obj) curBucket) >>
buildContent c >>= return . (<>) acc) mempty l
_ -> throwParser $ "`" ++ show exp ++ "` is not a LitList"
putBucket curBucket
return ret
process (IfPiece exp p n) = do
var <- reduceExpression exp
c <- case (toBool var) of
True -> buildContent p
False -> buildContent n
return c
process (Inherits n b) = do
tmplStore <- liftM templateStore getConfig
mtmpl <- liftIO (tmplStore n)
maybe (throwError (TemplateNotFound n))
(\(Template c) -> do
curBlocks <- getBlocks
putBlocks $ M.union b curBlocks
r <- buildContent c
putBlocks curBlocks
return r)
mtmpl
process (Include n) = do
tmplStore <- liftM templateStore getConfig
mtmpl <- liftIO (tmplStore n)
maybe (throwError (TemplateNotFound n))
(\(Template c) -> buildContent c)
mtmpl
process (Decl n exp) = do
val <- (reduceExpression exp)
bucket <- getBucket
putBucket $ combineBuckets (varBucket n (LitVal val)) bucket
return mempty
process (FuncPiece exp) = do
config <- getConfig
val <- reduceExpression exp
return $ renderOutput config val
buildContent pieces = foldlM (\acc (ParsedPiece piece pos) -> (process piece) `catchError` (\e -> throwError $ PositionedError e pos) >>= return . (<>) acc ) mempty pieces
render :: (MonadIO m) => StrappedConfig -> InputBucket m -> String -> m (Either StrapError Output)
render renderConfig !getter' tmplName = do
tmpl <- liftIO $ tmplStore tmplName
maybe (return $ Left $ TemplateNotFound tmplName)
(\(Template c) -> (flip evalStateT startState $ runExceptT $ runRenderT $ buildContent c))
tmpl
where tmplStore = templateStore renderConfig
startState = RenderState (initialPos tmplName) renderConfig M.empty getter'