diff --git a/src/Control/Hefty/Final/Naked.hs b/src/Control/Hefty/Final/Naked.hs index d071715..1f22ba4 100644 --- a/src/Control/Hefty/Final/Naked.hs +++ b/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) diff --git a/src/Control/Hefty/Trans/Final.hs b/src/Control/Hefty/Trans/Final.hs index 421dd0d..e2c4854 100644 --- a/src/Control/Hefty/Trans/Final.hs +++ b/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 diff --git a/src/Control/Hefty/Trans/Final/Naked.hs b/src/Control/Hefty/Trans/Final/Naked.hs index a86b5d5..0c39e99 100644 --- a/src/Control/Hefty/Trans/Final/Naked.hs +++ b/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