Handle Option like Maybe

Author: Lysxia

Data/Aeson/TH.hs

@@ -154,6 +154,7 @@ import qualified Data.Foldable as F (all)
 import qualified Data.HashMap.Strict as H (lookup, toList)
 import qualified Data.List.NonEmpty as NE (length, reverse)
 import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
+import qualified Data.Semigroup as Semigroup (Option(..))
 import qualified Data.Set as Set (empty, insert, member)
 import qualified Data.Text as T (Text, pack, unpack)
 import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)
@@ -487,26 +488,28 @@ argsToValue jc tvMap opts multiCons
                                                       restFields
                   | otherwise = listE $ map toPair argCons
 
-            argCons = zip3 args argTys' fields
+            argCons = zip3 (map varE args) argTys' fields
 
             maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
 
             restFields = listE $ map toPair rest
 
-            (maybes, rest) = partition isMaybe argCons
+            (maybes0, rest0) = partition isMaybe argCons
+            (options, rest) = partition isOption rest0
+            maybes = maybes0 ++ map optionToMaybe options
 
             maybeToPair (arg, argTy, field) =
                 infixApp ([|keyValuePairWith|]
                             `appE` dispatchToJSON jc conName tvMap argTy
                             `appE` toFieldName field)
                          [|(<$>)|]
-                         (varE arg)
+                         arg
 
             toPair (arg, argTy, field) =
                 [|keyValuePairWith|]
                   `appE` dispatchToJSON jc conName tvMap argTy
                   `appE` toFieldName field
-                  `appE` varE arg
+                  `appE` arg
 
             toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
 
@@ -553,6 +556,13 @@ isMaybe :: (a, Type, b) -> Bool
 isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe
 isMaybe _                       = False
 
+isOption :: (a, Type, b) -> Bool
+isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option
+isOption _                       = False
+
+optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)
+optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)
+
 (<^>) :: ExpQ -> ExpQ -> ExpQ
 (<^>) a b = infixApp a [|(E.><)|] b
 infixr 6 <^>
@@ -637,13 +647,15 @@ argsToEncoding jc tvMap opts multiCons
                                                       restFields
                   | otherwise = listE (map toPair argCons)
 
-            argCons = zip3 args argTys' fields
+            argCons = zip3 (map varE args) argTys' fields
 
             maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
 
             restFields = listE (map toPair rest)
 
-            (maybes, rest) = partition isMaybe argCons
+            (maybes0, rest0) = partition isMaybe argCons
+            (options, rest) = partition isOption rest0
+            maybes = maybes0 ++ map optionToMaybe options
 
             maybeToPair (arg, argTy, field) =
                 infixApp
@@ -655,12 +667,12 @@ argsToEncoding jc tvMap opts multiCons
                     [|(.)|]
                     (dispatchToEncoding jc conName tvMap argTy))
                   [|(<$>)|]
-                  (varE arg)
+                  arg
 
             toPair (arg, argTy, field) =
               toFieldName field
                 <:> dispatchToEncoding jc conName tvMap argTy
-                      `appE` varE arg
+                      `appE` arg
 
             toFieldName field = [|E.text|] `appE`
                                 ([|T.pack|] `appE` fieldLabelExp opts field)
@@ -1234,6 +1246,11 @@ instance OVERLAPPABLE_ LookupField a where
 instance INCOHERENT_ LookupField (Maybe a) where
     lookupField pj _ _ = parseOptionalFieldWith pj
 
+instance INCOHERENT_ LookupField (Semigroup.Option a) where
+    lookupField pj tName rec obj key =
+        fmap Semigroup.Option
+             (lookupField (fmap Semigroup.getOption . pj) tName rec obj key)
+
 lookupFieldWith :: (Value -> Parser a) -> String -> String
                 -> Object -> T.Text -> Parser a
 lookupFieldWith pj tName rec obj key =

Data/Aeson/Types/FromJSON.hs

@@ -1035,6 +1035,14 @@ instance INCOHERENT_ (Selector s, FromJSON a) =>
           label = fieldLabelModifier opts $
                     selName (undefined :: t s (K1 i (Maybe a)) p)
 
+-- Parse an Option like a Maybe.
+instance INCOHERENT_ (Selector s, FromJSON a) =>
+  FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where
+    parseRecord opts fargs lab obj = wrap <$> parseRecord opts fargs lab obj
+      where
+        wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
+        wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
+
 --------------------------------------------------------------------------------
 
 class FromProduct arity f where

Data/Aeson/Types/ToJSON.hs

@@ -1023,6 +1023,19 @@ instance INCOHERENT_
     recordToPairs opts targs m1 = fieldToPair opts targs m1
     {-# INLINE recordToPairs #-}
 
+instance INCOHERENT_
+    ( Selector s
+    , GToJSON enc arity (K1 i (Maybe a))
+    , GKeyValue enc pairs
+    , Monoid pairs
+    ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))
+  where
+    recordToPairs opts targs = recordToPairs opts targs . unwrap
+      where
+        unwrap :: S1 s (K1 i (Semigroup.Option a)) p -> S1 s (K1 i (Maybe a)) p
+        unwrap (M1 (K1 (Semigroup.Option a))) = M1 (K1 a)
+    {-# INLINE recordToPairs #-}
+
 fieldToPair :: (Selector s
                , GToJSON enc arity a
                , GKeyValue enc pairs)