module Text.Blaze.JSON.Internal
( JSON(..), toBuilder, encodeWith, encode
, EncodeConfig(..)
, unsafeToJSON
, bool
, null
, integral
, double, float
, text
, lazyText
, utf8
, lazyUtf8
, array', array
, object', object
, unsafeObject', unsafeObject
) where
import Prelude hiding (null)
#if !MIN_VERSION_bytestring(0,10,4)
#define COMPATIBILITY 1
#endif
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Prim as BP
import qualified Data.Foldable as F
import Data.Typeable(Typeable)
import Data.Monoid
import Data.Word
import Data.Char(ord)
import Data.Default.Class
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Set as Set
newtype JSON = JSON { unJSON :: EncodeConfig -> B.Builder }
deriving(Typeable)
newtype EncodeConfig = EncodeConfig
{ escapeHtml :: Bool
} deriving Show
instance Default EncodeConfig where
def = EncodeConfig False
toBuilder :: EncodeConfig -> JSON -> B.Builder
toBuilder = flip unJSON
encodeWith :: EncodeConfig -> JSON -> L.ByteString
encodeWith cfg = B.toLazyByteString . toBuilder cfg
encode :: JSON -> L.ByteString
encode = encodeWith def
instance Eq JSON where
a == b = encode a == encode b
instance Ord JSON where
a `compare` b = encode a `compare` encode b
instance Show JSON where
show = show . TL.decodeUtf8 . encode
ascii2 :: (Char, Char) -> BP.BoundedPrim a
ascii2 cs = BP.liftFixedToBounded $ (const cs) BP.>$< BP.char7 BP.>*< BP.char7
ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a
ascii4 cs = BP.liftFixedToBounded $ (const cs) BP.>$<
BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7
ascii5 :: (Char, (Char, (Char, (Char, Char)))) -> BP.BoundedPrim a
ascii5 cs = BP.liftFixedToBounded $ (const cs) BP.>$<
BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7
unsafeToJSON :: B.Builder -> JSON
unsafeToJSON = JSON . const
null :: JSON
null = unsafeToJSON $ BP.primBounded (ascii4 ('n', ('u', ('l', 'l')))) ()
bool :: Bool -> JSON
bool = unsafeToJSON . BP.primBounded
(BP.condB id
(ascii4 ('t', ('r', ('u', 'e'))))
(ascii5 ('f', ('a', ('l', ('s', 'e'))))))
integral :: Integral i => i -> JSON
integral = unsafeToJSON . B.integerDec . fromIntegral
float :: Float -> JSON
float = unsafeToJSON . B.floatDec
double :: Double -> JSON
double = unsafeToJSON . B.doubleDec
escapeAscii :: Bool -> BP.BoundedPrim Word8
escapeAscii html =
BP.condB (\w -> html && w == c2w '<') (BP.liftFixedToBounded hexEscape) $
BP.condB (\w -> html && w == c2w '>') (BP.liftFixedToBounded hexEscape) $
BP.condB (== c2w '\\' ) (ascii2 ('\\','\\')) $
BP.condB (== c2w '\"' ) (ascii2 ('\\','"' )) $
BP.condB (>= c2w '\x20') (BP.liftFixedToBounded BP.word8) $
BP.condB (== c2w '\n' ) (ascii2 ('\\','n' )) $
BP.condB (== c2w '\r' ) (ascii2 ('\\','r' )) $
BP.condB (== c2w '\t' ) (ascii2 ('\\','t' )) $
(BP.liftFixedToBounded hexEscape)
where
c2w = fromIntegral . ord
hexEscape :: BP.FixedPrim Word8
hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<
BP.char8 BP.>*< BP.char8 BP.>*< BP.word16HexFixed
utf8 :: S.ByteString -> JSON
utf8 t = JSON $ \cfg -> surround "\"" "\"" $
BP.primMapByteStringBounded (escapeAscii $ escapeHtml cfg) t
lazyUtf8 :: L.ByteString -> JSON
lazyUtf8 t = JSON $ \cfg -> surround "\"" "\"" $
BP.primMapLazyByteStringBounded (escapeAscii $ escapeHtml cfg) t
text :: T.Text -> JSON
lazyText :: TL.Text -> JSON
#if COMPATIBILITY
text = utf8 . T.encodeUtf8
lazyText = lazyUtf8 . TL.encodeUtf8
#else
encodeString :: (BP.BoundedPrim Word8 -> a -> B.Builder) -> Bool -> a -> B.Builder
encodeString encodeUtf8BuilderEscaped html = \t ->
B.char8 '"' <> encodeUtf8BuilderEscaped (escapeAscii html) t <> B.char8 '"'
text t = JSON $ \cfg ->
encodeString T.encodeUtf8BuilderEscaped (escapeHtml cfg) t
lazyText t = JSON $ \cfg ->
encodeString TL.encodeUtf8BuilderEscaped (escapeHtml cfg) t
#endif
intersperse :: (F.Foldable f, Monoid m) => (a -> m) -> m -> f a -> m
intersperse f s a = F.foldr go (\n _ -> n) a mempty id
where
go i g = \_ j -> g (j $ f i) (\b -> j $ f i <> s <> b)
surround :: B.Builder -> B.Builder -> B.Builder -> B.Builder
surround pre suf bdy = pre <> bdy <> suf
unsafeObject' :: F.Foldable f => (k -> T.Text) -> (a -> JSON) -> f (k, a) -> JSON
unsafeObject' kf vf a = JSON $ \cfg ->
surround curly brace $ intersperse (keyValue cfg) (B.char8 ',') a
where
curly = B.char8 '{'
brace = B.char8 '}'
colon = B.char8 ':'
keyValue cfg (k, v) =
unJSON (text $ kf k) cfg <> colon <> unJSON (vf v) cfg
object' :: F.Foldable f => (k -> T.Text) -> (a -> JSON) -> f (k, a) -> JSON
object' kf vf a = unsafeObject' id vf $
F.foldr go (\_ out -> out) a Set.empty id []
where
go (k, v) g = \dict l ->
if Set.member (kf k) dict
then g dict l
else g (Set.insert (kf k) dict) (l . ((kf k,v):))
array' :: F.Foldable f => (a -> JSON) -> f a -> JSON
array' f a = JSON $ \cfg -> surround bra ket $
intersperse (toBuilder cfg . f) (B.char8 ',') a
where
bra = B.char8 '['
ket = B.char8 ']'
array :: F.Foldable f => f JSON -> JSON
array = array' id
object :: F.Foldable f => f (T.Text, JSON) -> JSON
object = object' id id
unsafeObject :: F.Foldable f => f (T.Text, JSON) -> JSON
unsafeObject = unsafeObject' id id