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:
|
||||
Control.Freer
|
||||
Control.Freer.Trans
|
||||
Control.Freer.Trans.Final
|
||||
Control.Heftia
|
||||
Control.Heftia.Final
|
||||
Control.Heftia.Final.Naked
|
||||
Control.Heftia.Trans
|
||||
Control.Heftia.Trans.Final
|
||||
Control.Heftia.Trans.Final.Naked
|
||||
Control.Monad.Trans.Freer
|
||||
Control.Monad.Trans.Freer.Tree
|
||||
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