{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}
-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/WrapCTC.hs,v 1.5 2011/03/05 01:10:38 dosuser Exp dosuser $
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,
        -- FWDefaultMonadTrans,
        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

-- Functor definitions

data FWCTCDefaultFunctor = FWCTCDefaultFunctor

-- default instance
instance TypeCast r FWCTCDefaultFunctor => FWFunctor (FWCTC t o f g) r

-- deferred instance
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)

-- Monad definitions

data FWCTCDefaultMonad = FWCTCDefaultMonad

-- default instance
instance TypeCast r FWCTCDefaultMonad => FWMonad (FWCTC t o m n) r

-- deferred instance
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)

-- --- MonadPlus definitions

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)

-- MonadTrans definitions

{-
-- No default instances -- the kinds below don't work out
-- default instance
instance TypeCast r FWDefaultMonadTrans => FWMonadTrans (FWCTC t o) r

instance Apply (FWLift (FWCTC s o)) FWDefaultMonadTrans (WrapLift (FWCTC s o))
  where
    apply _ _ = WrapLift FlexiWrapCTC
-}

-- deferred instance
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)

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