    {-# LANGUAGE PatternGuards #-}
    -- | JSON serializer and deserializer using Data.Generics.
    -- The functions here handle algebraic data types and primitive types.
    -- It uses the same representation as "Text.JSON" for "Prelude" types.
    module Text.JSON.Generic
        ( module Text.JSON
        , Data
        , Typeable
        , toJSON
        , fromJSON
        , encodeJSON
        , decodeJSON

        , toJSON_generic
        , fromJSON_generic
        ) where

    import Control.Monad.State
    import Text.JSON
    import Text.JSON.String ( runGetJSON )
    import Data.Generics
    import Data.Word
    import Data.Int

    import qualified Data.ByteString.Char8 as S
    import qualified Data.ByteString.Lazy.Char8 as L
    import qualified Data.IntSet as I
    -- FIXME: The JSON library treats this specially, needs ext2Q
    -- import qualified Data.Map as M

    type T a = a -> JSValue

    -- |Convert anything to a JSON value.
    toJSON :: (Data a) => a -> JSValue
    toJSON :: a -> JSValue
    toJSON = a -> JSValue
    forall a. Data a => a -> JSValue
    toJSON_generic
             (a -> JSValue)
    -> (forall e. Data e => [e] -> JSValue) -> a -> JSValue
    forall d (t :: * -> *) q.
    (Data d, Typeable t) =>
    (d -> q) -> (forall e. Data e => t e -> q) -> d -> q
    `ext1Q` forall e. Data e => [e] -> JSValue
    jList
             -- Use the standard encoding for all base types.
             (a -> JSValue) -> (Integer -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Integer -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Integer)
             (a -> JSValue) -> (Int -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Int -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Int)
             (a -> JSValue) -> (Word8 -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Word8 -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Word8)
             (a -> JSValue) -> (Word16 -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Word16 -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Word16)
             (a -> JSValue) -> (Word32 -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Word32 -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Word32)
             (a -> JSValue) -> (Word64 -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Word64 -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Word64)
             (a -> JSValue) -> (Int8 -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Int8 -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Int8)
             (a -> JSValue) -> (Int16 -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Int16 -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Int16)
             (a -> JSValue) -> (Int32 -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Int32 -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Int32)
             (a -> JSValue) -> (Int64 -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Int64 -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Int64)
             (a -> JSValue) -> (Double -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Double -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Double)
             (a -> JSValue) -> (Float -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Float -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Float)
             (a -> JSValue) -> (Char -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Char -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Char)
             (a -> JSValue) -> (String -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (String -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T String)
             -- Bool has a special encoding.
             (a -> JSValue) -> (Bool -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Bool -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Bool)
             (a -> JSValue) -> (() -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (() -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T ())
             (a -> JSValue) -> (Ordering -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (Ordering -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T Ordering)
             -- More special cases.
             (a -> JSValue) -> (IntSet -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (IntSet -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T I.IntSet)
             (a -> JSValue) -> (ByteString -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (ByteString -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T S.ByteString)
             (a -> JSValue) -> (ByteString -> JSValue) -> a -> JSValue
    forall a b q.
    (Typeable a, Typeable b) =>
    (a -> q) -> (b -> q) -> a -> q
    `extQ` (ByteString -> JSValue
    forall a. JSON a => a -> JSValue
    showJSON :: T L.ByteString)
      where
            -- Lists are simply coded as arrays.
            jList :: [a] -> JSValue
    jList vs :: [a]
    vs = [JSValue] -> JSValue
    JSArray ([JSValue] -> JSValue) -> [JSValue] -> JSValue
    forall a b. (a -> b) -> a -> b
    $ (a -> JSValue) -> [a] -> [JSValue]
    forall a b. (a -> b) -> [a] -> [b]
    map a -> JSValue
    forall a. Data a => a -> JSValue
    toJSON [a]
    vs

    toJSON_generic :: (Data a) => a -> JSValue
    toJSON_generic :: a -> JSValue
    toJSON_generic = a -> JSValue
    forall a. Data a => a -> JSValue
    generic
      where
            -- Generic encoding of an algebraic data type.
            --   No constructor, so it must be an error value.  Code it anyway as JSNull.
            --   Elide a single constructor and just code the arguments.
            --   For multiple constructors, make an object with a field name that is the
            --   constructor (except lower case) and the data is the arguments encoded.
            generic :: a -> JSValue
    generic a :: a
    a =
                case DataType -> DataRep
    dataTypeRep (a -> DataType
    forall a. Data a => a -> DataType
    dataTypeOf a
    a) of
                    AlgRep []  -> JSValue
    JSNull
                    AlgRep [c :: Constr
    c] -> Constr -> [JSValue] -> JSValue
    encodeArgs Constr
    c ((forall a. Data a => a -> JSValue) -> a -> [JSValue]
    forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
    gmapQ forall a. Data a => a -> JSValue
    toJSON a
    a)
                    AlgRep _   -> Constr -> [JSValue] -> JSValue
    encodeConstr (a -> Constr
    forall a. Data a => a -> Constr
    toConstr a
    a) ((forall a. Data a => a -> JSValue) -> a -> [JSValue]
    forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
    gmapQ forall a. Data a => a -> JSValue
    toJSON a
    a)
                    rep :: DataRep
    rep        -> DataType -> DataRep -> JSValue
    forall a a a. (Show a, Show a) => a -> a -> a
    err (a -> DataType
    forall a. Data a => a -> DataType
    dataTypeOf a
    a) DataRep
    rep
               where
                  err :: a -> a -> a
    err dt :: a
    dt r :: a
    r = String -> a
    forall a. HasCallStack => String -> a
    error (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ "toJSON: not AlgRep " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ a -> String
    forall a. Show a => a -> String
    show a
    r String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ a -> String
    forall a. Show a => a -> String
    show a
    dt String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
            -- Encode nullary constructor as a string.
            -- Encode non-nullary constructors as an object with the constructor
            -- name as the single field and the arguments as the value.
            -- Use an array if the are no field names, but elide singleton arrays,
            -- and use an object if there are field names.
            encodeConstr :: Constr -> [JSValue] -> JSValue
    encodeConstr c :: Constr
    c [] = JSString -> JSValue
    JSString (JSString -> JSValue) -> JSString -> JSValue
    forall a b. (a -> b) -> a -> b
    $ String -> JSString
    toJSString (String -> JSString) -> String -> JSString
    forall a b. (a -> b) -> a -> b
    $ Constr -> String
    constrString Constr
    c
            encodeConstr c :: Constr
    c as :: [JSValue]
    as = [(String, JSValue)] -> JSValue
    jsObject [(Constr -> String
    constrString Constr
    c, Constr -> [JSValue] -> JSValue
    encodeArgs Constr
    c [JSValue]
    as)]

            constrString :: Constr -> String
    constrString = Constr -> String
    showConstr

            encodeArgs :: Constr -> [JSValue] -> JSValue
    encodeArgs c :: Constr
    c = [String] -> [JSValue] -> JSValue
    encodeArgs' (Constr -> [String]
    constrFields Constr
    c)
            encodeArgs' :: [String] -> [JSValue] -> JSValue
    encodeArgs' [] [j :: JSValue
    j] = JSValue
    j
            encodeArgs' [] js :: [JSValue]
    js  = [JSValue] -> JSValue
    JSArray [JSValue]
    js
            encodeArgs' ns :: [String]
    ns js :: [JSValue]
    js  = [(String, JSValue)] -> JSValue
    jsObject ([(String, JSValue)] -> JSValue) -> [(String, JSValue)] -> JSValue
    forall a b. (a -> b) -> a -> b
    $ [String] -> [JSValue] -> [(String, JSValue)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip ((String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String
    mungeField [String]
    ns) [JSValue]
    js

            -- Skip leading '_' in field name so we can use keywords etc. as field names.
            mungeField :: String -> String
    mungeField ('_':cs :: String
    cs) = String
    cs
            mungeField cs :: String
    cs = String
    cs

            jsObject :: [(String, JSValue)] -> JSValue
            jsObject :: [(String, JSValue)] -> JSValue
    jsObject = 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

    type F a = Result a

    -- |Convert a JSON value to anything (fails if the types do not match).
    fromJSON :: (Data a) => JSValue -> Result a
    fromJSON :: JSValue -> Result a
    fromJSON j :: JSValue
    j = JSValue -> Result a
    forall a. Data a => JSValue -> Result a
    fromJSON_generic JSValue
    j
                 Result a -> (forall e. Data e => Result [e]) -> Result a
    forall (m :: * -> *) d (t :: * -> *).
    (Monad m, Data d, Typeable t) =>
    m d -> (forall e. Data e => m (t e)) -> m d
    `ext1R` forall e. Data e => Result [e]
    jList

                 Result a -> Result Integer -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Integer
    forall a. JSON a => Result a
    value :: F Integer)
                 Result a -> Result Int -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Int
    forall a. JSON a => Result a
    value :: F Int)
                 Result a -> Result Word8 -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Word8
    forall a. JSON a => Result a
    value :: F Word8)
                 Result a -> Result Word16 -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Word16
    forall a. JSON a => Result a
    value :: F Word16)
                 Result a -> Result Word32 -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Word32
    forall a. JSON a => Result a
    value :: F Word32)
                 Result a -> Result Word64 -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Word64
    forall a. JSON a => Result a
    value :: F Word64)
                 Result a -> Result Int8 -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Int8
    forall a. JSON a => Result a
    value :: F Int8)
                 Result a -> Result Int16 -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Int16
    forall a. JSON a => Result a
    value :: F Int16)
                 Result a -> Result Int32 -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Int32
    forall a. JSON a => Result a
    value :: F Int32)
                 Result a -> Result Int64 -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Int64
    forall a. JSON a => Result a
    value :: F Int64)
                 Result a -> Result Double -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Double
    forall a. JSON a => Result a
    value :: F Double)
                 Result a -> Result Float -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Float
    forall a. JSON a => Result a
    value :: F Float)
                 Result a -> Result Char -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Char
    forall a. JSON a => Result a
    value :: F Char)
                 Result a -> Result String -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result String
    forall a. JSON a => Result a
    value :: F String)

                 Result a -> Result Bool -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Bool
    forall a. JSON a => Result a
    value :: F Bool)
                 Result a -> Result () -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result ()
    forall a. JSON a => Result a
    value :: F ())
                 Result a -> Result Ordering -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result Ordering
    forall a. JSON a => Result a
    value :: F Ordering)

                 Result a -> Result IntSet -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result IntSet
    forall a. JSON a => Result a
    value :: F I.IntSet)
                 Result a -> Result ByteString -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result ByteString
    forall a. JSON a => Result a
    value :: F S.ByteString)
                 Result a -> Result ByteString -> Result a
    forall (m :: * -> *) a b.
    (Monad m, Typeable a, Typeable b) =>
    m a -> m b -> m a
    `extR` (Result ByteString
    forall a. JSON a => Result a
    value :: F L.ByteString)
      where value :: (JSON a) => Result a
            value :: Result a
    value = JSValue -> Result a
    forall a. JSON a => JSValue -> Result a
    readJSON JSValue
    j

            jList :: (Data e) => Result [e]
            jList :: Result [e]
    jList = case JSValue
    j of
                    JSArray js :: [JSValue]
    js -> (JSValue -> Result e) -> [JSValue] -> Result [e]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM JSValue -> Result e
    forall a. Data a => JSValue -> Result a
    fromJSON [JSValue]
    js
                    _ -> String -> Result [e]
    forall a. String -> Result a
    Error (String -> Result [e]) -> String -> Result [e]
    forall a b. (a -> b) -> a -> b
    $ "fromJSON: Prelude.[] bad data: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ JSValue -> String
    forall a. Show a => a -> String
    show JSValue
    j

    fromJSON_generic :: (Data a) => JSValue -> Result a
    fromJSON_generic :: JSValue -> Result a
    fromJSON_generic j :: JSValue
    j = Result a
    generic
      where
            typ :: DataType
    typ = a -> DataType
    forall a. Data a => a -> DataType
    dataTypeOf (a -> DataType) -> a -> DataType
    forall a b. (a -> b) -> a -> b
    $ Result a -> a
    forall a. Result a -> a
    resType Result a
    generic
            generic :: Result a
    generic = case DataType -> DataRep
    dataTypeRep DataType
    typ of
                          AlgRep []  -> case JSValue
    j of JSNull -> a -> Result a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> a
    forall a. HasCallStack => String -> a
    error "Empty type"); _ -> String -> Result a
    forall a. String -> Result a
    Error (String -> Result a) -> String -> Result a
    forall a b. (a -> b) -> a -> b
    $ "fromJSON: no-constr bad data"
                          AlgRep [_] -> Constr -> JSValue -> Result a
    decodeArgs (DataType -> Int -> Constr
    indexConstr DataType
    typ 1) JSValue
    j
                          AlgRep _   -> do (c :: Constr
    c, j' :: JSValue
    j') <- DataType -> JSValue -> Result (Constr, JSValue)
    getConstr DataType
    typ JSValue
    j; Constr -> JSValue -> Result a
    decodeArgs Constr
    c JSValue
    j'
                          rep :: DataRep
    rep        -> String -> Result a
    forall a. String -> Result a
    Error (String -> Result a) -> String -> Result a
    forall a b. (a -> b) -> a -> b
    $ "fromJSON: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ DataRep -> String
    forall a. Show a => a -> String
    show DataRep
    rep String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ DataType -> String
    forall a. Show a => a -> String
    show DataType
    typ String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
            getConstr :: DataType -> JSValue -> Result (Constr, JSValue)
    getConstr t :: DataType
    t (JSObject o :: JSObject JSValue
    o) | [(s :: String
    s, j' :: JSValue
    j')] <- JSObject JSValue -> [(String, JSValue)]
    forall e. JSObject e -> [(String, e)]
    fromJSObject JSObject JSValue
    o = do Constr
    c <- DataType -> String -> Result Constr
    readConstr' DataType
    t String
    s; (Constr, JSValue) -> Result (Constr, JSValue)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Constr
    c, JSValue
    j')
            getConstr t :: DataType
    t (JSString js :: JSString
    js) = do Constr
    c <- DataType -> String -> Result Constr
    readConstr' DataType
    t (JSString -> String
    fromJSString JSString
    js); (Constr, JSValue) -> Result (Constr, JSValue)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Constr
    c, JSValue
    JSNull) -- handle nullare constructor
            getConstr _ _ = String -> Result (Constr, JSValue)
    forall a. String -> Result a
    Error "fromJSON: bad constructor encoding"
            readConstr' :: DataType -> String -> Result Constr
    readConstr' t :: DataType
    t s :: String
    s =
              Result Constr
    -> (Constr -> Result Constr) -> Maybe Constr -> Result Constr
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Result Constr
    forall a. String -> Result a
    Error (String -> Result Constr) -> String -> Result Constr
    forall a b. (a -> b) -> a -> b
    $ "fromJSON: unknown constructor: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ DataType -> String
    forall a. Show a => a -> String
    show DataType
    t)
                    Constr -> Result Constr
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Constr -> Result Constr) -> Maybe Constr -> Result Constr
    forall a b. (a -> b) -> a -> b
    $ DataType -> String -> Maybe Constr
    readConstr DataType
    t String
    s

            decodeArgs :: Constr -> JSValue -> Result a
    decodeArgs c :: Constr
    c = Int -> Constr -> [String] -> JSValue -> Result a
    forall a a.
    (Num a, Data a, Ord a) =>
    a -> Constr -> [String] -> JSValue -> Result a
    decodeArgs' (a -> Constr -> Int
    forall a. Data a => a -> Constr -> Int
    numConstrArgs (Result a -> a
    forall a. Result a -> a
    resType Result a
    generic) Constr
    c) Constr
    c (Constr -> [String]
    constrFields Constr
    c)
            decodeArgs' :: a -> Constr -> [String] -> JSValue -> Result a
    decodeArgs' 0 c :: Constr
    c  _       JSNull               = Constr -> [JSValue] -> Result a
    forall a. Data a => Constr -> [JSValue] -> Result a
    construct Constr
    c []   -- nullary constructor
            decodeArgs' 1 c :: Constr
    c []       jd :: JSValue
    jd                   = Constr -> [JSValue] -> Result a
    forall a. Data a => Constr -> [JSValue] -> Result a
    construct Constr
    c [JSValue
    jd] -- unary constructor
            decodeArgs' n :: a
    n c :: Constr
    c []       (JSArray js :: [JSValue]
    js) | a
    n a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    > 1 = Constr -> [JSValue] -> Result a
    forall a. Data a => Constr -> [JSValue] -> Result a
    construct Constr
    c [JSValue]
    js   -- no field names
            -- FIXME? We could allow reading an array into a constructor with field names.
            decodeArgs' _ c :: Constr
    c fs :: [String]
    fs@(_:_) (JSObject o :: JSObject JSValue
    o)         = [(String, JSValue)] -> [String] -> Result [JSValue]
    forall (t :: * -> *) b.
    Traversable t =>
    [(String, b)] -> t String -> Result (t b)
    selectFields (JSObject JSValue -> [(String, JSValue)]
    forall e. JSObject e -> [(String, e)]
    fromJSObject JSObject JSValue
    o) [String]
    fs Result [JSValue] -> ([JSValue] -> Result a) -> Result a
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Constr -> [JSValue] -> Result a
    forall a. Data a => Constr -> [JSValue] -> Result a
    construct Constr
    c -- field names
            decodeArgs' _ c :: Constr
    c _        jd :: JSValue
    jd                   = String -> Result a
    forall a. String -> Result a
    Error (String -> Result a) -> String -> Result a
    forall a b. (a -> b) -> a -> b
    $ "fromJSON: bad decodeArgs data " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Constr, JSValue) -> String
    forall a. Show a => a -> String
    show (Constr
    c, JSValue
    jd)

            -- Build the value by stepping through the list of subparts.
            construct :: Constr -> [JSValue] -> Result a
    construct c :: Constr
    c = StateT [JSValue] Result a -> [JSValue] -> Result a
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
    evalStateT (StateT [JSValue] Result a -> [JSValue] -> Result a)
    -> StateT [JSValue] Result a -> [JSValue] -> Result a
    forall a b. (a -> b) -> a -> b
    $ (forall d. Data d => StateT [JSValue] Result d)
    -> Constr -> StateT [JSValue] Result a
    forall (m :: * -> *) a.
    (Monad m, Data a) =>
    (forall d. Data d => m d) -> Constr -> m a
    fromConstrM forall d. Data d => StateT [JSValue] Result d
    f Constr
    c
              where f :: (Data a) => StateT [JSValue] Result a
                    f :: StateT [JSValue] Result a
    f = do [JSValue]
    js <- StateT [JSValue] Result [JSValue]
    forall s (m :: * -> *). MonadState s m => m s
    get; case [JSValue]
    js of [] -> Result a -> StateT [JSValue] Result a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Result a -> StateT [JSValue] Result a)
    -> Result a -> StateT [JSValue] Result a
    forall a b. (a -> b) -> a -> b
    $ String -> Result a
    forall a. String -> Result a
    Error "construct: empty list"; j' :: JSValue
    j' : js' :: [JSValue]
    js' -> do [JSValue] -> StateT [JSValue] Result ()
    forall s (m :: * -> *). MonadState s m => s -> m ()
    put [JSValue]
    js'; Result a -> StateT [JSValue] Result a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Result a -> StateT [JSValue] Result a)
    -> Result a -> StateT [JSValue] Result a
    forall a b. (a -> b) -> a -> b
    $ JSValue -> Result a
    forall a. Data a => JSValue -> Result a
    fromJSON JSValue
    j'

            -- Select the named fields from a JSON object.  FIXME? Should this use a map?
            selectFields :: [(String, b)] -> t String -> Result (t b)
    selectFields fjs :: [(String, b)]
    fjs = (String -> Result b) -> t String -> Result (t b)
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM String -> Result b
    sel
              where sel :: String -> Result b
    sel f :: String
    f = Result b -> (b -> Result b) -> Maybe b -> Result b
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Result b
    forall a. String -> Result a
    Error (String -> Result b) -> String -> Result b
    forall a b. (a -> b) -> a -> b
    $ "fromJSON: field does not exist " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    f) b -> Result b
    forall a. a -> Result a
    Ok (Maybe b -> Result b) -> Maybe b -> Result b
    forall a b. (a -> b) -> a -> b
    $ String -> [(String, b)] -> Maybe b
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    f [(String, b)]
    fjs

            -- Count how many arguments a constructor has.  The value x is used to determine what type the constructor returns.
            numConstrArgs :: (Data a) => a -> Constr -> Int
            numConstrArgs :: a -> Constr -> Int
    numConstrArgs x :: a
    x c :: Constr
    c = State Int a -> Int -> Int
    forall s a. State s a -> s -> s
    execState ((forall d. Data d => StateT Int Identity d)
    -> Constr -> State Int a
    forall (m :: * -> *) a.
    (Monad m, Data a) =>
    (forall d. Data d => m d) -> Constr -> m a
    fromConstrM forall b. StateT Int Identity b
    forall d. Data d => StateT Int Identity d
    f Constr
    c State Int a -> State Int a -> State Int a
    forall a. a -> a -> a
    `asTypeOf` a -> State Int a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    x) 0
              where f :: StateT Int Identity b
    f = do (Int -> Int) -> StateT Int Identity ()
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
    modify (Int -> Int -> Int
    forall a. Num a => a -> a -> a
    +1); b -> StateT Int Identity b
    forall (m :: * -> *) a. Monad m => a -> m a
    return b
    forall a. HasCallStack => a
    undefined

            resType :: Result a -> a
            resType :: Result a -> a
    resType _ = String -> a
    forall a. HasCallStack => String -> a
    error "resType"

    -- |Encode a value as a string.
    encodeJSON :: (Data a) => a -> String
    encodeJSON :: a -> String
    encodeJSON x :: a
    x = JSValue -> String -> String
    showJSValue (a -> JSValue
    forall a. Data a => a -> JSValue
    toJSON a
    x) ""

    -- |Decode a string as a value.
    decodeJSON :: (Data a) => String -> a
    decodeJSON :: String -> a
    decodeJSON s :: String
    s =
        case GetJSON JSValue -> String -> Either String JSValue
    forall a. GetJSON a -> String -> Either String a
    runGetJSON GetJSON JSValue
    readJSValue String
    s of
        Left msg :: String
    msg -> String -> a
    forall a. HasCallStack => String -> a
    error String
    msg
        Right j :: JSValue
    j ->
            case JSValue -> Result a
    forall a. Data a => JSValue -> Result a
    fromJSON JSValue
    j of
            Error msg :: String
    msg -> String -> a
    forall a. HasCallStack => String -> a
    error String
    msg
            Ok x :: a
    x -> a
    x