[add] Interconversion functions between trafos and non-trafos.

src/Control/Hefty/Final/Naked.hs

@@ -14,18 +14,18 @@ runHeftierFinalN i (HeftierFinalN f) = f i
 liftSigFinalN :: HFunctor h => h (HeftierFinalN h) a -> HeftierFinalN h a
 liftSigFinalN e = HeftierFinalN \i -> i $ hmap (runHeftierFinalN i) e
 
-toHeftierFinal :: HeftierFinalN h a -> HeftierFinal Noop h a
-toHeftierFinal (HeftierFinalN f) = HeftierFinal f
+wearHeftierFinal :: HeftierFinalN h a -> HeftierFinal Noop h a
+wearHeftierFinal (HeftierFinalN f) = HeftierFinal f
 
-fromHeftierFinal :: HeftierFinal Noop h a -> HeftierFinalN h a
-fromHeftierFinal (HeftierFinal f) = HeftierFinalN f
+nakeHeftierFinal :: HeftierFinal Noop h a -> HeftierFinalN h a
+nakeHeftierFinal (HeftierFinal f) = HeftierFinalN f
 
-toHeftierFinalF :: Freer c f => HeftierFinalN (f + h) a -> HeftierFinal c h a
-toHeftierFinalF (HeftierFinalN f) =
+wearHeftierFinalF :: Freer c f => HeftierFinalN (f + h) a -> HeftierFinal c h a
+wearHeftierFinalF (HeftierFinalN f) =
     HeftierFinal \i -> f \case
         L m -> retractF m
         R e -> i e
 
-fromHeftierFinalF :: (Freer c f, HFunctor h) => HeftierFinal c h a -> HeftierFinalN (f + h) a
-fromHeftierFinalF (HeftierFinal f) =
+nakeHeftierFinalF :: (Freer c f, HFunctor h) => HeftierFinal c h a -> HeftierFinalN (f + h) a
+nakeHeftierFinalF (HeftierFinal f) =
     HeftierFinalN \i -> i . L $ f $ liftIns . i . R . hmap (i . L)

src/Control/Hefty/Trans/Final.hs

@@ -4,10 +4,12 @@
 module Control.Hefty.Trans.Final where
 
 import Control.Applicative (Alternative, empty, (<|>))
-import Control.Hefty (HFunctor, hmap)
+import Control.Hefty (HFunctor, LiftIns (LiftIns), hmap)
+import Control.Hefty.Final (HeftierFinal (HeftierFinal))
 import Control.Monad (MonadPlus, mplus, mzero)
 import Control.Natural (type (~>))
 import Data.Constraint (Class, cls, (\\))
+import Data.Hefty.Sum (type (+) (L, R))
 
 newtype HeftierFinalT c h f a = HeftierFinalT
     {unHeftierFinalT :: forall g. c g => InterpreterT h f g -> g a}
@@ -64,3 +66,13 @@ instance
 
     HeftierFinalT f `mplus` HeftierFinalT g =
         HeftierFinalT \(i :: InterpreterT h m n) -> f i `mplus` g i \\ cls @(MonadPlus n) @(c n)
+
+cisHeftierFinal :: HeftierFinalT c h f a -> HeftierFinal c (h + LiftIns f) a
+cisHeftierFinal (HeftierFinalT f) =
+    HeftierFinal \i -> f $ InterpreterT (i . R . LiftIns) (i . L)
+
+transHeftierFinal :: HeftierFinal c (h + LiftIns f) a -> HeftierFinalT c h f a
+transHeftierFinal (HeftierFinal f) =
+    HeftierFinalT \InterpreterT{..} -> f \case
+        L e -> interpreter e
+        R (LiftIns a) -> interpretLower a

src/Control/Hefty/Trans/Final/Naked.hs

@@ -1,41 +1,50 @@
 module Control.Hefty.Trans.Final.Naked where
 
 import Control.Free.Class (Freer, liftIns, retractF)
