git.iko.soy/typeable/aeson
on master help sign in
Option to unwrap unary record constructors (Fixes #228)
commit4b78229bfc495e440a594ad0192dc50de80ff8ed authorjpmoresmau <jp@moresmau.fr> dateThu 26 Mar 2015, 22:27 (12 years ago) parent12682c0
7 files changed+113−61
compare with master
unifiedsplit
Data/Aeson/TH.hs+7−3 Data/Aeson/Types/Generic.hs+51−24 Data/Aeson/Types/Internal.hs+4 tests/Encoders.hs+33 tests/Instances.hs+6 tests/Options.hs+5 tests/Properties.hs+7−34
Data/Aeson/TH.hs+7−3
@@ -90,7 +90,7 @@ import Data.Aeson.Types ( Value(..), Parser
9090-- from base:
9191import Control.Applicative ( pure, (<$>), (<*>) )
9292import Control.Monad ( return, mapM, liftM2, fail )
93−import Data.Bool ( Bool(False, True), otherwise, (&&) )
93+import Data.Bool ( Bool(False, True), otherwise, (&&) , not)
9494import Data.Eq ( (==) )
9595import Data.Function ( ($), (.) )
9696import Data.Functor ( fmap )
@@ -281,7 +281,9 @@ encodeArgs opts multiCons (NormalC conName ts) = do
281281 []
282282
283283-- 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
285287 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
286288 let exp = [|object|] `appE` pairs
287289
@@ -664,7 +666,9 @@ parseArgs tName _ (NormalC conName ts) (Right valName) =
664666-- Records.
665667parseArgs tName opts (RecC conName ts) (Left (_, obj)) =
666668 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
668672 obj <- newName "recObj"
669673 caseE (varE valName)
670674 [ 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
272272 consToEncoding :: Options -> f a -> B.Builder
273273
274274class ConsToJSON' f isRecord where
275− consToJSON' :: Options -> f a -> Tagged isRecord Value
276− consToEncoding' :: Options -> f a -> Tagged isRecord B.Builder
277−
275+ consToJSON' :: Options -> Bool -- ^ Are we a record with one field
276+ -> f a -> Tagged isRecord Value
277+ consToEncoding' :: Options -> Bool -- ^ Are we a record with one field
278+ -> f a -> Tagged isRecord B.Builder
279+
278280instance ( IsRecord f isRecord
279281 , ConsToJSON' f isRecord ) => ConsToJSON f where
280282 consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)
281− . consToJSON' opts
283+ . consToJSON' opts (isUnary (undefined :: f a))
282284 {-# INLINE consToJSON #-}
283285
284286 consToEncoding opts = (unTagged :: Tagged isRecord B.Builder -> B.Builder)
285− . consToEncoding' opts
287+ . consToEncoding' opts (isUnary (undefined :: f a))
286288 {-# INLINE consToEncoding #-}
287289
288290instance (RecordTo f) => ConsToJSON' f True where
289− consToJSON' opts = Tagged . object . toList . recordToPairs opts
291+ consToJSON' opts isUn f = let
292+ vals = toList $ recordToPairs opts f
293+ in case (unwrapUnaryRecords opts,isUn,vals) of
294+ (True,True,[(_,val)]) -> Tagged val
295+ _ -> Tagged $ object vals
290296 {-# INLINE consToJSON' #-}
291297
292− consToEncoding' opts x = Tagged $
293− B.char7 '{' <>
294− recordToEncoding opts x <>
295− B.char7 '}'
298+ consToEncoding' opts isUn x
299+ | (True,True) <- (unwrapUnaryRecords opts,isUn) = Tagged $ recordToEncoding opts x
300+ | otherwise = Tagged $
301+ B.char7 '{' <>
302+ recordToEncoding opts x <>
303+ B.char7 '}'
296304 {-# INLINE consToEncoding' #-}
297305
298306instance GToJSON f => ConsToJSON' f False where
299− consToJSON' opts = Tagged . gToJSON opts
307+ consToJSON' opts _ = Tagged . gToJSON opts
300308 {-# INLINE consToJSON' #-}
301− consToEncoding' opts = Tagged . gbuilder opts
309+ consToEncoding' opts _ = Tagged . gbuilder opts
302310 {-# INLINE consToEncoding' #-}
303311
304312--------------------------------------------------------------------------------
@@ -585,7 +593,7 @@ instance ( IsRecord f isRecord
585593 {-# INLINE parseFromTaggedObject' #-}
586594
587595instance (FromRecord f) => FromTaggedObject'' f True where
588− parseFromTaggedObject'' opts _ = Tagged . parseRecord opts
596+ parseFromTaggedObject'' opts _ = Tagged . parseRecord opts Nothing
589597 {-# INLINE parseFromTaggedObject'' #-}
590598
591599instance (GFromJSON f) => FromTaggedObject'' f False where
@@ -599,42 +607,56 @@ class ConsFromJSON f where
599607 consParseJSON :: Options -> Value -> Parser (f a)
600608
601609class ConsFromJSON' f isRecord where
602− consParseJSON' :: Options -> Value -> Tagged isRecord (Parser (f a))
610+ consParseJSON' :: Options -> (Maybe Text) -- ^ A dummy label
611+ -- (Nothing to use proper label)
612+ -> Value -> Tagged isRecord (Parser (f a))
603613
604614instance ( IsRecord f isRecord
605615 , ConsFromJSON' f isRecord
606616 ) => ConsFromJSON f where
607− consParseJSON opts = (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
608− . consParseJSON' opts
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)
622+ in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
623+ $ consParseJSON' opts lab v2
609624 {-# INLINE consParseJSON #-}
610625
626+
611627instance (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)
613630 {-# INLINE consParseJSON' #-}
614631
615632instance (GFromJSON f) => ConsFromJSON' f False where
616− consParseJSON' opts = Tagged . gParseJSON opts
633+ consParseJSON' opts _ = Tagged . gParseJSON opts
617634 {-# INLINE consParseJSON' #-}
618635
619636--------------------------------------------------------------------------------
620637
621638class FromRecord f where
622− parseRecord :: Options -> Object -> Parser (f a)
639+ parseRecord :: Options -> (Maybe Text) -- ^ A dummy label
640+ -- (Nothing to use proper label)
641+ -> Object -> Parser (f a)
623642
624643instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where
625− parseRecord opts obj = (:*:) <$> parseRecord opts obj
626− <*> parseRecord opts obj
644+ parseRecord opts _ obj = (:*:) <$> parseRecord opts Nothing obj
645+ <*> parseRecord opts Nothing obj
627646 {-# INLINE parseRecord #-}
628647
629648instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where
630− parseRecord opts = maybe (notFound label) (gParseJSON opts)
631− . H.lookup (pack label)
649+ parseRecord opts (Just lab) = maybe (notFound $ unpack lab)
650+ (gParseJSON opts) . H.lookup lab
651+ parseRecord opts Nothing = maybe (notFound label)
652+ (gParseJSON opts) . H.lookup (pack label)
632653 where
633654 label = fieldLabelModifier opts $ selName (undefined :: t s a p)
634655 {-# INLINE parseRecord #-}
635656
636657instance (Selector s, FromJSON a) => FromRecord (S1 s (K1 i (Maybe a))) where
637− parseRecord opts obj = (M1 . K1) <$> obj .:? pack label
658+ parseRecord _ (Just lab) obj = (M1 . K1) <$> obj .:? lab
659+ parseRecord opts Nothing obj = (M1 . K1) <$> obj .:? pack label
638660 where
639661 label = fieldLabelModifier opts $
640662 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
695717--------------------------------------------------------------------------------
696718
697719class IsRecord (f :: * -> *) isRecord | f -> isRecord
720+ where
721+ isUnary :: f a -> Bool
722+ isUnary = const True
698723
699724instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
725+ where isUnary = const False
700726instance IsRecord (M1 S NoSelector f) False
701727instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord
702728instance IsRecord (K1 i c) True
703729instance IsRecord U1 False
730+ where isUnary = const False
704731
705732--------------------------------------------------------------------------------
706733
Data/Aeson/Types/Internal.hs+4
@@ -362,6 +362,9 @@ data Options = Options
362362 -- object will include those fields mapping to @null@.
363363 , sumEncoding :: SumEncoding
364364 -- ^ 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.
365368 }
366369
367370-- | Specifies how to encode constructors of a sum datatype.
@@ -407,6 +410,7 @@ defaultOptions = Options
407410 , allNullaryToStringTag = True
408411 , omitNothingFields = False
409412 , sumEncoding = defaultTaggedObject
413+ , unwrapUnaryRecords = False
410414 }
411415
412416-- | Default 'TaggedObject' 'SumEncoding' options:
tests/Encoders.hs+33
@@ -112,3 +112,36 @@ gSomeTypeToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField
112112
113113gSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)
114114gSomeTypeParseJSONObjectWithSingleField = 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
142142 , Product <$> arbitrary <*> arbitrary <*> arbitrary
143143 , Record <$> arbitrary <*> arbitrary <*> arbitrary
144144 ]
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
1515 , sumEncoding = TwoElemArray
1616 }
1717
18+optsUnwrapUnaryRecords :: Options
19+optsUnwrapUnaryRecords = optsDefault
20+ { unwrapUnaryRecords = True
21+ }
22+
1823optsTaggedObject :: Options
1924optsTaggedObject = optsDefault
2025 { allNullaryToStringTag = False }
tests/Properties.hs+7−34
@@ -174,40 +174,13 @@ tests = [
174174 , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject (thSomeTypeToJSONTaggedObject :: SomeTypeToJSON))
175175 , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
176176 ]
177− ]
178− ]
179− , testGroup "generics" [
180− testGroup "Nullary" [
181− testProperty "string" (isString . gNullaryToJSONString)
182− , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
183− , testProperty "TaggedObject" (isTaggedObjectValue . gNullaryToJSONTaggedObject)
184− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
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" [
192− testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
193− , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
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− ]
207− , testGroup "roundTrip" [
208− testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
209− , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject (gSomeTypeToJSONTaggedObject :: SomeTypeToJSON))
210− , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
177+ , testGroup "Approx" [
178+ testProperty "string" (isString . (thApproxToJSONUnwrap ::ApproxToJSON))
179+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (thApproxToJSONDefault ::ApproxToJSON))
180+ , testGroup "roundTrip" [
181+ testProperty "string" (toParseJSON thApproxParseJSONUnwrap (thApproxToJSONUnwrap ::ApproxToJSON))
182+ , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault (thApproxToJSONDefault ::ApproxToJSON))
183+ ]
211184 ]
212185 ]
213186 ]