@@ -16,16 +16,18 @@ module Data.Aeson.Encode
1616 ) where
1717
1818import Blaze.ByteString.Builder
19+import Blaze.ByteString.Builder.Internal.Write
1920import Blaze.ByteString.Builder.Char.Utf8
2021import Data.Aeson.Encode.Number (fromNumber)
2122import Data.Aeson.Types (ToJSON(..), Value(..))
2223import Data.Monoid (mappend)
23−import Numeric (showHex)
2424import qualified Data.ByteString.Lazy.Char8 as L
2525import qualified Data.Map as M
2626import qualified Data.Text as T
2727import qualified Data.Vector as V
2828
29+import Foreign
30+
2931-- | Encode a JSON value to a 'Builder'.
3032fromValue :: Value -> Builder
3133fromValue Null = fromByteString "null"
@@ -47,25 +49,60 @@ fromValue (Object m) =
4749 where f a z = fromChar ',' `mappend` one a `mappend` z
4850 one (k,v) = string k `mappend` fromChar ':' `mappend` fromValue v
4951
50−string :: T.Text -> Builder
51−string s = fromChar '"' `mappend` quote s `mappend` fromChar '"'
52− where
53− quote q = case T.uncons t of
54− Just (c,t') -> fromText h `mappend` escape c `mappend` quote t'
55− Nothing -> fromText h
56− where (h,t) = T.break isEscape q
57− isEscape c = c == '\"' || c == '\\' || c < '\x20'
58− escape '\"' = fromByteString "\\\""
59− escape '\\' = fromByteString "\\\\"
60− escape '\n' = fromByteString "\\n"
61− escape '\r' = fromByteString "\\r"
62− escape '\t' = fromByteString "\\t"
63− escape c
64− | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h
65− | otherwise = fromChar c
66− where h = showHex (fromEnum c) ""
6752
6853-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.
6954encode :: ToJSON a => a -> L.ByteString
7055encode = toLazyByteString . fromValue . toJSON
7156{-# INLINE encode #-}
57+
58+
59+-- TODO: Gain more speed by serialization of text values without prior
60+-- unpacking to lists.
61+string :: T.Text -> Builder
62+string s =
63+ fromChar '"' `mappend` fromWriteList writeJSONChar (T.unpack s) `mappend` fromChar '"'
64+
65+{-# INLINE writeJSONChar #-}
66+writeJSONChar :: Char -> Write
67+writeJSONChar c =
68+ -- FIXME: This interface to Write's is error-prone and hacky.
69+ -- The system-io-write library already provides a better one.
70+ boundedWrite 6 $ getPoke $ case c of
71+ '\"' -> writeByteString "\\\""
72+ '\\' -> writeByteString "\\\\"
73+ '\n' -> writeByteString "\\n"
74+ '\r' -> writeByteString "\\r"
75+ '\t' -> writeByteString "\\t"
76+ _ | c < '\x20' -> writeChar '\\' `mappend`
77+ writeChar 'u' `mappend`
78+ -- FIXME: Why do we have to use Word16 where Word8 would suffice?
79+ writeWord16Hex (fromIntegral $ fromEnum c)
80+ | otherwise -> writeChar c
81+
82+-- TODO: Extend blaze-builder or better the new bytestring lib with support for
83+-- hex encoding.
84+
85+{-# INLINE writeWord16Hex #-}
86+writeWord16Hex :: Word16 -> Write
87+writeWord16Hex = exactWrite 4 . pokeWord16Hex
88+
89+{-# INLINE pokeWord16Hex #-}
90+pokeWord16Hex :: Word16 -> Ptr Word8 -> IO ()
91+pokeWord16Hex x op = do
92+ pokeNibble 0 12
93+ pokeNibble 1 8
94+ pokeNibble 2 4
95+ pokeNibble 3 0
96+ where
97+ pokeNibble off s
98+ | n < 10 = pokeWord8 off (fromIntegral $ 48 + n)
99+ | otherwise = pokeWord8 off (fromIntegral $ 55 + n)
100+ where
101+ -- TODO: Could we gain speed using an unchecked shift?
102+ n = shiftR x s .&. 0xF
103+
104+ pokeWord8 :: Int -> Word8 -> IO ()
105+ pokeWord8 off = poke (op `plusPtr` off)
106+
107+
108+