Json.hs

{-# 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 Distribution.Client.Utils.Json
  ( Value (..)
  , Object
  , object
  , Pair
  , (.=)
  , encodeToString
  , encodeToBuilder
  , ToJSON (toJSON)
  )
where

import Distribution.Client.Compat.Prelude

import Data.Char (intToDigit)

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 = mconcat . intersperse (BB.char8 ',') . map encodeValueBB

encodeObjectBB :: Object -> Builder
encodeObjectBB [] = "{}"
encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'
  where
    go = 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` ['\\', '"']