1 files changed, 225 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs
new file mode 100644
index 00000000..e3c3dddc
--- /dev/null
+++ b/haddock-api/src/Haddock/Utils/Json.hs
@@ -0,0 +1,225 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Minimal JSON / RFC 7159 support
+--
+-- The API is heavily inspired by @aeson@'s API but puts emphasis on
+-- simplicity rather than performance. The 'ToJSON' instances are
+-- intended to have an encoding compatible with @aeson@'s encoding.
+--
+module Haddock.Utils.Json
+    ( Value(..)
+    , Object, object, Pair, (.=)
+    , encodeToString
+    , encodeToBuilder
+    , ToJSON(toJSON)
+    )
+    where
+
+import Data.Char
+import Data.Int
+import Data.String
+import Data.Word
+import Data.List
+import Data.Monoid
+
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as BB
+
+-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'
+
+-- | A JSON value represented as a Haskell value.
+data Value = Object !Object
+           | Array  [Value]
+           | String  String
+           | Number !Double
+           | Bool   !Bool
+           | Null
+           deriving (Eq, Read, Show)
+
+-- | A key\/value pair for an 'Object'
+type Pair = (String, Value)
+
+-- | A JSON \"object\" (key/value map).
+type Object = [Pair]
+
+infixr 8 .=
+
+-- | A key-value pair for encoding a JSON object.
+(.=) :: ToJSON v => String -> v -> Pair
+k .= v  = (k, toJSON v)
+
+-- | Create a 'Value' from a list of name\/value 'Pair's.
+object :: [Pair] -> Value
+object = Object
+
+instance IsString Value where
+  fromString = String
+
+
+-- | A type that can be converted to JSON.
+class ToJSON a where
+  -- | Convert a Haskell value to a JSON-friendly intermediate type.
+  toJSON :: a -> Value
+
+instance ToJSON () where
+  toJSON () = Array []
+
+instance ToJSON Value where
+  toJSON = id
+
+instance ToJSON Bool where
+  toJSON = Bool
+
+instance ToJSON a => ToJSON [a] where
+  toJSON = Array . map toJSON
+
+instance ToJSON a => ToJSON (Maybe a) where
+  toJSON Nothing  = Null
+  toJSON (Just a) = toJSON a
+
+instance (ToJSON a,ToJSON b) => ToJSON (a,b) where
+  toJSON (a,b) = Array [toJSON a, toJSON b]
+
+instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where
+  toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]
+
+instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
+  toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]
+
+instance ToJSON Float where
+  toJSON = Number . realToFrac
+
+instance ToJSON Double where
+  toJSON = Number
+
+instance ToJSON Int    where  toJSON = Number . realToFrac
+instance ToJSON Int8   where  toJSON = Number . realToFrac
+instance ToJSON Int16  where  toJSON = Number . realToFrac
+instance ToJSON Int32  where  toJSON = Number . realToFrac
+
+instance ToJSON Word   where  toJSON = Number . realToFrac
+instance ToJSON Word8  where  toJSON = Number . realToFrac
+instance ToJSON Word16 where  toJSON = Number . realToFrac
+instance ToJSON Word32 where  toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Int64  where  toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Word64 where  toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Integer where toJSON = Number . fromInteger
+
+------------------------------------------------------------------------------
+-- 'BB.Builder'-based encoding
+
+-- | Serialise value as JSON/UTF8-encoded 'Builder'
+encodeToBuilder :: ToJSON a => a -> Builder
+encodeToBuilder = encodeValueBB . toJSON
+
+encodeValueBB :: Value -> Builder
+encodeValueBB jv = case jv of
+  Bool True  -> "true"
+  Bool False -> "false"
+  Null       -> "null"
+  Number n
+    | isNaN n || isInfinite n   -> encodeValueBB Null
+    | Just i <- doubleToInt64 n -> BB.int64Dec i
+    | otherwise                 -> BB.doubleDec n
+  Array a  -> encodeArrayBB a
+  String s -> encodeStringBB s
+  Object o -> encodeObjectBB o
+
+encodeArrayBB :: [Value] -> Builder
+encodeArrayBB [] = "[]"
+encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'
+  where
+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB
+
+encodeObjectBB :: Object -> Builder
+encodeObjectBB [] = "{}"
+encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'
+  where
+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair
+    encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x
+
+encodeStringBB :: String -> Builder
+encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'
+  where
+    go = BB.stringUtf8 . escapeString
+
+------------------------------------------------------------------------------
+-- 'String'-based encoding
+
+-- | Serialise value as JSON-encoded Unicode 'String'
+encodeToString :: ToJSON a => a -> String
+encodeToString jv = encodeValue (toJSON jv) []
+
+encodeValue :: Value -> ShowS
+encodeValue jv = case jv of
+  Bool b   -> showString (if b then "true" else "false")
+  Null     -> showString "null"
+  Number n
+    | isNaN n || isInfinite n    -> encodeValue Null
+    | Just i <- doubleToInt64 n -> shows i
+    | otherwise                 -> shows n
+  Array a -> encodeArray a
+  String s -> encodeString s
+  Object o -> encodeObject o
+
+encodeArray :: [Value] -> ShowS
+encodeArray [] = showString "[]"
+encodeArray jvs = ('[':) . go jvs . (']':)
+  where
+    go []     = id
+    go [x]    = encodeValue x
+    go (x:xs) = encodeValue x . (',':) . go xs
+
+encodeObject :: Object -> ShowS
+encodeObject [] = showString "{}"
+encodeObject jvs = ('{':) . go jvs . ('}':)
+  where
+    go []          = id
+    go [(l,x)]     = encodeString l . (':':) . encodeValue x
+    go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs
+
+encodeString :: String -> ShowS
+encodeString str = ('"':) . showString (escapeString str) . ('"':)
+
+------------------------------------------------------------------------------
+-- helpers
+
+-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not
+-- representable loss-free as integral 'Int64' value.
+doubleToInt64 :: Double -> Maybe Int64
+doubleToInt64 x
+  | fromInteger x' == x
+  , x' <= toInteger (maxBound :: Int64)
+  , x' >= toInteger (minBound :: Int64)
+    = Just (fromIntegral x')
+  | otherwise = Nothing
+  where
+    x' = round x
+
+-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"
+escapeString :: String -> String
+escapeString s
+  | not (any needsEscape s) = s
+  | otherwise               = escape s
+  where
+    escape [] = []
+    escape (x:xs) = case x of
+      '\\' -> '\\':'\\':escape xs
+      '"'  -> '\\':'"':escape xs
+      '\b' -> '\\':'b':escape xs
+      '\f' -> '\\':'f':escape xs
+      '\n' -> '\\':'n':escape xs
+      '\r' -> '\\':'r':escape xs
+      '\t' -> '\\':'t':escape xs
+      c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs
+        | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs
+        | otherwise    -> c : escape xs
+
+    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF
+    needsEscape c = ord c < 0x20 || c `elem` ['\\','"']