1 files changed, 168 insertions, 0 deletions
diff --git a/users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs
new file mode 100644
index 0000000000..e89fcd6211
--- /dev/null
+++ b/users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs
@@ -0,0 +1,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))