Sum.hs

{-# LANGUAGE UndecidableInstances #-} -- due to typeclass design
{-# LANGUAGE AllowAmbiguousTypes #-}  -- due to typeclass design

module Generic.Data.Function.Contra.Sum where

import GHC.Generics
import Generic.Data.Function.Util.Generic ( conName' )
import Generic.Data.Function.Contra.Constructor
  ( GContraC(gContraC)
  , GenericContra(type GenericContraF)
  )
import Generic.Data.Rep.Error
import Generic.Data.Function.Common

import Data.Functor.Contravariant.Divisible
import Data.Functor.Contravariant

class GContraSum tag (opts :: SumOpts) gf where
    gContraSum :: GenericContraF tag String -> GenericContraF tag (gf p)

instance (GContraSumD tag opts gf, Contravariant (GenericContraF tag))
  => GContraSum tag opts (D1 cd gf) where
    gContraSum f = contramap unM1 (gContraSumD @tag @opts f)

class GContraSumD tag (opts :: SumOpts) gf where
    gContraSumD :: GenericContraF tag String -> GenericContraF tag (gf p)

instance GContraCSum tag (l :+: r) => GContraSumD tag opts (l :+: r) where
    gContraSumD = gContraCSum @tag

instance GContraSumD tag 'SumOnly (C1 cc gf) where
    gContraSumD = error eNeedSum

instance GContraCSum tag (C1 cc gf)
  => GContraSumD tag 'AllowSingletonSum (C1 cc gf) where
    gContraSumD = gContraCSum @tag

instance GContraSumD tag opts V1 where
    gContraSumD = error eNoEmpty

-- TODO rename (? had this on foldmap sum)
class GContraCSum tag gf where
    gContraCSum :: GenericContraF tag String -> GenericContraF tag (gf p)

instance
  ( Decidable (GenericContraF tag)
  , GContraCSum tag l
  , GContraCSum tag r
  ) => GContraCSum tag (l :+: r) where
    gContraCSum f = choose genericSumToEither (gContraCSum @tag f) (gContraCSum @tag f)
      where genericSumToEither = \case L1 l -> Left l; R1 r -> Right r

instance
  ( Divisible (GenericContraF tag)
  , GContraC tag gf, Constructor c
  ) => GContraCSum tag (C1 c gf) where
    gContraCSum f = divide (\(M1 g) -> (conName' @c, g)) f (gContraC @tag)