sayo-hs/heftia
1
1
Fork 0
mirror of https://github.com/sayo-hs/heftia.git synced 2024-11-23 20:09:22 +03:00
Code Issues Actions 2 Packages Projects Releases Wiki Activity

[add] Naked Finals.

Browse Source
This commit is contained in:
Yamada Ryo 2023-08-27 22:35:02 +09:00
parent 8ed05e40c6
commit 9d9983443b
No known key found for this signature in database
GPG Key ID: AAE3C7A542B02DBF
3 changed files with 74 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
heftier.cabal
View File

@ -55,8 +55,10 @@ library
exposed-modules:
Control.Hefty
Control.Hefty.Final
Control.Hefty.Final.Naked
Control.Hefty.Class
Control.Hefty.Trans.Final
Control.Hefty.Trans.Final.Naked
Control.Free
Control.Free.Class
Control.Monad.Heftier.Final

31
src/Control/Hefty/Final/Naked.hs Normal file
View File

@ -0,0 +1,31 @@
module Control.Hefty.Final.Naked where
import Control.Free.Class (Freer, liftIns, retractF)
import Control.Hefty (HFunctor, Signature, hmap)
import Control.Hefty.Final (HeftierFinal (HeftierFinal), Noop)
import Control.Natural (type (~>))
import Data.Hefty.Sum (type (+) (L, R))
newtype HeftierFinalN (h :: Signature) a = HeftierFinalN {unHeftierFinalN :: forall f. (h f ~> f) -> f a}
runHeftierFinalN :: (h f ~> f) -> HeftierFinalN h a -> f a
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
fromHeftierFinal :: HeftierFinal Noop h a -> HeftierFinalN h a
fromHeftierFinal (HeftierFinal f) = HeftierFinalN f
toHeftierFinalF :: Freer c f => HeftierFinalN (f + h) a -> HeftierFinal c h a
toHeftierFinalF (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) =
HeftierFinalN \i -> i . L $ f $ liftIns . i . R . hmap (i . L)

41
src/Control/Hefty/Trans/Final/Naked.hs Normal file
View File

@ -0,0 +1,41 @@
module Control.Hefty.Trans.Final.Naked where
import Control.Free.Class (Freer, liftIns, retractF)
import Control.Hefty (HFunctor, Signature, hmap)
import Control.Hefty.Final (Noop)
import Control.Hefty.Trans.Final (
HeftierFinalT (HeftierFinalT),
InterpreterT (InterpreterT),
interpretLower,
interpreter,
)
import Data.Hefty.Sum (type (+) (L, R))
newtype HeftierFinalTN (h :: Signature) f a = HeftierFinalN
{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
liftSigFinalTN :: HFunctor h => h (HeftierFinalTN h f) a -> HeftierFinalTN h f a
liftSigFinalTN e = HeftierFinalN \i -> interpreter i $ hmap (runHeftierFinalTN i) e
toHeftierFinalT :: HeftierFinalTN h f a -> HeftierFinalT Noop h f a
toHeftierFinalT (HeftierFinalN f) = HeftierFinalT f
fromHeftierFinalT :: HeftierFinalT Noop h f a -> HeftierFinalTN h f a
fromHeftierFinalT (HeftierFinalT f) = HeftierFinalN f
toHeftierFinalTF :: Freer c g => HeftierFinalTN (g + h) f a -> HeftierFinalT c h f a
toHeftierFinalTF (HeftierFinalN 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 ->
interpreter i . L . f $
InterpreterT
(liftIns . interpretLower i)
(liftIns . interpreter i . R . hmap (interpreter i . L))