diff --git a/json-builder.cabal b/json-builder.cabal --- a/json-builder.cabal +++ b/json-builder.cabal @@ -1,5 +1,5 @@ Name: json-builder -Version: 0.2.2 +Version: 0.2.3 Synopsis: Data structure agnostic JSON serialization License: BSD3 License-file: LICENSE @@ -28,6 +28,8 @@ Exposed-modules: Data.Json.Builder Data.Json.Builder.Internal + Other-modules: Data.Json.Builder.Implementation + Build-depends: base >= 4 && < 5, blaze-builder, blaze-textual, @@ -44,4 +46,4 @@ source-repository this type: git location: http://github.com/lpsmith/json-builder - tag: v0.2.2 + tag: v0.2.3 diff --git a/src/Data/Json/Builder.hs b/src/Data/Json/Builder.hs --- a/src/Data/Json/Builder.hs +++ b/src/Data/Json/Builder.hs @@ -10,12 +10,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE IncoherentInstances #-} - module Data.Json.Builder ( -- * Json Values Json @@ -38,251 +32,5 @@ , Monoid(mempty, mappend, mconcat) ) where -import Prelude hiding ((++)) - -import Blaze.ByteString.Builder as Blaze - ( Write - , Builder - , copyByteString - , fromByteString - , fromLazyByteString - , writeByteString - , fromWrite - , fromWriteList - , writeWord8 - , toByteString - , toLazyByteString ) -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 - -import Data.Json.Builder.Internal - -(++) :: Monoid a => a -> a -> a -(++) = mappend -infixr 5 ++ - -class JsObject a where - toObject :: a -> Object - -instance JsObject Object where - toObject = id - -class JsArray a where - toArray :: a -> Array - -instance JsArray Array where - toArray = id - -toBuilder :: Value a => a -> Builder -toBuilder x = case toJson x of - Json y -> y -{-# SPECIALIZE toBuilder :: Json -> Builder #-} -{-# INLINE toBuilder #-} - -toJsonBS :: Value a => a -> BS.ByteString -toJsonBS = toByteString . toBuilder - -toJsonLBS :: Value a => a -> BL.ByteString -toJsonLBS = toLazyByteString . toBuilder - --- | The 'row' function constructs a json object consisting of exactly --- one field. These objects can be concatinated using 'mappend'. -row :: (JsString k, Value a) => k -> a -> Object -row k a = Object (Comma (toBuilder k ++ fromChar ':' ++ toBuilder a)) - --- | 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 - --- | renders as @null@ -instance Value () where - toJson _ = Json (copyByteString "null") - -instance Value Int where - toJson = Json . integral - -instance Value Int8 where - toJson = Json . integral - -instance Value Int16 where - toJson = Json . integral - -instance Value Int32 where - toJson = Json . integral - -instance Value Int64 where - toJson = Json . integral - -instance Value Integer where - toJson = Json . integral - -instance Value Word where - toJson = Json . integral - -instance Value Word8 where - toJson = Json . integral - -instance Value Word16 where - toJson = Json . integral - -instance Value Word32 where - toJson = Json . integral - -instance Value Word64 where - toJson = Json . integral - -instance Value Double where - toJson = Json . double - -instance Value Float where - toJson = Json . float - --- | renders as @true@ or @false@ - -instance Value Bool where - toJson True = Json (copyByteString "true") - toJson False = Json (copyByteString "false") - --- | must be UTF-8 encoded - -instance JsString BS.ByteString where - escape x = Escaped (loop x) - where - loop (BU.break quoteNeeded -> (a,b)) - = fromByteString a ++ - case BU.decode b of - Nothing -> mempty - Just (c,n) -> quoteChar c ++ loop (BS.drop n b) - -instance Value BS.ByteString where - toJson = toJson . escape - --- | must be UTF-8 encoded - -instance JsString BL.ByteString where - escape x = Escaped (loop x) - where - loop (BLU.break quoteNeeded -> (a,b)) - = fromLazyByteString a ++ - case BLU.decode b of - Nothing -> mempty - Just (c,n) -> quoteChar c ++ loop (BL.drop n b) - -instance Value BL.ByteString where - toJson = toJson . escape - -instance JsString T.Text where - escape x = Escaped (loop x) - where - loop (T.break quoteNeeded -> (a,b)) - = fromText a ++ - case T.uncons b of - Nothing -> mempty - Just (c,b') -> quoteChar c ++ loop b' - -instance Value T.Text where - toJson = toJson . escape - -instance JsString TL.Text where - escape x = Escaped (loop x) - where - loop (TL.break quoteNeeded -> (a,b)) - = fromLazyText a ++ - case TL.uncons b of - Nothing -> mempty - Just (c,b') -> quoteChar c ++ loop b' - -instance Value TL.Text where - toJson = toJson . escape - -instance JsString [Char] where - escape str = Escaped (fromWriteList writeEscapedChar str) - where - writeEscapedChar c | quoteNeeded c = quoteCharW c - | otherwise = writeChar c - -instance Value [Char] where - toJson = toJson . escape - --- | renders as an 'Array' -instance Value a => Value [a] where - toJson = toJson . toArray - -instance Value a => JsArray [a] where - toArray = foldr (\a as -> element a ++ as) mempty - --- | renders as an 'Object' -instance (JsString k, Value a) => Value (Map.Map k a) where - toJson = toJson . toObject - -instance (JsString k, Value a) => JsObject (Map.Map k a) where - toObject = Map.foldrWithKey (\k a b -> row k a ++ b) mempty - --- | renders as an 'Object' -instance (JsString k, Value a) => Value (HashMap.HashMap k a) where - toJson = toJson . toObject - -instance (JsString k, Value a) => JsObject (HashMap.HashMap k a) where - toObject = HashMap.foldrWithKey (\k a b -> row k a ++ 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" - ++ writeWord8 (char ((c `shiftR` 4) .&. 0xF)) - ++ writeWord8 (char ( c .&. 0xF)) - -char :: Word8 -> Word8 -char i | i < 10 = i + 48 - | otherwise = i + 87 -{-# INLINE char #-} +import Data.Monoid +import Data.Json.Builder.Implementation diff --git a/src/Data/Json/Builder/Implementation.hs b/src/Data/Json/Builder/Implementation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Json/Builder/Implementation.hs @@ -0,0 +1,363 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Json.Builder.Implementation +-- Copyright : (c) 2011 Leon P Smith +-- License : BSD3 +-- +-- Maintainer : Leon P Smith +-- +-- This module contains all definitions for the library. Different +-- subsets are exported by Data.Json.Builder and Data.Json.Builder.Internal. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Json.Builder.Implementation where + +import Prelude hiding ((++)) + +import Blaze.ByteString.Builder as Blaze + ( Write + , Builder + , copyByteString + , fromByteString + , fromLazyByteString + , writeByteString + , fromWrite + , fromWriteList + , writeWord8 + , toByteString + , toLazyByteString ) +import Blaze.ByteString.Builder.Char.Utf8 + ( fromChar, writeChar, fromText, fromLazyText ) +import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder ( fromString ) + +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.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 Data.String ( fromString ) + +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import qualified Data.HashMap.Lazy as HashMap + +(++) :: Monoid a => a -> a -> a +(++) = mappend +infixr 5 ++ + +-- | The 'Value' typeclass represents types that can be rendered +-- into valid json syntax. + +class Value a where + toJson :: a -> Json + +-- | The 'Json' type represents valid json syntax. It cannot be directly +-- analyzed, however it can be turned into a 'Builder' via 'toBuilder', +-- a (lazy) 'BS.ByteString' via 'toJsonBS' or 'toJsonLBS', or used as a +-- component of a json 'Array' or json 'Object' using 'element' or 'row'. + +newtype Json = Json Builder + +instance Value Json where + toJson = id + + +-- | The 'Escaped' type represents json string syntax. The purpose of this +-- type is so that json strings can be efficiently constructed from multiple +-- Haskell strings without superfluous conversions or concatinations. +-- +-- Internally, it is just a 'Builder' value which must produce a UTF-8 encoded +-- bytestring with backslashes, quotes, and control characters appropriately +-- escaped. It also must not render the opening or closing quote, which +-- are instead rendered by 'toJson'. + +newtype Escaped = Escaped Builder deriving (Monoid) + +instance Value Escaped where + toJson (Escaped str) = Json (fromChar '"' ++ str ++ fromChar '"') + +-- | The 'JsString' typeclass represents types that can be render into json +-- string syntax. They are special because only strings can appear as field +-- names of json objects. + +class Value a => JsString a where + escape :: a -> Escaped + +instance JsString Escaped where + escape = id + +-- | The 'Object' type represents syntax for a json object. It has a singleton +-- constructor 'row', and an instance of 'Monoid', so that 'mempty' represents +-- the empty object and 'mappend' concatinates two objects. Arbitrary objects +-- can be constructed using these operators. +-- +-- 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 CommaMonoid deriving (Monoid) + +instance Value Object where + toJson (Object xs) = case xs of + Empty -> Json (copyByteString "{}") + Comma ys -> Json (fromChar '{' ++ ys ++ fromChar '}') + +class JsObject a where + toObject :: a -> Object + +instance JsObject Object where + toObject = id + +-- | The 'row' function constructs a json object consisting of exactly +-- one field. These objects can be concatinated using 'mappend'. +row :: (JsString k, Value a) => k -> a -> Object +row k a = Object (Comma (toBuilder k ++ fromChar ':' ++ toBuilder a)) + +-- | The 'Array' type represents syntax for a json array. It has been given +-- a singleton constructor 'element' and an instance of 'Monoid', so that +-- 'mempty' represents the empty array and 'mappend' concatinates two arrays. +-- Arbitrary arrays can be constructed using these operators. + +newtype Array = Array CommaMonoid deriving (Monoid) + +instance Value Array where + toJson (Array xs) = case xs of + Empty -> Json (copyByteString "[]") + Comma ys -> Json (fromChar '[' ++ ys ++ fromChar ']') + +class JsArray a where + toArray :: a -> Array + +instance JsArray Array where + toArray = id + +-- | 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)) + +-- | A 'CommaMonoid' inserts commas between builders. In order to +-- satisify the 'Monoid' identity laws, 'Empty' must be distinguished +-- from @'Comma' 'mempty'@. To demonstrate the difference: +-- +-- @ +-- mconcat [\"foo\", \"\" , \"bar\"] == \"foo,,bar\" +-- mconcat [\"foo\", Empty , \"bar\"] == \"foo,bar\" +-- @ +-- +-- The strings in this example denote @CommaMonoids@ via +-- @'fromString' = Comma . 'Builder.fromString'@. Thus @\"\"@ is equivalent +-- to @Comma mempty@. + +data CommaMonoid + = Empty + | Comma !Builder + +instance Monoid CommaMonoid where + mempty = Empty + mappend Empty x = x + mappend (Comma a) x + = Comma (a ++ case x of + Empty -> mempty + Comma b -> fromChar ',' ++ b) + +toBuilder :: Value a => a -> Builder +toBuilder x = case toJson x of + Json y -> y +{-# SPECIALIZE toBuilder :: Json -> Builder #-} +{-# INLINE toBuilder #-} + +toJsonBS :: Value a => a -> BS.ByteString +toJsonBS = toByteString . toBuilder + +toJsonLBS :: Value a => a -> BL.ByteString +toJsonLBS = toLazyByteString . toBuilder + + +-- Primitive instances for json-builder + +-- | renders as @null@ +instance Value () where + toJson _ = Json (copyByteString "null") + +instance Value Int where + toJson = Json . integral + +instance Value Int8 where + toJson = Json . integral + +instance Value Int16 where + toJson = Json . integral + +instance Value Int32 where + toJson = Json . integral + +instance Value Int64 where + toJson = Json . integral + +instance Value Integer where + toJson = Json . integral + +instance Value Word where + toJson = Json . integral + +instance Value Word8 where + toJson = Json . integral + +instance Value Word16 where + toJson = Json . integral + +instance Value Word32 where + toJson = Json . integral + +instance Value Word64 where + toJson = Json . integral + +instance Value Double where + toJson = Json . double + +instance Value Float where + toJson = Json . float + +-- | renders as @true@ or @false@ + +instance Value Bool where + toJson x = Json (fromByteString $! if x then "true" else "false") + +-- | must be UTF-8 encoded + +instance JsString BS.ByteString where + escape x = Escaped (loop x) + where + loop (BU.break quoteNeeded -> (a,b)) + = fromByteString a ++ + case BU.decode b of + Nothing -> mempty + Just (c,n) -> quoteChar c ++ loop (BS.drop n b) + +instance Value BS.ByteString where + toJson = toJson . escape + +-- | must be UTF-8 encoded + +instance JsString BL.ByteString where + escape x = Escaped (loop x) + where + loop (BLU.break quoteNeeded -> (a,b)) + = fromLazyByteString a ++ + case BLU.decode b of + Nothing -> mempty + Just (c,n) -> quoteChar c ++ loop (BL.drop n b) + +instance Value BL.ByteString where + toJson = toJson . escape + +instance JsString T.Text where + escape x = Escaped (loop x) + where + loop (T.break quoteNeeded -> (a,b)) + = fromText a ++ + case T.uncons b of + Nothing -> mempty + Just (c,b') -> quoteChar c ++ loop b' + +instance Value T.Text where + toJson = toJson . escape + +instance JsString TL.Text where + escape x = Escaped (loop x) + where + loop (TL.break quoteNeeded -> (a,b)) + = fromLazyText a ++ + case TL.uncons b of + Nothing -> mempty + Just (c,b') -> quoteChar c ++ loop b' + +instance Value TL.Text where + toJson = toJson . escape + +instance JsString [Char] where + escape str = Escaped (fromWriteList writeEscapedChar str) + where + writeEscapedChar c | quoteNeeded c = quoteCharW c + | otherwise = writeChar c + +instance Value [Char] where + toJson = toJson . escape + +-- | renders as an 'Array' +instance Value a => Value [a] where + toJson = toJson . toArray + +instance Value a => JsArray [a] where + toArray = foldr (\a as -> element a ++ as) mempty + +-- | renders as an 'Object' +instance (JsString k, Value a) => Value (Map.Map k a) where + toJson = toJson . toObject + +instance (JsString k, Value a) => JsObject (Map.Map k a) where + toObject = Map.foldrWithKey (\k a b -> row k a ++ b) mempty + +-- | renders as an 'Object' +instance (JsString k, Value a) => Value (HashMap.HashMap k a) where + toJson = toJson . toObject + +instance (JsString k, Value a) => JsObject (HashMap.HashMap k a) where + toObject = HashMap.foldrWithKey (\k a b -> row k a ++ b) mempty + +------------------------------------------------------------------------------ + +quoteNeeded :: Char -> Bool +quoteNeeded c = c == '\\' || c == '"' || c < '\x20' +{-# 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" + ++ writeWord8 (char ((c `shiftR` 4) .&. 0xF)) + ++ writeWord8 (char ( c .&. 0xF)) +{-# INLINE hexEscape #-} + +char :: Word8 -> Word8 +char i | i < 10 = i + 48 + | otherwise = i + 87 +{-# INLINE char #-} diff --git a/src/Data/Json/Builder/Internal.hs b/src/Data/Json/Builder/Internal.hs --- a/src/Data/Json/Builder/Internal.hs +++ b/src/Data/Json/Builder/Internal.hs @@ -13,119 +13,12 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Data.Json.Builder.Internal ( Json (..) , Object (..) , Array (..) - , Value (..) , Escaped (..) - , JsString(..) , CommaMonoid(..) ) where -import Prelude hiding ((++)) - -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Char.Utf8 ( fromChar ) -import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze ( fromString ) -import Data.String ( fromString ) -import Data.ByteString ( ByteString ) -import Data.ByteString.Char8() -import Data.Monoid - -(++) :: Monoid a => a -> a -> a -(++) = mappend -infixr 5 ++ - --- | The 'Value' typeclass represents types that can be rendered --- into valid json syntax. - -class Value a where - toJson :: a -> Json - --- | The 'Json' type represents valid json syntax. It cannot be directly --- analyzed, however it can be turned into a 'Builder' via 'toBuilder', --- a (lazy) 'ByteString' via 'toJsonBS' or 'toJsonLBS', or used as a component --- of a json 'Array' or json 'Object' using 'element' or 'row'. - -newtype Json = Json Builder - -instance Value Json where - toJson = id - --- | The 'JsString' typeclass represents types that can be render into json string --- syntax. They are special because only strings can appear as field names --- of json objects. - -class Value a => JsString a where - escape :: a -> Escaped - --- | The 'Escaped' type represents json string syntax. The purpose of this --- type is so that json strings can be efficiently constructed from multiple --- Haskell strings without superfluous conversions or concatinations. --- --- Internally, it is just a 'Builder' value which must produce a UTF-8 encoded --- bytestring with backslashes, quotes, and control characters appropriately --- escaped. It also must not render the opening or closing quote, which --- are instead rendered by 'toJson'. - -newtype Escaped = Escaped Builder deriving (Monoid) - -instance Value Escaped where - toJson (Escaped str) = Json (fromChar '"' ++ str ++ fromChar '"') - -instance JsString Escaped where - escape = id - --- | The 'Object' type represents syntax for a json object. It has a singleton --- constructor 'row', and an instance of 'Monoid', so that 'mempty' represents the --- empty object and 'mappend' concatinates two objects. Arbitrary objects can --- be constructed using these operators. --- --- 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 CommaMonoid deriving (Monoid) - -instance Value Object where - toJson (Object xs) = case xs of - Empty -> Json (copyByteString "{}") - Comma ys -> Json (fromChar '{' ++ ys ++ fromChar '}') - --- | The 'Array' type represents syntax for a json array. It has been given --- a singleton constructor 'element' and an instance of 'Monoid', so that --- 'mempty' represents the empty array and 'mappend' concatinates two arrays. --- Arbitrary arrays can be constructed using these operators. - -newtype Array = Array CommaMonoid deriving (Monoid) - -instance Value Array where - toJson (Array xs) = case xs of - Empty -> Json (copyByteString "[]") - Comma ys -> Json (fromChar '[' ++ ys ++ fromChar ']') - --- | A 'CommaMonoid' inserts commas between builders. In order to --- satisify the 'Monoid' identity laws, 'Empty' must be distinguished --- from @'Comma' 'mempty'@. To demonstrate the difference: --- --- @ --- mconcat [\"foo\", Comma mempty, \"bar\"] == \"foo,,bar\" --- mconcat [\"foo\", Empty , \"bar\"] == \"foo,bar\" --- @ --- --- Note that this example abuses notation somewhat, treating Builders as --- strings using the injection @'fromString' = Comma . 'Blaze.fromString'@ - -data CommaMonoid - = Empty - | Comma !Builder - -instance Monoid CommaMonoid where - mempty = Empty - mappend Empty x = x - mappend (Comma a) x - = Comma (a ++ case x of - Empty -> mempty - Comma b -> fromChar ',' ++ b) +import Data.Json.Builder.Implementation