TypeLevelFieldMetadata.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}

module Main where

import Data.Aeson
import Data.Aeson.Key (fromString, fromText)
import Data.Aeson.Types
import Data.Kind
import Data.Proxy
import GHC.Generics
import GHC.TypeLits

data Alias a b = Alias a b -- used as kind

type Aliases = [Alias Symbol Symbol] -- used as kind

type GAliasedToJSON :: Aliases -> (k -> Type) -> Aliases -> Constraint
class GAliasedToJSON before rep after | before rep -> after where
  toPairs :: rep z -> [Pair]

instance GAliasedToJSON before prod after => GAliasedToJSON before (D1 x (C1 y prod)) after where
  toPairs (M1 (M1 prod)) = toPairs @_ @before @_ @after prod

instance
  ( GAliasedToJSON before left middle,
    GAliasedToJSON middle right after 
  ) =>
  GAliasedToJSON before (left :*: right) after 
  where
  toPairs (left :*: right) =
    toPairs @_ @before @_ @middle left ++ toPairs @_ @middle @_ @after right

instance
  (KnownSymbol alias, ToJSON v) =>
  GAliasedToJSON ('Alias name alias ': aliases) (S1 ('MetaSel (Just name') u1 u2 u3) (Rec0 v)) aliases 
  where
  toPairs (M1 (K1 v)) =
    let key = Data.Aeson.Key.fromString (symbolVal (Proxy @alias))
     in [(key, toJSON v)]

data Person = Person {name :: String, age :: Int} deriving (Show, Generic)

instance ToJSON Person where
    toJSON person = 
        Data.Aeson.object $ 
        toPairs @_ @['Alias "name" "name1", 'Alias "age" "age2"] @_ @'[] 
        $ from person 

-- >>> toJSON (Person "John" 42)
-- Object (fromList [("age",Number 42.0),("name",String "John")])
main = pure ()