1-- | Basic support for working with JSON values. 2 3module Text.JSON.String 4 ( 5 -- * Parsing 6 -- 7 GetJSON 8 , runGetJSON 9 10 -- ** Reading JSON 11 , readJSNull 12 , readJSBool 13 , readJSString 14 , readJSRational 15 , readJSArray 16 , readJSObject 17 18 , readJSValue 19 , readJSTopType 20 21 -- ** Writing JSON 22 , showJSNull 23 , showJSBool 24 , showJSArray 25 , showJSObject 26 , showJSRational 27 , showJSRational' 28 29 , showJSValue 30 , showJSTopType 31 ) where 32 33import Text.JSON.Types (JSValue(..), 34 JSString, toJSString, fromJSString, 35 JSObject, toJSObject, fromJSObject) 36 37import Control.Monad (liftM, ap) 38import qualified Control.Monad.Fail as Fail 39import Control.Applicative((<$>)) 40import qualified Control.Applicative as A 41import Data.Char (isSpace, isDigit, digitToInt) 42import Data.Ratio (numerator, denominator, (%)) 43import Numeric (readHex, readDec, showHex) 44 45-- ----------------------------------------------------------------- 46-- | Parsing JSON 47 48-- | The type of JSON parsers for String 49newtype GetJSON a = GetJSON { un :: String -> Either String (a,String) } 50 51instance Functor GetJSON where fmap = liftM 52instance A.Applicative GetJSON where 53 pure = return 54 (<*>) = ap 55 56instance Monad GetJSON where 57 return x = GetJSON (\s -> Right (x,s)) 58 GetJSON m >>= f = GetJSON (\s -> case m s of 59 Left err -> Left err 60 Right (a,s1) -> un (f a) s1) 61 62instance Fail.MonadFail GetJSON where 63 fail x = GetJSON (\_ -> Left x) 64 65-- | Run a JSON reader on an input String, returning some Haskell value. 66-- All input will be consumed. 67runGetJSON :: GetJSON a -> String -> Either String a 68runGetJSON (GetJSON m) s = case m s of 69 Left err -> Left err 70 Right (a,t) -> case t of 71 [] -> Right a 72 _ -> Left $ "Invalid tokens at end of JSON string: "++ show (take 10 t) 73 74getInput :: GetJSON String 75getInput = GetJSON (\s -> Right (s,s)) 76 77setInput :: String -> GetJSON () 78setInput s = GetJSON (\_ -> Right ((),s)) 79 80------------------------------------------------------------------------- 81 82-- | Find 8 chars context, for error messages 83context :: String -> String 84context s = take 8 s 85 86-- | Read the JSON null type 87readJSNull :: GetJSON JSValue 88readJSNull = do 89 xs <- getInput 90 case xs of 91 'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull 92 _ -> fail $ "Unable to parse JSON null: " ++ context xs 93 94tryJSNull :: GetJSON JSValue -> GetJSON JSValue 95tryJSNull k = do 96 xs <- getInput 97 case xs of 98 'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull 99 _ -> k 100 101-- | Read the JSON Bool type 102readJSBool :: GetJSON JSValue 103readJSBool = do 104 xs <- getInput 105 case xs of 106 't':'r':'u':'e':xs1 -> setInput xs1 >> return (JSBool True) 107 'f':'a':'l':'s':'e':xs1 -> setInput xs1 >> return (JSBool False) 108 _ -> fail $ "Unable to parse JSON Bool: " ++ context xs 109 110-- | Read the JSON String type 111readJSString :: GetJSON JSValue 112readJSString = do 113 x <- getInput 114 case x of 115 '"' : cs -> parse [] cs 116 _ -> fail $ "Malformed JSON: expecting string: " ++ context x 117 where 118 parse rs cs = 119 case cs of 120 '\\' : c : ds -> esc rs c ds 121 '"' : ds -> do setInput ds 122 return (JSString (toJSString (reverse rs))) 123 c : ds 124 | c >= '\x20' && c <= '\xff' -> parse (c:rs) ds 125 | c < '\x20' -> fail $ "Illegal unescaped character in string: " ++ context cs 126 | i <= 0x10ffff -> parse (c:rs) ds 127 | otherwise -> fail $ "Illegal unescaped character in string: " ++ context cs 128 where 129 i = (fromIntegral (fromEnum c) :: Integer) 130 _ -> fail $ "Unable to parse JSON String: unterminated String: " ++ context cs 131 132 esc rs c cs = case c of 133 '\\' -> parse ('\\' : rs) cs 134 '"' -> parse ('"' : rs) cs 135 'n' -> parse ('\n' : rs) cs 136 'r' -> parse ('\r' : rs) cs 137 't' -> parse ('\t' : rs) cs 138 'f' -> parse ('\f' : rs) cs 139 'b' -> parse ('\b' : rs) cs 140 '/' -> parse ('/' : rs) cs 141 'u' -> case cs of 142 d1 : d2 : d3 : d4 : cs' -> 143 case readHex [d1,d2,d3,d4] of 144 [(n,"")] -> parse (toEnum n : rs) cs' 145 146 x -> fail $ "Unable to parse JSON String: invalid hex: " ++ context (show x) 147 _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ context cs 148 _ -> fail $ "Unable to parse JSON String: invalid escape char: " ++ show c 149 150 151-- | Read an Integer or Double in JSON format, returning a Rational 152readJSRational :: GetJSON Rational 153readJSRational = do 154 cs <- getInput 155 case cs of 156 '-' : ds -> negate <$> pos ds 157 _ -> pos cs 158 159 where 160 pos [] = fail $ "Unable to parse JSON Rational: " ++ context [] 161 pos (c:cs) = 162 case c of 163 '0' -> frac 0 cs 164 _ 165 | not (isDigit c) -> fail $ "Unable to parse JSON Rational: " ++ context cs 166 | otherwise -> readDigits (digitToIntI c) cs 167 168 readDigits acc [] = frac (fromInteger acc) [] 169 readDigits acc (x:xs) 170 | isDigit x = let acc' = 10*acc + digitToIntI x in 171 acc' `seq` readDigits acc' xs 172 | otherwise = frac (fromInteger acc) (x:xs) 173 174 frac n ('.' : ds) = 175 case span isDigit ds of 176 ([],_) -> setInput ds >> return n 177 (as,bs) -> let x = read as :: Integer 178 y = 10 ^ (fromIntegral (length as) :: Integer) 179 in exponent' (n + (x % y)) bs 180 frac n cs = exponent' n cs 181 182 exponent' n (c:cs) 183 | c == 'e' || c == 'E' = (n*) <$> exp_num cs 184 exponent' n cs = setInput cs >> return n 185 186 exp_num :: String -> GetJSON Rational 187 exp_num ('+':cs) = exp_digs cs 188 exp_num ('-':cs) = recip <$> exp_digs cs 189 exp_num cs = exp_digs cs 190 191 exp_digs :: String -> GetJSON Rational 192 exp_digs cs = case readDec cs of 193 [(a,ds)] -> do setInput ds 194 return (fromIntegral ((10::Integer) ^ (a::Integer))) 195 _ -> fail $ "Unable to parse JSON exponential: " ++ context cs 196 197 digitToIntI :: Char -> Integer 198 digitToIntI ch = fromIntegral (digitToInt ch) 199 200 201-- | Read a list in JSON format 202readJSArray :: GetJSON JSValue 203readJSArray = readSequence '[' ']' ',' >>= return . JSArray 204 205-- | Read an object in JSON format 206readJSObject :: GetJSON JSValue 207readJSObject = readAssocs '{' '}' ',' >>= return . JSObject . toJSObject 208 209 210-- | Read a sequence of items 211readSequence :: Char -> Char -> Char -> GetJSON [JSValue] 212readSequence start end sep = do 213 zs <- getInput 214 case dropWhile isSpace zs of 215 c : cs | c == start -> 216 case dropWhile isSpace cs of 217 d : ds | d == end -> setInput (dropWhile isSpace ds) >> return [] 218 ds -> setInput ds >> parse [] 219 _ -> fail $ "Unable to parse JSON sequence: sequence stars with invalid character: " ++ context zs 220 221 where parse rs = rs `seq` do 222 a <- readJSValue 223 ds <- getInput 224 case dropWhile isSpace ds of 225 e : es | e == sep -> do setInput (dropWhile isSpace es) 226 parse (a:rs) 227 | e == end -> do setInput (dropWhile isSpace es) 228 return (reverse (a:rs)) 229 _ -> fail $ "Unable to parse JSON array: unterminated array: " ++ context ds 230 231 232-- | Read a sequence of JSON labelled fields 233readAssocs :: Char -> Char -> Char -> GetJSON [(String,JSValue)] 234readAssocs start end sep = do 235 zs <- getInput 236 case dropWhile isSpace zs of 237 c:cs | c == start -> case dropWhile isSpace cs of 238 d:ds | d == end -> setInput (dropWhile isSpace ds) >> return [] 239 ds -> setInput ds >> parsePairs [] 240 _ -> fail "Unable to parse JSON object: unterminated object" 241 242 where parsePairs rs = rs `seq` do 243 a <- do k <- do x <- readJSString ; case x of 244 JSString s -> return (fromJSString s) 245 _ -> fail $ "Malformed JSON field labels: object keys must be quoted strings." 246 ds <- getInput 247 case dropWhile isSpace ds of 248 ':':es -> do setInput (dropWhile isSpace es) 249 v <- readJSValue 250 return (k,v) 251 _ -> fail $ "Malformed JSON labelled field: " ++ context ds 252 253 ds <- getInput 254 case dropWhile isSpace ds of 255 e : es | e == sep -> do setInput (dropWhile isSpace es) 256 parsePairs (a:rs) 257 | e == end -> do setInput (dropWhile isSpace es) 258 return (reverse (a:rs)) 259 _ -> fail $ "Unable to parse JSON object: unterminated sequence: " 260 ++ context ds 261 262-- | Read one of several possible JS types 263readJSValue :: GetJSON JSValue 264readJSValue = do 265 cs <- getInput 266 case cs of 267 '"' : _ -> readJSString 268 '[' : _ -> readJSArray 269 '{' : _ -> readJSObject 270 't' : _ -> readJSBool 271 'f' : _ -> readJSBool 272 (x:_) | isDigit x || x == '-' -> JSRational False <$> readJSRational 273 xs -> tryJSNull 274 (fail $ "Malformed JSON: invalid token in this context " ++ context xs) 275 276-- | Top level JSON can only be Arrays or Objects 277readJSTopType :: GetJSON JSValue 278readJSTopType = do 279 cs <- getInput 280 case cs of 281 '[' : _ -> readJSArray 282 '{' : _ -> readJSObject 283 _ -> fail "Invalid JSON: a JSON text a serialized object or array at the top level." 284 285-- ----------------------------------------------------------------- 286-- | Writing JSON 287 288-- | Show strict JSON top level types. Values not permitted 289-- at the top level are wrapped in a singleton array. 290showJSTopType :: JSValue -> ShowS 291showJSTopType (JSArray a) = showJSArray a 292showJSTopType (JSObject o) = showJSObject o 293showJSTopType x = showJSTopType $ JSArray [x] 294 295-- | Show JSON values 296showJSValue :: JSValue -> ShowS 297showJSValue jv = 298 case jv of 299 JSNull{} -> showJSNull 300 JSBool b -> showJSBool b 301 JSRational asF r -> showJSRational' asF r 302 JSArray a -> showJSArray a 303 JSString s -> showJSString s 304 JSObject o -> showJSObject o 305 306-- | Write the JSON null type 307showJSNull :: ShowS 308showJSNull = showString "null" 309 310-- | Write the JSON Bool type 311showJSBool :: Bool -> ShowS 312showJSBool True = showString "true" 313showJSBool False = showString "false" 314 315-- | Write the JSON String type 316showJSString :: JSString -> ShowS 317showJSString x xs = quote (encJSString x (quote xs)) 318 where 319 quote = showChar '"' 320 321-- | Show a Rational in JSON format 322showJSRational :: Rational -> ShowS 323showJSRational r = showJSRational' False r 324 325showJSRational' :: Bool -> Rational -> ShowS 326showJSRational' asFloat r 327 | denominator r == 1 = shows $ numerator r 328 | isInfinite x || isNaN x = showJSNull 329 | asFloat = shows xf 330 | otherwise = shows x 331 where 332 x :: Double 333 x = realToFrac r 334 335 xf :: Float 336 xf = realToFrac r 337 338 339 340-- | Show a list in JSON format 341showJSArray :: [JSValue] -> ShowS 342showJSArray = showSequence '[' ']' ',' 343 344-- | Show an association list in JSON format 345showJSObject :: JSObject JSValue -> ShowS 346showJSObject = showAssocs '{' '}' ',' . fromJSObject 347 348-- | Show a generic sequence of pairs in JSON format 349showAssocs :: Char -> Char -> Char -> [(String,JSValue)] -> ShowS 350showAssocs start end sep xs rest = start : go xs 351 where 352 go [(k,v)] = '"' : encJSString (toJSString k) 353 ('"' : ':' : showJSValue v (go [])) 354 go ((k,v):kvs) = '"' : encJSString (toJSString k) 355 ('"' : ':' : showJSValue v (sep : go kvs)) 356 go [] = end : rest 357 358-- | Show a generic sequence in JSON format 359showSequence :: Char -> Char -> Char -> [JSValue] -> ShowS 360showSequence start end sep xs rest = start : go xs 361 where 362 go [y] = showJSValue y (go []) 363 go (y:ys) = showJSValue y (sep : go ys) 364 go [] = end : rest 365 366encJSString :: JSString -> ShowS 367encJSString jss ss = go (fromJSString jss) 368 where 369 go s1 = 370 case s1 of 371 (x :xs) | x < '\x20' -> '\\' : encControl x (go xs) 372 ('"' :xs) -> '\\' : '"' : go xs 373 ('\\':xs) -> '\\' : '\\' : go xs 374 (x :xs) -> x : go xs 375 "" -> ss 376 377 encControl x xs = case x of 378 '\b' -> 'b' : xs 379 '\f' -> 'f' : xs 380 '\n' -> 'n' : xs 381 '\r' -> 'r' : xs 382 '\t' -> 't' : xs 383 _ | x < '\x10' -> 'u' : '0' : '0' : '0' : hexxs 384 | x < '\x100' -> 'u' : '0' : '0' : hexxs 385 | x < '\x1000' -> 'u' : '0' : hexxs 386 | otherwise -> 'u' : hexxs 387 where hexxs = showHex (fromEnum x) xs 388 389