json-builder-0.0.1: src/Data/Json/Builder.hs
-----------------------------------------------------------------------------
-- |
-- Module : Data.Json.Builder
-- Copyright : (c) 2011 Leon P Smith
-- License : BSD3
--
-- Maintainer : Leon P Smith <leon@melding-monads.com>
--
-- Data structure agnostic JSON serialization
--
-----------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Json.Builder
( Key (..)
, Value(..)
, Object
, row
, Array
, element
, Escaped(..)
) where
import Blaze.ByteString.Builder as Blaze
( Write
, Builder
, copyByteString
, fromByteString
, fromLazyByteString
, writeByteString
, fromWrite
, fromWriteList
, writeWord8 )
import Blaze.ByteString.Builder.Char.Utf8
( fromChar, writeChar, fromText, fromLazyText )
import Blaze.Text (float, double, integral)
import Data.Bits ( Bits((.&.), shiftR) )
import qualified Data.Map as Map
import Data.Monoid ( Monoid (mempty, mappend, mconcat) )
import Data.Int ( Int8, Int16, Int32, Int64)
import Data.Word ( Word, Word8, Word16, Word32, Word64 )
import qualified Data.Char as Char
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.UTF8 as BU
import qualified Data.ByteString.Lazy.UTF8 as BLU
import Data.ByteString.Internal ( c2w )
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.HashMap.Lazy as HashMap
-- | The 'Key' typeclass represents types that are rendered
-- into json strings. They are special because only strings
-- can appear as field names of a json objects.
class Value a => Key a where
escape :: a -> Escaped
-- | The 'Value' typeclass represents types that can be rendered
-- into valid json syntax.
class Value a where
toBuilder :: a -> Blaze.Builder
-- | The 'Escaped' type is a special Builder value that represents a UTF-8
-- encoded string with all necessary characters json-escaped. These builders
-- must not render the opening or closing quotes, which are instead rendered
-- by 'toBuilder'. This is so that Json strings can be efficiently constructed
-- from multiple Haskell strings without actually concatinating the Haskell
-- strings (which might require some kind of conversion in addition to
-- concatination.)
newtype Escaped = Escaped Blaze.Builder deriving (Monoid)
instance Key Escaped where
escape = id
instance Value Escaped where
toBuilder (Escaped str) = fromChar '"' `mappend` str `mappend` fromChar '"'
type CommaTracker = (Bool -> Blaze.Builder) -> Bool -> Blaze.Builder
comma :: Blaze.Builder -> CommaTracker
comma b f True = b `mappend` f False
comma b f False = fromChar ',' `mappend` b `mappend` f False
{-# INLINE comma #-}
-- | The 'Object' type represents a builder that constructs syntax for a
-- json object. It has a singleton constructor 'row', and an instance of
-- monoid, so that arbitrary objects can be constructed. Note that
-- duplicate field names will appear in the output, so it is up to the
-- user of this interface to avoid duplicate field names.
newtype Object = Object CommaTracker
instance Value Object where
toBuilder (Object f) = fromChar '{' `mappend` f (\_ -> fromChar '}') True
instance Monoid Object where
mempty = Object id
mappend (Object f) (Object g) = Object (f . g)
-- | The 'row' constructs a json object consisting of exactly one field.
-- These objects can be concatinated using 'mappend'.
row :: (Key k, Value a) => k -> a -> Object
row k a = Object syntax
where
syntax = comma (mconcat [ toBuilder k, fromChar ':', toBuilder a ])
-- | The 'Array' type represents a builder that constructs syntax for a
-- json array. It has a singleton constructor 'element' and an instance of
-- monoid, so that arbitrary arrays can be constructed.
newtype Array = Array CommaTracker
instance Value Array where
toBuilder (Array f) = fromChar '[' `mappend` f (\_ -> fromChar ']') True
instance Monoid Array where
mempty = Array id
mappend (Array f) (Array g) = Array (f . g)
-- | The 'element' function constructs a json array consisting of exactly
-- one value. These arrays can be concatinated using 'mappend'.
element :: Value a => a -> Array
element a = Array $ comma (toBuilder a)
-- Primitive instances for json-builder
instance Value () where
toBuilder _ = copyByteString "null"
instance Value Int where
toBuilder = integral
instance Value Int8 where
toBuilder = integral
instance Value Int16 where
toBuilder = integral
instance Value Int32 where
toBuilder = integral
instance Value Int64 where
toBuilder = integral
instance Value Integer where
toBuilder = integral
instance Value Word where
toBuilder = integral
instance Value Word8 where
toBuilder = integral
instance Value Word16 where
toBuilder = integral
instance Value Word32 where
toBuilder = integral
instance Value Word64 where
toBuilder = integral
instance Value Double where
toBuilder = double
instance Value Float where
toBuilder = float
instance Value Bool where
toBuilder True = copyByteString "true"
toBuilder False = copyByteString "false"
instance Key BS.ByteString where
escape x = Escaped (loop x)
where
loop (BU.break quoteNeeded -> (a,b))
= fromByteString a `mappend`
case BU.decode b of
Nothing -> mempty
Just (c,n) -> quoteChar c `mappend` loop (BS.drop n b)
instance Value BS.ByteString where
toBuilder = toBuilder . escape
instance Key BL.ByteString where
escape x = Escaped (loop x)
where
loop (BLU.break quoteNeeded -> (a,b))
= fromLazyByteString a `mappend`
case BLU.decode b of
Nothing -> mempty
Just (c,n) -> quoteChar c `mappend` loop (BL.drop n b)
instance Value BL.ByteString where
toBuilder = toBuilder . escape
instance Key T.Text where
escape x = Escaped (loop x)
where
loop (T.break quoteNeeded -> (a,b))
= fromText a `mappend`
case T.uncons b of
Nothing -> mempty
Just (c,b') -> quoteChar c `mappend` loop b'
instance Value T.Text where
toBuilder = toBuilder . escape
instance Key TL.Text where
escape x = Escaped (loop x)
where
loop (TL.break quoteNeeded -> (a,b))
= fromLazyText a `mappend`
case TL.uncons b of
Nothing -> mempty
Just (c,b') -> quoteChar c `mappend` loop b'
instance Value TL.Text where
toBuilder = toBuilder . escape
instance Key [Char] where
escape str = Escaped (fromWriteList writeEscapedChar str)
where
writeEscapedChar c | quoteNeeded c = quoteCharW c
| otherwise = writeChar c
instance Value [Char] where
toBuilder = toBuilder . escape
instance Value a => Value [a] where
toBuilder = toBuilder . mconcat . map element
instance (Key k, Value a) => Value (Map.Map k a) where
toBuilder = toBuilder
. Map.foldrWithKey (\k a b -> row k a `mappend` b) mempty
instance (Key k, Value a) => Value (HashMap.HashMap k a) where
toBuilder = toBuilder
. HashMap.foldrWithKey (\k a b -> row k a `mappend` b) mempty
------------------------------------------------------------------------------
quoteNeeded :: Char -> Bool
quoteNeeded c = c == '\\' || c == '"' || Char.ord c < 0x20
{-# INLINE quoteNeeded #-}
quoteChar :: Char -> Builder
quoteChar c = case c of
'\\' -> copyByteString "\\\\"
'"' -> copyByteString "\\\""
'\b' -> copyByteString "\\b"
'\f' -> copyByteString "\\f"
'\n' -> copyByteString "\\n"
'\r' -> copyByteString "\\r"
'\t' -> copyByteString "\\t"
_ -> fromWrite (hexEscape c)
quoteCharW :: Char -> Write
quoteCharW c = case c of
'\\' -> writeByteString "\\\\"
'"' -> writeByteString "\\\""
'\b' -> writeByteString "\\b"
'\f' -> writeByteString "\\f"
'\n' -> writeByteString "\\n"
'\r' -> writeByteString "\\r"
'\t' -> writeByteString "\\t"
_ -> hexEscape c
hexEscape :: Char -> Write
hexEscape (c2w -> c)
= writeByteString "\\u00"
`mappend` writeWord8 (char ((c `shiftR` 4) .&. 0xF))
`mappend` writeWord8 (char ( c .&. 0xF))
char :: Word8 -> Word8
char i | i < 10 = i + 48
| otherwise = i + 87
{-# INLINE char #-}