module Text.Templating.Heist.Aeson
( JsonT
, JsonTemplate
, JsonState
, JsonSpliceT
, JsonSplice
, addHeistAeson
, runJsonT
, renderJsonTemplate
) where
import Data.Aeson ( Value(..), Array )
import Text.Templating.Heist
import Blaze.ByteString.Builder ( Builder )
import qualified Data.Map as Map ( lookup )
import qualified Data.Vector as V ( forM, toList )
import qualified Data.ByteString as Strict ( ByteString )
import qualified Text.XmlHtml as X
import qualified Data.Text as T ( Text, append, pack, splitOn )
import Control.Monad.Reader ( ReaderT, ask, local, runReaderT )
data JsonInput = JsonInput { jsonRoot :: Value
, jsonCurrent :: Value
, jsonHistory :: [Value] }
mkJsonInput value
= JsonInput { jsonRoot = value
, jsonCurrent = value
, jsonHistory = [] }
type JsonT m = ReaderT JsonInput m
type JsonTemplate m a = TemplateMonad (JsonT m) a
type JsonState m = TemplateState (JsonT m)
type JsonSpliceT m = Splice (JsonT m)
type JsonSplice = JsonSpliceT IO
withValue :: Monad m => Value -> JsonSpliceT m -> JsonSpliceT m
withValue value
= local $ \input -> input{jsonCurrent = value, jsonHistory = jsonCurrent input : jsonHistory input}
jsonSplice :: Monad m => JsonSpliceT m
jsonSplice
= do node <-getParamNode
let attrs = X.elementAttrs node
methods = [ ("value", jsonValue)
, ("section", jsonSection)
, ("no-section", jsonNoSection)
, ("for-each", jsonForEach) ]
case [ action val | (key, val) <- attrs, (mKey, action) <- methods, key == mKey ] of
[x] -> x
[] -> error "No method invoked."
_ -> error "More than one method invoked."
jsonValue :: Monad m => T.Text -> JsonSpliceT m
jsonValue identifier
= withTextValue identifier $ \txt ->
return [X.TextNode txt]
jsonSection :: Monad m => T.Text -> JsonSpliceT m
jsonSection identifier
= withAnyValue identifier $ \json ->
withValue json $
runChildren
jsonNoSection :: Monad m => T.Text -> JsonSpliceT m
jsonNoSection identifier
= do input <- ask
case findWithIdentifier identifier input of
Just{} -> return []
Nothing -> runChildren
jsonForEach :: Monad m => T.Text -> JsonSpliceT m
jsonForEach identifier
= withArrayValue identifier $ \array ->
do result <- V.forM array $ \entry -> withValue entry runChildren
return $ concat (V.toList result)
withArrayValue ::Monad m => T.Text -> (Array -> JsonSpliceT m) -> JsonSpliceT m
withArrayValue nodeIdentifier action
= withAnyValue nodeIdentifier $ \json ->
case json of
Array array -> action array
_ -> return [X.TextNode $ "Json value expected to be an array: " `T.append` nodeIdentifier]
withTextValue ::Monad m => T.Text -> (T.Text -> JsonSpliceT m) -> JsonSpliceT m
withTextValue nodeIdentifier action
= withAnyValue nodeIdentifier $ \json ->
case json of
Object object -> action "object"
Array{} -> action "array"
String string -> action string
Number num -> action (T.pack $ show num)
Bool bool -> action (T.pack $ show bool)
Null -> action "null"
withAnyValue :: Monad m => T.Text -> (Value -> JsonSpliceT m) -> JsonSpliceT m
withAnyValue nodeIdentifier action
= do input <- ask
case findWithIdentifier nodeIdentifier input of
Nothing -> return []
Just value -> action value
findWithIdentifier :: T.Text -> JsonInput -> Maybe Value
findWithIdentifier identifier input
= case T.splitOn "/" identifier of
"":rest -> worker (jsonRoot input) [] rest
rest -> worker (jsonCurrent input) (jsonHistory input) rest
where worker current history []
= Just current
worker current history (".":xs)
= worker current history xs
worker current [] ("..":xs)
= error "Asked to access parent node of the top-level."
worker current (now:later) ("..":xs)
= worker now later xs
worker current history (key:xs)
= case current of
Object object | Just value <- Map.lookup key object
-> worker value (current:history) xs
_ -> Nothing
bindStrict :: Monad m => Splice m
bindStrict = do
node <- getParamNode
cs <- runChildren
maybe (return ()) (add cs)
(X.getAttribute "tag" node)
return []
where
add cs nm = modifyTS $ bindSplice nm $ do
return cs
addHeistAeson :: Monad m => JsonState m -> JsonState m
addHeistAeson = bindSplices [ ("json", jsonSplice)
, ("bind", bindStrict) ]
renderJsonTemplate :: Monad m => JsonState m -> Strict.ByteString -> Value -> m (Maybe (Builder, MIMEType))
renderJsonTemplate state tplName json
= runReaderT (renderTemplate state tplName) (mkJsonInput json)
runJsonT :: Monad m => JsonT m a -> Value -> m a
runJsonT action json
= runReaderT action (mkJsonInput json)