git.iko.soy/typeable/aeson
on master help sign in
Handle Option like Maybe
commitf4174c602b5048e796fadeb71062cd37aa87adab authorlyxia <lysxia@gmail.com> dateSun 30 Jul 2017, 12:33 (9 years ago) parent5e3895a
3 files changed+46−8
compare with master
unifiedsplit
Data/Aeson/TH.hs+25−8 Data/Aeson/Types/FromJSON.hs+8 Data/Aeson/Types/ToJSON.hs+13
Data/Aeson/TH.hs+25−8
@@ -154,6 +154,7 @@ import qualified Data.Foldable as F (all)
154154import qualified Data.HashMap.Strict as H (lookup, toList)
155155import qualified Data.List.NonEmpty as NE (length, reverse)
156156import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
157+import qualified Data.Semigroup as Semigroup (Option(..))
157158import qualified Data.Set as Set (empty, insert, member)
158159import qualified Data.Text as T (Text, pack, unpack)
159160import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)
@@ -487,26 +488,28 @@ argsToValue jc tvMap opts multiCons
487488 restFields
488489 | otherwise = listE $ map toPair argCons
489490
490− argCons = zip3 args argTys' fields
491+ argCons = zip3 (map varE args) argTys' fields
491492
492493 maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
493494
494495 restFields = listE $ map toPair rest
495496
496− (maybes, rest) = partition isMaybe argCons
497+ (maybes0, rest0) = partition isMaybe argCons
498+ (options, rest) = partition isOption rest0
499+ maybes = maybes0 ++ map optionToMaybe options
497500
498501 maybeToPair (arg, argTy, field) =
499502 infixApp ([|keyValuePairWith|]
500503 `appE` dispatchToJSON jc conName tvMap argTy
501504 `appE` toFieldName field)
502505 [|(<$>)|]
503− (varE arg)
506+ arg
504507
505508 toPair (arg, argTy, field) =
506509 [|keyValuePairWith|]
507510 `appE` dispatchToJSON jc conName tvMap argTy
508511 `appE` toFieldName field
509− `appE` varE arg
512+ `appE` arg
510513
511514 toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
512515
@@ -553,6 +556,13 @@ isMaybe :: (a, Type, b) -> Bool
553556isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe
554557isMaybe _ = False
555558
559+isOption :: (a, Type, b) -> Bool
560+isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option
561+isOption _ = False
562+
563+optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)
564+optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)
565+
556566(<^>) :: ExpQ -> ExpQ -> ExpQ
557567(<^>) a b = infixApp a [|(E.><)|] b
558568infixr 6 <^>
@@ -637,13 +647,15 @@ argsToEncoding jc tvMap opts multiCons
637647 restFields
638648 | otherwise = listE (map toPair argCons)
639649
640− argCons = zip3 args argTys' fields
650+ argCons = zip3 (map varE args) argTys' fields
641651
642652 maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
643653
644654 restFields = listE (map toPair rest)
645655
646− (maybes, rest) = partition isMaybe argCons
656+ (maybes0, rest0) = partition isMaybe argCons
657+ (options, rest) = partition isOption rest0
658+ maybes = maybes0 ++ map optionToMaybe options
647659
648660 maybeToPair (arg, argTy, field) =
649661 infixApp
@@ -655,12 +667,12 @@ argsToEncoding jc tvMap opts multiCons
655667 [|(.)|]
656668 (dispatchToEncoding jc conName tvMap argTy))
657669 [|(<$>)|]
658− (varE arg)
670+ arg
659671
660672 toPair (arg, argTy, field) =
661673 toFieldName field
662674 <:> dispatchToEncoding jc conName tvMap argTy
663− `appE` varE arg
675+ `appE` arg
664676
665677 toFieldName field = [|E.text|] `appE`
666678 ([|T.pack|] `appE` fieldLabelExp opts field)
@@ -1234,6 +1246,11 @@ instance OVERLAPPABLE_ LookupField a where
12341246instance INCOHERENT_ LookupField (Maybe a) where
12351247 lookupField pj _ _ = parseOptionalFieldWith pj
12361248
1249+instance INCOHERENT_ LookupField (Semigroup.Option a) where
1250+ lookupField pj tName rec obj key =
1251+ fmap Semigroup.Option
1252+ (lookupField (fmap Semigroup.getOption . pj) tName rec obj key)
1253+
12371254lookupFieldWith :: (Value -> Parser a) -> String -> String
12381255 -> Object -> T.Text -> Parser a
12391256lookupFieldWith pj tName rec obj key =
Data/Aeson/Types/FromJSON.hs+8
@@ -1035,6 +1035,14 @@ instance INCOHERENT_ (Selector s, FromJSON a) =>
10351035 label = fieldLabelModifier opts $
10361036 selName (undefined :: t s (K1 i (Maybe a)) p)
10371037
1038+-- Parse an Option like a Maybe.
1039+instance INCOHERENT_ (Selector s, FromJSON a) =>
1040+ FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where
1041+ parseRecord opts fargs lab obj = wrap <$> parseRecord opts fargs lab obj
1042+ where
1043+ wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
1044+ wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
1045+
10381046--------------------------------------------------------------------------------
10391047
10401048class FromProduct arity f where
Data/Aeson/Types/ToJSON.hs+13
@@ -1023,6 +1023,19 @@ instance INCOHERENT_
10231023 recordToPairs opts targs m1 = fieldToPair opts targs m1
10241024 {-# INLINE recordToPairs #-}
10251025
1026+instance INCOHERENT_
1027+ ( Selector s
1028+ , GToJSON enc arity (K1 i (Maybe a))
1029+ , GKeyValue enc pairs
1030+ , Monoid pairs
1031+ ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))
1032+ where
1033+ recordToPairs opts targs = recordToPairs opts targs . unwrap
1034+ where
1035+ unwrap :: S1 s (K1 i (Semigroup.Option a)) p -> S1 s (K1 i (Maybe a)) p
1036+ unwrap (M1 (K1 (Semigroup.Option a))) = M1 (K1 a)
1037+ {-# INLINE recordToPairs #-}
1038+
10261039fieldToPair :: (Selector s
10271040 , GToJSON enc arity a
10281041 , GKeyValue enc pairs)