module Data.Flex.FlipT where
import Control.Monad (MonadPlus(..))
import Data.Type.Apply (Apply(..))
import Data.Type.TList ((:*:))
import Data.Flex.Monad (
FWMonad, FWReturn, WrapReturn, wrapReturn, FWBind, WrapBind, wrapBind
)
import Data.Flex.MonadPlus (FWMonadPlus,
FWMZero, WrapMZero(..), FWMPlus, WrapMPlus(..)
)
import Data.Flex.WrapCTC (FWCTC, inFlexiWrapCTC)
import Data.Flex.Utils (bindWrapper, inCompose)
newtype FlipT (*.) (f :: * -> *) (g :: * -> *) a =
FlipT {unFlipT :: (g *. f) a}
inFlipT :: ((g *. f) a -> (g' ?. f') a') ->
(FlipT (*.) f g a -> FlipT (?.) f' g' a')
inFlipT = inCompose unFlipT FlipT
inFlipT2 :: ((g *. f) a -> (g' ?. f') a' -> (g'' @. f'') a'') ->
(FlipT (*.) f g a -> FlipT (?.) f' g' a' -> FlipT (@.) f'' g'' a'')
inFlipT2 = inCompose unFlipT inFlipT
data FWFlipDefaults = FWFlipDefaults
data FWFlipMonad = FWFlipMonad
instance FWMonad (FWCTC (FWFlipMonad :*: s) (FlipT o) f g) FWFlipMonad
instance FWMonad (FWCTC (FWFlipDefaults :*: s) (FlipT o) f g) FWFlipMonad
instance Monad (FWCTC t o g f) =>
Apply (FWReturn t (FlipT o f g)) FWFlipMonad
(WrapReturn (FWCTC t (FlipT o) f g))
where
apply _ _ = wrapReturn (inFlexiWrapCTC FlipT . return)
instance Monad (FWCTC t o g f) =>
Apply (FWBind t (FlipT o f g)) FWFlipMonad
(WrapBind (FWCTC t (FlipT o) f g))
where
apply _ _ = wrapBind (
bindWrapper (inFlexiWrapCTC unFlipT) (inFlexiWrapCTC FlipT) (>>=)
)
data FWFlipMonadPlus = FWFlipMonadPlus
instance FWMonadPlus (FWCTC (FWFlipMonadPlus :*: s) (FlipT o) f g)
FWFlipMonadPlus
instance FWMonadPlus (FWCTC (FWFlipDefaults :*: s) (FlipT o) f g)
FWFlipMonadPlus
instance MonadPlus (FWCTC t o g f) =>
Apply (FWMZero t (FlipT o f g)) FWFlipMonadPlus
(WrapMZero (FWCTC t (FlipT o) f g))
where
apply _ _ = WrapMZero (inFlexiWrapCTC FlipT mzero)
instance MonadPlus (FWCTC t o g f) =>
Apply (FWMPlus t (FlipT o f g)) FWFlipMonadPlus
(WrapMPlus (FWCTC t (FlipT o) f g))
where
apply _ _ = WrapMPlus
(inCompose2R (inFlexiWrapCTC unFlipT) (inFlexiWrapCTC FlipT) mplus)
where
inCompose2R :: (forall a. p a -> q a) -> (q d -> e) ->
(q b -> q c -> q d) ->
(p b -> p c -> e)
inCompose2R down up = inCompose down $ inCompose down up