{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/FlipT.hs,v 1.9 2011/03/05 00:57:29 dosuser Exp dosuser $
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
-- inFlipT2 = inCompose unFlipT $ inCompose unFlipT FlipT

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

-- vim: expandtab:tabstop=4:shiftwidth=4