faa1632 · typeable/aeson

1{-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleInstances,

2 FunctionalDependencies, KindSignatures, OverlappingInstances,

3 ScopedTypeVariables, TypeOperators, UndecidableInstances,

4− ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards #-}

4+ ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards,

5+ RecordWildCards #-}

5{-# OPTIONS_GHC -fno-warn-orphans #-}

6{-# OPTIONS_GHC -fno-warn-orphans #-}

6

7

7-- |

8-- |

19module Data.Aeson.Types.Generic ( ) where

20module Data.Aeson.Types.Generic ( ) where

20

21

21import Control.Applicative ((<*>), (<$>), (<|>), pure)

22import Control.Applicative ((<*>), (<$>), (<|>), pure)

23+import Control.Monad ((<=<))

22import Control.Monad.ST (ST)

24import Control.Monad.ST (ST)

23import Data.Aeson.Types.Class

25import Data.Aeson.Types.Class

24import Data.Aeson.Types.Internal

26import Data.Aeson.Types.Internal

36-- Generic toJSON

38-- Generic toJSON

37

39

38instance (GToJSON a) => GToJSON (M1 i c a) where

40instance (GToJSON a) => GToJSON (M1 i c a) where

41+ -- Meta-information, which is not handled elsewhere, is ignored:

39 gToJSON opts = gToJSON opts . unM1

42 gToJSON opts = gToJSON opts . unM1

40 {-# INLINE gToJSON #-}

43 {-# INLINE gToJSON #-}

41

44

42instance (ToJSON a) => GToJSON (K1 i a) where

45instance (ToJSON a) => GToJSON (K1 i a) where

46+ -- Constant values are encoded using their ToJSON instance:

43 gToJSON _opts = toJSON . unK1

47 gToJSON _opts = toJSON . unK1

44 {-# INLINE gToJSON #-}

48 {-# INLINE gToJSON #-}

45

49

46instance GToJSON U1 where

50instance GToJSON U1 where

51+ -- Empty constructors are encoded to an empty array:

47 gToJSON _opts _ = emptyArray

52 gToJSON _opts _ = emptyArray

48 {-# INLINE gToJSON #-}

53 {-# INLINE gToJSON #-}

49

54

50instance (ConsToJSON a) => GToJSON (C1 c a) where

55instance (ConsToJSON a) => GToJSON (C1 c a) where

56+ -- Constructors need to be encoded differently depending on whether they're

57+ -- a record or not. This distinction is made by constToJSON:

51 gToJSON opts = consToJSON opts . unM1

58 gToJSON opts = consToJSON opts . unM1

52 {-# INLINE gToJSON #-}

59 {-# INLINE gToJSON #-}

53

60

54−instance ( GProductToValues a, GProductToValues b

61+instance ( WriteProduct a, WriteProduct b

55− , ProductSize a, ProductSize b) => GToJSON (a :*: b) where

62+ , ProductSize a, ProductSize b ) => GToJSON (a :*: b) where

63+ -- Products are encoded to an array. Here we allocate a mutable vector of

64+ -- the the same size as the product and write the product's elements to it

65+ -- using writeProduct:

56 gToJSON opts p =

66 gToJSON opts p =

57 Array $ V.create $ do

67 Array $ V.create $ do

58 mv <- VM.unsafeNew lenProduct

68 mv <- VM.unsafeNew lenProduct

59− gProductToValues opts mv 0 lenProduct p

69+ writeProduct opts mv 0 lenProduct p

60 return mv

70 return mv

61 where

71 where

62− lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)

72+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)

73+ productSize

63 {-# INLINE gToJSON #-}

74 {-# INLINE gToJSON #-}

64

75

65−instance (AllNullary (a :+: b) c, GSumToJSON' c (a :+: b)) => GToJSON (a :+: b) where

76+instance ( AllNullary (a :+: b) bool

77+ , SumToJSON (a :+: b) bool ) => GToJSON (a :+: b) where

78+ -- If all constructors of a sum datatype are nullary and the

79+ -- 'nullaryToString' option is set they are encoded to strings.

80+ -- This distinction is made by 'sumToJSON':

66− gToJSON = unTagged (gSumToJSON' :: Tagged c (Options -> (a :+: b) d -> Value))

81+ gToJSON opts = (unTagged :: Tagged bool Value -> Value)

82+ . sumToJSON opts

67 {-# INLINE gToJSON #-}

83 {-# INLINE gToJSON #-}

68

84

69−class GSumToJSON' b f where

70− gSumToJSON' :: Tagged b (Options -> f a -> Value)

71−

72−instance ( GSumToString f

73− , GExtractSum f

74− , GObjectWithType f

75− , GObjectWithSingleField f

76− ) => GSumToJSON' True f where

77− gSumToJSON' = Tagged $ \opts x ->

78− if nullaryToString opts

79− then gSumToString opts x

80− else sumToJSON opts x

81− {-# INLINE gSumToJSON' #-}

82−

83−instance (GExtractSum f, GObjectWithType f, GObjectWithSingleField f) => GSumToJSON' False f where

84− gSumToJSON' = Tagged sumToJSON

85− {-# INLINE gSumToJSON' #-}

86−

87−sumToJSON :: (GExtractSum f, GObjectWithType f, GObjectWithSingleField f) => Options -> f a -> Value

88−sumToJSON opts x =

89− case sumEncoding opts of

90− TwoElemArray ->

91− Array $ V.create $ do

92− let (typ, val) = gExtractSum x opts

93− mv <- VM.unsafeNew 2

94− VM.unsafeWrite mv 0 typ

95− VM.unsafeWrite mv 1 val

96− return mv

97− ObjectWithType{typeFieldName,valueFieldName} ->

98− object $ gObjectWithType opts typeFieldName valueFieldName x

99− ObjectWithSingleField ->

100− Object $ gObjectWithSingleField opts x

101−{-# INLINE sumToJSON #-}

102−

103--------------------------------------------------------------------------------

85--------------------------------------------------------------------------------

104

86

105−class GObjectWithType f where

87+class SumToJSON f bool where

106− gObjectWithType :: Options -> String -> String -> f a -> [Pair]

88+ sumToJSON :: Options -> f a -> Tagged bool Value

89+

90+instance ( GetConName f

91+ , ObjectWithType f

92+ , ObjectWithSingleField f

93+ , TwoElemArray f ) => SumToJSON f True where

94+ sumToJSON opts

95+ | nullaryToString opts = Tagged . String . pack

96+ . constructorNameModifier opts . getConName

97+ | otherwise = Tagged . nonAllNullarySumToJSON opts

98+ {-# INLINE sumToJSON #-}

99+

100+instance ( TwoElemArray f

101+ , ObjectWithType f

102+ , ObjectWithSingleField f ) => SumToJSON f False where

103+ sumToJSON opts = Tagged . nonAllNullarySumToJSON opts

104+ {-# INLINE sumToJSON #-}

105+

106+nonAllNullarySumToJSON :: ( TwoElemArray f

107+ , ObjectWithType f

108+ , ObjectWithSingleField f

109+ ) => Options -> f a -> Value

110+nonAllNullarySumToJSON opts =

111+ case sumEncoding opts of

112+ ObjectWithType{..} -> object . objectWithType opts typeFieldName

113+ valueFieldName

114+ ObjectWithSingleField -> Object . objectWithSingleField opts

115+ TwoElemArray -> Array . twoElemArray opts

116+{-# INLINE nonAllNullarySumToJSON #-}

107

117

108−instance (GObjectWithType a, GObjectWithType b) => GObjectWithType (a :+: b) where

118+--------------------------------------------------------------------------------

109− gObjectWithType opts typeFieldName valueFieldName (L1 x) =

110− gObjectWithType opts typeFieldName valueFieldName x

111− gObjectWithType opts typeFieldName valueFieldName (R1 x) =

112− gObjectWithType opts typeFieldName valueFieldName x

113− {-# INLINE gObjectWithType #-}

114

119

120+class ObjectWithType f where

121+ objectWithType :: Options -> String -> String -> f a -> [Pair]

122+

123+instance ( ObjectWithType a

124+ , ObjectWithType b ) => ObjectWithType (a :+: b) where

125+ objectWithType opts typeFieldName valueFieldName (L1 x) =

126+ objectWithType opts typeFieldName valueFieldName x

127+ objectWithType opts typeFieldName valueFieldName (R1 x) =

128+ objectWithType opts typeFieldName valueFieldName x

129+ {-# INLINE objectWithType #-}

130+

115−instance (IsRecord a b, Constructor c, GObjectWithType' b a) =>

131+instance ( IsRecord a bool

116− GObjectWithType (C1 c a) where

132+ , ObjectWithType' a bool

133+ , Constructor c ) => ObjectWithType (C1 c a) where

117− gObjectWithType opts typeFieldName valueFieldName x =

134+ objectWithType opts typeFieldName valueFieldName =

118 (pack typeFieldName .= constructorNameModifier opts

135 (pack typeFieldName .= constructorNameModifier opts

119− (conName (undefined :: t c a p))) :

136+ (conName (undefined :: t c a p)) :) .

137+ (unTagged :: Tagged bool [Pair] -> [Pair]) .

120− unTagged (gObjectWithType' opts valueFieldName (unM1 x) :: Tagged b [Pair])

138+ objectWithType' opts valueFieldName . unM1

121− {-# INLINE gObjectWithType #-}

139+ {-# INLINE objectWithType #-}

122

140

123−class GObjectWithType' b f where

141+class ObjectWithType' f bool where

124− gObjectWithType' :: Options -> String -> f a -> Tagged b [Pair]

142+ objectWithType' :: Options -> String -> f a -> Tagged bool [Pair]

125

143

126−instance (GRecordToPairs f) => GObjectWithType' True f where

144+instance (GRecordToPairs f) => ObjectWithType' f True where

127− gObjectWithType' opts _ x = Tagged $ toList $ gRecordToPairs opts x

145+ objectWithType' opts _ = Tagged . toList . gRecordToPairs opts

128− {-# INLINE gObjectWithType' #-}

146+ {-# INLINE objectWithType' #-}

129

147

130−instance (GToJSON f) => GObjectWithType' False f where

148+instance (GToJSON f) => ObjectWithType' f False where

131− gObjectWithType' opts valueFieldName x =

149+ objectWithType' opts valueFieldName =

132− Tagged [pack valueFieldName .= gToJSON opts x]

150+ Tagged . (:[]) . (pack valueFieldName .=) . gToJSON opts

133− {-# INLINE gObjectWithType' #-}

151+ {-# INLINE objectWithType' #-}

134

152

135--------------------------------------------------------------------------------

153--------------------------------------------------------------------------------

136

154

155+-- | Get the name of the constructor of a sum datatype.

137−class GSumToString f where

156+class GetConName f where

138− gSumToString :: Options -> f a -> Value

157+ getConName :: f a -> String

139

158

140−instance (GSumToString a, GSumToString b) => GSumToString (a :+: b) where

159+instance (GetConName a, GetConName b) => GetConName (a :+: b) where

141− gSumToString opts (L1 x) = gSumToString opts x

160+ getConName (L1 x) = getConName x

142− gSumToString opts (R1 x) = gSumToString opts x

161+ getConName (R1 x) = getConName x

143− {-# INLINE gSumToString #-}

162+ {-# INLINE getConName #-}

144

163

145−instance (Constructor c, GToJSON a, ConsToJSON a) => GSumToString (C1 c a) where

164+instance (Constructor c, GToJSON a, ConsToJSON a) => GetConName (C1 c a) where

146− gSumToString opts _ = String $ pack $ constructorNameModifier opts

165+ getConName = conName

147− $ conName (undefined :: t c a p)

166+ {-# INLINE getConName #-}

148− {-# INLINE gSumToString #-}

149

167

150--------------------------------------------------------------------------------

168--------------------------------------------------------------------------------

151

169

152−class GExtractSum f where

170+class TwoElemArray f where

153− gExtractSum :: f a -> Options -> (Value, Value)

171+ twoElemArray :: Options -> f a -> V.Vector Value

154

172

155−instance (GExtractSum a, GExtractSum b) => GExtractSum (a :+: b) where

173+instance (TwoElemArray a, TwoElemArray b) => TwoElemArray (a :+: b) where

156− gExtractSum (L1 x) = gExtractSum x

174+ twoElemArray opts (L1 x) = twoElemArray opts x

157− gExtractSum (R1 x) = gExtractSum x

175+ twoElemArray opts (R1 x) = twoElemArray opts x

158− {-# INLINE gExtractSum #-}

176+ {-# INLINE twoElemArray #-}

159

177

160−instance (Constructor c, GToJSON a, ConsToJSON a) => GExtractSum (C1 c a) where

178+instance ( GToJSON a, ConsToJSON a

179+ , Constructor c ) => TwoElemArray (C1 c a) where

180+ twoElemArray opts x = V.create $ do

181+ mv <- VM.unsafeNew 2

161− gExtractSum x opts = ( String $ pack $ constructorNameModifier opts

182+ VM.unsafeWrite mv 0 $ String $ pack $ constructorNameModifier opts

162− $ conName (undefined :: t c a p)

183+ $ conName (undefined :: t c a p)

163− , gToJSON opts x

184+ VM.unsafeWrite mv 1 $ gToJSON opts x

164− )

185+ return mv

165− {-# INLINE gExtractSum #-}

186+ {-# INLINE twoElemArray #-}

166

187

167--------------------------------------------------------------------------------

188--------------------------------------------------------------------------------

168

189

169−class ConsToJSON f where consToJSON :: Options -> f a -> Value

190+class ConsToJSON f where

170−class ConsToJSON' b f where consToJSON' :: Tagged b (Options -> f a -> Value)

191+ consToJSON :: Options -> f a -> Value

171

192

172−newtype Tagged s b = Tagged {unTagged :: b}

193+class ConsToJSON' f bool where

194+ consToJSON' :: Options -> f a -> Tagged bool Value

173

195

196+instance ( IsRecord f bool

174−instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where

197+ , ConsToJSON' f bool ) => ConsToJSON f where

175− consToJSON = unTagged (consToJSON' :: Tagged b (Options -> f a -> Value))

198+ consToJSON opts = (unTagged :: Tagged bool Value -> Value)

199+ . consToJSON' opts

176 {-# INLINE consToJSON #-}

200 {-# INLINE consToJSON #-}

177

201

178−instance (GRecordToPairs f) => ConsToJSON' True f where

202+instance (GRecordToPairs f) => ConsToJSON' f True where

179− consToJSON' = Tagged (\opts -> object . toList . gRecordToPairs opts)

203+ consToJSON' opts = Tagged . object . toList . gRecordToPairs opts

180 {-# INLINE consToJSON' #-}

204 {-# INLINE consToJSON' #-}

181

205

182−instance GToJSON f => ConsToJSON' False f where

206+instance GToJSON f => ConsToJSON' f False where

183− consToJSON' = Tagged gToJSON

207+ consToJSON' opts = Tagged . gToJSON opts

184 {-# INLINE consToJSON' #-}

208 {-# INLINE consToJSON' #-}

185

209

186--------------------------------------------------------------------------------

210--------------------------------------------------------------------------------

209

233

210--------------------------------------------------------------------------------

234--------------------------------------------------------------------------------

211

235

212−class GProductToValues f where

236+class WriteProduct f where

213− gProductToValues :: Options

237+ writeProduct :: Options

214− -> VM.MVector s Value

238+ -> VM.MVector s Value

215− -> Int -- ^ index

239+ -> Int -- ^ index

216− -> Int -- ^ length

240+ -> Int -- ^ length

217− -> f a

241+ -> f a

218− -> ST s ()

242+ -> ST s ()

219−

243+

220−instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where

244+instance ( WriteProduct a

245+ , WriteProduct b ) => WriteProduct (a :*: b) where

221− gProductToValues opts mv ix len (a :*: b) = do

246+ writeProduct opts mv ix len (a :*: b) = do

222− gProductToValues opts mv ix lenL a

247+ writeProduct opts mv ix lenL a

223− gProductToValues opts mv ixR lenR b

248+ writeProduct opts mv ixR lenR b

224 where

249 where

225 lenL = len `shiftR` 1

250 lenL = len `shiftR` 1

226− ixR = ix + lenL

227 lenR = len - lenL

251 lenR = len - lenL

228− {-# INLINE gProductToValues #-}

252+ ixR = ix + lenL

253+ {-# INLINE writeProduct #-}

229

254

230−instance (GToJSON a) => GProductToValues a where

255+instance (GToJSON a) => WriteProduct a where

231− gProductToValues opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts

256+ writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts

232− {-# INLINE gProductToValues #-}

257+ {-# INLINE writeProduct #-}

233

258

234--------------------------------------------------------------------------------

259--------------------------------------------------------------------------------

235

260

236−class GObjectWithSingleField f where

261+class ObjectWithSingleField f where

237− gObjectWithSingleField :: Options -> f a -> Object

262+ objectWithSingleField :: Options -> f a -> Object

238

263

239−instance (GObjectWithSingleField a, GObjectWithSingleField b) =>

264+instance ( ObjectWithSingleField a

240− GObjectWithSingleField (a :+: b) where

265+ , ObjectWithSingleField b ) => ObjectWithSingleField (a :+: b) where

241− gObjectWithSingleField opts (L1 x) = gObjectWithSingleField opts x

266+ objectWithSingleField opts (L1 x) = objectWithSingleField opts x

242− gObjectWithSingleField opts (R1 x) = gObjectWithSingleField opts x

267+ objectWithSingleField opts (R1 x) = objectWithSingleField opts x

243− {-# INLINE gObjectWithSingleField #-}

268+ {-# INLINE objectWithSingleField #-}

244

269

245−instance (Constructor c, GToJSON a, ConsToJSON a) =>

270+instance ( GToJSON a, ConsToJSON a

246− GObjectWithSingleField (C1 c a) where

271+ , Constructor c ) => ObjectWithSingleField (C1 c a) where

247− gObjectWithSingleField opts x =

272+ objectWithSingleField opts = H.singleton typ . gToJSON opts

273+ where

248− H.singleton ( pack $ constructorNameModifier opts

274+ typ = pack $ constructorNameModifier opts $

249− $ conName (undefined :: t c a p)

275+ conName (undefined :: t c a p)

250− ) $ gToJSON opts x

276+ {-# INLINE objectWithSingleField #-}

251− {-# INLINE gObjectWithSingleField #-}

252

277

253--------------------------------------------------------------------------------

278--------------------------------------------------------------------------------

254-- Generic parseJSON

279-- Generic parseJSON

255

280

256instance (GFromJSON a) => GFromJSON (M1 i c a) where

281instance (GFromJSON a) => GFromJSON (M1 i c a) where

282+ -- Meta-information, which is not handled elsewhere, is just added to the

283+ -- parsed value:

257 gParseJSON opts = fmap M1 . gParseJSON opts

284 gParseJSON opts = fmap M1 . gParseJSON opts

258 {-# INLINE gParseJSON #-}

285 {-# INLINE gParseJSON #-}

259

286

260instance (FromJSON a) => GFromJSON (K1 i a) where

287instance (FromJSON a) => GFromJSON (K1 i a) where

288+ -- Constant values are decoded using their FromJSON instance:

261 gParseJSON _opts = fmap K1 . parseJSON

289 gParseJSON _opts = fmap K1 . parseJSON

262 {-# INLINE gParseJSON #-}

290 {-# INLINE gParseJSON #-}

263

291

264instance GFromJSON U1 where

292instance GFromJSON U1 where

293+ -- Empty constructors are expected to be encoded as an empty array:

265 gParseJSON _opts v

294 gParseJSON _opts v

266 | isEmptyArray v = pure U1

295 | isEmptyArray v = pure U1

267 | otherwise = typeMismatch "unit constructor (U1)" v

296 | otherwise = typeMismatch "unit constructor (U1)" v

268 {-# INLINE gParseJSON #-}

297 {-# INLINE gParseJSON #-}

269

298

270instance (ConsFromJSON a) => GFromJSON (C1 c a) where

299instance (ConsFromJSON a) => GFromJSON (C1 c a) where

300+ -- Constructors need to be decoded differently depending on whether they're

301+ -- a record or not. This distinction is made by consParseJSON:

271 gParseJSON opts = fmap M1 . consParseJSON opts

302 gParseJSON opts = fmap M1 . consParseJSON opts

272 {-# INLINE gParseJSON #-}

303 {-# INLINE gParseJSON #-}

273

304

274−instance ( GFromProduct a, GFromProduct b

305+instance ( FromProduct a, FromProduct b

275− , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where

306+ , ProductSize a, ProductSize b ) => GFromJSON (a :*: b) where

307+ -- Products are expected to be encoded to an array. Here we check whether we

308+ -- got an array of the same size as the product, then parse each of the

309+ -- product's elements using parseProduct:

276 gParseJSON opts = withArray "product (:*:)" $ \arr ->

310 gParseJSON opts = withArray "product (:*:)" $ \arr ->

277 let lenArray = V.length arr

311 let lenArray = V.length arr

278− lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int) in

312+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)

313+ productSize in

279 if lenArray == lenProduct

314 if lenArray == lenProduct

280− then gParseProduct opts arr 0 lenProduct

315+ then parseProduct opts arr 0 lenProduct

281 else fail $ "When expecting a product of " ++ show lenProduct ++

316 else fail $ "When expecting a product of " ++ show lenProduct ++

282 " values, encountered an Array of " ++ show lenArray ++

317 " values, encountered an Array of " ++ show lenArray ++

283 " elements instead"

318 " elements instead"

284 {-# INLINE gParseJSON #-}

319 {-# INLINE gParseJSON #-}

285

320

286−instance (AllNullary (a :+: b) c, GParseSum' c (a :+: b)) => GFromJSON (a :+: b) where

321+instance ( AllNullary (a :+: b) bool

322+ , ParseSum (a :+: b) bool ) => GFromJSON (a :+: b) where

323+ -- If all constructors of a sum datatype are nullary and the

324+ -- 'nullaryToString' option is set they are expected to be encoded as

325+ -- strings. This distinction is made by 'parseSum':

287− gParseJSON = unTagged (gParseSum' :: Tagged c (Options -> Value -> Parser ((a :+: b) d)))

326+ gParseJSON opts = (unTagged :: Tagged bool (Parser ((a :+: b) d)) ->

327+ (Parser ((a :+: b) d)))

328+ . parseSum opts

288 {-# INLINE gParseJSON #-}

329 {-# INLINE gParseJSON #-}

289

330

331+--------------------------------------------------------------------------------

332+

290−class GParseSum' b f where

333+class ParseSum f bool where

291− gParseSum' :: Tagged b (Options -> Value -> Parser (f a))

334+ parseSum :: Options -> Value -> Tagged bool (Parser (f a))

292

335

293−instance (GSumFromString (a :+: b), GFromPair (a :+: b), GFromObjectWithType (a :+: b)) =>

336+instance ( SumFromString (a :+: b)

294− GParseSum' True (a :+: b) where

337+ , FromPair (a :+: b)

295− gParseSum' = Tagged $ \opts v ->

338+ , FromObjectWithType (a :+: b) ) => ParseSum (a :+: b) True where

339+ parseSum opts

296− if nullaryToString opts

340+ | nullaryToString opts = Tagged . parseAllNullarySum opts

297− then parseSumFromString opts v

341+ | otherwise = Tagged . parseNonAllNullarySum opts

298− else parseSum opts v

299− {-# INLINE gParseSum' #-}

342+ {-# INLINE parseSum #-}

300

343

301−instance (GFromPair (a :+: b), GFromObjectWithType (a :+: b)) => GParseSum' False (a :+: b) where

344+instance ( FromPair (a :+: b)

302− gParseSum' = Tagged parseSum

345+ , FromObjectWithType (a :+: b) ) => ParseSum (a :+: b) False where

346+ parseSum opts = Tagged . parseNonAllNullarySum opts

303− {-# INLINE gParseSum' #-}

347+ {-# INLINE parseSum #-}

304

348

305--------------------------------------------------------------------------------

349--------------------------------------------------------------------------------

306

350

307−parseSumFromString :: GSumFromString f => Options -> Value -> Parser (f a)

351+parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)

308−parseSumFromString opts = withText "Text" $ \key ->

352+parseAllNullarySum opts = withText "Text" $ \key ->

309 maybe (notFound $ unpack key) return $

353 maybe (notFound $ unpack key) return $

310− gParseSumFromString opts key

354+ parseSumFromString opts key

311−{-# INLINE parseSumFromString #-}

355+{-# INLINE parseAllNullarySum #-}

312

356

313−class GSumFromString f where

357+class SumFromString f where

314− gParseSumFromString :: Options -> Text -> Maybe (f a)

358+ parseSumFromString :: Options -> Text -> Maybe (f a)

315

359

316−instance (GSumFromString a, GSumFromString b) => GSumFromString (a :+: b) where

360+instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where

317− gParseSumFromString opts key = (L1 <$> gParseSumFromString opts key) <|>

361+ parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>

318− (R1 <$> gParseSumFromString opts key)

362+ (R1 <$> parseSumFromString opts key)

319− {-# INLINE gParseSumFromString #-}

363+ {-# INLINE parseSumFromString #-}

320

364

321−instance (Constructor c) => GSumFromString (C1 c U1) where

365+instance (Constructor c) => SumFromString (C1 c U1) where

322− gParseSumFromString opts key | key == name = Just $ M1 U1

366+ parseSumFromString opts key | key == name = Just $ M1 U1

323− | otherwise = Nothing

367+ | otherwise = Nothing

324 where

368 where

325− name = pack $ constructorNameModifier opts $ conName (undefined :: t c U1 p)

369+ name = pack $ constructorNameModifier opts $

326− {-# INLINE gParseSumFromString #-}

370+ conName (undefined :: t c U1 p)

371+ {-# INLINE parseSumFromString #-}

327

372

328--------------------------------------------------------------------------------

373--------------------------------------------------------------------------------

329

374

330−parseSum :: (GFromPair (a :+: b), GFromObjectWithType (a :+: b)) =>

375+parseNonAllNullarySum :: ( FromPair (a :+: b)

376+ , FromObjectWithType (a :+: b)

331− Options -> Value -> Parser ((a :+: b) c)

377+ ) => Options -> Value -> Parser ((a :+: b) c)

332−parseSum opts v =

378+parseNonAllNullarySum opts =

333 case sumEncoding opts of

379 case sumEncoding opts of

334− TwoElemArray -> parseTwoElemArray opts v

335− ObjectWithType{typeFieldName,valueFieldName} ->

380+ ObjectWithType{..} ->

336− parseFromObjectWithType opts typeFieldName valueFieldName v

337− ObjectWithSingleField -> parseFromObjectWithSingleField opts v

338−{-# INLINE parseSum #-}

339−

340−parseFromObjectWithSingleField :: (GFromPair (a :+: b)) => Options -> Value -> Parser ((a :+: b) c)

341−parseFromObjectWithSingleField opts = withObject "Object" $ \obj ->

381+ withObject "Object" $ \obj -> do

342− case H.toList obj of

382+ key <- obj .: pack typeFieldName

343− [keyVal@(key, _)] -> fromMaybe (notFound $ unpack key) $ gParsePair opts keyVal

383+ fromMaybe (notFound $ unpack key) $

344− _ -> fail "Object doesn't have a single field"

384+ parseFromObjectWithType opts valueFieldName obj key

345−{-# INLINE parseFromObjectWithSingleField #-}

346−

347−notFound :: String -> Parser a

348−notFound key = fail $ "The key \"" ++ key ++ "\" was not found"

349−{-# INLINE notFound #-}

350

385

351−--------------------------------------------------------------------------------

386+ ObjectWithSingleField ->

387+ withObject "Object" $ \obj ->

388+ case H.toList obj of

389+ [keyVal@(key, _)] -> fromMaybe (notFound $ unpack key) $

390+ parsePair opts keyVal

391+ _ -> fail "Object doesn't have a single field"

352

392

353−parseTwoElemArray :: GFromPair f => Options -> Value -> Parser (f a)

393+ TwoElemArray ->

354−parseTwoElemArray opts = withArray "Array" $ \arr ->

394+ withArray "Array" $ \arr ->

355− if V.length arr == 2

395+ if V.length arr == 2

356− then case V.unsafeIndex arr 0 of

396+ then case V.unsafeIndex arr 0 of

357− String key -> fromMaybe (notFound $ unpack key) $

397+ String key -> fromMaybe (notFound $ unpack key) $

358− gParsePair opts (key, V.unsafeIndex arr 1)

398+ parsePair opts (key, V.unsafeIndex arr 1)

359− _ -> fail "First element is not a String"

399+ _ -> fail "First element is not a String"

360− else fail "Array doesn't have 2 elements"

400+ else fail "Array doesn't have 2 elements"

361−{-# INLINE parseTwoElemArray #-}

401+{-# INLINE parseNonAllNullarySum #-}

362

402

363--------------------------------------------------------------------------------

403--------------------------------------------------------------------------------

364

404

365−parseFromObjectWithType :: (GFromObjectWithType f)

405+class FromObjectWithType f where

366− => Options -> String -> String -> Value -> Parser (f a)

367−parseFromObjectWithType opts typeFieldName valueFieldName = withObject "Object" $ \obj -> do

368− key <- obj .: pack typeFieldName

369− fromMaybe (notFound $ unpack key) $

370− gParseFromObjectWithType opts valueFieldName obj key

371−{-# INLINE parseFromObjectWithType #-}

372−

373−class GFromObjectWithType f where

374− gParseFromObjectWithType :: Options -> String -> Object -> Text -> Maybe (Parser (f a))

406+ parseFromObjectWithType :: Options -> String -> Object -> Text

375−

407+ -> Maybe (Parser (f a))

376−instance (GFromObjectWithType a, GFromObjectWithType b) =>

408+

377− GFromObjectWithType (a :+: b) where

409+instance (FromObjectWithType a, FromObjectWithType b) =>

410+ FromObjectWithType (a :+: b) where

378− gParseFromObjectWithType opts valueFieldName obj key =

411+ parseFromObjectWithType opts valueFieldName obj key =

379− (fmap L1 <$> gParseFromObjectWithType opts valueFieldName obj key) <|>

412+ (fmap L1 <$> parseFromObjectWithType opts valueFieldName obj key) <|>

380− (fmap R1 <$> gParseFromObjectWithType opts valueFieldName obj key)

413+ (fmap R1 <$> parseFromObjectWithType opts valueFieldName obj key)

381− {-# INLINE gParseFromObjectWithType #-}

414+ {-# INLINE parseFromObjectWithType #-}

382−

415+

383−instance (GFromObjectWithType' f, Constructor c) => GFromObjectWithType (C1 c f) where

416+instance ( FromObjectWithType' f

417+ , Constructor c ) => FromObjectWithType (C1 c f) where

384− gParseFromObjectWithType opts valueFieldName obj key

418+ parseFromObjectWithType opts valueFieldName obj key

419+ | key == name = Just $ M1 <$> parseFromObjectWithType'

385− | key == name = Just $ M1 <$> gParseFromObjectWithType' opts valueFieldName obj

420+ opts valueFieldName obj

386 | otherwise = Nothing

421 | otherwise = Nothing

387 where

422 where

388− name = pack $ constructorNameModifier opts $ conName (undefined :: t c f p)

423+ name = pack $ constructorNameModifier opts $

389− {-# INLINE gParseFromObjectWithType #-}

424+ conName (undefined :: t c f p)

425+ {-# INLINE parseFromObjectWithType #-}

426+

427+--------------------------------------------------------------------------------

390

428

391−class GFromObjectWithType' f where

429+class FromObjectWithType' f where

392− gParseFromObjectWithType' :: Options -> String -> Object -> Parser (f a)

430+ parseFromObjectWithType' :: Options -> String -> Object -> Parser (f a)

393

431

394−instance (IsRecord f b, GFromObjectWithType'' b f) => GFromObjectWithType' f where

432+class FromObjectWithType'' f bool where

395− gParseFromObjectWithType' =

396− unTagged (gParseFromObjectWithType'' ::

397− Tagged b (Options -> String -> Object -> Parser (f a)))

433+ parseFromObjectWithType'' :: Options -> String -> Object

398− {-# INLINE gParseFromObjectWithType' #-}

434+ -> Tagged bool (Parser (f a))

399

435

400−class GFromObjectWithType'' b f where

436+instance ( IsRecord f bool

401− gParseFromObjectWithType'' :: Tagged b (Options -> String -> Object -> Parser (f a))

437+ , FromObjectWithType'' f bool

438+ ) => FromObjectWithType' f where

439+ parseFromObjectWithType' opts valueFieldName =

440+ (unTagged :: Tagged bool (Parser (f a)) -> Parser (f a)) .

441+ parseFromObjectWithType'' opts valueFieldName

442+ {-# INLINE parseFromObjectWithType' #-}

402

443

403−instance (GFromRecord f) => GFromObjectWithType'' True f where

444+instance (FromRecord f) => FromObjectWithType'' f True where

404− gParseFromObjectWithType'' = Tagged $ \opts _ obj -> gParseRecord opts obj

445+ parseFromObjectWithType'' opts _ = Tagged . parseRecord opts

405− {-# INLINE gParseFromObjectWithType'' #-}

446+ {-# INLINE parseFromObjectWithType'' #-}

406

447

407−instance (GFromJSON f) => GFromObjectWithType'' False f where

448+instance (GFromJSON f) => FromObjectWithType'' f False where

408− gParseFromObjectWithType'' = Tagged $ \opts valueFieldName obj ->

449+ parseFromObjectWithType'' opts valueFieldName = Tagged .

409− gParseJSON opts =<< (obj .: pack valueFieldName)

450+ (gParseJSON opts <=< (.: pack valueFieldName))

410− {-# INLINE gParseFromObjectWithType'' #-}

451+ {-# INLINE parseFromObjectWithType'' #-}

411

452

412--------------------------------------------------------------------------------

453--------------------------------------------------------------------------------

413

454

414−class ConsFromJSON f where

455+class ConsFromJSON f where

415− consParseJSON :: Options -> Value -> Parser (f a)

416−class ConsFromJSON' b f where

417− consParseJSON' :: Tagged b (Options -> Value -> Parser (f a))

456+ consParseJSON :: Options -> Value -> Parser (f a)

418

457

458+class ConsFromJSON' f bool where

459+ consParseJSON' :: Options -> Value -> Tagged bool (Parser (f a))

460+

461+instance ( IsRecord f bool

462+ , ConsFromJSON' f bool

419−instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where

463+ ) => ConsFromJSON f where

420− consParseJSON =

421− unTagged (consParseJSON' :: Tagged b (Options -> Value -> Parser (f a)))

464+ consParseJSON opts = (unTagged :: Tagged bool (Parser (f a)) -> Parser (f a))

465+ . consParseJSON' opts

422 {-# INLINE consParseJSON #-}

466 {-# INLINE consParseJSON #-}

423

467

424−instance (GFromRecord f) => ConsFromJSON' True f where

468+instance (FromRecord f) => ConsFromJSON' f True where

425− consParseJSON' = Tagged $ withObject "record (:*:)" . gParseRecord

469+ consParseJSON' opts = Tagged . (withObject "record (:*:)" $ parseRecord opts)

426 {-# INLINE consParseJSON' #-}

470 {-# INLINE consParseJSON' #-}

427

471

428−instance (GFromJSON f) => ConsFromJSON' False f where

472+instance (GFromJSON f) => ConsFromJSON' f False where

429− consParseJSON' = Tagged gParseJSON

473+ consParseJSON' opts = Tagged . gParseJSON opts

430 {-# INLINE consParseJSON' #-}

474 {-# INLINE consParseJSON' #-}

431

475

432--------------------------------------------------------------------------------

476--------------------------------------------------------------------------------

433

477

434−class GFromRecord f where

478+class FromRecord f where

435− gParseRecord :: Options -> Object -> Parser (f a)

479+ parseRecord :: Options -> Object -> Parser (f a)

436

480

437−instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where

481+instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where

438− gParseRecord opts obj = (:*:) <$> gParseRecord opts obj

482+ parseRecord opts obj = (:*:) <$> parseRecord opts obj

439− <*> gParseRecord opts obj

483+ <*> parseRecord opts obj

440− {-# INLINE gParseRecord #-}

484+ {-# INLINE parseRecord #-}

441

485

442−instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where

486+instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where

443− gParseRecord opts = maybe (notFound key) (gParseJSON opts)

487+ parseRecord opts = maybe (notFound key) (gParseJSON opts)

444 . H.lookup (pack key)

488 . H.lookup (pack key)

445 where

489 where

446 key = fieldNameModifier opts $ selName (undefined :: t s a p)

490 key = fieldNameModifier opts $ selName (undefined :: t s a p)

447− {-# INLINE gParseRecord #-}

491+ {-# INLINE parseRecord #-}

448

492

449−instance (Selector s, FromJSON a) => GFromRecord (S1 s (K1 i (Maybe a))) where

493+instance (Selector s, FromJSON a) => FromRecord (S1 s (K1 i (Maybe a))) where

450− gParseRecord opts obj = (M1 . K1) <$> obj .:? pack key

494+ parseRecord opts obj = (M1 . K1) <$> obj .:? pack key

451 where

495 where

452 key = fieldNameModifier opts $

496 key = fieldNameModifier opts $

453 selName (undefined :: t s (K1 i (Maybe a)) p)

497 selName (undefined :: t s (K1 i (Maybe a)) p)

454− {-# INLINE gParseRecord #-}

498+ {-# INLINE parseRecord #-}

455

499

456--------------------------------------------------------------------------------

500--------------------------------------------------------------------------------

457

501

458class ProductSize f where

502class ProductSize f where

459 productSize :: Tagged2 f Int

503 productSize :: Tagged2 f Int

460

504

461−newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}

462−

463instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where

505instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where

464 productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +

506 productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +

465 unTagged2 (productSize :: Tagged2 b Int)

507 unTagged2 (productSize :: Tagged2 b Int)

471

513

472--------------------------------------------------------------------------------

514--------------------------------------------------------------------------------

473

515

474−class GFromProduct f where

516+class FromProduct f where

475− gParseProduct :: Options -> Array -> Int -> Int -> Parser (f a)

517+ parseProduct :: Options -> Array -> Int -> Int -> Parser (f a)

476

518

477−instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where

519+instance (FromProduct a, FromProduct b) => FromProduct (a :*: b) where

478− gParseProduct opts arr ix len =

520+ parseProduct opts arr ix len =

479− (:*:) <$> gParseProduct opts arr ix lenL

521+ (:*:) <$> parseProduct opts arr ix lenL

480− <*> gParseProduct opts arr ixR lenR

522+ <*> parseProduct opts arr ixR lenR

481 where

523 where

482 lenL = len `shiftR` 1

524 lenL = len `shiftR` 1

483 ixR = ix + lenL

525 ixR = ix + lenL

484 lenR = len - lenL

526 lenR = len - lenL

485− {-# INLINE gParseProduct #-}

527+ {-# INLINE parseProduct #-}

486

528

487−instance (GFromJSON a) => GFromProduct (S1 s a) where

529+instance (GFromJSON a) => FromProduct (S1 s a) where

488− gParseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix

530+ parseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix

489− {-# INLINE gParseProduct #-}

531+ {-# INLINE parseProduct #-}

490

532

491--------------------------------------------------------------------------------

533--------------------------------------------------------------------------------

492

534

493−class GFromPair f where

535+class FromPair f where

494− gParsePair :: Options -> Pair -> Maybe (Parser (f a))

536+ parsePair :: Options -> Pair -> Maybe (Parser (f a))

495

537

496−instance (GFromPair a, GFromPair b) => GFromPair (a :+: b) where

538+instance (FromPair a, FromPair b) => FromPair (a :+: b) where

497− gParsePair opts keyVal = (fmap L1 <$> gParsePair opts keyVal) <|>

539+ parsePair opts keyVal = (fmap L1 <$> parsePair opts keyVal) <|>

498− (fmap R1 <$> gParsePair opts keyVal)

540+ (fmap R1 <$> parsePair opts keyVal)

499− {-# INLINE gParsePair #-}

541+ {-# INLINE parsePair #-}

500

542

501−instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromPair (C1 c a) where

543+instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where

502− gParsePair opts (key, value)

544+ parsePair opts (key, value)

503 | key == name = Just $ gParseJSON opts value

545 | key == name = Just $ gParseJSON opts value

504 | otherwise = Nothing

546 | otherwise = Nothing

505 where

547 where

506− name = pack $ constructorNameModifier opts $ conName (undefined :: t c a p)

548+ name = pack $ constructorNameModifier opts $

507− {-# INLINE gParsePair #-}

549+ conName (undefined :: t c a p)

550+ {-# INLINE parsePair #-}

508

551

509--------------------------------------------------------------------------------

552--------------------------------------------------------------------------------

510

553

511−class IsRecord (f :: * -> *) b | f -> b

554+class IsRecord (f :: * -> *) bool | f -> bool

512

555

513data True

556data True

514data False

557data False

515

558

516−instance (IsRecord f b) => IsRecord (f :*: g) b

559+instance (IsRecord f bool) => IsRecord (f :*: g) bool

517instance IsRecord (M1 S NoSelector f) False

560instance IsRecord (M1 S NoSelector f) False

518−instance (IsRecord f b) => IsRecord (M1 S c f) b

561+instance (IsRecord f bool) => IsRecord (M1 S c f) bool

519instance IsRecord (K1 i c) True

562instance IsRecord (K1 i c) True

520instance IsRecord U1 False

563instance IsRecord U1 False

521

564

522--------------------------------------------------------------------------------

565--------------------------------------------------------------------------------

523

566

524−class AllNullary (f :: * -> *) b | f -> b

567+class AllNullary (f :: * -> *) bool | f -> bool

525

568

526−instance (AllNullary a b1, AllNullary c b2, And b1 b2 b3) =>

569+instance ( AllNullary a bool1

570+ , AllNullary b bool2

571+ , And bool1 bool2 bool3

527− AllNullary (a :+: c) b3

572+ ) => AllNullary (a :+: b) bool3

528−instance AllNullary a b => AllNullary (M1 i c a) b

573+instance AllNullary a bool => AllNullary (M1 i c a) bool

529−instance AllNullary (a :*: c) False

574+instance AllNullary (a :*: b) False

530instance AllNullary (K1 i c) False

575instance AllNullary (K1 i c) False

531instance AllNullary U1 True

576instance AllNullary U1 True

532

577

533−class And b1 b2 b3 | b1 b2 -> b3

578+class And bool1 bool2 bool3 | bool1 bool2 -> bool3

579+

580+instance And True True True

581+instance And False False False

582+instance And False True False

583+instance And True False False

534

584

535−instance And True True True

585+--------------------------------------------------------------------------------

586+

587+newtype Tagged s b = Tagged {unTagged :: b}

536

588

537−instance And False False False

589+newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}

538−instance And False True False

539−instance And True False False

540

590

541--------------------------------------------------------------------------------

591--------------------------------------------------------------------------------

592+

593+notFound :: String -> Parser a

594+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"

595+{-# INLINE notFound #-}