4b78229 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Option to unwrap unary record constructors (Fixes #228)

4b78229jpmoresmau12 years ago

Data/Aeson/TH.hs+7−3

compare with master

unifiedsplit

@@ -90,7 +90,7 @@ import Data.Aeson.Types ( Value(..), Parser

90-- from base:

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

92import Control.Monad ( return, mapM, liftM2, fail )

93−import Data.Bool ( Bool(False, True), otherwise, (&&) )

93+import Data.Bool ( Bool(False, True), otherwise, (&&) , not)

94import Data.Eq ( (==) )

95import Data.Function ( ($), (.) )

96import Data.Functor ( fmap )

@@ -281,7 +281,9 @@ encodeArgs opts multiCons (NormalC conName ts) = do

281 []

282

283-- Records.

284−encodeArgs opts multiCons (RecC conName ts) = do

284+encodeArgs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,not multiCons,ts) of

285+ (True,True,[(_,st,ty)])-> encodeArgs opts multiCons (NormalC conName [(st,ty)])

286+ _ -> do

285 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]

287 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]

286 let exp = [|object|] `appE` pairs

288 let exp = [|object|] `appE` pairs

287

289

@@ -664,7 +666,9 @@ parseArgs tName _ (NormalC conName ts) (Right valName) =

664-- Records.

666-- Records.

665parseArgs tName opts (RecC conName ts) (Left (_, obj)) =

667parseArgs tName opts (RecC conName ts) (Left (_, obj)) =

666 parseRecord opts tName conName ts obj

668 parseRecord opts tName conName ts obj

667−parseArgs tName opts (RecC conName ts) (Right valName) = do

669+parseArgs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of

670+ (True,[(_,st,ty)])-> parseArgs tName opts (NormalC conName [(st,ty)]) (Right valName)

671+ _ -> do

668 obj <- newName "recObj"

672 obj <- newName "recObj"

669 caseE (varE valName)

673 caseE (varE valName)

