{-# 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 :: forall a. Data a => 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` [e] -> JSValue
forall e. Data e => [e] -> JSValue
jList
         -- Use the standard encoding for all base types.
         (a -> JSValue) -> (Integer -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Integer -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Integer)
         (a -> JSValue) -> (Int -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Int -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Int)
         (a -> JSValue) -> (Word8 -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Word8 -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Word8)
         (a -> JSValue) -> (Word16 -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Word16 -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Word16)
         (a -> JSValue) -> (Word32 -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Word32 -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Word32)
         (a -> JSValue) -> (Word64 -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Word64 -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Word64)
         (a -> JSValue) -> (Int8 -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Int8 -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Int8)
         (a -> JSValue) -> (Int16 -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Int16 -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Int16)
         (a -> JSValue) -> (Int32 -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Int32 -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Int32)
         (a -> JSValue) -> (Int64 -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Int64 -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Int64)
         (a -> JSValue) -> (Double -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Double -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Double)
         (a -> JSValue) -> (Float -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Float -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Float)
         (a -> JSValue) -> (Char -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Char -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Char)
         (a -> JSValue) -> ([Char] -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` ([Char] -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T String)
         -- Bool has a special encoding.
         (a -> JSValue) -> (Bool -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Bool -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Bool)
         (a -> JSValue) -> (() -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (() -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T ())
         (a -> JSValue) -> (Ordering -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Ordering -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T Ordering)
         -- More special cases.
         (a -> JSValue) -> (IntSet -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (IntSet -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T I.IntSet)
         (a -> JSValue) -> (ByteString -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (ByteString -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T S.ByteString)
         (a -> JSValue) -> (ByteString -> JSValue) -> a -> JSValue
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (ByteString -> JSValue
forall a. JSON a => a -> JSValue
showJSON :: T L.ByteString)
  where
        -- Lists are simply coded as arrays.
        jList :: [a] -> JSValue
jList [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 :: forall a. Data a => 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 =
            case DataType -> DataRep
dataTypeRep (a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
a) of
                AlgRep []  -> JSValue
JSNull
                AlgRep [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]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ d -> JSValue
forall a. Data a => a -> JSValue
toJSON a
a)
                AlgRep [Constr]
_   -> 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]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ d -> JSValue
forall a. Data a => a -> JSValue
toJSON a
a)
                DataRep
rep        -> DataType -> DataRep -> JSValue
forall {a} {a} {b}. (Show a, Show a) => a -> a -> b
err (a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
a) DataRep
rep
           where
              err :: a -> a -> b
err a
dt a
r = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"toJSON: not AlgRep " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
r [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
dt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
        -- 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 Constr
c [] = JSString -> JSValue
JSString (JSString -> JSValue) -> JSString -> JSValue
forall a b. (a -> b) -> a -> b
$ [Char] -> JSString
toJSString ([Char] -> JSString) -> [Char] -> JSString
forall a b. (a -> b) -> a -> b
$ Constr -> [Char]
constrString Constr
c
        encodeConstr Constr
c [JSValue]
as = [([Char], JSValue)] -> JSValue
jsObject [(Constr -> [Char]
constrString Constr
c, Constr -> [JSValue] -> JSValue
encodeArgs Constr
c [JSValue]
as)]

        constrString :: Constr -> [Char]
constrString = Constr -> [Char]
showConstr

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

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

        jsObject :: [(String, JSValue)] -> JSValue
        jsObject :: [([Char], JSValue)] -> JSValue
jsObject = JSObject JSValue -> JSValue
JSObject (JSObject JSValue -> JSValue)
-> ([([Char], JSValue)] -> JSObject JSValue)
-> [([Char], JSValue)]
-> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Char], JSValue)] -> JSObject JSValue
forall a. [([Char], 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 :: forall a. Data a => JSValue -> Result a
fromJSON 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` Result [e]
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 [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 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 :: forall a. JSON a => Result a
value = JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON JSValue
j

        jList :: (Data e) => Result [e]
        jList :: forall e. Data e => Result [e]
jList = case JSValue
j of
                JSArray [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM JSValue -> Result e
forall a. Data a => JSValue -> Result a
fromJSON [JSValue]
js
                JSValue
_ -> [Char] -> Result [e]
forall a. [Char] -> Result a
Error ([Char] -> Result [e]) -> [Char] -> Result [e]
forall a b. (a -> b) -> a -> b
$ [Char]
"fromJSON: Prelude.[] bad data: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JSValue -> [Char]
forall a. Show a => a -> [Char]
show JSValue
j



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

        decodeArgs :: Constr -> JSValue -> Result a
decodeArgs Constr
c = Int -> Constr -> [[Char]] -> JSValue -> Result a
forall {a} {a}.
(Num a, Data a, Ord a) =>
a -> Constr -> [[Char]] -> 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 -> [[Char]]
constrFields Constr
c)
        decodeArgs' :: a -> Constr -> [[Char]] -> JSValue -> Result a
decodeArgs' a
0 Constr
c  [[Char]]
_       JSValue
JSNull               = Constr -> [JSValue] -> Result a
forall {a}. Data a => Constr -> [JSValue] -> Result a
construct Constr
c []   -- nullary constructor
        decodeArgs' a
1 Constr
c []       JSValue
jd                   = Constr -> [JSValue] -> Result a
forall {a}. Data a => Constr -> [JSValue] -> Result a
construct Constr
c [JSValue
jd] -- unary constructor
        decodeArgs' a
n Constr
c []       (JSArray [JSValue]
js) | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
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' a
_ Constr
c fs :: [[Char]]
fs@([Char]
_:[[Char]]
_) (JSObject JSObject JSValue
o)         = [([Char], JSValue)] -> [[Char]] -> Result [JSValue]
forall {t :: * -> *} {b}.
Traversable t =>
[([Char], b)] -> t [Char] -> Result (t b)
selectFields (JSObject JSValue -> [([Char], JSValue)]
forall e. JSObject e -> [([Char], e)]
fromJSObject JSObject JSValue
o) [[Char]]
fs Result [JSValue] -> ([JSValue] -> Result a) -> Result a
forall a b. Result a -> (a -> Result b) -> Result b
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' a
_ Constr
c [[Char]]
_        JSValue
jd                   = [Char] -> Result a
forall a. [Char] -> Result a
Error ([Char] -> Result a) -> [Char] -> Result a
forall a b. (a -> b) -> a -> b
$ [Char]
"fromJSON: bad decodeArgs data " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Constr, JSValue) -> [Char]
forall a. Show a => a -> [Char]
show (Constr
c, JSValue
jd)

        -- Build the value by stepping through the list of subparts.
        construct :: Constr -> [JSValue] -> Result a
construct 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 StateT [JSValue] Result d
forall d. Data d => StateT [JSValue] Result d
f Constr
c
          where f :: (Data a) => StateT [JSValue] Result a
                f :: forall d. Data d => StateT [JSValue] Result d
f = do js <- StateT [JSValue] Result [JSValue]
forall s (m :: * -> *). MonadState s m => m s
get; case js of [] -> Result a -> StateT [JSValue] Result a
forall (m :: * -> *) a. Monad m => m a -> StateT [JSValue] m 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
$ [Char] -> Result a
forall a. [Char] -> Result a
Error [Char]
"construct: empty list"; JSValue
j' : [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 (m :: * -> *) a. Monad m => m a -> StateT [JSValue] m 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 :: [([Char], b)] -> t [Char] -> Result (t b)
selectFields [([Char], b)]
fjs = ([Char] -> Result b) -> t [Char] -> Result (t b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM [Char] -> Result b
sel
          where sel :: [Char] -> Result b
sel [Char]
f = Result b -> (b -> Result b) -> Maybe b -> Result b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Result b
forall a. [Char] -> Result a
Error ([Char] -> Result b) -> [Char] -> Result b
forall a b. (a -> b) -> a -> b
$ [Char]
"fromJSON: field does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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
$ [Char] -> [([Char], b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
f [([Char], 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 :: forall a. Data a => a -> Constr -> Int
numConstrArgs a
x 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 StateT Int Identity d
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 a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x) Int
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
+Int
1); b -> StateT Int Identity b
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return b
forall a. HasCallStack => a
undefined

        resType :: Result a -> a
        resType :: forall a. Result a -> a
resType Result a
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"resType"

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

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