[fix] Generalize the class of heftier transformers to non-Monad.

heftier.cabal

@@ -57,6 +57,7 @@ library
         Control.Hefty.Final
         Control.Hefty.Final.Naked
         Control.Hefty.Class
+        Control.Hefty.Trans.Class
         Control.Hefty.Trans.Final
         Control.Hefty.Trans.Final.Naked
         Control.Free
@@ -97,7 +98,8 @@ library
         TypeFamilies,
         BlockArguments,
         FunctionalDependencies,
-        RecordWildCards
+        RecordWildCards,
+        DefaultSignatures
 
 
 test-suite test
@@ -123,4 +125,5 @@ test-suite test
         TypeFamilies,
         BlockArguments,
         FunctionalDependencies,
-        RecordWildCards
+        RecordWildCards,
+        DefaultSignatures

src/Control/Hefty/Trans/Class.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+
+module Control.Hefty.Trans.Class where
+
+import Control.Hefty (HFunctor, hmap)
+import Control.Hefty.Class (Heftier, liftSig)
+import Control.Monad.Identity (IdentityT (IdentityT), runIdentityT)
+import Control.Natural (type (~>))
+
+class (forall m. c m => Heftier c (h m)) => TransHeftier c h | h -> c where
+    {-# MINIMAL liftLower, (hoistHeftier, interpretR | interpretT) #-}
+
+    liftLower :: forall sig m a. (c m, HFunctor sig) => m a -> h m sig a
+
+    -- | Translate an underlying monad.
+    hoistHeftier :: (c m, c n, HFunctor sig) => (m ~> n) -> h m sig a -> h n sig a
+    hoistHeftier phi = interpretT (liftLower . phi) (liftSig @c)
+    {-# INLINE hoistHeftier #-}
+
+    interpretR :: (c m, HFunctor sig) => (sig m ~> m) -> h m sig a -> m a
+    default interpretR :: (c m, c (IdentityT m), HFunctor sig) => (sig m ~> m) -> h m sig a -> m a
+    interpretR f = runIdentityT . interpretT IdentityT (IdentityT . f . hmap runIdentityT)
+    {-# INLINE interpretR #-}
+
+    interpretT :: (c m, c n, HFunctor sig) => (m ~> n) -> (sig n ~> n) -> h m sig a -> n a
+    interpretT phi i = interpretR i . hoistHeftier phi
+    {-# INLINE interpretT #-}

src/Control/Monad/Trans/Heftier.hs

@@ -1,33 +1,14 @@
-{-# LANGUAGE QuantifiedConstraints #-}
-
 module Control.Monad.Trans.Heftier where
 
-import Control.Hefty (HFunctor, Signature, hmap)
-import Control.Hefty.Class (Heftier, liftSig)
+import Control.Hefty (HFunctor, Signature)
+import Control.Hefty.Trans.Class (TransHeftier, hoistHeftier, interpretT, liftLower)
 import Control.Monad.Cont (ContT)
-import Control.Monad.Identity (IdentityT (IdentityT), runIdentityT)
 import Control.Monad.Trans (MonadTrans, lift)
 import Control.Natural (type (~>))
 import Data.Coerce (Coercible, coerce)
 import Data.Kind (Type)
 
-class
-    ( forall sig. HFunctor sig => MonadTrans (TransHeftier h sig)
-    , forall m. Monad m => Heftier Monad (h m)
-    ) =>
-    MonadTransHeftier h
-    where
-    {-# MINIMAL hoistHeftier, interpretTT | interpretT #-}
-
-    -- | Translate an underlying monad.
-    hoistHeftier :: (Monad m, Monad n, HFunctor sig) => (m ~> n) -> h m sig a -> h n sig a
-    hoistHeftier phi = interpretT (liftLower . phi) (liftSig @Monad)
-    {-# INLINE hoistHeftier #-}
-
-    interpretR :: (Monad m, HFunctor sig) => (sig m ~> m) -> h m sig a -> m a
-    interpretR f = runIdentityT . interpretTT (IdentityT . f . hmap runIdentityT)
-    {-# INLINE interpretR #-}
-
+class TransHeftier Monad h => MonadTransHeftier h where
     interpretK ::
         (Monad m, HFunctor sig) =>
         (sig (ContT b m) ~> ContT b m) ->
@@ -58,14 +39,10 @@ class
         (sig (t n) ~> t n) ->
         h m sig a ->
         t n a
-    reinterpretTT f = interpretTT f . hoistHeftier (coerce . liftLower @h @sig)
+    reinterpretTT f = interpretTT f . hoistHeftier (coerce . liftLower @Monad @h @sig)
     {-# INLINE reinterpretTT #-}
 
-    interpretT :: (Monad m, Monad n, HFunctor sig) => (m ~> n) -> (sig n ~> n) -> h m sig a -> n a
-    interpretT phi i = interpretR i . hoistHeftier phi
-    {-# INLINE interpretT #-}
-
-interceptTViaFinal ::
+reinterpretTTViaFinal ::
     forall h m t n sig a.
     ( MonadTransHeftier h
     , Monad m
@@ -78,13 +55,13 @@ interceptTViaFinal ::
     (sig (t n) ~> t n) ->
     h m sig a ->
     t n a
-interceptTViaFinal = interpretT $ lift . coerce . liftLower @h @sig
-{-# INLINE interceptTViaFinal #-}
+reinterpretTTViaFinal = interpretT $ lift . coerce . liftLower @Monad @h @sig
+{-# INLINE reinterpretTTViaFinal #-}
 
-newtype TransHeftier (h :: (Type -> Type) -> Signature -> Type -> Type) sig m a = TransHeftier
-    {getTransHeftier :: h m sig a}
+newtype HeftierT (h :: (Type -> Type) -> Signature -> Type -> Type) sig m a = HeftierT
+    {runHeftierT :: h m sig a}
     deriving newtype (Functor, Applicative, Monad)
     deriving stock (Foldable, Traversable)
 
-liftLower :: (MonadTrans (TransHeftier h sig), Monad m) => m a -> h m sig a
-liftLower = getTransHeftier . lift
+instance (MonadTransHeftier h, HFunctor sig) => MonadTrans (HeftierT h sig) where
+    lift = HeftierT . liftLower

src/Data/Hefty/Sum.hs

@@ -4,7 +4,7 @@ module Data.Hefty.Sum where
 
 import Control.Hefty (HFunctor, LiftIns, Signature, hmap)
 import Control.Hefty.Class (liftSig, translateH)
-import Control.Monad.Trans.Heftier (MonadTransHeftier, interpretT)
+import Control.Hefty.Trans.Class (TransHeftier, interpretT)
 import Data.Free.Sum (NopF)
 import Data.Hefty.Union (HFunctorUnion, Union, type (<:))
 import Data.Hefty.Union qualified as U
@@ -23,10 +23,11 @@ instance (HFunctor h1, HFunctor h2) => HFunctor (h1 + h2) where
 type Nop = LiftIns NopF
 
 mergeHeftier ::
-    (HFunctor sig, HFunctor sig', MonadTransHeftier h, Monad m) =>
+    forall h m sig sig' a c.
+    (HFunctor sig, HFunctor sig', TransHeftier c h, c m) =>
     h (h m sig') sig a ->
     h m (sig + sig') a
-mergeHeftier = interpretT (translateH @Monad R) (liftSig @Monad . L)
+mergeHeftier = interpretT (translateH @c R) (liftSig @c . L)
 
 swapSum :: (h1 + h2) f a -> (h2 + h1) f a
 swapSum = \case