670 [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []

674 [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []

Data/Aeson/Types/Generic.hs+51−24

@@ -272,33 +272,41 @@ class ConsToJSON f where

272 consToEncoding :: Options -> f a -> B.Builder

273

274class ConsToJSON' f isRecord where

275+ consToJSON' :: Options -> Bool -- ^ Are we a record with one field

275− consToJSON' :: Options -> f a -> Tagged isRecord Value

276+ -> f a -> Tagged isRecord Value

277+ consToEncoding' :: Options -> Bool -- ^ Are we a record with one field

276− consToEncoding' :: Options -> f a -> Tagged isRecord B.Builder

278+ -> f a -> Tagged isRecord B.Builder

277−

279+

278instance ( IsRecord f isRecord

280instance ( IsRecord f isRecord

279 , ConsToJSON' f isRecord ) => ConsToJSON f where

281 , ConsToJSON' f isRecord ) => ConsToJSON f where

280 consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)

282 consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)

281− . consToJSON' opts

283+ . consToJSON' opts (isUnary (undefined :: f a))

282 {-# INLINE consToJSON #-}

284 {-# INLINE consToJSON #-}

283

285

284 consToEncoding opts = (unTagged :: Tagged isRecord B.Builder -> B.Builder)

286 consToEncoding opts = (unTagged :: Tagged isRecord B.Builder -> B.Builder)

285− . consToEncoding' opts

287+ . consToEncoding' opts (isUnary (undefined :: f a))

286 {-# INLINE consToEncoding #-}

288 {-# INLINE consToEncoding #-}

287

289

288instance (RecordTo f) => ConsToJSON' f True where

290instance (RecordTo f) => ConsToJSON' f True where

291+ consToJSON' opts isUn f = let

289− consToJSON' opts = Tagged . object . toList . recordToPairs opts

292+ vals = toList $ recordToPairs opts f

293+ in case (unwrapUnaryRecords opts,isUn,vals) of

294+ (True,True,[(_,val)]) -> Tagged val

295+ _ -> Tagged $ object vals

290 {-# INLINE consToJSON' #-}

296 {-# INLINE consToJSON' #-}

291

297

292− consToEncoding' opts x = Tagged $

298+ consToEncoding' opts isUn x

299+ | (True,True) <- (unwrapUnaryRecords opts,isUn) = Tagged $ recordToEncoding opts x

300+ | otherwise = Tagged $

293− B.char7 '{' <>

301+ B.char7 '{' <>

294− recordToEncoding opts x <>

302+ recordToEncoding opts x <>

295− B.char7 '}'

303+ B.char7 '}'

296 {-# INLINE consToEncoding' #-}

304 {-# INLINE consToEncoding' #-}

297

305

298instance GToJSON f => ConsToJSON' f False where

306instance GToJSON f => ConsToJSON' f False where

299− consToJSON' opts = Tagged . gToJSON opts

307+ consToJSON' opts _ = Tagged . gToJSON opts

300 {-# INLINE consToJSON' #-}

308 {-# INLINE consToJSON' #-}

301− consToEncoding' opts = Tagged . gbuilder opts

309+ consToEncoding' opts _ = Tagged . gbuilder opts

302 {-# INLINE consToEncoding' #-}

310 {-# INLINE consToEncoding' #-}

303

311

304--------------------------------------------------------------------------------

312--------------------------------------------------------------------------------

@@ -585,7 +593,7 @@ instance ( IsRecord f isRecord

585 {-# INLINE parseFromTaggedObject' #-}

593 {-# INLINE parseFromTaggedObject' #-}

586

594

587instance (FromRecord f) => FromTaggedObject'' f True where

595instance (FromRecord f) => FromTaggedObject'' f True where

588− parseFromTaggedObject'' opts _ = Tagged . parseRecord opts

596+ parseFromTaggedObject'' opts _ = Tagged . parseRecord opts Nothing

589 {-# INLINE parseFromTaggedObject'' #-}

597 {-# INLINE parseFromTaggedObject'' #-}

590

598

591instance (GFromJSON f) => FromTaggedObject'' f False where

599instance (GFromJSON f) => FromTaggedObject'' f False where

@@ -599,42 +607,56 @@ class ConsFromJSON f where

599 consParseJSON :: Options -> Value -> Parser (f a)

607 consParseJSON :: Options -> Value -> Parser (f a)

600

608

601class ConsFromJSON' f isRecord where

609class ConsFromJSON' f isRecord where

610+ consParseJSON' :: Options -> (Maybe Text) -- ^ A dummy label

611+ -- (Nothing to use proper label)

602− consParseJSON' :: Options -> Value -> Tagged isRecord (Parser (f a))

612+ -> Value -> Tagged isRecord (Parser (f a))

603

613

604instance ( IsRecord f isRecord

614instance ( IsRecord f isRecord

605 , ConsFromJSON' f isRecord

615 , ConsFromJSON' f isRecord

606 ) => ConsFromJSON f where

616 ) => ConsFromJSON f where

617+ consParseJSON opts v = let

618+ (v2,lab) = case (unwrapUnaryRecords opts,isUnary (undefined :: f a)) of

619+ -- use a dummy object with a dummy label

620+ (True,True) -> ((object [(pack "dummy",v)]),Just $ pack "dummy")

621+ _ ->(v,Nothing)

607− consParseJSON opts = (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

622+ in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

608− . consParseJSON' opts

623+ $ consParseJSON' opts lab v2

609 {-# INLINE consParseJSON #-}

624 {-# INLINE consParseJSON #-}

610

625

626+

611instance (FromRecord f) => ConsFromJSON' f True where

627instance (FromRecord f) => ConsFromJSON' f True where

612− consParseJSON' opts = Tagged . (withObject "record (:*:)" $ parseRecord opts)

628+ consParseJSON' opts mlab = Tagged . (withObject "record (:*:)"

629+ $ parseRecord opts mlab)

613 {-# INLINE consParseJSON' #-}

630 {-# INLINE consParseJSON' #-}

614

631

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

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

616− consParseJSON' opts = Tagged . gParseJSON opts

633+ consParseJSON' opts _ = Tagged . gParseJSON opts

617 {-# INLINE consParseJSON' #-}

634 {-# INLINE consParseJSON' #-}

618

635

619--------------------------------------------------------------------------------

636--------------------------------------------------------------------------------

620

637

621class FromRecord f where

638class FromRecord f where

639+ parseRecord :: Options -> (Maybe Text) -- ^ A dummy label

640+ -- (Nothing to use proper label)

622− parseRecord :: Options -> Object -> Parser (f a)

641+ -> Object -> Parser (f a)

623

642

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

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

625− parseRecord opts obj = (:*:) <$> parseRecord opts obj

644+ parseRecord opts _ obj = (:*:) <$> parseRecord opts Nothing obj

626− <*> parseRecord opts obj

645+ <*> parseRecord opts Nothing obj

627 {-# INLINE parseRecord #-}

646 {-# INLINE parseRecord #-}

628

647

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

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

630− parseRecord opts = maybe (notFound label) (gParseJSON opts)

649+ parseRecord opts (Just lab) = maybe (notFound $ unpack lab)

650+ (gParseJSON opts) . H.lookup lab

651+ parseRecord opts Nothing = maybe (notFound label)

631− . H.lookup (pack label)

652+ (gParseJSON opts) . H.lookup (pack label)

632 where

653 where

633 label = fieldLabelModifier opts $ selName (undefined :: t s a p)

654 label = fieldLabelModifier opts $ selName (undefined :: t s a p)

634 {-# INLINE parseRecord #-}

655 {-# INLINE parseRecord #-}

635

656

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

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

658+ parseRecord _ (Just lab) obj = (M1 . K1) <$> obj .:? lab

637− parseRecord opts obj = (M1 . K1) <$> obj .:? pack label

659+ parseRecord opts Nothing obj = (M1 . K1) <$> obj .:? pack label

638 where

660 where

639 label = fieldLabelModifier opts $

661 label = fieldLabelModifier opts $

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

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

@@ -695,12 +717,17 @@ instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where

695--------------------------------------------------------------------------------

717--------------------------------------------------------------------------------

696

718

697class IsRecord (f :: * -> *) isRecord | f -> isRecord

719class IsRecord (f :: * -> *) isRecord | f -> isRecord

720+ where

721+ isUnary :: f a -> Bool

722+ isUnary = const True

698

723

699instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord

724instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord

725+ where isUnary = const False

700instance IsRecord (M1 S NoSelector f) False

726instance IsRecord (M1 S NoSelector f) False

701instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord

727instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord

702instance IsRecord (K1 i c) True

728instance IsRecord (K1 i c) True

703instance IsRecord U1 False

729instance IsRecord U1 False

730+ where isUnary = const False

704

731

705--------------------------------------------------------------------------------

732--------------------------------------------------------------------------------

706

733

Data/Aeson/Types/Internal.hs+4

@@ -362,6 +362,9 @@ data Options = Options

362 -- object will include those fields mapping to @null@.

363 , sumEncoding :: SumEncoding

364 -- ^ Specifies how to encode constructors of a sum datatype.

365+ , unwrapUnaryRecords :: Bool

366+ -- ^ Hide the field name when a record constructor has only one

367+ -- field, like a newtype.

365 }

368 }

366

369

367-- | Specifies how to encode constructors of a sum datatype.

370-- | Specifies how to encode constructors of a sum datatype.

@@ -407,6 +410,7 @@ defaultOptions = Options

407 , allNullaryToStringTag = True

410 , allNullaryToStringTag = True

408 , omitNothingFields = False

411 , omitNothingFields = False

409 , sumEncoding = defaultTaggedObject

412 , sumEncoding = defaultTaggedObject

413+ , unwrapUnaryRecords = False

410 }

414 }

411

415

412-- | Default 'TaggedObject' 'SumEncoding' options:

416-- | Default 'TaggedObject' 'SumEncoding' options:

tests/Encoders.hs+33

@@ -112,3 +112,36 @@ gSomeTypeToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField

112

113gSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)

114gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

115+

116+

117+--------------------------------------------------------------------------------

118+-- Approx encoders/decoders

119+--------------------------------------------------------------------------------

120+

121+type ApproxToJSON = Approx String -> Value

122+

123+thApproxToJSONUnwrap :: ToJSON a => Approx a -> Value

124+thApproxToJSONUnwrap = $(mkToJSON optsUnwrapUnaryRecords ''Approx)

125+

126+thApproxParseJSONUnwrap :: FromJSON a => Value -> Parser (Approx a)

127+thApproxParseJSONUnwrap = $(mkParseJSON optsUnwrapUnaryRecords ''Approx)

128+

129+

130+thApproxToJSONDefault :: ToJSON a => Approx a -> Value

131+thApproxToJSONDefault = $(mkToJSON defaultOptions ''Approx)

132+

133+thApproxParseJSONDefault :: FromJSON a => Value -> Parser (Approx a)

134+thApproxParseJSONDefault = $(mkParseJSON defaultOptions ''Approx)

135+

136+gApproxToJSONUnwrap :: Approx String -> Value

137+gApproxToJSONUnwrap = genericToJSON optsUnwrapUnaryRecords

138+

139+gApproxParseJSONUnwrap :: Value -> Parser (Approx String)

140+gApproxParseJSONUnwrap = genericParseJSON optsUnwrapUnaryRecords

141+

142+

143+gApproxToJSONDefault :: Approx String -> Value

144+gApproxToJSONDefault = genericToJSON defaultOptions

145+

146+gApproxParseJSONDefault :: Value -> Parser (Approx String)

147+gApproxParseJSONDefault = genericParseJSON defaultOptions

tests/Instances.hs+6

@@ -142,3 +142,9 @@ instance Arbitrary a => Arbitrary (SomeType a) where

142 , Product <$> arbitrary <*> arbitrary <*> arbitrary

143 , Record <$> arbitrary <*> arbitrary <*> arbitrary

144 ]

145+

146+instance ApproxEq Char where

147+ (=~) = (==)

148+

149+instance (ApproxEq a) => ApproxEq [a] where

150+ a =~ b = length a == length b && all (uncurry (=~)) (zip a b)

tests/Options.hs+5

@@ -15,6 +15,11 @@ opts2ElemArray = optsDefault

15 , sumEncoding = TwoElemArray

16 }

18+optsUnwrapUnaryRecords :: Options

19+optsUnwrapUnaryRecords = optsDefault

20+ { unwrapUnaryRecords = True

21+ }

22+

18optsTaggedObject :: Options

23optsTaggedObject :: Options

19optsTaggedObject = optsDefault

24optsTaggedObject = optsDefault

20 { allNullaryToStringTag = False }

25 { allNullaryToStringTag = False }

tests/Properties.hs+7−34

@@ -174,40 +174,13 @@ tests = [

174 , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject (thSomeTypeToJSONTaggedObject :: SomeTypeToJSON))

175 , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))

176 ]

177− ]

178− ]

179− , testGroup "generics" [

177+ , testGroup "Approx" [

180− testGroup "Nullary" [

181− testProperty "string" (isString . gNullaryToJSONString)

178+ testProperty "string" (isString . (thApproxToJSONUnwrap ::ApproxToJSON))

182− , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)

183− , testProperty "TaggedObject" (isTaggedObjectValue . gNullaryToJSONTaggedObject)

184− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)

179+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (thApproxToJSONDefault ::ApproxToJSON))

185− , testGroup "eq" [

186− testProperty "string" (\n -> gNullaryToJSONString n == thNullaryToJSONString n)

187− , testProperty "2ElemArray" (\n -> gNullaryToJSON2ElemArray n == thNullaryToJSON2ElemArray n)

188− , testProperty "TaggedObject" (\n -> gNullaryToJSONTaggedObject n == thNullaryToJSONTaggedObject n)

189− , testProperty "ObjectWithSingleField" (\n -> gNullaryToJSONObjectWithSingleField n == thNullaryToJSONObjectWithSingleField n)

190− ]

191− , testGroup "roundTrip" [

180+ , testGroup "roundTrip" [

192− testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)

181+ testProperty "string" (toParseJSON thApproxParseJSONUnwrap (thApproxToJSONUnwrap ::ApproxToJSON))

193− , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)

182+ , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault (thApproxToJSONDefault ::ApproxToJSON))

194− , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)

195− , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)

196− ]

197− ]

198− , testGroup "SomeType" [

199− testProperty "2ElemArray" (is2ElemArray . (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))

200− , testProperty "TaggedObject" (isTaggedObject . (gSomeTypeToJSONTaggedObject :: SomeTypeToJSON))

201− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))

202− , testGroup "eq" [

203− testProperty "2ElemArray" (\n -> (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON) n == thSomeTypeToJSON2ElemArray n)

204− , testProperty "TaggedObject" (\n -> (gSomeTypeToJSONTaggedObject :: SomeTypeToJSON) n == thSomeTypeToJSONTaggedObject n)

205− , testProperty "ObjectWithSingleField" (\n -> (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON) n == thSomeTypeToJSONObjectWithSingleField n)

206− ]

183+ ]

207− , testGroup "roundTrip" [

208− testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))

209− , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject (gSomeTypeToJSONTaggedObject :: SomeTypeToJSON))

210− , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))

211 ]

184 ]

212 ]

185 ]

213 ]

186 ]