Json string quoting

I really need to start writing some correctness and performance tests.

src/Json.hs

@@ -10,8 +10,8 @@
 --
 -----------------------------------------------------------------------------
 
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns      #-}
 
 module Json
      ( Value(..)
@@ -27,7 +27,13 @@ import           Blaze.ByteString.Builder.ByteString
 import           Blaze.ByteString.Builder.Char8
 import qualified Data.ByteString        as BS
 import qualified Data.ByteString.Lazy   as BL
+import qualified Data.ByteString.UTF8   as BU
 import           Data.ByteString.Char8()
+import           Data.ByteString.Internal (w2c, c2w)
+import qualified Data.Char              as Char
+import           Data.Word (Word16, Word8)
+import           Data.Bits (shiftL, shiftR)
+
 
 ---- The "core" of json-builder
 
@@ -86,22 +92,58 @@ instance Value () where
   toBuilder _ = fromByteString "null"
 
 instance Value Integer where
-  -- FIXME:  Do we emit the correct syntax?
-  -- FIXME:  Can this be more efficient?
+  -- FIXME:  Should this be more efficient?
   toBuilder x = fromString (show x)
 
 instance Value Double where
   -- FIXME:  Do we emit the correct syntax?
-  -- FIXME:  Can this be more efficient?
+  -- FIXME:  Should this be more efficient?
   toBuilder x = fromString (show x)
 
 instance Value Bool where
   toBuilder True  = fromByteString "true"
   toBuilder False = fromByteString "false"
 
 instance Value BS.ByteString where
-  -- FIXME!  Quote chars as needed
-  toBuilder x = fromWrite (mconcat [writeChar '"',  writeByteString x, writeChar '"'])
+  toBuilder x = fromWrite (loop ("\"",x))
+    where
+      loop (a,b)
+        = writeByteString a `mappend`
+            case BU.decode b of
+              Nothing     ->  writeChar '"'
+              Just (c,n)  ->  writeByteString (quoteChar c) `mappend`
+                                loop (BU.break quoteNeeded (BS.drop n b))
+
+      quoteNeeded :: Char -> Bool
+      quoteNeeded c = case c of
+                         '\\' -> True
+                         '"'  -> True
+                         _    -> Char.isControl c
+
+      quoteChar :: Char -> BS.ByteString
+      quoteChar c = case c of
+                     '\\'  ->  "\\\\"
+                     '"'   ->  "\\\""
+                     '\b'  ->  "\\b"
+                     '\f'  ->  "\\f"
+                     '\n'  ->  "\\n"
+                     '\r'  ->  "\\r"
+                     '\t'  ->  "\\t"
+                     _     ->  hexEscape c
+
+      hexEscape :: Char -> BS.ByteString
+      hexEscape c = s
+        where
+          !n = fromIntegral (Char.ord c) :: Word16
+
+          !s = BS.append "\\u" $ fst $ BS.unfoldrN 4 f n
+
+          f n = Just (char (fromIntegral (n `shiftR` 12)), n `shiftL` 4)
+
+          char i
+            | i < 10    = (c2w '0' -  0) + i
+            | otherwise = (c2w 'a' - 10) + i
+
 
 
 -- Convenient (?) instances for json-builder