    -- | 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 Prelude hiding (fail)
    import Text.JSON.Types (JSValue(..),
                            JSString, toJSString, fromJSString,
                            JSObject, toJSObject, fromJSObject)

    import Control.Monad (liftM, ap)
    import Control.Monad.Fail (MonadFail (..))
    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, readSigned, readFloat)

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

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

    instance Functor GetJSON where fmap :: forall a b. (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 :: forall a. a -> GetJSON a
    pure  = a -> GetJSON a
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
      <*> :: forall a b. 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 :: forall a. a -> GetJSON a
    return a
    x        = (String -> Either String (a, String)) -> GetJSON a
    forall a. (String -> Either String (a, String)) -> GetJSON a
    GetJSON (\String
    s -> (a, String) -> Either String (a, String)
    forall a b. b -> Either a b
    Right (a
    x,String
    s))
      GetJSON String -> Either String (a, String)
    m >>= :: forall a b. GetJSON a -> (a -> GetJSON b) -> GetJSON b
    >>= a -> GetJSON b
    f = (String -> Either String (b, String)) -> GetJSON b
    forall a. (String -> Either String (a, String)) -> GetJSON a
    GetJSON (\String
    s -> case String -> Either String (a, String)
    m String
    s of
                                         Left String
    err -> String -> Either String (b, String)
    forall a b. a -> Either a b
    Left String
    err
                                         Right (a
    a,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 MonadFail GetJSON where
      fail :: forall a. String -> GetJSON a
    fail String
    x          = (String -> Either String (a, String)) -> GetJSON a
    forall a. (String -> Either String (a, String)) -> GetJSON a
    GetJSON (\String
    _ -> 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 :: forall a. GetJSON a -> String -> Either String a
    runGetJSON (GetJSON String -> Either String (a, String)
    m) String
    s = case String -> Either String (a, String)
    m String
    s of
         Left String
    err    -> String -> Either String a
    forall a b. a -> Either a b
    Left String
    err
         Right (a
    a,String
    t) -> case String
    t of
                            [] -> a -> Either String a
    forall a b. b -> Either a b
    Right a
    a
                            String
    _  -> 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
    $ String
    "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 Int
    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 (\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 String
    s  = (String -> Either String ((), String)) -> GetJSON ()
    forall a. (String -> Either String (a, String)) -> GetJSON a
    GetJSON (\String
    _ -> ((), 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 String
    s = Int -> String -> String
    forall a. Int -> [a] -> [a]
    take Int
    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
        Char
    'n':Char
    'u':Char
    'l':Char
    'l':String
    xs1 -> String -> GetJSON ()
    setInput String
    xs1 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
    forall a b. GetJSON a -> GetJSON b -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> JSValue -> GetJSON JSValue
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return JSValue
    JSNull
        String
    _ -> String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "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 GetJSON JSValue
    k = do
      String
    xs <- GetJSON String
    getInput
      case String
    xs of
        Char
    'n':Char
    'u':Char
    'l':Char
    'l':String
    xs1 -> String -> GetJSON ()
    setInput String
    xs1 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
    forall a b. GetJSON a -> GetJSON b -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> JSValue -> GetJSON JSValue
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return JSValue
    JSNull
        String
    _ -> 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
        Char
    't':Char
    'r':Char
    'u':Char
    'e':String
    xs1 -> String -> GetJSON ()
    setInput String
    xs1 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
    forall a b. GetJSON a -> GetJSON b -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> JSValue -> GetJSON JSValue
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> JSValue
    JSBool Bool
    True)
        Char
    'f':Char
    'a':Char
    'l':Char
    's':Char
    'e':String
    xs1 -> String -> GetJSON ()
    setInput String
    xs1 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
    forall a b. GetJSON a -> GetJSON b -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> JSValue -> GetJSON JSValue
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> JSValue
    JSBool Bool
    False)
        String
    _ -> String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "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
           Char
    '"' : String
    cs -> String -> String -> GetJSON JSValue
    parse [] String
    cs
           String
    _        -> String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "Malformed JSON: expecting string: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    x
     where
      parse :: String -> String -> GetJSON JSValue
    parse String
    rs String
    cs =
        case String
    cs of
          Char
    '\\' : Char
    c : String
    ds -> String -> Char -> String -> GetJSON JSValue
    esc String
    rs Char
    c String
    ds
          Char
    '"'  : String
    ds     -> do String -> GetJSON ()
    setInput String
    ds
                              JSValue -> GetJSON JSValue
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSString -> JSValue
    JSString (String -> JSString
    toJSString (String -> String
    forall a. [a] -> [a]
    reverse String
    rs)))
          Char
    c    : String
    ds
           | Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Char
    '\x20' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Char
    '\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
    < Char
    '\x20'     -> String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "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
    <= Integer
    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 a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "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
    _ -> String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "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 String
    rs Char
    c String
    cs = case Char
    c of
       Char
    '\\' -> String -> String -> GetJSON JSValue
    parse (Char
    '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       Char
    '"'  -> String -> String -> GetJSON JSValue
    parse (Char
    '"'  Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       Char
    'n'  -> String -> String -> GetJSON JSValue
    parse (Char
    '\n' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       Char
    'r'  -> String -> String -> GetJSON JSValue
    parse (Char
    '\r' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       Char
    't'  -> String -> String -> GetJSON JSValue
    parse (Char
    '\t' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       Char
    'f'  -> String -> String -> GetJSON JSValue
    parse (Char
    '\f' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       Char
    'b'  -> String -> String -> GetJSON JSValue
    parse (Char
    '\b' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       Char
    '/'  -> String -> String -> GetJSON JSValue
    parse (Char
    '/'  Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rs) String
    cs
       Char
    'u'  -> case String
    cs of
                 Char
    d1 : Char
    d2 : Char
    d3 : Char
    d4 : String
    cs' ->
                   case ReadS Int
    forall a. (Eq a, Num a) => ReadS a
    readHex [Char
    d1,Char
    d2,Char
    d3,Char
    d4] of
                     [(Int
    n,String
    "")] -> 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'

                     [(Int, String)]
    x -> String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "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
    _ -> String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "Unable to parse JSON String: invalid hex: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    cs
       Char
    _ ->  String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "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 (ReadS Double
    forall a. Read a => ReadS a
    reads String
    cs, ReadS Rational -> ReadS Rational
    forall a. Real a => ReadS a -> ReadS a
    readSigned ReadS Rational
    forall a. RealFrac a => ReadS a
    readFloat String
    cs) of
        ([(Double
    x,String
    _)], [(Rational, String)]
    _)
          | Double -> Bool
    forall a. RealFloat a => a -> Bool
    isInfinite (Double
    x :: Double) ->
              String -> GetJSON Rational
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "JSON Rational out of range: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    cs)
        ([(Double, String)]
    _, [(Rational
    y,String
    cs')]) -> String -> GetJSON ()
    setInput String
    cs' GetJSON () -> GetJSON Rational -> GetJSON Rational
    forall a b. GetJSON a -> GetJSON b -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Rational -> GetJSON Rational
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Rational
    y
        ([(Double, String)], [(Rational, String)])
    _ -> String -> GetJSON Rational
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "Unable to parse JSON Rational: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    context String
    cs)

    -- | Read a list in JSON format
    readJSArray  :: GetJSON JSValue
    readJSArray :: GetJSON JSValue
    readJSArray  = Char -> Char -> Char -> GetJSON [JSValue]
    readSequence Char
    '[' Char
    ']' Char
    ',' GetJSON [JSValue]
    -> ([JSValue] -> GetJSON JSValue) -> GetJSON JSValue
    forall a b. GetJSON a -> (a -> GetJSON b) -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= JSValue -> GetJSON JSValue
    forall a. a -> GetJSON a
    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 Char
    '{' Char
    '}' Char
    ',' GetJSON [(String, JSValue)]
    -> ([(String, JSValue)] -> GetJSON JSValue) -> GetJSON JSValue
    forall a b. GetJSON a -> (a -> GetJSON b) -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= JSValue -> GetJSON JSValue
    forall a. a -> GetJSON a
    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 Char
    start Char
    end 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
        Char
    c : 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
                Char
    d : 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 a b. GetJSON a -> GetJSON b -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [JSValue] -> GetJSON [JSValue]
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                String
    ds                -> String -> GetJSON ()
    setInput String
    ds GetJSON () -> GetJSON [JSValue] -> GetJSON [JSValue]
    forall a b. GetJSON a -> GetJSON b -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [JSValue] -> GetJSON [JSValue]
    parse []
        String
    _ -> String -> GetJSON [JSValue]
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON [JSValue]) -> String -> GetJSON [JSValue]
    forall a b. (a -> b) -> a -> b
    $ String
    "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 [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
                Char
    e : 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 a. a -> GetJSON a
    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
    _ -> String -> GetJSON [JSValue]
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON [JSValue]) -> String -> GetJSON [JSValue]
    forall a b. (a -> b) -> a -> b
    $ String
    "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 Char
    start Char
    end 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
        Char
    c: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
                Char
    d: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 a b. GetJSON a -> GetJSON b -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [(String, JSValue)] -> GetJSON [(String, JSValue)]
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                String
    ds              -> String -> GetJSON ()
    setInput String
    ds GetJSON ()
    -> GetJSON [(String, JSValue)] -> GetJSON [(String, JSValue)]
    forall a b. GetJSON a -> GetJSON b -> GetJSON b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [(String, JSValue)] -> GetJSON [(String, JSValue)]
    parsePairs []
        String
    _ -> String -> GetJSON [(String, JSValue)]
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Unable to parse JSON object: unterminated object"

      where parsePairs :: [(String, JSValue)] -> GetJSON [(String, JSValue)]
    parsePairs [(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 JSString
    s -> String -> GetJSON String
    forall a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSString -> String
    fromJSString JSString
    s)
                                    JSValue
    _          -> String -> GetJSON String
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON String) -> String -> GetJSON String
    forall a b. (a -> b) -> a -> b
    $ String
    "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
                           Char
    ':':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 a. a -> GetJSON a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String
    k,JSValue
    v)
                           String
    _      -> String -> GetJSON (String, JSValue)
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON (String, JSValue))
    -> String -> GetJSON (String, JSValue)
    forall a b. (a -> b) -> a -> b
    $ String
    "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
                Char
    e : 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 a. a -> GetJSON a
    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
    _ -> String -> GetJSON [(String, JSValue)]
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON [(String, JSValue)])
    -> String -> GetJSON [(String, JSValue)]
    forall a b. (a -> b) -> a -> b
    $ String
    "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
        Char
    '"' : String
    _ -> GetJSON JSValue
    readJSString
        Char
    '[' : String
    _ -> GetJSON JSValue
    readJSArray
        Char
    '{' : String
    _ -> GetJSON JSValue
    readJSObject
        Char
    't' : String
    _ -> GetJSON JSValue
    readJSBool
        Char
    'f' : String
    _ -> GetJSON JSValue
    readJSBool
        (Char
    x:String
    _) | Char -> Bool
    isDigit Char
    x Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-' -> 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
        String
    xs -> GetJSON JSValue -> GetJSON JSValue
    tryJSNull
                 (String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
    forall a b. (a -> b) -> a -> b
    $ String
    "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
        Char
    '[' : String
    _ -> GetJSON JSValue
    readJSArray
        Char
    '{' : String
    _ -> GetJSON JSValue
    readJSObject
        String
    _       -> String -> GetJSON JSValue
    forall a. String -> GetJSON a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "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 [JSValue]
    a)    = [JSValue] -> String -> String
    showJSArray [JSValue]
    a
    showJSTopType (JSObject JSObject JSValue
    o)   = JSObject JSValue -> String -> String
    showJSObject JSObject JSValue
    o
    showJSTopType 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 JSValue
    jv =
      case JSValue
    jv of
        JSNull{}         -> String -> String
    showJSNull
        JSBool Bool
    b         -> Bool -> String -> String
    showJSBool Bool
    b
        JSRational Bool
    asF Rational
    r -> Bool -> Rational -> String -> String
    showJSRational' Bool
    asF Rational
    r
        JSArray [JSValue]
    a        -> [JSValue] -> String -> String
    showJSArray [JSValue]
    a
        JSString JSString
    s       -> JSString -> String -> String
    showJSString JSString
    s
        JSObject 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 String
    "null"

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

    -- | Write the JSON String type
    showJSString :: JSString -> ShowS
    showJSString :: JSString -> String -> String
    showJSString JSString
    x 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 Char
    '"'

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

    showJSRational' :: Bool -> Rational -> ShowS
    showJSRational' :: Bool -> Rational -> String -> String
    showJSRational' Bool
    asFloat Rational
    r
     | Rational -> Integer
    forall a. Ratio a -> a
    denominator Rational
    r Integer -> Integer -> Bool
    forall a. Eq a => a -> a -> Bool
    == Integer
    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 Char
    '[' Char
    ']' Char
    ','

    -- | 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 Char
    '{' Char
    '}' Char
    ',' ([(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 Char
    start Char
    end Char
    sep [(String, JSValue)]
    xs 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 [(String
    k,JSValue
    v)]     = Char
    '"' Char -> String -> String
    forall a. a -> [a] -> [a]
    : JSString -> String -> String
    encJSString (String -> JSString
    toJSString String
    k)
                                (Char
    '"' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char
    ':' Char -> String -> String
    forall a. a -> [a] -> [a]
    : JSValue -> String -> String
    showJSValue JSValue
    v ([(String, JSValue)] -> String
    go []))
      go ((String
    k,JSValue
    v):[(String, JSValue)]
    kvs) = Char
    '"' Char -> String -> String
    forall a. a -> [a] -> [a]
    : JSString -> String -> String
    encJSString (String -> JSString
    toJSString String
    k)
                                (Char
    '"' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char
    ':' 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 Char
    start Char
    end Char
    sep [JSValue]
    xs String
    rest = Char
    start Char -> String -> String
    forall a. a -> [a] -> [a]
    : [JSValue] -> String
    go [JSValue]
    xs
      where
      go :: [JSValue] -> String
    go [JSValue
    y]        = JSValue -> String -> String
    showJSValue JSValue
    y ([JSValue] -> String
    go [])
      go (JSValue
    y:[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 JSString
    jss String
    ss = String -> String
    go (JSString -> String
    fromJSString JSString
    jss)
      where
      go :: String -> String
    go String
    s1 =
        case String
    s1 of
          (Char
    x   :String
    xs) | Char
    x Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    < Char
    '\x20' -> Char
    '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char -> String -> String
    encControl Char
    x (String -> String
    go String
    xs)
          (Char
    '"' :String
    xs)              -> Char
    '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char
    '"'  Char -> String -> String
    forall a. a -> [a] -> [a]
    : String -> String
    go String
    xs
          (Char
    '\\':String
    xs)              -> Char
    '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char
    '\\' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String -> String
    go String
    xs
          (Char
    x   :String
    xs)              -> Char
    x    Char -> String -> String
    forall a. a -> [a] -> [a]
    : String -> String
    go String
    xs
          String
    ""                     -> String
    ss

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