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

[add] instances for Church-encoded carriers and improve performance.

Browse Source
This commit is contained in:
Yamada Ryo 2023-09-17 17:31:25 +09:00
parent be8f0b2b8f
commit 811c18e773
No known key found for this signature in database
GPG Key ID: AAE3C7A542B02DBF
2 changed files with 27 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
heftia/src/Control/Monad/Trans/Freer/Church.hs
View File

@ -6,12 +6,15 @@
module Control.Monad.Trans.Freer.Church where
import Control.Effect.Class
import Control.Freer.Trans
import Control.Effect.Class (Instruction, LiftIns (..))
import Control.Freer.Trans (TransFreer (hoistFreer, liftInsT, liftLowerFT, runInterpretF))
import Control.Heftia.Trans (TransHeftia (..), liftSigT)
import Control.Monad.Trans
import Control.Monad.Trans.Freer
import Control.Monad.Trans.Heftia.Church
import Control.Monad.Trans (MonadTrans)
import Control.Monad.Trans.Freer (
MonadTransFreer (interpretMK, reinterpretMK),
ViaLiftLower (ViaLiftLower),
)
import Control.Monad.Trans.Heftia.Church (HeftiaChurchT (HeftiaChurchT))
newtype FreerChurchT (ins :: Instruction) f a = FreerChurchT
{unFreerChurchT :: HeftiaChurchT (LiftIns ins) f a}
@ -35,4 +38,9 @@ instance TransFreer Monad FreerChurchT where
deriving via ViaLiftLower FreerChurchT ins instance MonadTrans (FreerChurchT ins)
instance MonadTransFreer FreerChurchT
instance MonadTransFreer FreerChurchT where
interpretMK f (FreerChurchT (HeftiaChurchT g)) = g $ f . unliftIns
{-# INLINE interpretMK #-}
reinterpretMK f = interpretMK f . hoistFreer liftLowerFT
{-# INLINE reinterpretMK #-}

14
heftia/src/Control/Monad/Trans/Heftia/Church.hs
View File

@ -8,8 +8,9 @@ import Control.Effect.Class (type (~>))
import Control.Effect.Class.Machinery.HFunctor (hfmap)
import Control.Heftia.Trans (TransHeftia (..))
import Control.Monad (join)
import Control.Monad.Trans (lift)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Monad.Trans.Cont (ContT (ContT), runContT)
import Control.Monad.Trans.Heftia (MonadTransHeftia, elaborateMK, reelaborateMK)
newtype HeftiaChurchT h f a = HeftiaChurchT
{unHeftiaChurchT :: forall r. (h (HeftiaChurchT h f) ~> ContT r f) -> ContT r f a}
@ -53,3 +54,14 @@ instance TransHeftia Monad HeftiaChurchT where
runElaborateH g (HeftiaChurchT f) =
runContT (f $ lift . g . hfmap (runElaborateH g)) pure
instance MonadTrans (HeftiaChurchT h) where
lift m = HeftiaChurchT \_ -> lift m
{-# INLINE lift #-}
instance MonadTransHeftia HeftiaChurchT where
elaborateMK f (HeftiaChurchT g) = g $ f . hfmap (elaborateMK f)
{-# INLINE elaborateMK #-}
reelaborateMK f = elaborateMK f . hoistHeftia liftLowerHT
{-# INLINE reelaborateMK #-}