Skip to content

Commit af0897f

Browse files
author
Poscat
committed
Implement generic encoding and decoding for TaggingFlatObject
1 parent f7918b2 commit af0897f

File tree

3 files changed

+141
-0
lines changed

3 files changed

+141
-0
lines changed

‎Data/Aeson/Types/FromJSON.hs‎

Lines changed: 74 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@
1010
{-# LANGUAGE PolyKinds #-}
1111
{-# LANGUAGE RecordWildCards #-}
1212
{-# LANGUAGE ScopedTypeVariables #-}
13+
{-# LANGUAGE TypeApplications #-}
1314
{-# LANGUAGE TypeOperators #-}
1415
{-# LANGUAGE TupleSections #-}
1516
{-# LANGUAGE UndecidableInstances #-}
@@ -158,6 +159,8 @@ import qualified Data.Primitive.Types as PM
158159
import qualified Data.Primitive.PrimArray as PM
159160

160161
import Data.Coerce (Coercible, coerce)
162+
import GHC.TypeNats
163+
import Data.Kind (Type)
161164

162165
parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
163166
parseIndexedJSON p idx value = p value <?> Index idx
@@ -1010,6 +1013,7 @@ instance ( ConstructorNames f
10101013
, FromPair arity f
10111014
, FromTaggedObject arity f
10121015
, FromUntaggedValue arity f
1016+
, FromTaggedFlatObject arity f
10131017
) => ParseSum arity f True where
10141018
parseSum p@(tname :* opts :* _)
10151019
| allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts
@@ -1019,6 +1023,7 @@ instance ( ConstructorNames f
10191023
, FromPair arity f
10201024
, FromTaggedObject arity f
10211025
, FromUntaggedValue arity f
1026+
, FromTaggedFlatObject arity f
10221027
) => ParseSum arity f False where
10231028
parseSum p = Tagged . parseNonAllNullarySum p
10241029

@@ -1101,6 +1106,7 @@ parseNonAllNullarySum :: forall f c arity.
11011106
( FromPair arity f
11021107
, FromTaggedObject arity f
11031108
, FromUntaggedValue arity f
1109+
, FromTaggedFlatObject arity f
11041110
, ConstructorNames f
11051111
) => TypeName :* Options :* FromArgs arity c
11061112
-> Value -> Parser (f c)
@@ -1118,6 +1124,17 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11181124
", but found tag " ++ show tag
11191125
cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
11201126

1127+
TaggedFlatObject{..} ->
1128+
withObject tname $ \obj -> do
1129+
let tagKey = pack tagFieldName
1130+
badTag tag = failWith_ $ \cnames ->
1131+
"expected tag field to be one of " ++ show cnames ++
1132+
", but found tag " ++ show tag
1133+
cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
1134+
tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
1135+
fromMaybe (badTag tag <?> Key tagKey) $
1136+
parseTaggedFlatObject (tag :* p) obj
1137+
11211138
ObjectWithSingleField ->
11221139
withObject tname $ \obj -> case H.toList obj of
11231140
[(tag, v)] -> maybe (badTag tag) (<?> Key tag) $
@@ -1401,6 +1418,63 @@ instance ( Constructor c
14011418

14021419
--------------------------------------------------------------------------------
14031420

1421+
class FromTaggedFlatObject arity f where
1422+
parseTaggedFlatObject :: Text :* TypeName :* Options :* FromArgs arity a
1423+
-> Object
1424+
-> Maybe (Parser (f a))
1425+
1426+
instance ( FromTaggedFlatObject arity f
1427+
, FromTaggedFlatObject arity g
1428+
) => FromTaggedFlatObject arity (f :+: g) where
1429+
parseTaggedFlatObject p obj =
1430+
(fmap L1 <$> parseTaggedFlatObject p obj) <|>
1431+
(fmap R1 <$> parseTaggedFlatObject p obj)
1432+
1433+
instance ( IsRecord f isRecord
1434+
, FromTaggedFlatObject' arity f isRecord
1435+
, Constructor c
1436+
) => FromTaggedFlatObject arity (C1 c f) where
1437+
parseTaggedFlatObject (tag :* p@(_ :* opts :* _)) obj
1438+
| tag == tag' = Just $ fmap M1 $ (unTagged @Type @isRecord) $ parseTaggedFlatObject' (cname :* p) obj
1439+
| otherwise = Nothing
1440+
where
1441+
tag' = pack $ constructorTagModifier opts cname
1442+
cname = conName (undefined :: M1 i c a p)
1443+
1444+
class FromTaggedFlatObject' arity f isRecord where
1445+
parseTaggedFlatObject' :: ConName :* TypeName :* Options :* FromArgs arity a
1446+
-> Object
1447+
-> Tagged isRecord (Parser (f a))
1448+
1449+
instance (RecordFromJSON arity f, FieldNames f) => FromTaggedFlatObject' arity f True where
1450+
parseTaggedFlatObject' p = Tagged . recordParseJSON (True :* p)
1451+
1452+
instance FromTaggedFlatObject' arity U1 False where
1453+
parseTaggedFlatObject' _ _ = Tagged (pure U1)
1454+
1455+
instance OVERLAPPABLE_ (PositionFromObject 1 arity f) => FromTaggedFlatObject' arity f False where
1456+
parseTaggedFlatObject' (_ :* p) obj = Tagged (positionFromObject (Proxy @1) p obj)
1457+
1458+
class KnownNat n => PositionFromObject n arity f where
1459+
positionFromObject :: Proxy n
1460+
-> TypeName :* Options :* FromArgs arity a
1461+
-> Object
1462+
-> Parser (f a)
1463+
1464+
instance (KnownNat n, GFromJSON arity a) => PositionFromObject n arity (S1 m a) where
1465+
positionFromObject _ (_ :* opts :* fargs) obj =
1466+
explicitParseField (gParseJSON opts fargs) obj $ pack $ show $ natVal $ Proxy @n
1467+
1468+
instance ( PositionFromObject n arity f
1469+
, PositionFromObject (n+1) arity g
1470+
) => PositionFromObject n arity (f :*: g) where
1471+
positionFromObject _ p obj =
1472+
(:*:)
1473+
<$> positionFromObject (Proxy @n) p obj
1474+
<*> positionFromObject (Proxy @(n+1)) p obj
1475+
1476+
--------------------------------------------------------------------------------
1477+
14041478
class FromUntaggedValue arity f where
14051479
parseUntaggedValue :: TypeName :* Options :* FromArgs arity a
14061480
-> Value

‎Data/Aeson/Types/Internal.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -682,6 +682,8 @@ data SumEncoding =
682682
-- by the encoded value of that field! If the constructor is not a
683683
-- record the encoded constructor contents will be stored under
684684
-- the 'contentsFieldName' field.
685+
| TaggedFlatObject { tagFieldName :: String }
686+
-- ^ A constructor will be encoded to an object with a field
685687
| UntaggedValue
686688
-- ^ Constructor names won't be encoded. Instead only the contents of the
687689
-- constructor will be encoded as if the type had a single constructor. JSON

‎Data/Aeson/Types/ToJSON.hs‎

Lines changed: 65 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE CPP #-}
23
{-# LANGUAGE DefaultSignatures #-}
34
{-# LANGUAGE EmptyDataDecls #-}
@@ -141,6 +142,7 @@ import qualified Data.Primitive.Array as PM
141142
import qualified Data.Primitive.SmallArray as PM
142143
import qualified Data.Primitive.Types as PM
143144
import qualified Data.Primitive.PrimArray as PM
145+
import GHC.TypeNats
144146

145147
toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value
146148
toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)
@@ -851,6 +853,7 @@ class SumToJSON enc arity f allNullary where
851853
instance ( GetConName f
852854
, FromString enc
853855
, TaggedObject enc arity f
856+
, TaggedFlatObject enc arity f
854857
, SumToJSON' ObjectWithSingleField enc arity f
855858
, SumToJSON' TwoElemArray enc arity f
856859
, SumToJSON' UntaggedValue enc arity f
@@ -862,6 +865,7 @@ instance ( GetConName f
862865
| otherwise = Tagged . nonAllNullarySumToJSON opts targs
863866

864867
instance ( TaggedObject enc arity f
868+
, TaggedFlatObject enc arity f
865869
, SumToJSON' ObjectWithSingleField enc arity f
866870
, SumToJSON' TwoElemArray enc arity f
867871
, SumToJSON' UntaggedValue enc arity f
@@ -870,6 +874,7 @@ instance ( TaggedObject enc arity f
870874
sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs
871875

872876
nonAllNullarySumToJSON :: ( TaggedObject enc arity f
877+
, TaggedFlatObject enc arity f
873878
, SumToJSON' ObjectWithSingleField enc arity f
874879
, SumToJSON' TwoElemArray enc arity f
875880
, SumToJSON' UntaggedValue enc arity f
@@ -881,6 +886,9 @@ nonAllNullarySumToJSON opts targs =
881886
TaggedObject{..} ->
882887
taggedObject opts targs tagFieldName contentsFieldName
883888

889+
TaggedFlatObject{..} ->
890+
taggedFlatObject opts targs tagFieldName
891+
884892
ObjectWithSingleField ->
885893
(unTagged :: Tagged ObjectWithSingleField enc -> enc)
886894
. sumToJSON' opts targs
@@ -906,6 +914,63 @@ instance FromString Value where
906914

907915
--------------------------------------------------------------------------------
908916

917+
class TaggedFlatObject enc arity f where
918+
taggedFlatObject :: Options -> ToArgs enc arity a
919+
-> String -> f a -> enc
920+
921+
instance (TaggedFlatObject enc arity a
922+
, TaggedFlatObject enc arity b
923+
) => TaggedFlatObject enc arity (a :+: b)
924+
where
925+
taggedFlatObject opts targs tagFieldName (L1 x) =
926+
taggedFlatObject opts targs tagFieldName x
927+
taggedFlatObject opts targs tagFieldName (R1 x) =
928+
taggedFlatObject opts targs tagFieldName x
929+
930+
instance ( IsRecord a isRecord
931+
, TaggedFlatObject' enc pairs arity a isRecord
932+
, KeyValuePair enc pairs
933+
, FromString enc
934+
, Constructor c
935+
, FromPairs enc pairs
936+
) => TaggedFlatObject enc arity (C1 c a) where
937+
taggedFlatObject opts targs tagFieldName (M1 a) =
938+
fromPairs (tag `mappend` contents)
939+
where
940+
tag :: pairs
941+
tag = tagFieldName `pair`
942+
(fromString (constructorTagModifier opts (conName (undefined :: t c a p)))
943+
:: enc)
944+
contents :: pairs
945+
contents = (unTagged :: Tagged isRecord pairs -> pairs) $ taggedFlatObject' opts targs a
946+
947+
class TaggedFlatObject' enc pairs arity f isRecord where
948+
taggedFlatObject' :: Options -> ToArgs enc arity a
949+
-> f a -> Tagged isRecord pairs
950+
951+
instance RecordToPairs pairs enc arity f => TaggedFlatObject' pairs enc arity f True where
952+
taggedFlatObject' opts targs = Tagged . recordToPairs opts targs
953+
954+
instance Monoid pairs => TaggedFlatObject' enc pairs arity U1 False where
955+
taggedFlatObject' _ _ _ = Tagged mempty
956+
957+
instance OVERLAPPABLE_ (PositionToPairs 1 pairs enc arity f) => TaggedFlatObject' enc pairs arity f False where
958+
taggedFlatObject' opts targs a = Tagged $ positionToPairs (Proxy :: Proxy 1) opts targs a
959+
960+
class KnownNat n => PositionToPairs n pairs enc arity f where
961+
positionToPairs :: Proxy n -> Options -> ToArgs enc arity a -> f a -> pairs
962+
963+
instance (KeyValuePair enc pairs, GToJSON' enc arity a, KnownNat n) => PositionToPairs n pairs enc arity (S1 m a) where
964+
positionToPairs p opts targs (M1 a) =
965+
show (natVal p) `pair` gToJSON opts targs a
966+
967+
instance (Semigroup pairs, PositionToPairs n pairs enc arity f, PositionToPairs (n+1) pairs enc arity g) => PositionToPairs n pairs enc arity (f :*: g) where
968+
positionToPairs _ opts targs (f :*: g) =
969+
positionToPairs (Proxy :: Proxy n) opts targs f
970+
<> positionToPairs (Proxy :: Proxy (n+1)) opts targs g
971+
972+
--------------------------------------------------------------------------------
973+
909974
class TaggedObject enc arity f where
910975
taggedObject :: Options -> ToArgs enc arity a
911976
-> String -> String

0 commit comments

Comments
 (0)