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

    , toJSON_generic
    , fromJSON_generic
    ) where

import Control.Monad.State
import Text.JSON5.Types
import Text.JSON5 (JSON5(..), Result(..))
import Text.JSON5.String (runGetJSON, readJSValue, showJSValue)
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 JSON5 library treats this specially, needs ext2Q
-- import qualified Data.Map as M

type T a = a -> JSValue

-- |Convert anything to a JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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. JSON5 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 :: 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]
gmapQ 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]
gmapQ forall a. Data a => a -> JSValue
toJSON a
a)
                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 a
dt a
r = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"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 -> 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]
++ 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 (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 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 ([(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 (Char
'_':String
cs) = String
cs
        mungeField 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 R a = Result a

-- |Convert a JSON5 value to anything (fails if the types do not match).
fromJSON :: (Data a) => JSValue -> Result a
fromJSON :: 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` 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R ())
             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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R 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. JSON5 a => Result a
value :: R L.ByteString)
  where value :: (JSON5 a) => Result a
        value :: Result a
value = JSValue -> Result a
forall a. JSON5 a => JSValue -> Result a
readJSON JSValue
j

        jList :: (Data e) => Result [e]
        jList :: 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)
mapM JSValue -> Result e
forall a. Data a => JSValue -> Result a
fromJSON [JSValue]
js
                JSValue
_ -> String -> Result [e]
forall a. String -> Result a
Error (String -> Result [e]) -> String -> Result [e]
forall a b. (a -> b) -> a -> b
$ String
"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 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 (m :: * -> *) a. Monad m => a -> m a
return (String -> a
forall a. HasCallStack => String -> a
error String
"Empty type"); JSValue
_ -> String -> Result a
forall a. String -> Result a
Error (String -> Result a) -> String -> Result a
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        -> String -> Result a
forall a. String -> Result a
Error (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ String
"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 -> 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]
++ String
")"
        getConstr :: DataType -> JSValue -> Result (Constr, JSValue)
getConstr DataType
t (JSObject JSObject JSValue
o) | [(String
s, JSValue
j')] <- JSObject JSValue -> [(String, JSValue)]
forall a. JSObject a -> [(String, a)]
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 DataType
t (JSString 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 DataType
_ JSValue
_ = String -> Result (Constr, JSValue)
forall a. String -> Result a
Error String
"fromJSON: bad constructor encoding"
        readConstr' :: DataType -> String -> Result Constr
readConstr' DataType
t 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
$ String
"fromJSON: unknown constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " 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 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' a
0 Constr
c  [String]
_       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 :: [String]
fs@(String
_:[String]
_) (JSObject 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 a. JSObject a -> [(String, a)]
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' a
_ Constr
c [String]
_        JSValue
jd                   = String -> Result a
forall a. String -> Result a
Error (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ String
"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 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 String
"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 (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 JSON5 object.  FIXME? Should this use a map?
        selectFields :: [(String, b)] -> t String -> Result (t b)
selectFields [(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 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
$ String
"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 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 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) 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 (m :: * -> *) a. Monad m => a -> m a
return b
forall a. HasCallStack => a
undefined

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

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

-- |Decode a string as a value.
decodeJSON :: (Data a) => String -> a
decodeJSON :: String -> a
decodeJSON 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 String
msg -> String -> a
forall a. HasCallStack => String -> a
error String
msg
    Right JSValue
j ->
        case JSValue -> Result a
forall a. Data a => JSValue -> Result a
fromJSON JSValue
j of
        Error String
msg -> String -> a
forall a. HasCallStack => String -> a
error String
msg
        Ok a
x -> a
x