-
Notifications
You must be signed in to change notification settings - Fork 57
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Add support for binding JSON values to heist.
- Loading branch information
1 parent
51d2247
commit a3c9063
Showing
7 changed files
with
282 additions
and
8 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,222 @@ | ||
| {-# LANGUAGE BangPatterns #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
|
|
||
| module Text.Templating.Heist.Splices.Json ( | ||
| bindJson | ||
| ) where | ||
|
|
||
| ------------------------------------------------------------------------------ | ||
| import Control.Monad.Reader | ||
| import Data.Aeson | ||
| import Data.Attoparsec.Number | ||
| import qualified Data.ByteString.Char8 as S | ||
| import qualified Data.ByteString.Lazy.Char8 as L | ||
| import qualified Data.HashMap.Strict as Map | ||
| import Data.Maybe | ||
| import Data.Text (Text) | ||
| import qualified Data.Text as T | ||
| import qualified Data.Text.Encoding as T | ||
| import qualified Data.Vector as V | ||
| import Text.Templating.Heist | ||
| import qualified Text.Blaze.Html5 as B | ||
| import Text.Blaze.Html5 ((!)) | ||
| import Text.Blaze.Renderer.XmlHtml | ||
| import Text.XmlHtml | ||
| ------------------------------------------------------------------------------ | ||
|
|
||
| ------------ | ||
| -- public -- | ||
| ------------ | ||
|
|
||
| ------------------------------------------------------------------------------ | ||
| -- | This splice binds convenience tags for the given JSON (or | ||
| -- JSON-convertible) value and runs the tag's child nodes using the new | ||
| -- bindings. | ||
| -- | ||
| -- /Tags bound when you pass in an object/ | ||
| -- | ||
| -- Tags bound for an object looking like this: | ||
| -- | ||
| -- > { "k_1": v_1, ..., "k_N": v_N } | ||
| -- | ||
| -- @\<value:{k_i}\>@ -- treats v_i as text | ||
| -- @\<snippet:{k_i}\>@ -- treats v_i as HTML | ||
| -- @\<with:{k_i}\>@ -- explodes v_i and runs its children | ||
| -- | ||
| -- @\<value var=\"foo.bar.baz\"\/>@ -- walks the JSON tree to find | ||
| -- \"foo.bar.baz\", and interprets it as a string | ||
| -- @\<snippet var=\"foo.bar.baz\"\/\>@ | ||
| -- @\<with var=\"foo.bar.baz\"\>...\<with\>@ | ||
| -- | ||
| -- /Tags bound when you pass in anything else/ | ||
| -- | ||
| -- @\<value\/\>@ -- the given JSON value, as a string | ||
| -- @\<snippet\/\>@ -- the given JSON value, parsed and spliced in as HTML | ||
| -- | ||
| bindJson :: (ToJSON a, Monad m) => a -> Splice m | ||
| bindJson = runReaderT explodeTag . toJSON | ||
|
|
||
|
|
||
| ------------- | ||
| -- private -- | ||
| ------------- | ||
|
|
||
| ------------------------------------------------------------------------------ | ||
| errorMessage :: String -> [Node] | ||
| errorMessage s = renderHtmlNodes $ | ||
| B.strong ! B.customAttribute "class" "error" $ | ||
| B.toHtml s | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------ | ||
| type JsonMonad m a = ReaderT Value (HeistT m) a | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------ | ||
| withValue :: (Monad m) => Value -> JsonMonad m a -> HeistT m a | ||
| withValue = flip runReaderT | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------ | ||
| boolToText :: Bool -> Text | ||
| boolToText b = if b then "true" else "false" | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------ | ||
| numToText :: Number -> Text | ||
| numToText = T.decodeUtf8 . S.concat . L.toChunks . encode | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------ | ||
| findExpr :: Text -> Value -> Maybe Value | ||
| findExpr t = go (T.split (=='.') t) | ||
| where | ||
| go [] !value = Just value | ||
| go (x:xs) !value = findIn value >>= go xs | ||
| where | ||
| findIn (Object obj) = Map.lookup x obj | ||
| findIn _ = Nothing | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------ | ||
| asHtml :: Monad m => Text -> m [Node] | ||
| asHtml t = | ||
| case (parseHTML "" $ T.encodeUtf8 t) of | ||
| Left e -> return $ errorMessage $ | ||
| "Template error turning JSON into HTML: " ++ e | ||
| Right d -> return $! docContent d | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------ | ||
| snippetTag :: Monad m => JsonMonad m [Node] | ||
| snippetTag = ask >>= snip | ||
| where | ||
| txt t = lift $ asHtml t | ||
|
|
||
| snip Null = txt "" | ||
| snip (Bool b) = txt $ boolToText b | ||
| snip (Number n) = txt $ numToText n | ||
| snip (String t) = txt t | ||
| snip _ = lift $ do | ||
| node <- getParamNode | ||
| return $ errorMessage $ concat [ | ||
| "error processing tag <" | ||
| , T.unpack $ fromMaybe "???" $ tagName node | ||
| , ">: can't interpret JSON arrays or objects as HTML." | ||
| ] | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------ | ||
| valueTag :: Monad m => JsonMonad m [Node] | ||
| valueTag = ask >>= go | ||
| where | ||
| go Null = txt "" | ||
| go (Bool b) = txt $ boolToText b | ||
| go (Number n) = txt $ numToText n | ||
| go (String t) = txt t | ||
| go _ = lift $ do | ||
| node <- getParamNode | ||
| return $ errorMessage $ concat [ | ||
| "error processing tag <" | ||
| , T.unpack $ fromMaybe "???" $ tagName node | ||
| , ">: can't interpret JSON arrays or objects as text." | ||
| ] | ||
|
|
||
|
|
||
| txt t = return [TextNode t] | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------ | ||
| explodeTag :: (Monad m) => JsonMonad m [Node] | ||
| explodeTag = ask >>= go | ||
| where | ||
| -------------------------------------------------------------------------- | ||
| go Null = goText "" | ||
| go (Bool b) = goText $ boolToText b | ||
| go (Number n) = goText $ numToText n | ||
| go (String t) = goText t | ||
| go (Array a) = goArray a | ||
| go (Object o) = goObject o | ||
|
|
||
| -------------------------------------------------------------------------- | ||
| goText t = lift $ runChildrenWith [ ("value" , return [TextNode t]) | ||
| , ("snippet" , asHtml t ) | ||
| ] | ||
|
|
||
| -------------------------------------------------------------------------- | ||
| goArray :: (Monad m) => V.Vector Value -> JsonMonad m [Node] | ||
| goArray a = do | ||
| lift stopRecursion | ||
| dl <- V.foldM f id a | ||
| return $! dl [] | ||
| where | ||
| f dl jsonValue = do | ||
| tags <- go jsonValue | ||
| return $! dl . (tags ++) | ||
|
|
||
| -------------------------------------------------------------------------- | ||
| -- search the param node for attribute \"var=expr\", search the given JSON | ||
| -- object for the expression, and if it's found run the JsonMonad action m | ||
| -- using the restricted JSON object. | ||
| varAttrTag :: (Monad m) => Value -> (JsonMonad m [Node]) -> Splice m | ||
| varAttrTag v m = do | ||
| node <- getParamNode | ||
| maybe (noVar node) (hasVar node) $ getAttribute "var" node | ||
| where | ||
| noVar node = return $ errorMessage $ | ||
| concat [ "expression error: no var attribute in <" | ||
| , T.unpack $ fromMaybe "???" $ tagName node | ||
| , "> tag" | ||
| ] | ||
|
|
||
| hasVar node expr = maybe (return $ errorMessage $ | ||
| concat [ | ||
| "expression error: can't find \"" | ||
| , T.unpack expr | ||
| , "\" in JSON object (<" | ||
| , T.unpack $ fromMaybe "???" $ tagName node | ||
| , "> tag)" | ||
| ]) | ||
| (runReaderT m) | ||
| (findExpr expr v) | ||
|
|
||
| -------------------------------------------------------------------------- | ||
| genericBindings :: Monad m => JsonMonad m [(Text, Splice m)] | ||
| genericBindings = ask >>= \v -> return [ ("with", varAttrTag v explodeTag) | ||
| , ("snippet", varAttrTag v snippetTag) | ||
| , ("value", varAttrTag v valueTag ) | ||
| ] | ||
|
|
||
| -------------------------------------------------------------------------- | ||
| goObject obj = do | ||
| start <- genericBindings | ||
| let bindings = Map.foldlWithKey' bindKvp start obj | ||
| lift $ runChildrenWith bindings | ||
|
|
||
| -------------------------------------------------------------------------- | ||
| bindKvp bindings k v = | ||
| let newBindings = [ (T.append "with:" k , withValue v explodeTag) | ||
| , (T.append "snippet:" k, withValue v snippetTag) | ||
| , (T.append "value:" k , withValue v valueTag ) | ||
| ] | ||
| in newBindings ++ bindings |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1 @@ | ||
| <json><i><value/></i></json> |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1 @@ | ||
| <jsonObject><i><value:foo/></i><i><snippet:bar/></i><with:baz><value:baz1/><value:baz2/></with:baz><with:quux><value/></with:quux><with var="quux"><value/></with><value var="baz.baz1"/><snippet var="bar"/></jsonObject> |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1 @@ | ||
| <json><i><snippet/></i></json> |