module Data.Flex.WrapCTC where
import Control.Monad (MonadPlus(..))
import Control.Monad.Trans (MonadTrans(..))
import Data.Type.Apply (Apply(..))
import Data.Type.Eq (TypeCast)
import Data.Type.TList ((:*:))
import Data.Flex.Functor (FWFunctor, FWFmap, WrapFmap(..))
import Data.Flex.Monad (FWMonad,
FWReturn, WrapReturn, wrapReturn, unwrapReturn,
FWBind, WrapBind(..), wrapBind
)
import Data.Flex.MonadPlus (FWMonadPlus,
FWMZero, WrapMZero(..),
FWMPlus, WrapMPlus(..)
)
import Data.Flex.MonadTrans (
FWMonadTrans,
FWLift, WrapLift(..)
)
import Data.Flex.Utils (inCompose, bindWrapper)
newtype FlexiWrapCTC s o (f :: * -> *) (g :: * -> *) a =
FlexiWrapCTC {unFlexiWrapCTC :: o f g a}
type FWCTC = FlexiWrapCTC
flexiWrapCTC :: s -> o f g a -> FWCTC s o f g a
flexiWrapCTC _ = FlexiWrapCTC
inFlexiWrapCTC :: (o f g a -> o' f' g' a') ->
(FWCTC s o f g a -> FWCTC s o' f' g' a')
inFlexiWrapCTC = inCompose unFlexiWrapCTC FlexiWrapCTC
inFlexiWrapCTC2 :: (o f g a -> o' f' g' a' -> o'' f'' g'' a'') ->
(FWCTC s o f g a -> FWCTC s o' f' g' a' -> FWCTC s o'' f'' g'' a'')
inFlexiWrapCTC2 = inCompose unFlexiWrapCTC $
inCompose unFlexiWrapCTC FlexiWrapCTC
data FWCTCDefaultFunctor = FWCTCDefaultFunctor
instance TypeCast r FWCTCDefaultFunctor => FWFunctor (FWCTC t o f g) r
instance FWFunctor (FWCTC s o f g) r => FWFunctor (FWCTC (x :*: s) o f g) r
instance Functor (o f g) =>
Apply (FWFmap t (o f g)) FWCTCDefaultFunctor (WrapFmap (FWCTC t o f g))
where
apply _ _ = WrapFmap (inFlexiWrapCTC . fmap)
instance forall t o f g r. (FWFunctor (FWCTC t o f g) r,
Apply (FWFmap t (o f g)) r (WrapFmap (FWCTC t o f g))
) =>
Functor (FWCTC t o f g)
where
fmap = unwrapFmap $ apply (undefined :: FWFmap t (o f g)) (undefined :: r)
data FWCTCDefaultMonad = FWCTCDefaultMonad
instance TypeCast r FWCTCDefaultMonad => FWMonad (FWCTC t o m n) r
instance FWMonad (FWCTC s o m n) r => FWMonad (FWCTC (x :*: s) o m n) r
instance Monad (o m n) =>
Apply (FWReturn t (o m n)) FWCTCDefaultMonad (WrapReturn (FWCTC t o m n))
where
apply _ _ = wrapReturn (FlexiWrapCTC . return)
instance Monad (o m n) =>
Apply (FWBind t (o m n)) FWCTCDefaultMonad (WrapBind (FWCTC t o m n))
where
apply _ _ = wrapBind (bindWrapper unFlexiWrapCTC FlexiWrapCTC (>>=))
instance forall t o m n r. (
Apply (FWReturn t (o m n)) r (WrapReturn (FWCTC t o m n)),
Apply (FWBind t (o m n)) r (WrapBind (FWCTC t o m n)),
FWMonad (FWCTC t o m n) r
) =>
Monad (FWCTC t o m n) where
return = unwrapReturn $
apply (undefined :: FWReturn t (o m n)) (undefined :: r)
(>>=) = unwrapBind $ apply (undefined :: FWBind t (o m n)) (undefined :: r)
instance FWMonadPlus (FWCTC s o m n) r => FWMonadPlus (FWCTC (t :*: s) o m n) r
instance forall t o m n r. (
Monad (FWCTC t o m n),
FWMonadPlus (FWCTC t o m n) r,
Apply (FWMZero t (o m n)) r (WrapMZero (FWCTC t o m n)),
Apply (FWMPlus t (o m n)) r (WrapMPlus (FWCTC t o m n))
) =>
MonadPlus (FWCTC t o m n)
where
mzero = unwrapMZero $
apply (undefined :: (FWMZero t (o m n))) (undefined :: r)
mplus = unwrapMPlus $
apply (undefined :: (FWMPlus t (o m n))) (undefined :: r)
instance FWMonadTrans (FWCTC s o f) r => FWMonadTrans (FWCTC (x :*: s) o f) r
instance forall s o f r. (
Apply (FWLift (FWCTC s o f)) r (WrapLift (FWCTC s o f)),
FWMonadTrans (FWCTC s o f) r
) => MonadTrans (FWCTC s o f) where
lift = unwrapLift $
apply (undefined :: FWLift (FWCTC s o f)) (undefined :: r)