1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
{-# LANGUAGE ConstraintKinds, DataKinds, DeriveGeneric, DerivingVia #-}
{-# LANGUAGE ExplicitNamespaces, FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds, ScopedTypeVariables, StandaloneDeriving #-}
{-# LANGUAGE TypeApplications, TypeFamilies, TypeInType, TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
-- | https://gist.github.com/konn/27c00f784dd883ec2b90eab8bc84a81d
module Data.Aeson.Generic.DerivingVia
( StrFun(..), Setting(..), SumEncoding'(..), DefaultOptions, WithOptions(..)
, -- Utility type synonyms to save ticks (') before promoted data constructors
type Drop, type CamelTo2, type UserDefined
, type TaggedObj, type UntaggedVal, type ObjWithSingleField, type TwoElemArr
, type FieldLabelModifier
, type ConstructorTagModifier
, type AllNullaryToStringTag
, type OmitNothingFields
, type SumEnc
, type UnwrapUnaryRecords
, type TagSingleConstructors
)
where
import Prelude
import Data.Aeson (FromJSON (..), GFromJSON, GToJSON,
ToJSON (..))
import Data.Aeson (Options (..), Zero, camelTo2,
genericParseJSON)
import Data.Aeson (defaultOptions, genericToJSON)
import qualified Data.Aeson as Aeson
import Data.Kind (Constraint, Type)
import Data.Proxy (Proxy (..))
import Data.Reflection (Reifies (..))
import GHC.Generics (Generic, Rep)
import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal)
import GHC.TypeLits (Nat, Symbol)
newtype WithOptions options a = WithOptions { runWithOptions :: a }
data StrFun = Drop Nat
| CamelTo2 Symbol
| forall p. UserDefined p
type Drop = 'Drop
type CamelTo2 = 'CamelTo2
type UserDefined = 'UserDefined
type family Demoted a where
Demoted Symbol = String
Demoted StrFun = String -> String
Demoted [a] = [Demoted a]
Demoted Setting = Options -> Options
Demoted SumEncoding' = Aeson.SumEncoding
Demoted a = a
data SumEncoding' = TaggedObj {tagFieldName' :: Symbol, contentsFieldName :: Symbol }
| UntaggedVal
| ObjWithSingleField
| TwoElemArr
type TaggedObj = 'TaggedObj
type UntaggedVal = 'UntaggedVal
type ObjWithSingleField = 'ObjWithSingleField
type TwoElemArr = 'TwoElemArr
data Setting = FieldLabelModifier [StrFun]
| ConstructorTagModifier [StrFun]
| AllNullaryToStringTag Bool
| OmitNothingFields Bool
| SumEnc SumEncoding'
| UnwrapUnaryRecords Bool
| TagSingleConstructors Bool
type FieldLabelModifier = 'FieldLabelModifier
type ConstructorTagModifier = 'ConstructorTagModifier
-- | If 'True' the constructors of a datatype, with all nullary constructors,
-- will be encoded to just a string with the constructor tag. If 'False' the
-- encoding will always follow the 'SumEncoding'.
type AllNullaryToStringTag = 'AllNullaryToStringTag
type OmitNothingFields = 'OmitNothingFields
type SumEnc = 'SumEnc
-- | Hide the field name when a record constructor has only one field, like a
-- newtype.
type UnwrapUnaryRecords = 'UnwrapUnaryRecords
-- | Encode types with a single constructor as sums, so that
-- 'AllNullaryToStringTag' and 'SumEncoding' apply.
type TagSingleConstructors = 'TagSingleConstructors
class Demotable (a :: k) where
demote :: proxy a -> Demoted k
type All :: (Type -> Constraint) -> [Type] -> Constraint
type family All p xs where
All p '[] = ()
All p (x ': xs) = (p x, All p xs)
instance Reifies f (String -> String) => Demotable ('UserDefined f) where
demote _ = reflect @f Proxy
instance KnownSymbol sym => Demotable sym where
demote = symbolVal
instance (KnownSymbol s, KnownSymbol t) => Demotable ('TaggedObj s t) where
demote _ = Aeson.TaggedObject (symbolVal @s Proxy) (symbolVal @t Proxy)
instance Demotable 'UntaggedVal where
demote _ = Aeson.UntaggedValue
instance Demotable 'ObjWithSingleField where
demote _ = Aeson.ObjectWithSingleField
instance Demotable 'TwoElemArr where
demote _ = Aeson.TwoElemArray
instance Demotable xs => Demotable ('FieldLabelModifier xs) where
demote _ o = o { fieldLabelModifier = foldr (.) id (demote (Proxy @xs)) }
instance Demotable xs => Demotable ('ConstructorTagModifier xs) where
demote _ o = o { constructorTagModifier = foldr (.) id (demote (Proxy @xs)) }
instance Demotable b => Demotable ('AllNullaryToStringTag b) where
demote _ o = o { allNullaryToStringTag = demote (Proxy @b) }
instance Demotable b => Demotable ('OmitNothingFields b) where
demote _ o = o { omitNothingFields = demote (Proxy @b) }
instance Demotable b => Demotable ('UnwrapUnaryRecords b) where
demote _ o = o { unwrapUnaryRecords = demote (Proxy @b) }
instance Demotable b => Demotable ('TagSingleConstructors b) where
demote _ o = o { tagSingleConstructors = demote (Proxy @b) }
instance Demotable b => Demotable ('SumEnc b) where
demote _ o = o { sumEncoding = demote (Proxy @b) }
instance Demotable 'True where
demote _ = True
instance Demotable 'False where
demote _ = False
instance KnownNat n => Demotable ('Drop n) where
demote _ = drop (fromIntegral $ natVal (Proxy :: Proxy n))
instance KnownSymbol sym => Demotable ('CamelTo2 sym) where
demote _ = camelTo2 $ head $ symbolVal @sym Proxy
instance {-# OVERLAPPING #-} Demotable ('[] :: [k]) where
demote _ = []
instance (Demotable (x :: k), Demotable (xs :: [k])) => Demotable (x ': xs) where
demote _ = demote (Proxy @x) : demote (Proxy @xs)
type DefaultOptions = ('[] :: [Setting])
reflectOptions :: forall xs proxy. Demotable (xs :: [Setting]) => proxy xs -> Options
reflectOptions pxy = foldr (.) id (demote pxy) defaultOptions
instance (Demotable (options :: [Setting])) => Reifies options Options where
reflect = reflectOptions
instance (Generic a, GToJSON Zero (Rep a), Reifies (options :: k) Options)
=> ToJSON (WithOptions options a) where
toJSON = genericToJSON (reflect (Proxy @options)) . runWithOptions
instance (Generic a, GFromJSON Zero (Rep a), Reifies (options :: k) Options)
=> FromJSON (WithOptions options a) where
parseJSON = fmap WithOptions . genericParseJSON (reflect (Proxy @options))
|
