diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2011, Leon P Smith + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Leon P Smith nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/json-builder.cabal b/json-builder.cabal new file mode 100644 --- /dev/null +++ b/json-builder.cabal @@ -0,0 +1,45 @@ +Name: json-builder +Version: 0.0 +Synopsis: Data structure agnostic JSON serialization +License: BSD3 +License-file: LICENSE +Author: Leon P Smith +Maintainer: leon@melding-monads.com +Stability: experimental +Copyright: (c) 2011 Leon P Smith +Category: JSON +Build-type: Simple +Cabal-version: >= 1.6 +homepage: http://github.com/lpsmith/json-builder +bug-reports: http://github.com/lpsmith/json-builder/issues +description: + Most json packages define a data structure that corresponds to json values. + To serialize other values to a json string, then that value must be + marshalled into the json data structure. + . + This library avoids this marshalling step, and is thus potentially more + efficient when serializing arbitrary data structures. Unfortunately + json-builder cannot yet read or process json data, and it's not clear + to me yet how pull a similar kind of trick to avoid unnecessary data + structures when parsing json data into arbitrary data types. + +Library + hs-source-dirs: src + Exposed-modules: Data.Json.Builder + + Build-depends: base >= 4 && < 5, + blaze-builder, + blaze-textual, + bytestring, + containers, + text, + utf8-string + +source-repository head + type: git + location: http://github.com/lpsmith/json-builder + +source-repository this + type: git + location: http://github.com/lpsmith/json-builder + tag: v0.0 diff --git a/src/Data/Json/Builder.hs b/src/Data/Json/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Data/Json/Builder.hs @@ -0,0 +1,287 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Json.Builder +-- Copyright : (c) 2011 Leon P Smith +-- License : BSD3 +-- +-- Maintainer : Leon P Smith +-- +-- Data structure agnostic JSON serialization +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# 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 + +-- | 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 (splitQ x)) + where + splitQ = BU.break quoteNeeded + + loop (a,b) + = fromByteString a `mappend` + case BU.decode b of + Nothing -> mempty + Just (c,n) -> fromWrite (quoteChar c) `mappend` + loop (splitQ (BS.drop n b)) + +instance Value BS.ByteString where + toBuilder = toBuilder . escape + +instance Key BL.ByteString where + escape x = Escaped (loop (splitQ x)) + where + splitQ = BLU.break quoteNeeded + + loop (a,b) + = fromLazyByteString a `mappend` + case BLU.decode b of + Nothing -> mempty + Just (c,n) -> fromWrite (quoteChar c) `mappend` + loop (splitQ (BL.drop n b)) + +instance Value BL.ByteString where + toBuilder = toBuilder . escape + +instance Key T.Text where + escape x = Escaped (loop (splitQ x)) + where + splitQ = T.break quoteNeeded + + loop (a,b) + = fromText a `mappend` + case T.uncons b of + Nothing -> mempty + Just (c,b') -> fromWrite (quoteChar c) `mappend` + loop (splitQ b') + +instance Value T.Text where + toBuilder = toBuilder . escape + +instance Key TL.Text where + escape x = Escaped (loop (splitQ x)) + where + splitQ = TL.break quoteNeeded + + loop (a,b) + = fromLazyText a `mappend` + case TL.uncons b of + Nothing -> mempty + Just (c,b') -> fromWrite (quoteChar c) `mappend` + loop (splitQ b') + +instance Value TL.Text where + toBuilder = toBuilder . escape + +instance Key [Char] where + escape str = Escaped (fromWriteList writeEscapedChar str) + where + writeEscapedChar c | quoteNeeded c = quoteChar 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 + +------------------------------------------------------------------------------ + +quoteNeeded :: Char -> Bool +quoteNeeded c = c == '\\' || c == '"' || Char.ord c < 0x20 +{-# INLINE quoteNeeded #-} + +quoteChar :: Char -> Write +quoteChar 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 #-}