    -- | Basic support for working with JSON values.

    module Text.JSON.String
         (
           -- * Parsing
           --
           GetJSON
         , runGetJSON

           -- ** Reading JSON
         , readJSNull
         , readJSBool
         , readJSString
         , readJSRational
         , readJSArray
         , readJSObject

         , readJSValue
         , readJSTopType

           -- ** Writing JSON
         , showJSNull
         , showJSBool
         , showJSArray
         , showJSObject
         , showJSRational
         , showJSRational'

         , showJSValue
         , showJSTopType
         ) where

    import Text.JSON.Types (JSValue(..),
                            JSString, toJSString, fromJSString,
                            JSObject, toJSObject, fromJSObject)

    import Control.Monad (liftM, ap)
    import qualified Control.Monad.Fail as Fail
    import Control.Applicative((<$>))
    import qualified Control.Applicative as A
    import Data.Char (isSpace, isDigit, digitToInt)
    import Data.Ratio (numerator, denominator, (%))
    import Numeric (readHex, readDec, showHex)

    -- -----------------------------------------------------------------
    -- | Parsing JSON

    -- | The type of JSON parsers for String
    newtype GetJSON a = GetJSON { GetJSON a -> String -> Either String (a, String)
    un :: String -> Either String (a,String) }

    instance Functor GetJSON where fmap :: (a -> b) -> GetJSON a -> GetJSON b
    fmap = (a -> b) -> GetJSON a -> GetJSON b
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM
    instance A.Applicative GetJSON where
      pure :: a -> GetJSON a
    pure  = a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
      <*> :: GetJSON (a -> b) -> GetJSON a -> GetJSON b
    (<*>) = GetJSON (a -> b) -> GetJSON a -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Monad GetJSON where
      return :: a -> GetJSON a
    return x :: a
    x        = (String -> Either String (a, String)) -> GetJSON a
    forall a. (String -> Either String (a, String)) -> GetJSON a
    GetJSON (\s :: String
    s -> (a, String) -> Either String (a, String)
    forall a b. b -> Either a b
    Right (a
    x,String
    s))
      GetJSON m :: String -> Either String (a, String)
    m >>= :: GetJSON a -> (a -> GetJSON b) -> GetJSON b
    >>= f :: a -> GetJSON b
    f = (String -> Either String (b, String)) -> GetJSON b
    forall a. (String -> Either String (a, String)) -> GetJSON a
    GetJSON (\s :: String
    s -> case String -> Either String (a, String)
    m String
    s of
                                         Left err :: String
    err -> String -> Either String (b, String)
    forall a b. a -> Either a b
    Left String
    err
                                         Right (a :: a
    a,s1 :: String
    s1) -> GetJSON b -> String -> Either String (b, String)
    forall a. GetJSON a -> String -> Either String (a, String)
    un (a -> GetJSON b
    f a
    a) String
    s1)

    instance Fail.MonadFail GetJSON where
      fail :: String -> GetJSON a
    fail x :: String
    x          = (String -> Either String (a, String)) -> GetJSON a
    forall a. (String -> Either String (a, String)) -> GetJSON a
    GetJSON (\_ -> String -> Either String (a, String)
    forall a b. a -> Either a b
    Left String
    x)

    -- | Run a JSON reader on an input String, returning some Haskell value.
    -- All input will be consumed.
    runGetJSON :: GetJSON a -> String -> Either String a
    runGetJSON :: GetJSON a -> String -> Either String a
    runGetJSON (GetJSON m :: String -> Either String (a, String)
    m) s :: String
    s = case String -> Either String (a, String)
    m String
    s of
         Left err :: String
    err    -> String -> Either String a
    forall a b. a -> Either a b
    Left String
    err
         Right (a :: a
    a,t :: String
    t) -> case String
    t of
                            [] -> a -> Either String a
    forall a b. b -> Either a b
    Right a
    a
                            _  -> String -> Either String a
    forall a b. a -> Either a b
    Left (String -> Either String a) -> String -> Either String a
    forall a b. (a -> b) -> a -> b
    $ "Invalid tokens at end of JSON string: "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show (Int -> String -> String
    forall a. Int -> [a] -> [a]
    take 10 String
    t)

    getInput   :: GetJSON String
    getInput :: GetJSON String
    getInput    = (String -> Either String (String, String)) -> GetJSON String
    forall a. (String -> Either String (a, String)) -> GetJSON a
    GetJSON (\s :: String
    s -> (String, String) -> Either String (String, String)
    forall a b. b -> Either a b
    Right (String
    s,String
    s))

    setInput   :: String -> GetJSON ()
    setInput :: String -> GetJSON ()
    setInput s :: String
    s  = (String -> Either String ((), String)) -> GetJSON ()
    forall a. (String -> Either String (a, String)) -> GetJSON a
    GetJSON (\_ -> ((), String) -> Either String ((), String)
    forall a b. b -> Either a b
    Right ((),String
    s))

    -------------------------------------------------------------------------

    -- | Find 8 chars context, for error messages
    context :: String -> String
    context :: String -> String
    context s :: String
    s = Int -> String -> String
    forall a. Int -> [a] -> [a]
    take 8 String
    s

    -- | Read the JSON null type
    readJSNull :: GetJSON JSValue
    readJSNull :: GetJSON JSValue
    readJSNull = do
      String
    xs <- GetJSON String
    getInput
      case String
    xs of
        'n':'u':'l':'l':xs1 :: String
    xs1 -> String -> GetJSON ()
    setInput String
    xs1 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> JSValue -> GetJSON JSValue
    forall (m :: * -> *) a. Monad m => a -> m a
    return JSValue
    JSNull
        _ -> String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON null: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    xs

    tryJSNull :: GetJSON JSValue -> GetJSON JSValue
    tryJSNull :: GetJSON JSValue -> GetJSON JSValue
    tryJSNull k :: GetJSON JSValue
    k = do
      String
    xs <- GetJSON String
    getInput
      case String
    xs of
        'n':'u':'l':'l':xs1 :: String
    xs1 -> String -> GetJSON ()
    setInput String
    xs1 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> JSValue -> GetJSON JSValue
    forall (m :: * -> *) a. Monad m => a -> m a
    return JSValue
    JSNull
        _ -> GetJSON JSValue
    k

    -- | Read the JSON Bool type
    readJSBool :: GetJSON JSValue
    readJSBool :: GetJSON JSValue
    readJSBool = do
      String
    xs <- GetJSON String
    getInput
      case String
    xs of
        't':'r':'u':'e':xs1 :: String
    xs1 -> String -> GetJSON ()
    setInput String
    xs1 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> JSValue -> GetJSON JSValue
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> JSValue
    JSBool Bool
    True)
        'f':'a':'l':'s':'e':xs1 :: String
    xs1 -> String -> GetJSON ()
    setInput String
    xs1 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> JSValue -> GetJSON JSValue
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> JSValue
    JSBool Bool
    False)
        _ -> String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON Bool: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    xs

    -- | Read the JSON String type
    readJSString :: GetJSON JSValue
    readJSString :: GetJSON JSValue
    readJSString = do
      String
    x <- GetJSON String
    getInput
      case String
    x of
           '"' : cs :: String
    cs -> String -> String -> GetJSON JSValue
    parse [] String
    cs
           _        -> String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Malformed JSON: expecting string: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    x
     where
      parse :: String -> String -> GetJSON JSValue
    parse rs :: String
    rs cs :: String
    cs =
        case String
    cs of
          '\\' : c :: Char
    c : ds :: String
    ds -> String -> Char -> String -> GetJSON JSValue
    esc String
    rs Char
    c String
    ds
          '"'  : ds :: String
    ds     -> do String -> GetJSON ()
    setInput String
    ds
                              JSValue -> GetJSON JSValue
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSString -> JSValue
    JSString (String -> JSString
    toJSString (String -> String
    forall a. [a] -> [a]
    reverse String
    rs)))
          c :: Char
    c    : ds :: String
    ds
           | Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    >= '\x20' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    <= '\xff'    -> String -> String -> GetJSON JSValue
    parse (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    rs) String
    ds
           | Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    < '\x20'     -> String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Illegal unescaped character in string: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    cs
           | Integer
    i Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    <= 0x10ffff  -> String -> String -> GetJSON JSValue
    parse (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    rs) String
    ds
           | Bool
    otherwise -> String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Illegal unescaped character in string: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    cs
           where
            i :: Integer
    i = (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Char -> Int
    forall a. Enum a => a -> Int
    fromEnum Char
    c) :: Integer)
          _ -> String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON String: unterminated String: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    cs

      esc :: String -> Char -> String -> GetJSON JSValue
    esc rs :: String
    rs c :: Char
    c cs :: String
    cs = case Char
    c of
       '\\' -> String -> String -> GetJSON JSValue
    parse ('\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       '"'  -> String -> String -> GetJSON JSValue
    parse ('"'  Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       'n'  -> String -> String -> GetJSON JSValue
    parse ('\n' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       'r'  -> String -> String -> GetJSON JSValue
    parse ('\r' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       't'  -> String -> String -> GetJSON JSValue
    parse ('\t' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       'f'  -> String -> String -> GetJSON JSValue
    parse ('\f' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       'b'  -> String -> String -> GetJSON JSValue
    parse ('\b' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       '/'  -> String -> String -> GetJSON JSValue
    parse ('/'  Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       'u'  -> case String
    cs of
                 d1 :: Char
    d1 : d2 :: Char
    d2 : d3 :: Char
    d3 : d4 :: Char
    d4 : cs' :: String
    cs' ->
                   case ReadS Int
    forall a. (Eq a, Num a) => ReadS a
    readHex [Char
    d1,Char
    d2,Char
    d3,Char
    d4] of
                     [(n :: Int
    n,"")] -> String -> String -> GetJSON JSValue
    parse (Int -> Char
    forall a. Enum a => Int -> a
    toEnum Int
    n Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs'

                     x :: [(Int, String)]
    x -> String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON String: invalid hex: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context ([(Int, String)] -> String
    forall a. Show a => a -> String
    show [(Int, String)]
    x)
                 _ -> String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON String: invalid hex: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    cs
       _ ->  String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON String: invalid escape char: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Char -> String
    forall a. Show a => a -> String
    show Char
    c

    -- | Read an Integer or Double in JSON format, returning a Rational
    readJSRational :: GetJSON Rational
    readJSRational :: GetJSON Rational
    readJSRational = do
      String
    cs <- GetJSON String
    getInput
      case String
    cs of
        '-' : ds :: String
    ds -> Rational -> Rational
    forall a. Num a => a -> a
    negate (Rational -> Rational) -> GetJSON Rational -> GetJSON Rational
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> GetJSON Rational
    pos String
    ds
        _        -> String -> GetJSON Rational
    pos String
    cs

      where
       pos :: String -> GetJSON Rational
    pos []     = String -> GetJSON Rational
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON Rational) -> String -> GetJSON Rational
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON Rational: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context []
       pos (c :: Char
    c:cs :: String
    cs) =
         case Char
    c of
           '0' -> Rational -> String -> GetJSON Rational
    frac 0 String
    cs
           _
            | Bool -> Bool
    not (Char -> Bool
    isDigit Char
    c) -> String -> GetJSON Rational
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON Rational) -> String -> GetJSON Rational
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON Rational: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    cs
            | Bool
    otherwise -> Integer -> String -> GetJSON Rational
    readDigits (Char -> Integer
    digitToIntI Char
    c) String
    cs

       readDigits :: Integer -> String -> GetJSON Rational
    readDigits acc :: Integer
    acc [] = Rational -> String -> GetJSON Rational
    frac (Integer -> Rational
    forall a. Num a => Integer -> a
    fromInteger Integer
    acc) []
       readDigits acc :: Integer
    acc (x :: Char
    x:xs :: String
    xs)
        | Char -> Bool
    isDigit Char
    x = let acc' :: Integer
    acc' = 10Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    *Integer
    acc Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    + Char -> Integer
    digitToIntI Char
    x in
                          Integer
    acc' Integer -> GetJSON Rational -> GetJSON Rational
    forall a b. a -> b -> b
    `seq` Integer -> String -> GetJSON Rational
    readDigits Integer
    acc' String
    xs
        | Bool
    otherwise = Rational -> String -> GetJSON Rational
    frac (Integer -> Rational
    forall a. Num a => Integer -> a
    fromInteger Integer
    acc) (Char
    xChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    xs)

       frac :: Rational -> String -> GetJSON Rational
    frac n :: Rational
    n ('.' : ds :: String
    ds) =
           case (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    span Char -> Bool
    isDigit String
    ds of
             ([],_) -> String -> GetJSON ()
    setInput String
    ds GetJSON () -> GetJSON Rational -> GetJSON Rational
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Rational -> GetJSON Rational
    forall (m :: * -> *) a. Monad m => a -> m a
    return Rational
    n
             (as :: String
    as,bs :: String
    bs) -> let x :: Integer
    x = String -> Integer
    forall a. Read a => String -> a
    read String
    as :: Integer
                            y :: Integer
    y = 10 Integer -> Integer -> Integer
    forall a b. (Num a, Integral b) => a -> b -> a
    ^ (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (String -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    as) :: Integer)
                        in Rational -> String -> GetJSON Rational
    exponent' (Rational
    n Rational -> Rational -> Rational
    forall a. Num a => a -> a -> a
    + (Integer
    x Integer -> Integer -> Rational
    forall a. Integral a => a -> a -> Ratio a
    % Integer
    y)) String
    bs
       frac n :: Rational
    n cs :: String
    cs = Rational -> String -> GetJSON Rational
    exponent' Rational
    n String
    cs

       exponent' :: Rational -> String -> GetJSON Rational
    exponent' n :: Rational
    n (c :: Char
    c:cs :: String
    cs)
        | Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == 'e' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == 'E' = (Rational
    nRational -> Rational -> Rational
    forall a. Num a => a -> a -> a
    *) (Rational -> Rational) -> GetJSON Rational -> GetJSON Rational
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> GetJSON Rational
    exp_num String
    cs
       exponent' n :: Rational
    n cs :: String
    cs = String -> GetJSON ()
    setInput String
    cs GetJSON () -> GetJSON Rational -> GetJSON Rational
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Rational -> GetJSON Rational
    forall (m :: * -> *) a. Monad m => a -> m a
    return Rational
    n

       exp_num          :: String -> GetJSON Rational
       exp_num :: String -> GetJSON Rational
    exp_num ('+':cs :: String
    cs)  = String -> GetJSON Rational
    exp_digs String
    cs
       exp_num ('-':cs :: String
    cs)  = Rational -> Rational
    forall a. Fractional a => a -> a
    recip (Rational -> Rational) -> GetJSON Rational -> GetJSON Rational
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> GetJSON Rational
    exp_digs String
    cs
       exp_num cs :: String
    cs        = String -> GetJSON Rational
    exp_digs String
    cs

       exp_digs :: String -> GetJSON Rational
       exp_digs :: String -> GetJSON Rational
    exp_digs cs :: String
    cs = case ReadS Integer
    forall a. (Eq a, Num a) => ReadS a
    readDec String
    cs of
           [(a :: Integer
    a,ds :: String
    ds)] -> do String -> GetJSON ()
    setInput String
    ds
                          Rational -> GetJSON Rational
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Integer -> Rational
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral ((10::Integer) Integer -> Integer -> Integer
    forall a b. (Num a, Integral b) => a -> b -> a
    ^ (Integer
    a::Integer)))
           _        -> String -> GetJSON Rational
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON Rational) -> String -> GetJSON Rational
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON exponential: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    cs

       digitToIntI :: Char -> Integer
       digitToIntI :: Char -> Integer
    digitToIntI ch :: Char
    ch = Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Char -> Int
    digitToInt Char
    ch)

    -- | Read a list in JSON format
    readJSArray  :: GetJSON JSValue
    readJSArray :: GetJSON JSValue
    readJSArray  = Char -> Char -> Char -> GetJSON [JSValue]
    readSequence '[' ']' ',' GetJSON [JSValue]
    -> ([JSValue] -> GetJSON JSValue) -> GetJSON JSValue
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= JSValue -> GetJSON JSValue
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSValue -> GetJSON JSValue)
    -> ([JSValue] -> JSValue) -> [JSValue] -> GetJSON JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [JSValue] -> JSValue
    JSArray

    -- | Read an object in JSON format
    readJSObject :: GetJSON JSValue
    readJSObject :: GetJSON JSValue
    readJSObject = Char -> Char -> Char -> GetJSON [(String, JSValue)]
    readAssocs '{' '}' ',' GetJSON [(String, JSValue)]
    -> ([(String, JSValue)] -> GetJSON JSValue) -> GetJSON JSValue
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= JSValue -> GetJSON JSValue
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSValue -> GetJSON JSValue)
    -> ([(String, JSValue)] -> JSValue)
    -> [(String, JSValue)]
    -> GetJSON JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . JSObject JSValue -> JSValue
    JSObject (JSObject JSValue -> JSValue)
    -> ([(String, JSValue)] -> JSObject JSValue)
    -> [(String, JSValue)]
    -> JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(String, JSValue)] -> JSObject JSValue
    forall a. [(String, a)] -> JSObject a
    toJSObject

    -- | Read a sequence of items
    readSequence :: Char -> Char -> Char -> GetJSON [JSValue]
    readSequence :: Char -> Char -> Char -> GetJSON [JSValue]
    readSequence start :: Char
    start end :: Char
    end sep :: Char
    sep = do
      String
    zs <- GetJSON String
    getInput
      case (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    zs of
        c :: Char
    c : cs :: String
    cs | Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    start ->
            case (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    cs of
                d :: Char
    d : ds :: String
    ds | Char
    d Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    end -> String -> GetJSON ()
    setInput ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    ds) GetJSON () -> GetJSON [JSValue] -> GetJSON [JSValue]
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [JSValue] -> GetJSON [JSValue]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                ds :: String
    ds                -> String -> GetJSON ()
    setInput String
    ds GetJSON () -> GetJSON [JSValue] -> GetJSON [JSValue]
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [JSValue] -> GetJSON [JSValue]
    parse []
        _ -> String -> GetJSON [JSValue]
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON [JSValue]) -> String -> GetJSON [JSValue]
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON sequence: sequence stars with invalid character: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    zs

      where parse :: [JSValue] -> GetJSON [JSValue]
    parse rs :: [JSValue]
    rs = [JSValue]
    rs [JSValue] -> GetJSON [JSValue] -> GetJSON [JSValue]
    forall a b. a -> b -> b
    `seq` do
              JSValue
    a  <- GetJSON JSValue
    readJSValue
              String
    ds <- GetJSON String
    getInput
              case (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    ds of
                e :: Char
    e : es :: String
    es | Char
    e Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    sep -> do String -> GetJSON ()
    setInput ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    es)
                                        [JSValue] -> GetJSON [JSValue]
    parse (JSValue
    aJSValue -> [JSValue] -> [JSValue]
    forall a. a -> [a] -> [a]
    :[JSValue]
    rs)
                       | Char
    e Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    end -> do String -> GetJSON ()
    setInput ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    es)
                                        [JSValue] -> GetJSON [JSValue]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([JSValue] -> [JSValue]
    forall a. [a] -> [a]
    reverse (JSValue
    aJSValue -> [JSValue] -> [JSValue]
    forall a. a -> [a] -> [a]
    :[JSValue]
    rs))
                _ -> String -> GetJSON [JSValue]
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON [JSValue]) -> String -> GetJSON [JSValue]
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON array: unterminated array: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    ds

    -- | Read a sequence of JSON labelled fields
    readAssocs :: Char -> Char -> Char -> GetJSON [(String,JSValue)]
    readAssocs :: Char -> Char -> Char -> GetJSON [(String, JSValue)]
    readAssocs start :: Char
    start end :: Char
    end sep :: Char
    sep = do
      String
    zs <- GetJSON String
    getInput
      case (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    zs of
        c :: Char
    c:cs :: String
    cs | Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    start -> case (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    cs of
                d :: Char
    d:ds :: String
    ds | Char
    d Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    end -> String -> GetJSON ()
    setInput ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    ds) GetJSON ()
    -> GetJSON [(String, JSValue)] -> GetJSON [(String, JSValue)]
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [(String, JSValue)] -> GetJSON [(String, JSValue)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                ds :: String
    ds              -> String -> GetJSON ()
    setInput String
    ds GetJSON ()
    -> GetJSON [(String, JSValue)] -> GetJSON [(String, JSValue)]
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [(String, JSValue)] -> GetJSON [(String, JSValue)]
    parsePairs []
        _ -> String -> GetJSON [(String, JSValue)]
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail "Unable to parse JSON object: unterminated object"

      where parsePairs :: [(String, JSValue)] -> GetJSON [(String, JSValue)]
    parsePairs rs :: [(String, JSValue)]
    rs = [(String, JSValue)]
    rs [(String, JSValue)]
    -> GetJSON [(String, JSValue)] -> GetJSON [(String, JSValue)]
    forall a b. a -> b -> b
    `seq` do
              (String, JSValue)
    a  <- do String
    k  <- do JSValue
    x <- GetJSON JSValue
    readJSString ; case JSValue
    x of
                                    JSString s :: JSString
    s -> String -> GetJSON String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSString -> String
    fromJSString JSString
    s)
                                    _          -> String -> GetJSON String
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON String) -> String -> GetJSON String
    forall a b. (a -> b) -> a -> b
    $ "Malformed JSON field labels: object keys must be quoted strings."
                       String
    ds <- GetJSON String
    getInput
                       case (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    ds of
                           ':':es :: String
    es -> do String -> GetJSON ()
    setInput ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    es)
                                        JSValue
    v <- GetJSON JSValue
    readJSValue
                                        (String, JSValue) -> GetJSON (String, JSValue)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String
    k,JSValue
    v)
                           _      -> String -> GetJSON (String, JSValue)
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON (String, JSValue))
    -> String -> GetJSON (String, JSValue)
    forall a b. (a -> b) -> a -> b
    $ "Malformed JSON labelled field: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    ds

              String
    ds <- GetJSON String
    getInput
              case (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    ds of
                e :: Char
    e : es :: String
    es | Char
    e Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    sep -> do String -> GetJSON ()
    setInput ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    es)
                                        [(String, JSValue)] -> GetJSON [(String, JSValue)]
    parsePairs ((String, JSValue)
    a(String, JSValue) -> [(String, JSValue)] -> [(String, JSValue)]
    forall a. a -> [a] -> [a]
    :[(String, JSValue)]
    rs)
                       | Char
    e Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    end -> do String -> GetJSON ()
    setInput ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    es)
                                        [(String, JSValue)] -> GetJSON [(String, JSValue)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([(String, JSValue)] -> [(String, JSValue)]
    forall a. [a] -> [a]
    reverse ((String, JSValue)
    a(String, JSValue) -> [(String, JSValue)] -> [(String, JSValue)]
    forall a. a -> [a] -> [a]
    :[(String, JSValue)]
    rs))
                _ -> String -> GetJSON [(String, JSValue)]
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON [(String, JSValue)])
    -> String -> GetJSON [(String, JSValue)]
    forall a b. (a -> b) -> a -> b
    $ "Unable to parse JSON object: unterminated sequence: "
                                String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    ds

    -- | Read one of several possible JS types
    readJSValue :: GetJSON JSValue
    readJSValue :: GetJSON JSValue
    readJSValue = do
      String
    cs <- GetJSON String
    getInput
      case String
    cs of
        '"' : _ -> GetJSON JSValue
    readJSString
        '[' : _ -> GetJSON JSValue
    readJSArray
        '{' : _ -> GetJSON JSValue
    readJSObject
        't' : _ -> GetJSON JSValue
    readJSBool
        'f' : _ -> GetJSON JSValue
    readJSBool
        (x :: Char
    x:_) | Char -> Bool
    isDigit Char
    x Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == '-' -> Bool -> Rational -> JSValue
    JSRational Bool
    False (Rational -> JSValue) -> GetJSON Rational -> GetJSON JSValue
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GetJSON Rational
    readJSRational
        xs :: String
    xs -> GetJSON JSValue -> GetJSON JSValue
    tryJSNull
                 (String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ "Malformed JSON: invalid token in this context " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    xs)

    -- | Top level JSON can only be Arrays or Objects
    readJSTopType :: GetJSON JSValue
    readJSTopType :: GetJSON JSValue
    readJSTopType = do
      String
    cs <- GetJSON String
    getInput
      case String
    cs of
        '[' : _ -> GetJSON JSValue
    readJSArray
        '{' : _ -> GetJSON JSValue
    readJSObject
        _       -> String -> GetJSON JSValue
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail "Invalid JSON: a JSON text a serialized object or array at the top level."

    -- -----------------------------------------------------------------
    -- | Writing JSON

    -- | Show strict JSON top level types. Values not permitted
    -- at the top level are wrapped in a singleton array.
    showJSTopType :: JSValue -> ShowS
    showJSTopType :: JSValue -> String -> String
    showJSTopType (JSArray a :: [JSValue]
    a)    = [JSValue] -> String -> String
    showJSArray [JSValue]
    a
    showJSTopType (JSObject o :: JSObject JSValue
    o)   = JSObject JSValue -> String -> String
    showJSObject JSObject JSValue
    o
    showJSTopType x :: JSValue
    x              = JSValue -> String -> String
    showJSTopType (JSValue -> String -> String) -> JSValue -> String -> String
    forall a b. (a -> b) -> a -> b
    $ [JSValue] -> JSValue
    JSArray [JSValue
    x]

    -- | Show JSON values
    showJSValue :: JSValue -> ShowS
    showJSValue :: JSValue -> String -> String
    showJSValue jv :: JSValue
    jv =
      case JSValue
    jv of
        JSNull{}         -> String -> String
    showJSNull
        JSBool b :: Bool
    b         -> Bool -> String -> String
    showJSBool Bool
    b
        JSRational asF :: Bool
    asF r :: Rational
    r -> Bool -> Rational -> String -> String
    showJSRational' Bool
    asF Rational
    r
        JSArray a :: [JSValue]
    a        -> [JSValue] -> String -> String
    showJSArray [JSValue]
    a
        JSString s :: JSString
    s       -> JSString -> String -> String
    showJSString JSString
    s
        JSObject o :: JSObject JSValue
    o       -> JSObject JSValue -> String -> String
    showJSObject JSObject JSValue
    o

    -- | Write the JSON null type
    showJSNull :: ShowS
    showJSNull :: String -> String
    showJSNull = String -> String -> String
    showString "null"

    -- | Write the JSON Bool type
    showJSBool :: Bool -> ShowS
    showJSBool :: Bool -> String -> String
    showJSBool True  = String -> String -> String
    showString "true"
    showJSBool False = String -> String -> String
    showString "false"

    -- | Write the JSON String type
    showJSString :: JSString -> ShowS
    showJSString :: JSString -> String -> String
    showJSString x :: JSString
    x xs :: String
    xs = String -> String
    quote (JSString -> String -> String
    encJSString JSString
    x (String -> String
    quote String
    xs))
      where
            quote :: String -> String
    quote = Char -> String -> String
    showChar '"'

    -- | Show a Rational in JSON format
    showJSRational :: Rational -> ShowS
    showJSRational :: Rational -> String -> String
    showJSRational r :: Rational
    r = Bool -> Rational -> String -> String
    showJSRational' Bool
    False Rational
    r

    showJSRational' :: Bool -> Rational -> ShowS
    showJSRational' :: Bool -> Rational -> String -> String
    showJSRational' asFloat :: Bool
    asFloat r :: Rational
    r
     | Rational -> Integer
    forall a. Ratio a -> a
    denominator Rational
    r Integer -> Integer -> Bool
    forall a. Eq a => a -> a -> Bool
    == 1      = Integer -> String -> String
    forall a. Show a => a -> String -> String
    shows (Integer -> String -> String) -> Integer -> String -> String
    forall a b. (a -> b) -> a -> b
    $ Rational -> Integer
    forall a. Ratio a -> a
    numerator Rational
    r
     | Double -> Bool
    forall a. RealFloat a => a -> Bool
    isInfinite Double
    x Bool -> Bool -> Bool
    || Double -> Bool
    forall a. RealFloat a => a -> Bool
    isNaN Double
    x = String -> String
    showJSNull
     | Bool
    asFloat                 = Float -> String -> String
    forall a. Show a => a -> String -> String
    shows Float
    xf
     | Bool
    otherwise               = Double -> String -> String
    forall a. Show a => a -> String -> String
    shows Double
    x
     where
       x :: Double
       x :: Double
    x = Rational -> Double
    forall a b. (Real a, Fractional b) => a -> b
    realToFrac Rational
    r

       xf :: Float
       xf :: Float
    xf = Rational -> Float
    forall a b. (Real a, Fractional b) => a -> b
    realToFrac Rational
    r

    -- | Show a list in JSON format
    showJSArray :: [JSValue] -> ShowS
    showJSArray :: [JSValue] -> String -> String
    showJSArray = Char -> Char -> Char -> [JSValue] -> String -> String
    showSequence '[' ']' ','

    -- | Show an association list in JSON format
    showJSObject :: JSObject JSValue -> ShowS
    showJSObject :: JSObject JSValue -> String -> String
    showJSObject = Char -> Char -> Char -> [(String, JSValue)] -> String -> String
    showAssocs '{' '}' ',' ([(String, JSValue)] -> String -> String)
    -> (JSObject JSValue -> [(String, JSValue)])
    -> JSObject JSValue
    -> String
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . JSObject JSValue -> [(String, JSValue)]
    forall e. JSObject e -> [(String, e)]
    fromJSObject

    -- | Show a generic sequence of pairs in JSON format
    showAssocs :: Char -> Char -> Char -> [(String,JSValue)] -> ShowS
    showAssocs :: Char -> Char -> Char -> [(String, JSValue)] -> String -> String
    showAssocs start :: Char
    start end :: Char
    end sep :: Char
    sep xs :: [(String, JSValue)]
    xs rest :: String
    rest = Char
    start Char -> String -> String
    forall a. a -> [a] -> [a]
    : [(String, JSValue)] -> String
    go [(String, JSValue)]
    xs
      where
      go :: [(String, JSValue)] -> String
    go [(k :: String
    k,v :: JSValue
    v)]     = '"' Char -> String -> String
    forall a. a -> [a] -> [a]
    : JSString -> String -> String
    encJSString (String -> JSString
    toJSString String
    k)
                                ('"' Char -> String -> String
    forall a. a -> [a] -> [a]
    : ':' Char -> String -> String
    forall a. a -> [a] -> [a]
    : JSValue -> String -> String
    showJSValue JSValue
    v ([(String, JSValue)] -> String
    go []))
      go ((k :: String
    k,v :: JSValue
    v):kvs :: [(String, JSValue)]
    kvs) = '"' Char -> String -> String
    forall a. a -> [a] -> [a]
    : JSString -> String -> String
    encJSString (String -> JSString
    toJSString String
    k)
                                ('"' Char -> String -> String
    forall a. a -> [a] -> [a]
    : ':' Char -> String -> String
    forall a. a -> [a] -> [a]
    : JSValue -> String -> String
    showJSValue JSValue
    v (Char
    sep Char -> String -> String
    forall a. a -> [a] -> [a]
    : [(String, JSValue)] -> String
    go [(String, JSValue)]
    kvs))
      go []          = Char
    end Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rest

    -- | Show a generic sequence in JSON format
    showSequence :: Char -> Char -> Char -> [JSValue] -> ShowS
    showSequence :: Char -> Char -> Char -> [JSValue] -> String -> String
    showSequence start :: Char
    start end :: Char
    end sep :: Char
    sep xs :: [JSValue]
    xs rest :: String
    rest = Char
    start Char -> String -> String
    forall a. a -> [a] -> [a]
    : [JSValue] -> String
    go [JSValue]
    xs
      where
      go :: [JSValue] -> String
    go [y :: JSValue
    y]        = JSValue -> String -> String
    showJSValue JSValue
    y ([JSValue] -> String
    go [])
      go (y :: JSValue
    y:ys :: [JSValue]
    ys)     = JSValue -> String -> String
    showJSValue JSValue
    y (Char
    sep Char -> String -> String
    forall a. a -> [a] -> [a]
    : [JSValue] -> String
    go [JSValue]
    ys)
      go []         = Char
    end Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rest

    encJSString :: JSString -> ShowS
    encJSString :: JSString -> String -> String
    encJSString jss :: JSString
    jss ss :: String
    ss = String -> String
    go (JSString -> String
    fromJSString JSString
    jss)
      where
      go :: String -> String
    go s1 :: String
    s1 =
        case String
    s1 of
          (x :: Char
    x   :xs :: String
    xs) | Char
    x Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    < '\x20' -> '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char -> String -> String
    encControl Char
    x (String -> String
    go String
    xs)
          ('"' :xs :: String
    xs)              -> '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : '"'  Char -> String -> String
    forall a. a -> [a] -> [a]
    : String -> String
    go String
    xs
          ('\\':xs :: String
    xs)              -> '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String -> String
    go String
    xs
          (x :: Char
    x   :xs :: String
    xs)              -> Char
    x    Char -> String -> String
    forall a. a -> [a] -> [a]
    : String -> String
    go String
    xs
          ""                     -> String
    ss

      encControl :: Char -> String -> String
    encControl x :: Char
    x xs :: String
    xs = case Char
    x of
        '\b' -> 'b' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    xs
        '\f' -> 'f' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    xs
        '\n' -> 'n' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    xs
        '\r' -> 'r' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    xs
        '\t' -> 't' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    xs
        _ | Char
    x Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    < '\x10'   -> 'u' Char -> String -> String
    forall a. a -> [a] -> [a]
    : '0' Char -> String -> String
    forall a. a -> [a] -> [a]
    : '0' Char -> String -> String
    forall a. a -> [a] -> [a]
    : '0' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    hexxs
          | Char
    x Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    < '\x100'  -> 'u' Char -> String -> String
    forall a. a -> [a] -> [a]
    : '0' Char -> String -> String
    forall a. a -> [a] -> [a]
    : '0' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    hexxs
          | Char
    x Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    < '\x1000' -> 'u' Char -> String -> String
    forall a. a -> [a] -> [a]
    : '0' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    hexxs
          | Bool
    otherwise    -> 'u' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    hexxs
          where hexxs :: String
    hexxs = Int -> String -> String
    forall a. (Integral a, Show a) => a -> String -> String
    showHex (Char -> Int
    forall a. Enum a => a -> Int
    fromEnum Char
    x) String
    xs