Converting sums to products.

Lib.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Lib where

import Data.Proxy
import GHC.Generics
import GHC.TypeLits

someFunc :: IO ()
someFunc = pure ()

data Sum = A | B | C
  deriving (Generic, Show)

data Product
  = Product
      { _A :: Bool
      , _B :: Bool
      , _C :: Bool
      }
  deriving (Generic, Show)

class SumToProduct sum record where
  sumToProduct
    :: sum
    -> record

instance (Generic sum, GSumToProduct (Rep sum) record)
    => SumToProduct sum record where
  sumToProduct sum = gsumToProduct (from sum)

class GSumToProduct gsum record where
  gsumToProduct :: gsum p -> record

instance GSumToProduct inner record
    => GSumToProduct (D1 meta inner) record where
  gsumToProduct (M1 inner) = gsumToProduct inner

instance (GSumToProduct left record, GSumToProduct right record)
    => GSumToProduct (left :+: right) record where
  gsumToProduct rep = case rep of
    L1 left  -> gsumToProduct left
    R1 right -> gsumToProduct right

instance
    ( Generic record
    , fieldName ~ AppendSymbol "_" field
    , fieldName `GIsFieldOf` (Rep record)
    , KnownSymbol field
    )
    => GSumToProduct (C1 ('MetaCons field lol idk) U1) record
  where
    gsumToProduct _ = makeRecord @fieldName

---

class (field :: Symbol) `IsFieldOf` record where
  makeRecord :: record

class (field :: Symbol) `GIsFieldOf` rep where
  gmakeRecord :: rep p

instance field `GIsFieldOf` inner
    => field `GIsFieldOf` D1 meta inner where
  gmakeRecord = M1 (gmakeRecord @field)

instance field `GIsFieldOf` inner
    => field `GIsFieldOf` C1 meta inner where
  gmakeRecord = M1 (gmakeRecord @field)

instance (field `GIsFieldOf` left, field `GIsFieldOf` right)
    => field `GIsFieldOf` (left :*: right) where
  gmakeRecord = (gmakeRecord @field) :*: (gmakeRecord @field)

instance {-# OVERLAPPING #-}
    field `GIsFieldOf` S1 ('MetaSel ('Just field) i d c) (Rec0 Bool) where
  gmakeRecord = M1 (K1 True)

instance {-# OVERLAPPABLE #-}
    field `GIsFieldOf` S1 ('MetaSel ('Just lol) i d c) (Rec0 Bool) where
  gmakeRecord = M1 (K1 False)

instance (Generic record, field `GIsFieldOf` Rep record)
    => field `IsFieldOf` record
  where
    makeRecord = to (gmakeRecord @field)