HKD deriving ToJSON by encoding quantified constraints

hkd-apply.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

import           Data.Coerce
import           Data.Functor.Identity
import           GHC.Generics
import           Data.Aeson

-- "Higher Kinded Data"
-- "Defunctionalized application"
type family s @@ a
type instance Id   @@ a = a
type instance Tc f @@ a = f a

-- Defunctionalization symbols
data Id  -- Identity function
data Tc (f :: * -> *)  -- Type constructor

data Person f = Person
  { pName :: f @@ String
  , pAge  :: f @@ Int
  } deriving (Generic)

gcoerce :: forall a b. (Generic a, Generic b, Coercible (Rep a ()) (Rep b ())) => a -> b
gcoerce = to . (coerce :: Rep a () -> Rep b ()) . from

instance ToJSON_Apply f => ToJSON (Person f) where
  toJSON = genericToJSON defaultOptions . gcoerce @_ @(Person (Tc (Apply f)))

newtype Apply f a = Apply (f @@ a)

instance (ToJSON_Apply f, ToJSON a) => ToJSON (Apply f a) where
  toJSON (Apply x) = toJSON_Apply @f @a x

class ToJSON_Apply f where
  toJSON_Apply :: ToJSON a => f @@ a -> Value

instance ToJSON1 f => ToJSON_Apply (Tc f) where
  toJSON_Apply = toJSON1

instance ToJSON_Apply Id where
  toJSON_Apply = toJSON

main = do
  print (encode (Person "John" 33 :: Person Id))
  print (encode (Person Nothing (Just 33) :: Person (Tc Maybe)))