{-# 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 = forall a. Data a => a -> JSValue
toJSON_generic
         forall d (t :: * -> *) q.
(Data d, Typeable t) =>
(d -> q) -> (forall e. Data e => t e -> q) -> d -> q
`ext1Q` forall {a}. Data a => [a] -> JSValue
jList
         -- Use the standard encoding for all base types.
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Integer)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Int)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Word8)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Word16)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Word32)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Word64)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Int8)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Int16)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Int32)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Int64)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Double)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Float)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Char)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T String)
         -- Bool has a special encoding.
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Bool)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T ())
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T Ordering)
         -- More special cases.
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T I.IntSet)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a. JSON a => a -> JSValue
showJSON :: T S.ByteString)
         forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 = 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 (forall a. Data a => a -> DataType
dataTypeOf a
a) of
                AlgRep []  -> JSValue
JSNull
                AlgRep [Constr
c] -> Constr -> [JSValue] -> JSValue
encodeArgs Constr
c (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]
_   -> Constr -> [JSValue] -> JSValue
encodeConstr (forall a. Data a => a -> Constr
toConstr a
a) (forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall a. Data a => a -> JSValue
toJSON a
a)
                DataRep
rep        -> forall {a} {a} {a}. (Show a, Show a) => a -> a -> a
err (forall a. Data a => a -> DataType
dataTypeOf a
a) DataRep
rep
           where
              err :: a -> a -> a
err a
dt a
r = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"toJSON: not AlgRep " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
r forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
dt forall a. [a] -> [a] -> [a]
++ String
")"
        -- 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 forall a b. (a -> b) -> a -> b
$ String -> JSString
toJSString forall a b. (a -> b) -> a -> b
$ Constr -> String
constrString Constr
c
        encodeConstr Constr
c [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 Constr
c = [String] -> [JSValue] -> JSValue
encodeArgs' (Constr -> [String]
constrFields Constr
c)
        encodeArgs' :: [String] -> [JSValue] -> JSValue
encodeArgs' [] [JSValue
j] = JSValue
j
        encodeArgs' [] [JSValue]
js  = [JSValue] -> JSValue
JSArray [JSValue]
js
        encodeArgs' [String]
ns [JSValue]
js  = [(String, JSValue)] -> JSValue
jsObject forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (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 (Char
'_':String
cs) = String
cs
        mungeField String
cs = String
cs

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

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

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

             forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
m a -> m b -> m a
`extR` (forall a. JSON a => Result a
value :: F I.IntSet)
             forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
m a -> m b -> m a
`extR` (forall a. JSON a => Result a
value :: F S.ByteString)
             forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
m a -> m b -> m a
`extR` (forall a. JSON a => Result a
value :: F L.ByteString)
  where value :: (JSON a) => Result a
        value :: forall a. JSON a => Result a
value = 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 -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Data a => JSValue -> Result a
fromJSON [JSValue]
js
                JSValue
_ -> forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"fromJSON: Prelude.[] bad data: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
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 = forall a. Data a => a -> DataType
dataTypeOf forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. HasCallStack => String -> a
error String
"Empty type"); JSValue
_ -> forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"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 (Constr
c, JSValue
j') <- DataType -> JSValue -> Result (Constr, JSValue)
getConstr DataType
typ JSValue
j; Constr -> JSValue -> Result a
decodeArgs Constr
c JSValue
j'
                      DataRep
rep        -> forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"fromJSON: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DataRep
rep forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DataType
typ forall a. [a] -> [a] -> [a]
++ String
")"
        getConstr :: DataType -> JSValue -> Result (Constr, JSValue)
getConstr DataType
t (JSObject JSObject JSValue
o) | [(String
s, JSValue
j')] <- forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
o = do Constr
c <- DataType -> String -> Result Constr
readConstr' DataType
t String
s; forall (m :: * -> *) a. Monad m => a -> m a
return (Constr
c, JSValue
j')
        getConstr DataType
t (JSString JSString
js) = do Constr
c <- DataType -> String -> Result Constr
readConstr' DataType
t (JSString -> String
fromJSString JSString
js); forall (m :: * -> *) a. Monad m => a -> m a
return (Constr
c, JSValue
JSNull) -- handle nullare constructor
        getConstr DataType
_ JSValue
_ = forall a. String -> Result a
Error String
"fromJSON: bad constructor encoding"
        readConstr' :: DataType -> String -> Result Constr
readConstr' DataType
t String
s =
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"fromJSON: unknown constructor: " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DataType
t)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataType -> String -> Maybe Constr
readConstr DataType
t String
s

        decodeArgs :: Constr -> JSValue -> Result a
decodeArgs Constr
c = forall {a} {a}.
(Num a, Data a, Ord a) =>
a -> Constr -> [String] -> JSValue -> Result a
decodeArgs' (forall a. Data a => a -> Constr -> Int
numConstrArgs (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' a
0 Constr
c  [String]
_       JSValue
JSNull               = forall {a}. Data a => Constr -> [JSValue] -> Result a
construct Constr
c []   -- nullary constructor
        decodeArgs' a
1 Constr
c []       JSValue
jd                   = 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 forall a. Ord a => a -> a -> Bool
> a
1 = 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 :: [String]
fs@(String
_:[String]
_) (JSObject JSObject JSValue
o)         = forall {t :: * -> *} {b}.
Traversable t =>
[(String, b)] -> t String -> Result (t b)
selectFields (forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
o) [String]
fs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a}. Data a => Constr -> [JSValue] -> Result a
construct Constr
c -- field names
        decodeArgs' a
_ Constr
c [String]
_        JSValue
jd                   = forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"fromJSON: bad decodeArgs data " forall a. [a] -> [a] -> [a]
++ 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 Constr
c = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(Monad m, Data a) =>
(forall d. Data d => m d) -> Constr -> m a
fromConstrM forall a. Data a => StateT [JSValue] Result a
f Constr
c
          where f :: (Data a) => StateT [JSValue] Result a
                f :: forall a. Data a => StateT [JSValue] Result a
f = do [JSValue]
js <- forall s (m :: * -> *). MonadState s m => m s
get; case [JSValue]
js of [] -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. String -> Result a
Error String
"construct: empty list"; JSValue
j' : [JSValue]
js' -> do forall s (m :: * -> *). MonadState s m => s -> m ()
put [JSValue]
js'; forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 [(String, b)]
fjs = 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 String
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"fromJSON: field does not exist " forall a. [a] -> [a] -> [a]
++ String
f) forall a. a -> Result a
Ok forall a b. (a -> b) -> a -> 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 :: forall a. Data a => a -> Constr -> Int
numConstrArgs a
x Constr
c = forall s a. State s a -> s -> s
execState (forall (m :: * -> *) a.
(Monad m, Data a) =>
(forall d. Data d => m d) -> Constr -> m a
fromConstrM forall {b}. StateT Int Identity b
f Constr
c forall a. a -> a -> a
`asTypeOf` forall (m :: * -> *) a. Monad m => a -> m a
return a
x) Int
0
          where f :: StateT Int Identity b
f = do forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Num a => a -> a -> a
+Int
1); forall (m :: * -> *) a. Monad m => a -> m a
return forall a. HasCallStack => a
undefined

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

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

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