b38618c · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Refactoring in Data.Aeson.Types.Generic

b38618cBas van Dijk13 years ago

Data/Aeson/Types/Generic.hs+27−36

compare with master

unifiedsplit

@@ -24,6 +24,7 @@ import Data.Aeson.Types.Class

24import Data.Aeson.Types.Internal

25import Data.Bits (shiftR)

26import Data.DList (DList, toList, empty)

27+import Data.Maybe (fromMaybe)

27import Data.Monoid (mappend)

28import Data.Monoid (mappend)

28import Data.Text (Text, pack, unpack)

29import Data.Text (Text, pack, unpack)

29import GHC.Generics

30import GHC.Generics

@@ -272,17 +273,14 @@ instance (ConsFromJSON a) => GFromJSON (C1 c a) where

272

273

273instance ( GFromProduct a, GFromProduct b

274instance ( GFromProduct a, GFromProduct b

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

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

275− gParseJSON opts (Array arr)

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

277+ let lenArray = V.length arr

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

279+ if lenArray == lenProduct

276− | lenArray == lenProduct = gParseProduct opts arr 0 lenProduct

280+ then gParseProduct opts arr 0 lenProduct

277− | otherwise =

278− fail $ "When expecting a product of " ++ show lenProduct ++

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

279− " values, encountered an Array of " ++ show lenArray ++

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

280− " elements instead"

283+ " elements instead"

281− where

282− lenArray = V.length arr

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

284−

285− gParseJSON _opts v = typeMismatch "product (:*:)" v

286 {-# INLINE gParseJSON #-}

284 {-# INLINE gParseJSON #-}

287

285

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

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

@@ -307,10 +305,9 @@ instance (GFromPair (a :+: b), GFromObjectWithType (a :+: b)) => GParseSum' Fals

307--------------------------------------------------------------------------------

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

308

306

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

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

310−parseSumFromString opts (String key) = case gParseSumFromString opts key of

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

311− Nothing -> notFound $ unpack key

309+ maybe (notFound $ unpack key) return $

312− Just x -> return x

310+ gParseSumFromString opts key

313−parseSumFromString _ v = typeMismatch "String" v

314{-# INLINE parseSumFromString #-}

311{-# INLINE parseSumFromString #-}

315

312

316class GSumFromString f where

313class GSumFromString f where

@@ -341,11 +338,10 @@ parseSum opts v =

341{-# INLINE parseSum #-}

338{-# INLINE parseSum #-}

342

339

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

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

344−parseFromObjectWithSingleField opts (Object (H.toList -> [keyVal@(key, _)])) =

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

345− case gParsePair opts keyVal of

342+ case H.toList obj of

346− Nothing -> notFound $ unpack key

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

347− Just p -> p

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

348−parseFromObjectWithSingleField _opts v = typeMismatch "Object with single field" v

349{-# INLINE parseFromObjectWithSingleField #-}

345{-# INLINE parseFromObjectWithSingleField #-}

350

346

351notFound :: String -> Parser a

347notFound :: String -> Parser a

@@ -355,25 +351,23 @@ notFound key = fail $ "The key \"" ++ key ++ "\" was not found"

355--------------------------------------------------------------------------------

351--------------------------------------------------------------------------------

356

352

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

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

358−parseTwoElemArray opts (Array arr)

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

359− | V.length arr == 2

355+ if V.length arr == 2

360− , String key <- V.unsafeIndex arr 0 =

356+ then case V.unsafeIndex arr 0 of

361− case gParsePair opts (key, V.unsafeIndex arr 1) of

362− Nothing -> notFound $ unpack key

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

363− Just p -> p

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

364−parseTwoElemArray _ v = typeMismatch "Array with a key and value element" v

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

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

365{-# INLINE parseTwoElemArray #-}

361{-# INLINE parseTwoElemArray #-}

366

362

367--------------------------------------------------------------------------------

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

368

364

369parseFromObjectWithType :: (GFromObjectWithType f)

365parseFromObjectWithType :: (GFromObjectWithType f)

370 => Options -> String -> String -> Value -> Parser (f a)

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

371−parseFromObjectWithType opts typeFieldName valueFieldName (Object obj) = do

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

372 key <- obj .: pack typeFieldName

368 key <- obj .: pack typeFieldName

369+ fromMaybe (notFound $ unpack key) $

373− case gParseFromObjectWithType opts valueFieldName obj key of

370+ gParseFromObjectWithType opts valueFieldName obj key

374− Nothing -> notFound $ unpack key

375− Just p -> p

376−parseFromObjectWithType _ _ _ v = typeMismatch "Object" v

377{-# INLINE parseFromObjectWithType #-}

371{-# INLINE parseFromObjectWithType #-}

378

372

379class GFromObjectWithType f where

373class GFromObjectWithType f where

@@ -428,10 +422,7 @@ instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where

428 {-# INLINE consParseJSON #-}

422 {-# INLINE consParseJSON #-}

429

423

430instance (GFromRecord f) => ConsFromJSON' True f where

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

431− consParseJSON' = Tagged parseRecord

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

432− where

433− parseRecord opts (Object obj) = gParseRecord opts obj

434− parseRecord _opts v = typeMismatch "record (:*:)" v

435 {-# INLINE consParseJSON' #-}

426 {-# INLINE consParseJSON' #-}

436

427

437instance (GFromJSON f) => ConsFromJSON' False f where

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