{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
module Heist.Splices.Json (
bindJson
) where
import Control.Monad.Reader
import Data.Aeson
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as K
import qualified Data.Foldable.WithIndex as FI
#else
import qualified Data.HashMap.Strict as Map
#endif
import Data.Map.Syntax
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.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as B
import Text.Blaze.Renderer.XmlHtml
import Text.XmlHtml
import Heist.Interpreted.Internal
import Heist.Internal.Types.HeistState
bindJson :: (ToJSON a, Monad n) => a -> Splice n
bindJson :: forall a (n :: * -> *). (ToJSON a, Monad n) => a -> Splice n
bindJson = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall (n :: * -> *). Monad n => JsonMonad n n [Node]
explodeTag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON
errorMessage :: String -> [Node]
errorMessage :: String -> [Node]
errorMessage String
s = Html -> [Node]
renderHtmlNodes forall a b. (a -> b) -> a -> b
$
Html -> Html
B.strong forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
B.customAttribute Tag
"class" AttributeValue
"error" forall a b. (a -> b) -> a -> b
$
forall a. ToMarkup a => a -> Html
B.toHtml String
s
type JsonMonad n m a = ReaderT Value (HeistT n m) a
withValue :: (Monad m) => Value -> JsonMonad n m a -> HeistT n m a
withValue :: forall (m :: * -> *) (n :: * -> *) a.
Monad m =>
Value -> JsonMonad n m a -> HeistT n m a
withValue = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
boolToText :: Bool -> Text
boolToText :: Bool -> Text
boolToText Bool
b = if Bool
b then Text
"true" else Text
"false"
numToText :: ToJSON a => a -> Text
numToText :: forall a. ToJSON a => a -> Text
numToText = ByteString -> Text
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
S.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode
findExpr :: Text -> Value -> Maybe Value
findExpr :: Text -> Value -> Maybe Value
findExpr Text
t = [Text] -> Value -> Maybe Value
go ((Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
==Char
'.') Text
t)
where
go :: [Text] -> Value -> Maybe Value
go [] !Value
value = forall a. a -> Maybe a
Just Value
value
go (Text
x:[Text]
xs) !Value
value = Value -> Maybe Value
findIn Value
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Text] -> Value -> Maybe Value
go [Text]
xs
where
#if MIN_VERSION_aeson(2,0,0)
findIn :: Value -> Maybe Value
findIn (Object Object
obj) = forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
x) Object
obj
#else
findIn (Object obj) = Map.lookup x obj
#endif
findIn (Array Array
arr) = forall {b}. Read b => Maybe b
tryReadIndex forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
i -> Array
arr forall a. Vector a -> Int -> Maybe a
V.!? Int
i
findIn Value
_ = forall a. Maybe a
Nothing
tryReadIndex :: Maybe b
tryReadIndex = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ReadS a
reads forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
x
asHtml :: Monad m => Text -> m [Node]
asHtml :: forall (m :: * -> *). Monad m => Text -> m [Node]
asHtml Text
t =
case (String -> ByteString -> Either String Document
parseHTML String
"" forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
t) of
Left String
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [Node]
errorMessage forall a b. (a -> b) -> a -> b
$
String
"Template error turning JSON into HTML: " forall a. [a] -> [a] -> [a]
++ String
e
Right Document
d -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Document -> [Node]
docContent Document
d
snippetTag :: Monad m => JsonMonad n m [Node]
snippetTag :: forall (m :: * -> *) (n :: * -> *). Monad m => JsonMonad n m [Node]
snippetTag = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {t :: (* -> *) -> * -> *} {m :: * -> *} {n :: * -> *}.
(MonadTrans t, Monad m) =>
Value -> t (HeistT n m) [Node]
snip
where
txt :: Text -> t m [Node]
txt Text
t = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => Text -> m [Node]
asHtml Text
t
snip :: Value -> t (HeistT n m) [Node]
snip Value
Null = forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadTrans t, Monad m) =>
Text -> t m [Node]
txt Text
""
snip (Bool Bool
b) = forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadTrans t, Monad m) =>
Text -> t m [Node]
txt forall a b. (a -> b) -> a -> b
$ Bool -> Text
boolToText Bool
b
snip (Number Scientific
n) = forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadTrans t, Monad m) =>
Text -> t m [Node]
txt forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Text
numToText Scientific
n
snip (String Text
t) = forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadTrans t, Monad m) =>
Text -> t m [Node]
txt Text
t
snip Value
_ = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
Node
node <- forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [Node]
errorMessage forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
String
"error processing tag <"
, Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"???" forall a b. (a -> b) -> a -> b
$ Node -> Maybe Text
tagName Node
node
, String
">: can't interpret JSON arrays or objects as HTML."
]
valueTag :: Monad m => JsonMonad n m [Node]
valueTag :: forall (m :: * -> *) (n :: * -> *). Monad m => JsonMonad n m [Node]
valueTag = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {t :: (* -> *) -> * -> *} {m :: * -> *} {n :: * -> *}.
(MonadTrans t, Monad m, Monad (t (HeistT n m))) =>
Value -> t (HeistT n m) [Node]
go
where
go :: Value -> t (HeistT n m) [Node]
go Value
Null = forall (m :: * -> *). Monad m => Text -> m [Node]
txt Text
""
go (Bool Bool
b) = forall (m :: * -> *). Monad m => Text -> m [Node]
txt forall a b. (a -> b) -> a -> b
$ Bool -> Text
boolToText Bool
b
go (Number Scientific
n) = forall (m :: * -> *). Monad m => Text -> m [Node]
txt forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Text
numToText Scientific
n
go (String Text
t) = forall (m :: * -> *). Monad m => Text -> m [Node]
txt Text
t
go Value
_ = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
Node
node <- forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [Node]
errorMessage forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
String
"error processing tag <"
, Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"???" forall a b. (a -> b) -> a -> b
$ Node -> Maybe Text
tagName Node
node
, String
">: can't interpret JSON arrays or objects as text."
]
txt :: Text -> m [Node]
txt Text
t = forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Node
TextNode Text
t]
explodeTag :: forall n. (Monad n) => JsonMonad n n [Node]
explodeTag :: forall (n :: * -> *). Monad n => JsonMonad n n [Node]
explodeTag = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> ReaderT Value (HeistT n n) [Node]
go
where
go :: Value -> ReaderT Value (HeistT n n) [Node]
go Value
Null = forall {t :: (* -> *) -> * -> *} {n :: * -> *}.
(MonadTrans t, Monad n) =>
Text -> t (HeistT n n) [Node]
goText Text
""
go (Bool Bool
b) = forall {t :: (* -> *) -> * -> *} {n :: * -> *}.
(MonadTrans t, Monad n) =>
Text -> t (HeistT n n) [Node]
goText forall a b. (a -> b) -> a -> b
$ Bool -> Text
boolToText Bool
b
go (Number Scientific
n) = forall {t :: (* -> *) -> * -> *} {n :: * -> *}.
(MonadTrans t, Monad n) =>
Text -> t (HeistT n n) [Node]
goText forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Text
numToText Scientific
n
go (String Text
t) = forall {t :: (* -> *) -> * -> *} {n :: * -> *}.
(MonadTrans t, Monad n) =>
Text -> t (HeistT n n) [Node]
goText Text
t
go (Array Array
a) = Array -> ReaderT Value (HeistT n n) [Node]
goArray Array
a
go (Object Object
o) = forall {f :: * -> *}.
FoldableWithIndex Key f =>
f Value -> ReaderT Value (HeistT n n) [Node]
goObject Object
o
goText :: Text -> t (HeistT n n) [Node]
goText Text
t = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (n :: * -> *). Monad n => Splices (Splice n) -> Splice n
runChildrenWith forall a b. (a -> b) -> a -> b
$ do
Text
"value" forall k v. k -> v -> MapSyntax k v
## forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Node
TextNode Text
t]
Text
"snippet" forall k v. k -> v -> MapSyntax k v
## forall (m :: * -> *). Monad m => Text -> m [Node]
asHtml Text
t
goArray :: V.Vector Value -> JsonMonad n n [Node]
goArray :: Array -> ReaderT Value (HeistT n n) [Node]
goArray Array
a = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m ()
stopRecursion
[Node] -> [Node]
dl <- forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m a) -> a -> Vector b -> m a
V.foldM forall {c}.
([Node] -> c) -> Value -> ReaderT Value (HeistT n n) ([Node] -> c)
f forall a. a -> a
id Array
a
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [Node] -> [Node]
dl []
where
f :: ([Node] -> c) -> Value -> ReaderT Value (HeistT n n) ([Node] -> c)
f [Node] -> c
dl Value
jsonValue = do
[Node]
tags <- Value -> ReaderT Value (HeistT n n) [Node]
go Value
jsonValue
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [Node] -> c
dl forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Node]
tags forall a. [a] -> [a] -> [a]
++)
varAttrTag :: Value -> (JsonMonad n n [Node]) -> Splice n
varAttrTag :: Value -> ReaderT Value (HeistT n n) [Node] -> Splice n
varAttrTag Value
v ReaderT Value (HeistT n n) [Node]
m = do
Node
node <- forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {m :: * -> *}. Monad m => Node -> m [Node]
noVar Node
node) (Node -> Text -> Splice n
hasVar Node
node) forall a b. (a -> b) -> a -> b
$ Text -> Node -> Maybe Text
getAttribute Text
"var" Node
node
where
noVar :: Node -> m [Node]
noVar Node
node = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [Node]
errorMessage forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"expression error: no var attribute in <"
, Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"???" forall a b. (a -> b) -> a -> b
$ Node -> Maybe Text
tagName Node
node
, String
"> tag"
]
hasVar :: Node -> Text -> Splice n
hasVar Node
node Text
expr = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [Node]
errorMessage forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
String
"expression error: can't find \""
, Text -> String
T.unpack Text
expr
, String
"\" in JSON object (<"
, Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"???" forall a b. (a -> b) -> a -> b
$ Node -> Maybe Text
tagName Node
node
, String
"> tag)"
])
(forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Value (HeistT n n) [Node]
m)
(Text -> Value -> Maybe Value
findExpr Text
expr Value
v)
genericBindings :: JsonMonad n n (Splices (Splice n))
genericBindings :: JsonMonad n n (Splices (Splice n))
genericBindings = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value
v -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
Text
"with" forall k v. k -> v -> MapSyntax k v
## Value -> ReaderT Value (HeistT n n) [Node] -> Splice n
varAttrTag Value
v forall (n :: * -> *). Monad n => JsonMonad n n [Node]
explodeTag
Text
"snippet" forall k v. k -> v -> MapSyntax k v
## Value -> ReaderT Value (HeistT n n) [Node] -> Splice n
varAttrTag Value
v forall (m :: * -> *) (n :: * -> *). Monad m => JsonMonad n m [Node]
snippetTag
Text
"value" forall k v. k -> v -> MapSyntax k v
## Value -> ReaderT Value (HeistT n n) [Node] -> Splice n
varAttrTag Value
v forall (m :: * -> *) (n :: * -> *). Monad m => JsonMonad n m [Node]
valueTag
goObject :: f Value -> ReaderT Value (HeistT n n) [Node]
goObject f Value
obj = do
Splices (Splice n)
start <- JsonMonad n n (Splices (Splice n))
genericBindings
#if MIN_VERSION_aeson(2,0,0)
let bindings :: Splices (Splice n)
bindings = forall i (f :: * -> *) b a.
FoldableWithIndex i f =>
(i -> b -> a -> b) -> b -> f a -> b
FI.ifoldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {m :: * -> *} {a}.
Monad m =>
MapSyntaxM Text (HeistT m m [Node]) a
-> Key -> Value -> MapSyntaxM Text (HeistT m m [Node]) ()
bindKvp) Splices (Splice n)
start f Value
obj
#else
let bindings = Map.foldlWithKey' bindKvp start obj
#endif
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (n :: * -> *). Monad n => Splices (Splice n) -> Splice n
runChildrenWith Splices (Splice n)
bindings
bindKvp :: MapSyntaxM Text (HeistT m m [Node]) a
-> Key -> Value -> MapSyntaxM Text (HeistT m m [Node]) ()
bindKvp MapSyntaxM Text (HeistT m m [Node]) a
bindings Key
k Value
v =
#if MIN_VERSION_aeson(2,0,0)
let k' :: Text
k' = Key -> Text
K.toText Key
k
#else
let k' = k
#endif
newBindings :: MapSyntaxM Text (HeistT m m [Node]) ()
newBindings = do
Text -> Text -> Text
T.append Text
"with:" Text
k' forall k v. k -> v -> MapSyntax k v
## forall (m :: * -> *) (n :: * -> *) a.
Monad m =>
Value -> JsonMonad n m a -> HeistT n m a
withValue Value
v forall (n :: * -> *). Monad n => JsonMonad n n [Node]
explodeTag
Text -> Text -> Text
T.append Text
"snippet:" Text
k' forall k v. k -> v -> MapSyntax k v
## forall (m :: * -> *) (n :: * -> *) a.
Monad m =>
Value -> JsonMonad n m a -> HeistT n m a
withValue Value
v forall (m :: * -> *) (n :: * -> *). Monad m => JsonMonad n m [Node]
snippetTag
Text -> Text -> Text
T.append Text
"value:" Text
k' forall k v. k -> v -> MapSyntax k v
## forall (m :: * -> *) (n :: * -> *) a.
Monad m =>
Value -> JsonMonad n m a -> HeistT n m a
withValue Value
v forall (m :: * -> *) (n :: * -> *). Monad m => JsonMonad n m [Node]
valueTag
in MapSyntaxM Text (HeistT m m [Node]) a
bindings forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}.
Monad m =>
MapSyntaxM Text (HeistT m m [Node]) ()
newBindings