-import Control.Hefty (HFunctor, Signature, hmap)
+import Control.Hefty (HFunctor, LiftIns, Signature, hmap)
 import Control.Hefty.Final (Noop)
+import Control.Hefty.Final.Naked (HeftierFinalN, nakeHeftierFinal, wearHeftierFinal)
 import Control.Hefty.Trans.Final (
     HeftierFinalT (HeftierFinalT),
     InterpreterT (InterpreterT),
+    cisHeftierFinal,
     interpretLower,
     interpreter,
+    transHeftierFinal,
  )
 import Data.Hefty.Sum (type (+) (L, R))
 
-newtype HeftierFinalTN (h :: Signature) f a = HeftierFinalN
+newtype HeftierFinalTN (h :: Signature) f a = HeftierFinalTN
     {unHeftierFinalTN :: forall g. InterpreterT h f g -> g a}
 
 runHeftierFinalTN :: InterpreterT h f g -> HeftierFinalTN h f a -> g a
-runHeftierFinalTN i (HeftierFinalN f) = f i
+runHeftierFinalTN i (HeftierFinalTN f) = f i
 
 liftSigFinalTN :: HFunctor h => h (HeftierFinalTN h f) a -> HeftierFinalTN h f a
-liftSigFinalTN e = HeftierFinalN \i -> interpreter i $ hmap (runHeftierFinalTN i) e
+liftSigFinalTN e = HeftierFinalTN \i -> interpreter i $ hmap (runHeftierFinalTN i) e
 
-toHeftierFinalT :: HeftierFinalTN h f a -> HeftierFinalT Noop h f a
-toHeftierFinalT (HeftierFinalN f) = HeftierFinalT f
+wearHeftierFinalT :: HeftierFinalTN h f a -> HeftierFinalT Noop h f a
+wearHeftierFinalT (HeftierFinalTN f) = HeftierFinalT f
 
-fromHeftierFinalT :: HeftierFinalT Noop h f a -> HeftierFinalTN h f a
-fromHeftierFinalT (HeftierFinalT f) = HeftierFinalN f
+nakeHeftierFinalT :: HeftierFinalT Noop h f a -> HeftierFinalTN h f a
+nakeHeftierFinalT (HeftierFinalT f) = HeftierFinalTN f
 
-toHeftierFinalTF :: Freer c g => HeftierFinalTN (g + h) f a -> HeftierFinalT c h f a
-toHeftierFinalTF (HeftierFinalN f) =
+wearHeftierFinalTF :: Freer c g => HeftierFinalTN (g + h) f a -> HeftierFinalT c h f a
+wearHeftierFinalTF (HeftierFinalTN f) =
     HeftierFinalT \i -> f $ InterpreterT (interpretLower i) \case
         L m -> retractF m
         R e -> interpreter i e
 
-fromHeftierFinalTF :: (Freer c g, HFunctor h) => HeftierFinalT c h f a -> HeftierFinalTN (g + h) f a
-fromHeftierFinalTF (HeftierFinalT f) =
-    HeftierFinalN \i ->
+nakeHeftierFinalTF :: (Freer c g, HFunctor h) => HeftierFinalT c h f a -> HeftierFinalTN (g + h) f a
+nakeHeftierFinalTF (HeftierFinalT f) =
+    HeftierFinalTN \i ->
         interpreter i . L . f $
             InterpreterT
                 (liftIns . interpretLower i)
                 (liftIns . interpreter i . R . hmap (interpreter i . L))
+
+cisHeftierFinalN :: HeftierFinalTN h f a -> HeftierFinalN (h + LiftIns f) a
+cisHeftierFinalN = nakeHeftierFinal . cisHeftierFinal . wearHeftierFinalT
+
+transHeftierFinalN :: HeftierFinalN (h + LiftIns f) a -> HeftierFinalTN h f a
+transHeftierFinalN = nakeHeftierFinalT . transHeftierFinal . wearHeftierFinal