module Data.Flex.Compose where
import Control.Monad (liftM, liftM2, join, MonadPlus(..))
import Control.Monad.Error (Error)
import Control.Monad.Writer (Writer, tell, runWriter)
import Data.Monoid (Monoid)
import Data.Type.Apply
import Data.Type.TList
import Data.Flex.FlipT (FlipT(..))
import Data.Flex.Monad (
FWMonad, FWReturn, FWBind,
WrapReturn(..), WrapBind(..), wrapReturn, wrapBind
)
import Data.Flex.MonadPlus (FWMonadPlus,
FWMZero, WrapMZero(..),
FWMPlus, WrapMPlus(..)
)
import Data.Flex.MonadTrans (FWMonadTrans, FWLift, WrapLift(..))
import Data.Flex.Utils (inCompose)
import Data.Flex.Wrap (FlexiWrap(..), FW)
import Data.Flex.WrapCTC (FlexiWrapCTC(..), FWCTC, inFlexiWrapCTC2)
newtype (f :. g) a = O {unO :: f (g a)}
type O = (:.)
inO :: (f (g a) -> f' (g' b)) -> ((f :. g) a -> (f' :. g') b)
inO = inCompose unO O
inO2 :: (f (g a) -> f' (g' b) -> f'' (g'' c)) ->
((f :. g) a -> (f' :. g') b -> (f'' :. g'') c)
inO2 = inCompose unO $ inCompose unO O
flexiCompose :: s -> (forall b. b -> f b) -> g a -> FWCTC s O f g a
flexiCompose _ f ga = FlexiWrapCTC . O $ f ga
returnC :: (Monad m, Monad n) => a -> m (n a)
returnC = return . return
liftMC :: (Monad f, Monad g) => (a -> b) -> (f (g a) -> f (g b))
liftMC = liftM . liftM
open :: FWCTC t O m n a -> m (n a)
open = unO . unFlexiWrapCTC
close :: m (n a) -> FWCTC t O m n a
close = FlexiWrapCTC . O
fmapC :: (Monad f, Monad g) =>
(a -> b) -> (FWCTC t O f g a -> FWCTC t O f g b)
fmapC f = close . liftMC f . open
wrapM :: (Monad m, Monad n) =>
(m (n (m (n a))) -> m (n a)) ->
(FWCTC t O m n (FWCTC t O m n a) -> FWCTC t O m n a)
wrapM j = close . j . liftMC open . open
wrapFW :: (Monad m, Monad n) =>
(forall a. (m (n (m (n a))) -> m (n a))) ->
WrapBind (FWCTC t O m n)
wrapFW j = wrapBind ((wrapM j .) . flip fmapC)
class (Monad m, Monad n) => PComposable m n where
prod :: n (m (n a)) -> m (n a)
joinP :: PComposable m n => m (n (m (n a))) -> m (n a)
joinP = join . liftM prod
instance Monad m => PComposable m Maybe where
prod (Just m) = m
prod Nothing = return Nothing
data FWCompP = FWCompP
instance FWMonad (FWCTC (FWCompP :*: s) O m n) FWCompP
instance PComposable m n =>
Apply (FWReturn t (O m n)) FWCompP (WrapReturn (FWCTC t O m n))
where
apply _ _ = wrapReturn (close . returnC)
instance PComposable m n =>
Apply (FWBind t (O m n)) FWCompP (WrapBind (FWCTC t O m n))
where
apply _ _ = wrapFW joinP
class (Monad m, Monad n) => DComposable m n where
dorp :: m (n (m a)) -> m (n a)
joinD :: DComposable m n => m (n (m (n a))) -> m (n a)
joinD = liftM join . dorp
data FWCompD = FWCompD
instance FWMonad (FWCTC (FWCompD :*: s) O m n) FWCompD
instance DComposable m n =>
Apply (FWReturn t (O m n)) FWCompD (WrapReturn (FWCTC t O m n))
where
apply _ _ = wrapReturn (close . returnC)
instance DComposable m n =>
Apply (FWBind t (O m n)) FWCompD (WrapBind (FWCTC t O m n))
where
apply _ _ = wrapFW joinD
instance Monad n => DComposable ((->)r) n where
dorp f r = f r >>= \g -> return (g r)
class (Monad m, Monad n) => SComposable m n where
swap :: n (m a) -> m (n a)
joinS :: SComposable m n => m (n (m (n a))) -> m (n a)
joinS = liftM join . join . liftM swap
data FWCompS = FWCompS
instance FWMonad (FWCTC (FWCompS :*: s) O m n) FWCompS
instance SComposable m n =>
Apply (FWReturn t (O m n)) FWCompS (WrapReturn (FWCTC t O m n))
where
apply _ _ = wrapReturn (close . returnC)
instance SComposable m n =>
Apply (FWBind t (O m n)) FWCompS (WrapBind (FWCTC t O m n))
where
apply _ _ = wrapFW joinS
instance Monad m => SComposable m [] where
swap [] = return []
swap (x:xs) = x >>= \y ->
swap xs >>= \ys ->
return (y:ys)
instance (Monad m, Monoid s) => SComposable m (Writer s) where
swap wm = do
a <- ma
return $ do
tell s
return a
where
(ma, s) = runWriter wm
instance (Monad m, Error e) => SComposable m (Either e) where
swap (Right m) = liftM Right m
swap (Left msg) = return (Left msg)
instance Monad m => SComposable m (FW t) where
swap = liftM FlexiWrap . unFlexiWrap
instance Monad m => SComposable (FW t) m where
swap = FlexiWrap . liftM unFlexiWrap
instance SComposable (FW s) (FW t) where
swap = FlexiWrap . liftM unFlexiWrap
instance Monoid s => SComposable (FW t) (Writer s) where
swap = FlexiWrap . liftM unFlexiWrap
instance SComposable (FW s) [] where
swap = FlexiWrap . liftM unFlexiWrap
instance Error e => SComposable (FW s) (Either e) where
swap = FlexiWrap . liftM unFlexiWrap
data FWCompDefaults = FWCompDefaults
data FWCompTrans = FWCompTrans
instance FWMonadTrans (FWCTC (FWCompTrans :*: s) o f) FWCompTrans
instance FWMonadTrans (FWCTC (FWCompDefaults :*: s) o f) FWCompTrans
instance Monad m =>
Apply (FWLift (FWCTC t O m)) FWCompTrans (WrapLift (FWCTC t O m))
where
apply _ _ = WrapLift (FlexiWrapCTC . O . return)
instance Monad m =>
Apply (FWLift (FWCTC t (FlipT O) m)) FWCompTrans
(WrapLift (FWCTC t (FlipT O) m))
where
apply _ _ = WrapLift (FlexiWrapCTC . FlipT . O . liftM return)
data FWCompMonadPlus = FWCompMonadPlus
data FWCompMonadPlusL = FWCompMonadPlusL
data FWCompMonadPlusR = FWCompMonadPlusR
instance FWMonadPlus (FWCTC (FWCompMonadPlusR :*: s) O m n) FWCompMonadPlusR
instance FWMonadPlus (FWCTC (FWCompMonadPlus :*: s) O m n) FWCompMonadPlusR
instance FWMonadPlus (FWCTC (FWCompDefaults :*: s) O m n) FWCompMonadPlusR
instance (Monad m, MonadPlus n) =>
Apply (FWMZero t (O m n)) FWCompMonadPlusR (WrapMZero (FWCTC t O m n))
where
apply _ _ = WrapMZero (FlexiWrapCTC . O $ return mzero)
instance (Monad m, MonadPlus n) =>
Apply (FWMPlus t (O m n)) FWCompMonadPlusR (WrapMPlus (FWCTC t O m n))
where
apply _ _ = WrapMPlus (inFlexiWrapCTC2 . inO2 $ liftM2 mplus)
instance FWMonadPlus (FWCTC (FWCompMonadPlusL :*: s) O m n) FWCompMonadPlusL
instance MonadPlus m =>
Apply (FWMZero t (O m n)) FWCompMonadPlusL (WrapMZero (FWCTC t O m n))
where
apply _ _ = WrapMZero (FlexiWrapCTC $ O mzero)
instance MonadPlus m =>
Apply (FWMPlus t (O m n)) FWCompMonadPlusL (WrapMPlus (FWCTC t O m n))
where
apply _ _ = WrapMPlus (inFlexiWrapCTC2 $ inO2 mplus)
data FWCompMaybeMonadPlus = FWCompMaybeMonadPlus
instance FWMonadPlus (FWCTC (FWCompMaybeMonadPlus :*: s) O m n)
FWCompMaybeMonadPlus
instance Monad m =>
Apply (FWMZero t (O m Maybe)) FWCompMaybeMonadPlus
(WrapMZero (FWCTC t O m Maybe))
where
apply _ _ = WrapMZero (FlexiWrapCTC . O $ return Nothing)
instance Monad m =>
Apply (FWMPlus t (O m Maybe)) FWCompMaybeMonadPlus
(WrapMPlus (FWCTC t O m Maybe))
where
apply _ _ = WrapMPlus (inFlexiWrapCTC2 . inO2 $ liftM2 mplus)