sayo-hs/heftia
1
1
Fork 0
mirror of https://github.com/sayo-hs/heftia.git synced 2024-11-30 10:59:09 +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 module Control.Monad.Trans.Freer.Church where
import Control.Effect.Class import Control.Effect.Class (Instruction, LiftIns (..))
import Control.Freer.Trans import Control.Freer.Trans (TransFreer (hoistFreer, liftInsT, liftLowerFT, runInterpretF))
import Control.Heftia.Trans (TransHeftia (..), liftSigT) import Control.Heftia.Trans (TransHeftia (..), liftSigT)
import Control.Monad.Trans import Control.Monad.Trans (MonadTrans)
import Control.Monad.Trans.Freer import Control.Monad.Trans.Freer (
import Control.Monad.Trans.Heftia.Church MonadTransFreer (interpretMK, reinterpretMK),
ViaLiftLower (ViaLiftLower),
)
import Control.Monad.Trans.Heftia.Church (HeftiaChurchT (HeftiaChurchT))
newtype FreerChurchT (ins :: Instruction) f a = FreerChurchT newtype FreerChurchT (ins :: Instruction) f a = FreerChurchT
{unFreerChurchT :: HeftiaChurchT (LiftIns ins) f a} {unFreerChurchT :: HeftiaChurchT (LiftIns ins) f a}
@ -35,4 +38,9 @@ instance TransFreer Monad FreerChurchT where
deriving via ViaLiftLower FreerChurchT ins instance MonadTrans (FreerChurchT ins) 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.Effect.Class.Machinery.HFunctor (hfmap)
import Control.Heftia.Trans (TransHeftia (..)) import Control.Heftia.Trans (TransHeftia (..))
import Control.Monad (join) 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.Cont (ContT (ContT), runContT)
import Control.Monad.Trans.Heftia (MonadTransHeftia, elaborateMK, reelaborateMK)
newtype HeftiaChurchT h f a = HeftiaChurchT newtype HeftiaChurchT h f a = HeftiaChurchT
{unHeftiaChurchT :: forall r. (h (HeftiaChurchT h f) ~> ContT r f) -> ContT r f a} {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) = runElaborateH g (HeftiaChurchT f) =
runContT (f $ lift . g . hfmap (runElaborateH g)) pure 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 #-}