Usage of generic programming for deriving a JSON codec.

Gen.hs

#!/usr/bin/env cabal
{- cabal:
build-depends:
  base,
  containers,
  aeson
-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}

module Gen (module Gen) where

import Data.List (intercalate)
import Data.Map qualified as M
import Data.Aeson qualified as A
import GHC.Generics

data JSON
  = JObject (M.Map String JSON)
  | JArray [JSON]
  | JString !String
  | JNumber !Double
  | JBool !Bool
  | JNull
  deriving stock (Show)

class ToJSON a where
  toJson :: a -> JSON
  default toJson :: (Generic a, GToJSON JSON (Rep a)) => a -> JSON
  toJson = gToJson . from

class GToJSON enc f where
  gToJson :: f a -> enc

instance GToJSON JSON U1 where
  gToJson U1 = JNull

instance (GToJSON JSON a, GToJSON JSON b) => GToJSON JSON (a :*: b) where
  gToJson (a :*: b) = case (gToJson a :: JSON, gToJson b :: JSON) of
    (JObject oa, JObject ob) -> JObject (oa <> ob)
    _ -> undefined

instance (GToJSON JSON a, GToJSON JSON b) => GToJSON JSON (a :+: b) where
  gToJson (L1 x) = gToJson x
  gToJson (R1 x) = gToJson x

instance (GToJSON JSON a, Constructor c) => GToJSON JSON (M1 C c a) where
  gToJson m@(M1 x) = gToJson x

instance (GToJSON JSON a) => GToJSON JSON (M1 D c a) where
  gToJson (M1 x) = gToJson x

instance (GToJSON JSON a, Selector c) => GToJSON JSON (M1 S c a) where
  gToJson m@(M1 x) = JObject (M.singleton (selName m) (gToJson x))

instance GToJSON JSON (K1 i Char) where
  gToJson (K1 c) = JString [c]

instance {-# OVERLAPPING #-} GToJSON JSON (K1 i String) where
  gToJson (K1 s) = JString s

instance GToJSON JSON (K1 i Int) where
  gToJson (K1 s) = JNumber (fromIntegral s)

instance {-# OVERLAPPABLE #-} (ToJSON a) => GToJSON JSON (K1 i [a]) where
  gToJson (K1 xs) = JArray (map toJson xs)

data Person = MkPerson { name :: String, age :: Int }
  deriving stock (Generic)
  deriving anyclass (ToJSON, A.ToJSON)

data Company = MkCompany String [Person]
  deriving stock (Generic)
  deriving anyclass (ToJSON, A.ToJSON)