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.0.1 +Version: 0.1.0 Synopsis: Data structure agnostic JSON serialization License: BSD3 License-file: LICENSE @@ -26,6 +26,7 @@ Library hs-source-dirs: src Exposed-modules: Data.Json.Builder + Data.Json.Builder.Internal Build-depends: base >= 4 && < 5, blaze-builder, @@ -43,4 +44,4 @@ source-repository this type: git location: http://github.com/lpsmith/json-builder - tag: v0.0.1 + tag: v0.1.0 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,23 +10,28 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} module Data.Json.Builder - ( Key (..) - , Value(..) - , Object - , row + ( Value(toJson) + , Json + , toBuilder + , toJsonByteString + , toJsonLazyByteString , Array , element - , Escaped(..) + , Object + , row + , JsString(escape) + , Escaped ) where +import Prelude hiding ((++)) + import Blaze.ByteString.Builder as Blaze ( Write , Builder @@ -36,7 +41,9 @@ , writeByteString , fromWrite , fromWriteList - , writeWord8 ) + , writeWord8 + , toByteString + , toLazyByteString ) import Blaze.ByteString.Builder.Char.Utf8 ( fromChar, writeChar, fromText, fromLazyText ) import Blaze.Text (float, double, integral) @@ -60,72 +67,64 @@ 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 +import Data.Json.Builder.Internal --- | 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.) +(++) :: Monoid a => a -> a -> a +(++) = mappend +infixr 5 ++ -newtype Escaped = Escaped Blaze.Builder deriving (Monoid) +toBuilder :: Value a => a -> Builder +toBuilder x = case toJson x of + Json y -> y +{-# SPECIALIZE toBuilder :: Json -> Builder #-} +{-# INLINE toBuilder #-} -instance Key Escaped where - escape = id +toJsonByteString :: Value a => a -> BS.ByteString +toJsonByteString = toByteString . toBuilder -instance Value Escaped where - toBuilder (Escaped str) = fromChar '"' `mappend` str `mappend` fromChar '"' +toJsonLazyByteString :: Value a => a -> BL.ByteString +toJsonLazyByteString = toLazyByteString . toBuilder -type CommaTracker = (Bool -> Blaze.Builder) -> Bool -> Blaze.Builder +type CommaTracker = (Bool -> Builder) -> Bool -> Builder -comma :: Blaze.Builder -> CommaTracker -comma b f True = b `mappend` f False -comma b f False = fromChar ',' `mappend` b `mappend` f False +comma :: Builder -> CommaTracker +comma b f True = b ++ f False +comma b f False = fromChar ',' ++ b ++ 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. +-- | 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 CommaTracker instance Value Object where - toBuilder (Object f) = fromChar '{' `mappend` f (\_ -> fromChar '}') True + toJson (Object f) = Json (fromChar '{' ++ 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 +-- | 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 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. +-- | 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 CommaTracker instance Value Array where - toBuilder (Array f) = fromChar '[' `mappend` f (\_ -> fromChar ']') True + toJson (Array f) = Json (fromChar '[' ++ f (\_ -> fromChar ']') True) instance Monoid Array where mempty = Array id @@ -138,119 +137,123 @@ -- Primitive instances for json-builder +-- | renders as @null@ instance Value () where - toBuilder _ = copyByteString "null" + toJson _ = Json (copyByteString "null") instance Value Int where - toBuilder = integral + toJson = Json . integral instance Value Int8 where - toBuilder = integral + toJson = Json . integral instance Value Int16 where - toBuilder = integral + toJson = Json . integral instance Value Int32 where - toBuilder = integral + toJson = Json . integral instance Value Int64 where - toBuilder = integral + toJson = Json . integral instance Value Integer where - toBuilder = integral + toJson = Json . integral instance Value Word where - toBuilder = integral + toJson = Json . integral instance Value Word8 where - toBuilder = integral + toJson = Json . integral instance Value Word16 where - toBuilder = integral + toJson = Json . integral instance Value Word32 where - toBuilder = integral + toJson = Json . integral instance Value Word64 where - toBuilder = integral + toJson = Json . integral instance Value Double where - toBuilder = double + toJson = Json . double instance Value Float where - toBuilder = float + toJson = Json . float +-- | renders as @true@ or @false@ + instance Value Bool where - toBuilder True = copyByteString "true" - toBuilder False = copyByteString "false" + toJson True = Json (copyByteString "true") + toJson False = Json (copyByteString "false") -instance Key BS.ByteString where +instance JsString BS.ByteString where escape x = Escaped (loop x) where loop (BU.break quoteNeeded -> (a,b)) - = fromByteString a `mappend` + = fromByteString a ++ case BU.decode b of Nothing -> mempty - Just (c,n) -> quoteChar c `mappend` loop (BS.drop n b) + Just (c,n) -> quoteChar c ++ loop (BS.drop n b) instance Value BS.ByteString where - toBuilder = toBuilder . escape + toJson = toJson . escape -instance Key BL.ByteString where +instance JsString BL.ByteString where escape x = Escaped (loop x) where loop (BLU.break quoteNeeded -> (a,b)) - = fromLazyByteString a `mappend` + = fromLazyByteString a ++ case BLU.decode b of Nothing -> mempty - Just (c,n) -> quoteChar c `mappend` loop (BL.drop n b) + Just (c,n) -> quoteChar c ++ loop (BL.drop n b) instance Value BL.ByteString where - toBuilder = toBuilder . escape + toJson = toJson . escape -instance Key T.Text where +instance JsString T.Text where escape x = Escaped (loop x) where loop (T.break quoteNeeded -> (a,b)) - = fromText a `mappend` + = fromText a ++ case T.uncons b of Nothing -> mempty - Just (c,b') -> quoteChar c `mappend` loop b' + Just (c,b') -> quoteChar c ++ loop b' instance Value T.Text where - toBuilder = toBuilder . escape + toJson = toJson . escape -instance Key TL.Text where +instance JsString TL.Text where escape x = Escaped (loop x) where loop (TL.break quoteNeeded -> (a,b)) - = fromLazyText a `mappend` + = fromLazyText a ++ case TL.uncons b of Nothing -> mempty - Just (c,b') -> quoteChar c `mappend` loop b' + Just (c,b') -> quoteChar c ++ loop b' instance Value TL.Text where - toBuilder = toBuilder . escape + toJson = toJson . escape -instance Key [Char] where +instance JsString [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 + toJson = toJson . escape +-- | renders as an 'Array' instance Value a => Value [a] where - toBuilder = toBuilder . mconcat . map element + toJson = toJson . 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 +-- | renders as an 'Object' +instance (JsString k, Value a) => Value (Map.Map k a) where + toJson = toJson . Map.foldrWithKey (\k a b -> row k a ++ 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 +-- | renders as an 'Object' +instance (JsString k, Value a) => Value (HashMap.HashMap k a) where + toJson = toJson . HashMap.foldrWithKey (\k a b -> row k a ++ b) mempty ------------------------------------------------------------------------------ @@ -283,8 +286,8 @@ hexEscape :: Char -> Write hexEscape (c2w -> c) = writeByteString "\\u00" - `mappend` writeWord8 (char ((c `shiftR` 4) .&. 0xF)) - `mappend` writeWord8 (char ( c .&. 0xF)) + ++ writeWord8 (char ((c `shiftR` 4) .&. 0xF)) + ++ writeWord8 (char ( c .&. 0xF)) char :: Word8 -> Word8 char i | i < 10 = i + 48 diff --git a/src/Data/Json/Builder/Internal.hs b/src/Data/Json/Builder/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Json/Builder/Internal.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Json.Builder.Internal +-- Copyright : (c) 2011 Leon P Smith +-- License : BSD3 +-- +-- Maintainer : Leon P Smith +-- +-- Internal bits. You can break this library's abstraction and emit +-- invalid Json syntax the constructors provided in this module. +----------------------------------------------------------------------------- + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Json.Builder.Internal + ( Value (..) + , Json (..) + , JsString(..) + , Escaped (..) + ) where + +import Prelude hiding ((++)) + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 ( fromChar ) +import Data.ByteString(ByteString) +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 rendered into a 'ByteString' and used to +-- as a component of an array or an object to build a bigger json value. + +newtype Json = Json Builder + +instance Value Json where + toJson = id + +-- | The 'String' typeclass represents types that 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 +