Blaze.hs

{-# LANGUAGE OverloadedStrings #-}
{-|
Efficient build ByteString from `Json` with escaped string.

/For example - use in YESOD:/

@
    import Yesod
    import Data.JSON2       as JSON
    import Data.JSON2.Blaze as JSON
    import Blaze.ByteString.Builder (toLazyByteString)
    --
    toRepJson :: ToJson a => a -> RepJson
    toRepJson =  RepJson . toContent . toLazyByteString . (JSON.blazeJson) . (JSON.toJson)
@

-}

module Data.JSON2.Blaze (blazeJson) where
import Data.JSON2.Types
import Data.ByteString.Char8 ()
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Internal(runWrite, boundedWrite)
import Blaze.ByteString.Builder.Char.Utf8 (writeChar, fromChar, fromString, fromShow)
import Data.Ratio (denominator, numerator)
import Data.Monoid (mempty, mappend, mconcat)
import Data.Map as Map

blazeJson :: Json -> Builder
blazeJson JNull           = fromByteString "null"
blazeJson (JBool True)    = fromByteString "true"
blazeJson (JBool False)   = fromByteString "false"
blazeJson (JString xs)    = escQuoted xs  --fromWriteList writeJsonEscChar xs
blazeJson (JNumber x)
    | denominator x == 1  = fromShow (numerator x)
    | otherwise           = fromShow (fromRational x :: Double)
blazeJson (JArray [])     = fromByteString "[]"
blazeJson (JArray (x:xs)) = mconcat [fromChar '[', blazeJson x, go xs, fromChar ']' ]
    where go xs = mconcat [fromChar ',' `mappend` blazeJson x | x <- xs]
blazeJson (JObject x)   = goo (Map.toList x)
    where goo []     = fromByteString "{}"
          goo (p:ps) = mconcat [fromChar '{', buildPair p, goo' ps, fromChar '}' ]
          goo' vs = mconcat [fromChar ',' `mappend` buildPair w | w <- vs]
          buildPair (k,v) = mconcat[escQuoted k, fromChar ':', blazeJson v]

escQuoted :: String -> Builder
escQuoted xs = mconcat [fromChar '\"', (fromWriteList writeJsonEscChar xs), fromChar '\"']

writeJsonEscChar :: Char -> Write
writeJsonEscChar x = 
    boundedWrite 2 (wc x)  where
        wc '\"'  = runWrite $ writeByteString "\\\""
        wc '\\'  = runWrite $ writeByteString "\\\\"
        wc '/'  = runWrite $ writeByteString "\\/"
        wc '\b'  = runWrite $ writeByteString "\\b"
        wc '\f'  = runWrite $ writeByteString "\\f"
        wc '\n'  = runWrite $ writeByteString "\\n"
        wc '\r'  = runWrite $ writeByteString "\\r"
        wc '\t'  = runWrite $ writeByteString "\\t"
        wc c     = runWrite $ writeChar c