mirror of
https://github.com/sayo-hs/heftia.git
synced 2024-11-26 23:05:04 +03:00
[remove] the carriers encoded with Final encoding.
This commit is contained in:
Yamada Ryo
parent
7f5d8c63d1
commit
724ef0832c
@ -54,13 +54,8 @@ library
|
|||||||
exposed-modules:
|
exposed-modules:
|
||||||
Control.Freer
|
Control.Freer
|
||||||
Control.Freer.Trans
|
Control.Freer.Trans
|
||||||
Control.Freer.Trans.Final
|
|
||||||
Control.Heftia
|
Control.Heftia
|
||||||
Control.Heftia.Final
|
|
||||||
Control.Heftia.Final.Naked
|
|
||||||
Control.Heftia.Trans
|
Control.Heftia.Trans
|
||||||
Control.Heftia.Trans.Final
|
|
||||||
Control.Heftia.Trans.Final.Naked
|
|
||||||
Control.Monad.Trans.Freer
|
Control.Monad.Trans.Freer
|
||||||
Control.Monad.Trans.Freer.Tree
|
Control.Monad.Trans.Freer.Tree
|
||||||
Control.Monad.Trans.Freer.Church
|
Control.Monad.Trans.Freer.Church
|
||||||
|
|||||||
@ -1,121 +0,0 @@
|
|||||||
{-# LANGUAGE DerivingVia #-}
|
|
||||||
{-# LANGUAGE QuantifiedConstraints #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
{-# OPTIONS_GHC -Wno-deprecations #-}
|
|
||||||
|
|
||||||
-- This Source Code Form is subject to the terms of the Mozilla Public
|
|
||||||
-- License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
||||||
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.
|
|
||||||
|
|
||||||
module Control.Freer.Trans.Final
|
|
||||||
{-# DEPRECATED
|
|
||||||
"The current implementation of final-encoded Freer and Heftia can easily cause infinite loops."
|
|
||||||
#-}
|
|
||||||
where
|
|
||||||
|
|
||||||
import Control.Applicative (Alternative)
|
|
||||||
import Control.Effect.Class (Instruction, LiftIns (LiftIns), unliftIns, type (~>))
|
|
||||||
import Control.Freer.Trans (TransFreer (..), liftInsT)
|
|
||||||
import Control.Heftia.Trans.Final (
|
|
||||||
FinalTElaborator (FinalTElaborator),
|
|
||||||
HeftiaFinalT,
|
|
||||||
elaborateFinalT,
|
|
||||||
elaborateFinalTLower,
|
|
||||||
heftiaFinalT,
|
|
||||||
hoistHeftiaFinal,
|
|
||||||
liftLowerHTFinal,
|
|
||||||
liftSigFinalT,
|
|
||||||
runHeftiaFinalT,
|
|
||||||
subsumeHeftiaFinal,
|
|
||||||
weakenHeftiaFinalT,
|
|
||||||
)
|
|
||||||
import Control.Monad (MonadPlus)
|
|
||||||
import Control.Monad.Trans (MonadTrans)
|
|
||||||
import Control.Monad.Trans.Freer (MonadTransFreer, ViaLiftLower (ViaLiftLower))
|
|
||||||
|
|
||||||
newtype FreerFinalT c (ins :: Instruction) f a = FreerFinalT
|
|
||||||
{unFreerFinalT :: HeftiaFinalT c (LiftIns ins) f a}
|
|
||||||
|
|
||||||
data FinalTInterpreter ins f g = FinalTInterpreter
|
|
||||||
{ interpretFinalTLower :: f ~> g
|
|
||||||
, interpretFinalT :: ins ~> g
|
|
||||||
}
|
|
||||||
|
|
||||||
runFreerFinalT :: c g => FinalTInterpreter ins f g -> FreerFinalT c ins f ~> g
|
|
||||||
runFreerFinalT FinalTInterpreter{..} (FreerFinalT a) =
|
|
||||||
($ a) $ runHeftiaFinalT $ FinalTElaborator interpretFinalTLower (interpretFinalT . unliftIns)
|
|
||||||
{-# INLINE runFreerFinalT #-}
|
|
||||||
|
|
||||||
freerFinalT :: (forall g. c g => FinalTInterpreter ins f g -> g a) -> FreerFinalT c ins f a
|
|
||||||
freerFinalT f =
|
|
||||||
FreerFinalT $ heftiaFinalT \FinalTElaborator{..} ->
|
|
||||||
f $ FinalTInterpreter elaborateFinalTLower (elaborateFinalT . LiftIns)
|
|
||||||
{-# INLINE freerFinalT #-}
|
|
||||||
|
|
||||||
liftInsFinalT :: ins ~> FreerFinalT c ins f
|
|
||||||
liftInsFinalT = FreerFinalT . liftSigFinalT . LiftIns
|
|
||||||
{-# INLINE liftInsFinalT #-}
|
|
||||||
|
|
||||||
liftLowerFTFinal :: f ~> FreerFinalT c ins f
|
|
||||||
liftLowerFTFinal = FreerFinalT . liftLowerHTFinal
|
|
||||||
{-# INLINE liftLowerFTFinal #-}
|
|
||||||
|
|
||||||
weakenFreerFinalT :: (forall g. c' g => c g) => FreerFinalT c ins f ~> FreerFinalT c' ins f
|
|
||||||
weakenFreerFinalT = FreerFinalT . weakenHeftiaFinalT . unFreerFinalT
|
|
||||||
{-# INLINE weakenFreerFinalT #-}
|
|
||||||
|
|
||||||
hoistFreerFinal :: (f ~> g) -> FreerFinalT c ins f ~> FreerFinalT c ins g
|
|
||||||
hoistFreerFinal phi = FreerFinalT . hoistHeftiaFinal phi . unFreerFinalT
|
|
||||||
{-# INLINE hoistFreerFinal #-}
|
|
||||||
|
|
||||||
deriving newtype instance Functor (FreerFinalT Functor ins f)
|
|
||||||
|
|
||||||
deriving newtype instance Functor (FreerFinalT Applicative ins f)
|
|
||||||
deriving newtype instance Applicative (FreerFinalT Applicative ins f)
|
|
||||||
|
|
||||||
deriving newtype instance Functor (FreerFinalT Alternative ins f)
|
|
||||||
deriving newtype instance Applicative (FreerFinalT Alternative ins f)
|
|
||||||
deriving newtype instance Alternative (FreerFinalT Alternative ins f)
|
|
||||||
|
|
||||||
deriving newtype instance Functor (FreerFinalT Monad ins m)
|
|
||||||
deriving newtype instance Applicative (FreerFinalT Monad ins m)
|
|
||||||
deriving newtype instance Monad (FreerFinalT Monad ins m)
|
|
||||||
|
|
||||||
deriving newtype instance Functor (FreerFinalT MonadPlus ins m)
|
|
||||||
deriving newtype instance Applicative (FreerFinalT MonadPlus ins m)
|
|
||||||
deriving newtype instance Alternative (FreerFinalT MonadPlus ins m)
|
|
||||||
deriving newtype instance Monad (FreerFinalT MonadPlus ins m)
|
|
||||||
deriving newtype instance MonadPlus (FreerFinalT MonadPlus ins m)
|
|
||||||
|
|
||||||
instance (forall h f. c f => c (FreerFinalT c h f)) => TransFreer c (FreerFinalT c) where
|
|
||||||
liftInsT = liftInsFinalT
|
|
||||||
{-# INLINE liftInsT #-}
|
|
||||||
|
|
||||||
liftLowerFT = liftLowerFTFinal
|
|
||||||
{-# INLINE liftLowerFT #-}
|
|
||||||
|
|
||||||
runInterpretF i = runFreerFinalT $ FinalTInterpreter id i
|
|
||||||
{-# INLINE runInterpretF #-}
|
|
||||||
|
|
||||||
hoistFreer = hoistFreerFinal
|
|
||||||
{-# INLINE hoistFreer #-}
|
|
||||||
|
|
||||||
interpretFT f i = runFreerFinalT $ FinalTInterpreter f i
|
|
||||||
|
|
||||||
deriving via ViaLiftLower (FreerFinalT Monad) ins instance MonadTrans (FreerFinalT Monad ins)
|
|
||||||
|
|
||||||
instance MonadTransFreer (FreerFinalT Monad)
|
|
||||||
|
|
||||||
subsumeFreerFinal ::
|
|
||||||
c (HeftiaFinalT c (LiftIns ins) f) =>
|
|
||||||
FreerFinalT c ins (FreerFinalT c ins f) ~> FreerFinalT c ins f
|
|
||||||
subsumeFreerFinal =
|
|
||||||
FreerFinalT
|
|
||||||
. subsumeHeftiaFinal
|
|
||||||
. hoistHeftiaFinal unFreerFinalT
|
|
||||||
. unFreerFinalT
|
|
||||||
{-# INLINE subsumeFreerFinal #-}
|
|
||||||
|
|
||||||
dupFreerFinal :: FreerFinalT c ins f ~> FreerFinalT c ins (FreerFinalT c ins f)
|
|
||||||
dupFreerFinal = hoistFreerFinal liftLowerFTFinal
|
|
||||||
{-# INLINE dupFreerFinal #-}
|
|
||||||
@ -1,114 +0,0 @@
|
|||||||
{-# LANGUAGE PatternSynonyms #-}
|
|
||||||
{-# LANGUAGE QuantifiedConstraints #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
|
||||||
|
|
||||||
{-# HLINT ignore "Use const" #-}
|
|
||||||
|
|
||||||
-- This Source Code Form is subject to the terms of the Mozilla Public
|
|
||||||
-- License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
||||||
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.
|
|
||||||
|
|
||||||
module Control.Heftia.Final
|
|
||||||
{-# DEPRECATED
|
|
||||||
"The current implementation of final-encoded Freer and Heftia can easily cause infinite loops."
|
|
||||||
#-}
|
|
||||||
where
|
|
||||||
|
|
||||||
import Control.Applicative (Alternative, empty, (<|>))
|
|
||||||
import Control.Effect.Class (LiftIns (LiftIns), Signature, type (~>))
|
|
||||||
import Control.Effect.Class.Machinery.HFunctor (HFunctor, hfmap, (:+:) (Inl, Inr))
|
|
||||||
import Control.Heftia (Heftia, interpretHH, liftSig)
|
|
||||||
import Control.Monad (MonadPlus (mplus, mzero))
|
|
||||||
import Data.Free.Sum (pattern L1, pattern R1, type (+))
|
|
||||||
|
|
||||||
newtype HeftiaFinal c (h :: Signature) a = HeftiaFinal
|
|
||||||
{unHeftiaFinal :: forall f. c f => (h f ~> f) -> f a}
|
|
||||||
|
|
||||||
runHeftiaFinal :: c f => (h f ~> f) -> HeftiaFinal c h a -> f a
|
|
||||||
runHeftiaFinal i (HeftiaFinal f) = f i
|
|
||||||
{-# INLINE runHeftiaFinal #-}
|
|
||||||
|
|
||||||
liftSigFinal :: HFunctor h => h (HeftiaFinal c h) a -> HeftiaFinal c h a
|
|
||||||
liftSigFinal e = HeftiaFinal \i -> i $ hfmap (runHeftiaFinal i) e
|
|
||||||
{-# INLINE liftSigFinal #-}
|
|
||||||
|
|
||||||
weakenHeftiaFinal :: (forall f. c' f => c f) => HeftiaFinal c h a -> HeftiaFinal c' h a
|
|
||||||
weakenHeftiaFinal (HeftiaFinal f) = HeftiaFinal f
|
|
||||||
{-# INLINE weakenHeftiaFinal #-}
|
|
||||||
|
|
||||||
transformHeftiaFinal ::
|
|
||||||
(forall f. h f ~> i f) ->
|
|
||||||
HeftiaFinal c h a ->
|
|
||||||
HeftiaFinal c i a
|
|
||||||
transformHeftiaFinal phi (HeftiaFinal f) = HeftiaFinal \i -> f $ i . phi
|
|
||||||
{-# INLINE transformHeftiaFinal #-}
|
|
||||||
|
|
||||||
translateHeftiaFinal ::
|
|
||||||
(c (HeftiaFinal c i), HFunctor i) =>
|
|
||||||
(h (HeftiaFinal c i) ~> i (HeftiaFinal c i)) ->
|
|
||||||
HeftiaFinal c h a ->
|
|
||||||
HeftiaFinal c i a
|
|
||||||
translateHeftiaFinal f = runHeftiaFinal $ liftSigFinal . f
|
|
||||||
{-# INLINE translateHeftiaFinal #-}
|
|
||||||
|
|
||||||
instance (forall f. c f => Functor f, c (HeftiaFinal c h)) => Functor (HeftiaFinal c h) where
|
|
||||||
fmap f (HeftiaFinal g) =
|
|
||||||
HeftiaFinal \(i :: h f ~> f) -> f <$> g i
|
|
||||||
{-# INLINE fmap #-}
|
|
||||||
|
|
||||||
instance
|
|
||||||
(forall f. c f => Applicative f, c (HeftiaFinal c h)) =>
|
|
||||||
Applicative (HeftiaFinal c h)
|
|
||||||
where
|
|
||||||
pure x = HeftiaFinal \_ -> pure x
|
|
||||||
|
|
||||||
HeftiaFinal f <*> HeftiaFinal g =
|
|
||||||
HeftiaFinal \i -> f i <*> g i
|
|
||||||
|
|
||||||
{-# INLINE pure #-}
|
|
||||||
{-# INLINE (<*>) #-}
|
|
||||||
|
|
||||||
instance
|
|
||||||
(forall f. c f => Alternative f, c (HeftiaFinal c h)) =>
|
|
||||||
Alternative (HeftiaFinal c h)
|
|
||||||
where
|
|
||||||
empty = HeftiaFinal \_ -> empty
|
|
||||||
|
|
||||||
HeftiaFinal f <|> HeftiaFinal g =
|
|
||||||
HeftiaFinal \i -> f i <|> g i
|
|
||||||
|
|
||||||
{-# INLINE empty #-}
|
|
||||||
{-# INLINE (<|>) #-}
|
|
||||||
|
|
||||||
instance (forall m. c m => Monad m, c (HeftiaFinal c h)) => Monad (HeftiaFinal c h) where
|
|
||||||
HeftiaFinal f >>= k =
|
|
||||||
HeftiaFinal \i ->
|
|
||||||
f i >>= runHeftiaFinal i . k
|
|
||||||
{-# INLINE (>>=) #-}
|
|
||||||
|
|
||||||
instance
|
|
||||||
(forall m. c m => MonadPlus m, Alternative (HeftiaFinal c h), Monad (HeftiaFinal c h)) =>
|
|
||||||
MonadPlus (HeftiaFinal c h)
|
|
||||||
where
|
|
||||||
mzero = HeftiaFinal \_ -> mzero
|
|
||||||
|
|
||||||
HeftiaFinal f `mplus` HeftiaFinal g =
|
|
||||||
HeftiaFinal \i -> f i `mplus` g i
|
|
||||||
|
|
||||||
{-# INLINE mzero #-}
|
|
||||||
{-# INLINE mplus #-}
|
|
||||||
|
|
||||||
instance (forall sig. c (HeftiaFinal c sig)) => Heftia c (HeftiaFinal c) where
|
|
||||||
liftSig = liftSigFinal
|
|
||||||
interpretHH = runHeftiaFinal
|
|
||||||
{-# INLINE liftSig #-}
|
|
||||||
{-# INLINE interpretHH #-}
|
|
||||||
|
|
||||||
slipFreer ::
|
|
||||||
(HFunctor h, c (HeftiaFinal c (h :+: LiftIns f))) =>
|
|
||||||
HeftiaFinal c (LiftIns (f + HeftiaFinal c h))
|
|
||||||
~> HeftiaFinal c (h :+: LiftIns f)
|
|
||||||
slipFreer (HeftiaFinal run) = run \(LiftIns a) -> case a of
|
|
||||||
L1 fr -> liftSigFinal $ Inr $ LiftIns fr
|
|
||||||
R1 he -> transformHeftiaFinal Inl he
|
|
||||||
@ -1,44 +0,0 @@
|
|||||||
{-# OPTIONS_GHC -Wno-deprecations #-}
|
|
||||||
|
|
||||||
-- This Source Code Form is subject to the terms of the Mozilla Public
|
|
||||||
-- License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
||||||
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.
|
|
||||||
|
|
||||||
module Control.Heftia.Final.Naked
|
|
||||||
{-# DEPRECATED
|
|
||||||
"The current implementation of final-encoded Freer and Heftia can easily cause infinite loops."
|
|
||||||
#-}
|
|
||||||
where
|
|
||||||
|
|
||||||
import Control.Effect.Class (Nop, Signature, type (~>))
|
|
||||||
import Control.Effect.Class.Machinery.HFunctor (HFunctor, hfmap, (:+:) (Inl, Inr))
|
|
||||||
import Control.Freer (Freer, liftIns, retract)
|
|
||||||
import Control.Heftia.Final (HeftiaFinal (HeftiaFinal))
|
|
||||||
|
|
||||||
newtype HeftiaFinalN (h :: Signature) a = HeftiaFinalN {unHeftiaFinalN :: forall f. (h f ~> f) -> f a}
|
|
||||||
|
|
||||||
runHeftiaFinalN :: (h f ~> f) -> HeftiaFinalN h a -> f a
|
|
||||||
runHeftiaFinalN i (HeftiaFinalN f) = f i
|
|
||||||
{-# INLINE runHeftiaFinalN #-}
|
|
||||||
|
|
||||||
liftSigFinalN :: HFunctor h => h (HeftiaFinalN h) a -> HeftiaFinalN h a
|
|
||||||
liftSigFinalN e = HeftiaFinalN \i -> i $ hfmap (runHeftiaFinalN i) e
|
|
||||||
{-# INLINE liftSigFinalN #-}
|
|
||||||
|
|
||||||
wearHeftiaFinal :: HeftiaFinalN h a -> HeftiaFinal Nop h a
|
|
||||||
wearHeftiaFinal (HeftiaFinalN f) = HeftiaFinal f
|
|
||||||
{-# INLINE wearHeftiaFinal #-}
|
|
||||||
|
|
||||||
nakeHeftiaFinal :: HeftiaFinal Nop h a -> HeftiaFinalN h a
|
|
||||||
nakeHeftiaFinal (HeftiaFinal f) = HeftiaFinalN f
|
|
||||||
{-# INLINE nakeHeftiaFinal #-}
|
|
||||||
|
|
||||||
wearHeftiaFinalF :: Freer c f => HeftiaFinalN (f :+: h) a -> HeftiaFinal c h a
|
|
||||||
wearHeftiaFinalF (HeftiaFinalN f) =
|
|
||||||
HeftiaFinal \i -> f \case
|
|
||||||
Inl m -> retract m
|
|
||||||
Inr e -> i e
|
|
||||||
|
|
||||||
nakeHeftiaFinalF :: (Freer c f, HFunctor h) => HeftiaFinal c h a -> HeftiaFinalN (f :+: h) a
|
|
||||||
nakeHeftiaFinalF (HeftiaFinal f) =
|
|
||||||
HeftiaFinalN \i -> i . Inl $ f $ liftIns . i . Inr . hfmap (i . Inl)
|
|
||||||
@ -1,124 +0,0 @@
|
|||||||
{-# LANGUAGE DerivingVia #-}
|
|
||||||
{-# LANGUAGE QuantifiedConstraints #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
{-# OPTIONS_GHC -Wno-deprecations #-}
|
|
||||||
|
|
||||||
-- This Source Code Form is subject to the terms of the Mozilla Public
|
|
||||||
-- License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
||||||
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.
|
|
||||||
|
|
||||||
module Control.Heftia.Trans.Final
|
|
||||||
{-# DEPRECATED
|
|
||||||
"The current implementation of final-encoded Freer and Heftia can easily cause infinite loops."
|
|
||||||
#-}
|
|
||||||
where
|
|
||||||
|
|
||||||
import Control.Applicative (Alternative)
|
|
||||||
import Control.Effect.Class (LiftIns (LiftIns), type (~>))
|
|
||||||
import Control.Effect.Class.Machinery.HFunctor (HFunctor, hfmap, (:+:) (Inl, Inr))
|
|
||||||
import Control.Heftia.Final (
|
|
||||||
HeftiaFinal (HeftiaFinal),
|
|
||||||
liftSigFinal,
|
|
||||||
runHeftiaFinal,
|
|
||||||
transformHeftiaFinal,
|
|
||||||
weakenHeftiaFinal,
|
|
||||||
)
|
|
||||||
import Control.Heftia.Trans (TransHeftia (..))
|
|
||||||
import Control.Monad (MonadPlus)
|
|
||||||
import Control.Monad.Trans (MonadTrans)
|
|
||||||
import Control.Monad.Trans.Heftia (MonadTransHeftia, ViaLiftLowerH (ViaLiftLowerH))
|
|
||||||
import Data.Function ((&))
|
|
||||||
|
|
||||||
newtype HeftiaFinalT c h f a = HeftiaFinalT
|
|
||||||
{unHeftiaFinalT :: HeftiaFinal c (h :+: LiftIns f) a}
|
|
||||||
|
|
||||||
data FinalTElaborator h f g = FinalTElaborator
|
|
||||||
{ elaborateFinalTLower :: f ~> g
|
|
||||||
, elaborateFinalT :: h g ~> g
|
|
||||||
}
|
|
||||||
|
|
||||||
runHeftiaFinalT :: c g => FinalTElaborator h f g -> HeftiaFinalT c h f a -> g a
|
|
||||||
runHeftiaFinalT FinalTElaborator{..} (HeftiaFinalT (HeftiaFinal h)) = h \case
|
|
||||||
Inl e -> elaborateFinalT e
|
|
||||||
Inr (LiftIns a) -> elaborateFinalTLower a
|
|
||||||
|
|
||||||
heftiaFinalT :: (forall g. c g => FinalTElaborator h f g -> g a) -> HeftiaFinalT c h f a
|
|
||||||
heftiaFinalT f = HeftiaFinalT $ HeftiaFinal \i -> f $ FinalTElaborator (i . Inr . LiftIns) (i . Inl)
|
|
||||||
|
|
||||||
liftSigFinalT :: HFunctor h => h (HeftiaFinalT c h f) a -> HeftiaFinalT c h f a
|
|
||||||
liftSigFinalT = HeftiaFinalT . liftSigFinal . Inl . hfmap unHeftiaFinalT
|
|
||||||
{-# INLINE liftSigFinalT #-}
|
|
||||||
|
|
||||||
liftLowerHTFinal :: HFunctor h => f a -> HeftiaFinalT c h f a
|
|
||||||
liftLowerHTFinal = HeftiaFinalT . liftSigFinal . Inr . LiftIns
|
|
||||||
{-# INLINE liftLowerHTFinal #-}
|
|
||||||
|
|
||||||
weakenHeftiaFinalT :: (forall g. c' g => c g) => HeftiaFinalT c h f a -> HeftiaFinalT c' h f a
|
|
||||||
weakenHeftiaFinalT = HeftiaFinalT . weakenHeftiaFinal . unHeftiaFinalT
|
|
||||||
{-# INLINE weakenHeftiaFinalT #-}
|
|
||||||
|
|
||||||
hoistHeftiaFinal ::
|
|
||||||
(f ~> g) ->
|
|
||||||
HeftiaFinalT c h f ~> HeftiaFinalT c h g
|
|
||||||
hoistHeftiaFinal phi (HeftiaFinalT a) =
|
|
||||||
HeftiaFinalT $
|
|
||||||
a & transformHeftiaFinal \case
|
|
||||||
Inl e -> Inl e
|
|
||||||
Inr (LiftIns a') -> Inr $ LiftIns $ phi a'
|
|
||||||
|
|
||||||
deriving newtype instance Functor (HeftiaFinalT Functor h f)
|
|
||||||
|
|
||||||
deriving newtype instance Functor (HeftiaFinalT Applicative h f)
|
|
||||||
deriving newtype instance Applicative (HeftiaFinalT Applicative h f)
|
|
||||||
|
|
||||||
deriving newtype instance Functor (HeftiaFinalT Alternative h f)
|
|
||||||
deriving newtype instance Applicative (HeftiaFinalT Alternative h f)
|
|
||||||
deriving newtype instance Alternative (HeftiaFinalT Alternative h f)
|
|
||||||
|
|
||||||
deriving newtype instance Functor (HeftiaFinalT Monad h m)
|
|
||||||
deriving newtype instance Applicative (HeftiaFinalT Monad h m)
|
|
||||||
deriving newtype instance Monad (HeftiaFinalT Monad h m)
|
|
||||||
|
|
||||||
deriving newtype instance Functor (HeftiaFinalT MonadPlus h m)
|
|
||||||
deriving newtype instance Applicative (HeftiaFinalT MonadPlus h m)
|
|
||||||
deriving newtype instance Alternative (HeftiaFinalT MonadPlus h m)
|
|
||||||
deriving newtype instance Monad (HeftiaFinalT MonadPlus h m)
|
|
||||||
deriving newtype instance MonadPlus (HeftiaFinalT MonadPlus h m)
|
|
||||||
|
|
||||||
instance (forall h f. c f => c (HeftiaFinalT c h f)) => TransHeftia c (HeftiaFinalT c) where
|
|
||||||
liftSigT = liftSigFinalT
|
|
||||||
{-# INLINE liftSigT #-}
|
|
||||||
|
|
||||||
translateT f (HeftiaFinalT a) =
|
|
||||||
a & runHeftiaFinal \case
|
|
||||||
Inl e -> liftSigFinalT $ f e
|
|
||||||
Inr (LiftIns a') -> liftLowerHT a'
|
|
||||||
|
|
||||||
liftLowerHT = liftLowerHTFinal
|
|
||||||
{-# INLINE liftLowerHT #-}
|
|
||||||
|
|
||||||
runElaborateH i = runHeftiaFinalT $ FinalTElaborator id i
|
|
||||||
{-# INLINE runElaborateH #-}
|
|
||||||
|
|
||||||
hoistHeftia = hoistHeftiaFinal
|
|
||||||
{-# INLINE hoistHeftia #-}
|
|
||||||
|
|
||||||
deriving via
|
|
||||||
ViaLiftLowerH (HeftiaFinalT Monad) h
|
|
||||||
instance
|
|
||||||
HFunctor h => MonadTrans (HeftiaFinalT Monad h)
|
|
||||||
|
|
||||||
instance MonadTransHeftia (HeftiaFinalT Monad)
|
|
||||||
|
|
||||||
subsumeHeftiaFinal ::
|
|
||||||
(c (HeftiaFinalT c h f), HFunctor h) =>
|
|
||||||
HeftiaFinalT c h (HeftiaFinalT c h f) a ->
|
|
||||||
HeftiaFinalT c h f a
|
|
||||||
subsumeHeftiaFinal (HeftiaFinalT (HeftiaFinal f)) =
|
|
||||||
f \case
|
|
||||||
Inl e -> liftSigFinalT e
|
|
||||||
Inr (LiftIns e) -> e
|
|
||||||
|
|
||||||
dupHeftiaFinal :: HFunctor h => HeftiaFinalT c h f a -> HeftiaFinalT c h (HeftiaFinalT c h f) a
|
|
||||||
dupHeftiaFinal = hoistHeftiaFinal liftLowerHTFinal
|
|
||||||
{-# INLINE dupHeftiaFinal #-}
|
|
||||||
@ -1,66 +0,0 @@
|
|||||||
{-# OPTIONS_GHC -Wno-deprecations #-}
|
|
||||||
|
|
||||||
-- This Source Code Form is subject to the terms of the Mozilla Public
|
|
||||||
-- License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
||||||
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.
|
|
||||||
|
|
||||||
module Control.Heftia.Trans.Final.Naked
|
|
||||||
{-# DEPRECATED
|
|
||||||
"The current implementation of final-encoded Freer and Heftia can easily cause infinite loops."
|
|
||||||
#-}
|
|
||||||
where
|
|
||||||
|
|
||||||
import Control.Effect.Class (LiftIns, Nop, Signature)
|
|
||||||
import Control.Effect.Class.Machinery.HFunctor (HFunctor, hfmap, (:+:) (Inl, Inr))
|
|
||||||
import Control.Freer (Freer, liftIns, retract)
|
|
||||||
import Control.Heftia.Final.Naked (HeftiaFinalN, nakeHeftiaFinal, wearHeftiaFinal)
|
|
||||||
import Control.Heftia.Trans.Final (
|
|
||||||
FinalTElaborator (FinalTElaborator),
|
|
||||||
HeftiaFinalT (HeftiaFinalT),
|
|
||||||
elaborateFinalT,
|
|
||||||
elaborateFinalTLower,
|
|
||||||
heftiaFinalT,
|
|
||||||
runHeftiaFinalT,
|
|
||||||
unHeftiaFinalT,
|
|
||||||
)
|
|
||||||
|
|
||||||
newtype HeftiaFinalTN (h :: Signature) f a = HeftiaFinalTN
|
|
||||||
{unHeftiaFinalTN :: forall g. FinalTElaborator h f g -> g a}
|
|
||||||
|
|
||||||
runHeftiaFinalTN :: FinalTElaborator h f g -> HeftiaFinalTN h f a -> g a
|
|
||||||
runHeftiaFinalTN i (HeftiaFinalTN f) = f i
|
|
||||||
{-# INLINE runHeftiaFinalTN #-}
|
|
||||||
|
|
||||||
liftSigFinalTN :: HFunctor h => h (HeftiaFinalTN h f) a -> HeftiaFinalTN h f a
|
|
||||||
liftSigFinalTN e = HeftiaFinalTN \i -> elaborateFinalT i $ hfmap (runHeftiaFinalTN i) e
|
|
||||||
{-# INLINE liftSigFinalTN #-}
|
|
||||||
|
|
||||||
wearHeftiaFinalT :: HeftiaFinalTN h f a -> HeftiaFinalT Nop h f a
|
|
||||||
wearHeftiaFinalT (HeftiaFinalTN f) = heftiaFinalT f
|
|
||||||
{-# INLINE wearHeftiaFinalT #-}
|
|
||||||
|
|
||||||
nakeHeftiaFinalT :: HeftiaFinalT Nop h f a -> HeftiaFinalTN h f a
|
|
||||||
nakeHeftiaFinalT m = HeftiaFinalTN (`runHeftiaFinalT` m)
|
|
||||||
{-# INLINE nakeHeftiaFinalT #-}
|
|
||||||
|
|
||||||
wearHeftiaFinalTF :: Freer c fr => HeftiaFinalTN (fr :+: h) f a -> HeftiaFinalT c h f a
|
|
||||||
wearHeftiaFinalTF (HeftiaFinalTN f) =
|
|
||||||
heftiaFinalT \i -> f $ FinalTElaborator (elaborateFinalTLower i) \case
|
|
||||||
Inl m -> retract m
|
|
||||||
Inr e -> elaborateFinalT i e
|
|
||||||
|
|
||||||
nakeHeftiaFinalTF :: (Freer c fr, HFunctor h) => HeftiaFinalT c h f a -> HeftiaFinalTN (fr :+: h) f a
|
|
||||||
nakeHeftiaFinalTF m =
|
|
||||||
HeftiaFinalTN \i ->
|
|
||||||
elaborateFinalT i . Inl . (`runHeftiaFinalT` m) $
|
|
||||||
FinalTElaborator
|
|
||||||
(liftIns . elaborateFinalTLower i)
|
|
||||||
(liftIns . elaborateFinalT i . Inr . hfmap (elaborateFinalT i . Inl))
|
|
||||||
|
|
||||||
cisHeftiaFinalN :: HeftiaFinalTN h f a -> HeftiaFinalN (h :+: LiftIns f) a
|
|
||||||
cisHeftiaFinalN = nakeHeftiaFinal . unHeftiaFinalT . wearHeftiaFinalT
|
|
||||||
{-# INLINE cisHeftiaFinalN #-}
|
|
||||||
|
|
||||||
transHeftiaFinalN :: HeftiaFinalN (h :+: LiftIns f) a -> HeftiaFinalTN h f a
|
|
||||||
transHeftiaFinalN = nakeHeftiaFinalT . HeftiaFinalT . wearHeftiaFinal
|
|
||||||
{-# INLINE transHeftiaFinalN #-}
|
|
||||||
Loading…
Reference in New Issue
Block a user