cabal-install/src/Distribution/Client/Utils/Json.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 -- | Minimal JSON / RFC 7159 support
   4 --
   5 -- The API is heavily inspired by @aeson@'s API but puts emphasis on
   6 -- simplicity rather than performance. The 'ToJSON' instances are
   7 -- intended to have an encoding compatible with @aeson@'s encoding.
   8 module Distribution.Client.Utils.Json
   9   ( Value (..)
  10   , Object
  11   , object
  12   , Pair
  13   , (.=)
  14   , encodeToString
  15   , encodeToBuilder
  16   , ToJSON (toJSON)
  17   )
  18 where
  19
  20 import Distribution.Client.Compat.Prelude
  21
  22 import Data.Char (intToDigit)
  23
  24 import Data.ByteString.Builder (Builder)
  25 import qualified Data.ByteString.Builder as BB
  26
  27 -- TODO: We may want to replace 'String' with 'Text' or 'ByteString'
  28
  29 -- | A JSON value represented as a Haskell value.
  30 data Value
  31   = Object !Object
  32   | Array [Value]
  33   | String String
  34   | Number !Double
  35   | Bool !Bool
  36   | Null
  37   deriving (Eq, Read, Show)
  38
  39 -- | A key\/value pair for an 'Object'
  40 type Pair = (String, Value)
  41
  42 -- | A JSON \"object\" (key/value map).
  43 type Object = [Pair]
  44
  45 infixr 8 .=
  46
  47 -- | A key-value pair for encoding a JSON object.
  48 (.=) :: ToJSON v => String -> v -> Pair
  49 k .= v = (k, toJSON v)
  50
  51 -- | Create a 'Value' from a list of name\/value 'Pair's.
  52 object :: [Pair] -> Value
  53 object = Object
  54
  55 instance IsString Value where
  56   fromString = String
  57
  58 -- | A type that can be converted to JSON.
  59 class ToJSON a where
  60   -- | Convert a Haskell value to a JSON-friendly intermediate type.
  61   toJSON :: a -> Value
  62
  63 instance ToJSON () where
  64   toJSON () = Array []
  65
  66 instance ToJSON Value where
  67   toJSON = id
  68
  69 instance ToJSON Bool where
  70   toJSON = Bool
  71
  72 instance ToJSON a => ToJSON [a] where
  73   toJSON = Array . map toJSON
  74
  75 instance ToJSON a => ToJSON (Maybe a) where
  76   toJSON Nothing = Null
  77   toJSON (Just a) = toJSON a
  78
  79 instance (ToJSON a, ToJSON b) => ToJSON (a, b) where
  80   toJSON (a, b) = Array [toJSON a, toJSON b]
  81
  82 instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a, b, c) where
  83   toJSON (a, b, c) = Array [toJSON a, toJSON b, toJSON c]
  84
  85 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a, b, c, d) where
  86   toJSON (a, b, c, d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]
  87
  88 instance ToJSON Float where
  89   toJSON = Number . realToFrac
  90
  91 instance ToJSON Double where
  92   toJSON = Number
  93
  94 instance ToJSON Int where toJSON = Number . realToFrac
  95 instance ToJSON Int8 where toJSON = Number . realToFrac
  96 instance ToJSON Int16 where toJSON = Number . realToFrac
  97 instance ToJSON Int32 where toJSON = Number . realToFrac
  98
  99 instance ToJSON Word where toJSON = Number . realToFrac
 100 instance ToJSON Word8 where toJSON = Number . realToFrac
 101 instance ToJSON Word16 where toJSON = Number . realToFrac
 102 instance ToJSON Word32 where toJSON = Number . realToFrac
 103
 104 -- | Possibly lossy due to conversion to 'Double'
 105 instance ToJSON Int64 where toJSON = Number . realToFrac
 106
 107 -- | Possibly lossy due to conversion to 'Double'
 108 instance ToJSON Word64 where toJSON = Number . realToFrac
 109
 110 -- | Possibly lossy due to conversion to 'Double'
 111 instance ToJSON Integer where toJSON = Number . fromInteger
 112
 113 ------------------------------------------------------------------------------
 114 -- 'BB.Builder'-based encoding
 115
 116 -- | Serialise value as JSON/UTF8-encoded 'Builder'
 117 encodeToBuilder :: ToJSON a => a -> Builder
 118 encodeToBuilder = encodeValueBB . toJSON
 119
 120 encodeValueBB :: Value -> Builder
 121 encodeValueBB jv = case jv of
 122   Bool True -> "true"
 123   Bool False -> "false"
 124   Null -> "null"
 125   Number n
 126     | isNaN n || isInfinite n -> encodeValueBB Null
 127     | Just i <- doubleToInt64 n -> BB.int64Dec i
 128     | otherwise -> BB.doubleDec n
 129   Array a -> encodeArrayBB a
 130   String s -> encodeStringBB s
 131   Object o -> encodeObjectBB o
 132
 133 encodeArrayBB :: [Value] -> Builder
 134 encodeArrayBB [] = "[]"
 135 encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'
 136   where
 137     go = mconcat . intersperse (BB.char8 ',') . map encodeValueBB
 138
 139 encodeObjectBB :: Object -> Builder
 140 encodeObjectBB [] = "{}"
 141 encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'
 142   where
 143     go = mconcat . intersperse (BB.char8 ',') . map encPair
 144     encPair (l, x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x
 145
 146 encodeStringBB :: String -> Builder
 147 encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'
 148   where
 149     go = BB.stringUtf8 . escapeString
 150
 151 ------------------------------------------------------------------------------
 152 -- 'String'-based encoding
 153
 154 -- | Serialise value as JSON-encoded Unicode 'String'
 155 encodeToString :: ToJSON a => a -> String
 156 encodeToString jv = encodeValue (toJSON jv) []
 157
 158 encodeValue :: Value -> ShowS
 159 encodeValue jv = case jv of
 160   Bool b -> showString (if b then "true" else "false")
 161   Null -> showString "null"
 162   Number n
 163     | isNaN n || isInfinite n -> encodeValue Null
 164     | Just i <- doubleToInt64 n -> shows i
 165     | otherwise -> shows n
 166   Array a -> encodeArray a
 167   String s -> encodeString s
 168   Object o -> encodeObject o
 169
 170 encodeArray :: [Value] -> ShowS
 171 encodeArray [] = showString "[]"
 172 encodeArray jvs = ('[' :) . go jvs . (']' :)
 173   where
 174     go [] = id
 175     go [x] = encodeValue x
 176     go (x : xs) = encodeValue x . (',' :) . go xs
 177
 178 encodeObject :: Object -> ShowS
 179 encodeObject [] = showString "{}"
 180 encodeObject jvs = ('{' :) . go jvs . ('}' :)
 181   where
 182     go [] = id
 183     go [(l, x)] = encodeString l . (':' :) . encodeValue x
 184     go ((l, x) : lxs) = encodeString l . (':' :) . encodeValue x . (',' :) . go lxs
 185
 186 encodeString :: String -> ShowS
 187 encodeString str = ('"' :) . showString (escapeString str) . ('"' :)
 188
 189 ------------------------------------------------------------------------------
 190 -- helpers
 191
 192 -- | Try to convert 'Double' into 'Int64', return 'Nothing' if not
 193 -- representable loss-free as integral 'Int64' value.
 194 doubleToInt64 :: Double -> Maybe Int64
 195 doubleToInt64 x
 196   | fromInteger x' == x
 197   , x' <= toInteger (maxBound :: Int64)
 198   , x' >= toInteger (minBound :: Int64) =
 199       Just (fromIntegral x')
 200   | otherwise = Nothing
 201   where
 202     x' = round x
 203
 204 -- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"
 205 escapeString :: String -> String
 206 escapeString s
 207   | not (any needsEscape s) = s
 208   | otherwise = escape s
 209   where
 210     escape [] = []
 211     escape (x : xs) = case x of
 212       '\\' -> '\\' : '\\' : escape xs
 213       '"' -> '\\' : '"' : escape xs
 214       '\b' -> '\\' : 'b' : escape xs
 215       '\f' -> '\\' : 'f' : escape xs
 216       '\n' -> '\\' : 'n' : escape xs
 217       '\r' -> '\\' : 'r' : escape xs
 218       '\t' -> '\\' : 't' : escape xs
 219       c
 220         | ord c < 0x10 -> '\\' : 'u' : '0' : '0' : '0' : intToDigit (ord c) : escape xs
 221         | ord c < 0x20 -> '\\' : 'u' : '0' : '0' : '1' : intToDigit (ord c - 0x10) : escape xs
 222         | otherwise -> c : escape xs
 223
 224     -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF
 225     needsEscape c = ord c < 0x20 || c `elem` ['\\', '"']