{-# LANGUAGE PatternGuards #-}
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
type T a = a -> JSValue
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
(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)
(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)
(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
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 :: 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
")"
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
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
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)
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 []
decodeArgs' a
1 Constr
c [] JSValue
jd = Constr -> [JSValue] -> Result a
forall a. Data a => Constr -> [JSValue] -> Result a
construct Constr
c [JSValue
jd]
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
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
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)
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'
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
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"
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
""
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