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