Permalink
Browse files

Added "Escaped" value, optimized String escaping, and other misc changes

The "escaped" type was added so that you could build long json strings from
multiple strings without actually appending them to each other.

Also minimized the imports, removed need for Undecidable Instances, and
optimized handling of type String
  • Loading branch information...
1 parent 0c6d267 commit ee4b371b13404ccb8b864b4261e01fe64913a975 @lpsmith committed Jun 2, 2011
Showing with 104 additions and 50 deletions.
  1. +104 −50 src/Json.hs
View
154 src/Json.hs
@@ -15,7 +15,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Json
( Key (..)
@@ -24,18 +24,28 @@ module Json
, row
, Array
, element
+ , Escaped(..)
) where
import Blaze.ByteString.Builder as Blaze
-import Blaze.ByteString.Builder.ByteString
-import Blaze.ByteString.Builder.Char8 (fromChar)
-import Blaze.ByteString.Builder.Char.Utf8 (fromText, fromLazyText)
+ ( 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 (shiftL, shiftR, (.&.))
+import Data.Bits ( Bits((.&.), shiftR) )
import qualified Data.Map as Map
-import Data.Monoid
-import Data.Word (Word16, Word8)
+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
@@ -44,22 +54,30 @@ 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.Char8()
-import Data.ByteString.Internal (w2c, c2w)
+import Data.ByteString.Internal ( c2w )
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
---- The "core" of json-builder
+class Value a => Key a where
+ escape :: a -> Escaped
+
class Value a where
toBuilder :: a -> Blaze.Builder
-class Value a => Key a
+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 '"'
data Pair = Pair !Blaze.Builder !Bool
newtype Object = Object (Bool -> Pair)
-
instance Value Object where
toBuilder (Object f)
= case f True of
@@ -110,7 +128,37 @@ element a = Array $ comma (toBuilder a)
instance Value () where
toBuilder _ = copyByteString "null"
-instance Integral a => Value a where
+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
@@ -123,68 +171,74 @@ instance Value Bool where
toBuilder True = copyByteString "true"
toBuilder False = copyByteString "false"
-instance Value BS.ByteString where
- toBuilder x = fromChar '"' `mappend` loop (splitQ x)
+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 -> fromChar '"'
- Just (c,n) -> quoteChar c `mappend`
+ Nothing -> mempty
+ Just (c,n) -> fromWrite (quoteChar c) `mappend`
loop (splitQ (BS.drop n b))
-instance Key BS.ByteString
+instance Value BS.ByteString where
+ toBuilder = toBuilder . escape
-instance Value BL.ByteString where
- toBuilder x = fromChar '"' `mappend` loop (splitQ x)
+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 -> fromChar '"'
- Just (c,n) -> quoteChar c `mappend`
+ Nothing -> mempty
+ Just (c,n) -> fromWrite (quoteChar c) `mappend`
loop (splitQ (BL.drop n b))
-instance Key BL.ByteString
+instance Value BL.ByteString where
+ toBuilder = toBuilder . escape
-instance Value T.Text where
- toBuilder x = fromChar '"' `mappend` loop (splitQ x)
+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 -> fromChar '"'
- Just (c,b') -> quoteChar c `mappend` loop (splitQ b')
+ Nothing -> mempty
+ Just (c,b') -> fromWrite (quoteChar c) `mappend`
+ loop (splitQ b')
-instance Key T.Text
+instance Value T.Text where
+ toBuilder = toBuilder . escape
-instance Value TL.Text where
- toBuilder x = fromChar '"' `mappend` loop (splitQ x)
+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 -> fromChar '"'
- Just (c,b') -> quoteChar c `mappend` loop (splitQ b')
+ Nothing -> mempty
+ Just (c,b') -> fromWrite (quoteChar c) `mappend`
+ loop (splitQ b')
-instance Key TL.Text
+instance Value TL.Text where
+ toBuilder = toBuilder . escape
--- FIXME: rewrite/optimize the quoting routines for Strings
+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 . BU.fromString
-
-instance Key [Char]
-
--- Convenient (?) instances for json-builder
+ toBuilder = toBuilder . escape
instance Value a => Value [a] where
toBuilder = toBuilder . mconcat . map element
@@ -193,28 +247,28 @@ 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 -> Builder
+quoteChar :: Char -> Write
quoteChar c = case c of
- '\\' -> copyByteString "\\\\"
- '"' -> copyByteString "\\\""
- '\b' -> copyByteString "\\b"
- '\f' -> copyByteString "\\f"
- '\n' -> copyByteString "\\n"
- '\r' -> copyByteString "\\r"
- '\t' -> copyByteString "\\t"
+ '\\' -> writeByteString "\\\\"
+ '"' -> writeByteString "\\\""
+ '\b' -> writeByteString "\\b"
+ '\f' -> writeByteString "\\f"
+ '\n' -> writeByteString "\\n"
+ '\r' -> writeByteString "\\r"
+ '\t' -> writeByteString "\\t"
_ -> hexEscape c
-hexEscape :: Char -> Builder
+hexEscape :: Char -> Write
hexEscape (c2w -> c)
- = fromWrite (writeByteString "\\u00"
- `mappend` writeWord8 (char ((c `shiftR` 4) .&. 0xF))
- `mappend` writeWord8 (char ( c .&. 0xF)))
+ = writeByteString "\\u00"
+ `mappend` writeWord8 (char ((c `shiftR` 4) .&. 0xF))
+ `mappend` writeWord8 (char ( c .&. 0xF))
char :: Word8 -> Word8
char i | i < 10 = i + 48

0 comments on commit ee4b371

Please sign in to comment.