{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}
-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/WrapT.hs,v 1.10 2011/03/05 01:15:44 dosuser Exp dosuser $
module Data.Flex.WrapT where

import Control.Applicative (Applicative(..))
import Control.Monad.Trans (MonadTrans(..))
import Control.Monad.State (MonadState(..))

import Data.Type.Apply (Apply(..))
import Data.Type.Eq (TypeCast)
import Data.Type.TList ((:*:), TNil)

import Data.Flex.Utils (inCompose, bindWrapper)

import Data.Flex.Applicative (FWApplicative,
        FWPure, WrapPure(..),
        FWCombine, WrapCombine(..)
    )
import Data.Flex.Functor (FWFunctor, FWFmap, WrapFmap(..))
import Data.Flex.MonadTrans (
        FWMonadTrans, FWDefaultMonadTrans, FWLift, WrapLift(..)
    )
import Data.Flex.Monad (FWMonad,
        FWReturn, WrapReturn, wrapReturn, unwrapReturn,
        FWBind, WrapBind(..), wrapBind
    )

import Data.Flex.MonadState (FWMonadState, FWGet, FWPut)
import Data.Flex.Wrap (FWAlreadyWrapped, FWNewWrapper, FWNormAppend)

-- begin FlexiWrapT

newtype FlexiWrapT s f a = FlexiWrapT {unFlexiWrapT :: f a}

type FWT = FlexiWrapT

flexiWrapT :: s -> f a -> FWT s f a
flexiWrapT _ = FlexiWrapT

inFlexiWrapT :: (f a -> g b) -> (FWT s f a -> FWT s g b)
inFlexiWrapT = inCompose unFlexiWrapT FlexiWrapT

inFlexiWrapT2 :: (f a -> g b -> h c) ->
    (FWT s f a -> FWT s g b -> FWT s h c)
inFlexiWrapT2 = inCompose unFlexiWrapT $ inCompose unFlexiWrapT FlexiWrapT

asFlexiWrapT :: (FWT s f a -> FWT s g b) -> (f a -> g b)
asFlexiWrapT = inCompose FlexiWrapT unFlexiWrapT

-- --- Functor definitions

data FWTDefaultFunctor = FWTDefaultFunctor

-- default instance
instance TypeCast r FWTDefaultFunctor => FWFunctor (FWT t f) r

-- deferred instance
instance FWFunctor (FWT s f) r => FWFunctor (FWT (x :*: s) f) r

instance Functor f =>
    Apply (FWFmap t f) FWTDefaultFunctor (WrapFmap (FWT t f))
  where
    apply _ _ = WrapFmap (inFlexiWrapT . fmap)

instance forall t f r. (FWFunctor (FWT t f) r,
            Apply (FWFmap t f) r (WrapFmap (FWT t f))
        ) =>
    Functor (FWT t f)
  where
    fmap = unwrapFmap $ apply (undefined :: FWFmap t f) (undefined :: r)

{-
instance Functor f => Functor (FWT s f) where
    fmap = inFlexiWrapT . fmap
-}

-- --- Applicative definitions

data FWTDefaultApplicative = FWTDefaultApplicative

-- default instance
instance TypeCast r FWTDefaultApplicative => FWApplicative (FWT t f) r

-- deferred instance
instance FWApplicative (FWT s f) r =>
    FWApplicative (FWT (x :*: s) f) r

instance Applicative f =>
    Apply (FWPure t f) FWTDefaultApplicative (WrapPure (FWT t f))
  where
    apply _ _ = WrapPure (FlexiWrapT . pure)

instance Applicative f =>
    Apply (FWCombine t f) FWTDefaultApplicative (WrapCombine (FWT t f))
  where
    apply _ _ = WrapCombine (inFlexiWrapT2 (<*>))

instance forall t f r. (Apply (FWPure t f) r (WrapPure (FWT t f)),
            Apply (FWCombine t f) r (WrapCombine (FWT t f)),
            FWApplicative (FWT t f) r,
            Functor (FWT t f)
        ) =>
        Applicative (FWT t f) where
    pure = unwrapPure $ apply (undefined :: FWPure t f) (undefined :: r)
    (<*>) = unwrapCombine $ apply (undefined :: FWCombine t f) (undefined :: r)

{-
instance Applicative f => Apply FWPure t (WrapPure (FWT t f)) where
    apply _ _ = WrapPure $ FlexiWrapT . pure

instance Applicative f => Apply FWCombine t (WrapCombine (FWT t f)) where
    apply _ _ = WrapCombine $ inFlexiWrapT2 (<*>)

instance (Apply FWPure t (WrapPure f), Apply FWCombine t (WrapCombine f)) =>
        Applicative (FWT t f) where
    pure = unwrapPure $ apply FWPure (undefined :: t)
    (<*>) = unwrapCombine $ apply FWCombine (undefined :: t)
-}


{-
instance FWrap TNil (FWT s f a) (FWT s f a) where
    fWrap _ = id

instance FWrap s (FWT t f a) (FWT u f a) =>
        FWrap (w :*: s) (FWT t f a) (FWT (w :*: u) f a) where
    fWrap _ (FlexiWrapT a) = FlexiWrapT a

instance FWrap w (FWT s f a) (FWT (w :*: s) f a) where
    fWrap _ (FlexiWrapT a) = FlexiWrapT a

instance FWrap TNil (f a) (FWT TNil f a) where
    fWrap _ = FlexiWrapT

instance FWrap s (f a) (FWT t f a) => FWrap (x :*: s) (f a) (FWT (x :*: t) f a) where
    fWrap _ = FlexiWrapT

instance FWrap w (f a) (FWT (w :*: TNil) f a) where
    fWrap _ = FlexiWrapT
-}

-- --- Monad definitions

data FWTDefaultMonad = FWTDefaultMonad

data FWTDefaultMonadAll = FWTDefaultMonadAll

-- default instance
instance TypeCast r FWTDefaultMonad => FWMonad (FWT t m) r

-- explicit instances
instance FWMonad (FWT (FWTDefaultMonad :*: s) m) FWTDefaultMonad
instance FWMonad (FWT (FWTDefaultMonadAll :*: s) m) FWTDefaultMonad

-- deferred instance
instance FWMonad (FWT s m) r => FWMonad (FWT (x :*: s) m) r

instance Monad m =>
    Apply (FWReturn t m) FWTDefaultMonad (WrapReturn (FWT t m))
  where
    apply _ _ = wrapReturn (FlexiWrapT . return)

instance Monad m =>
    Apply (FWBind t m) FWTDefaultMonad (WrapBind (FWT t m))
  where
    apply _ _ = wrapBind (bindWrapper unFlexiWrapT FlexiWrapT (>>=))

instance forall t m r. (Apply (FWReturn t m) r (WrapReturn (FWT t m)),
            Apply (FWBind t m) r (WrapBind (FWT t m)),
            FWMonad (FWT t m) r
        ) =>
        Monad (FWT t m) where
    return = unwrapReturn $
        apply (undefined :: FWReturn t m) (undefined :: r)
    (>>=) = unwrapBind $ apply (undefined :: FWBind t m) (undefined :: r)

-- MonadState

data FWTDefaultMonadState = FWTDefaultMonadState

-- default instance
instance TypeCast r FWTDefaultMonadState => FWMonadState (FWT t m) r

-- explicit instances
instance FWMonadState (FWT (FWTDefaultMonadState :*: s) m) FWTDefaultMonadState
instance FWMonadState (FWT (FWTDefaultMonadAll :*: s) m) FWTDefaultMonadState

-- deferred instance
instance FWMonadState (FWT s m) r => FWMonadState (FWT (x :*: s) m) r

instance MonadState s m =>
    Apply (FWGet t s m) FWTDefaultMonadState (FWT t m s)
  where
    apply _ _ = FlexiWrapT get

instance MonadState s m =>
    Apply (FWPut t s m) FWTDefaultMonadState (s -> FWT t m ())
  where
    apply _ _ = FlexiWrapT . put

class FwtMonadState s m | m -> s where
    fwtGet :: m s
    fwtPut :: s -> m ()

instance forall t s m r. (
            -- Monad (FWT t m),
            MonadState s m,
            Apply (FWGet t s m) r (FWT t m s),
            Apply (FWPut t s m) r (s -> FWT t m ()),
            FWMonadState (FWT t m) r
        ) =>
        FwtMonadState s (FWT t m) where
    fwtGet = apply (undefined :: FWGet t s m) (undefined :: r)
    fwtPut = apply (undefined :: FWPut t s m) (undefined :: r)

instance (Monad (FWT t m), FwtMonadState s (FWT t m)) =>
    MonadState s (FWT t m)
  where
    get = fwtGet
    put = fwtPut

-- MonadTrans

-- default instance
instance TypeCast r FWDefaultMonadTrans => FWMonadTrans (FWT t) r

-- deferred instance
instance FWMonadTrans (FWT s) r => FWMonadTrans (FWT (x :*: s)) r

instance Apply (FWLift (FWT s)) FWDefaultMonadTrans (WrapLift (FWT s)) where
    apply _ _ = WrapLift FlexiWrapT

instance forall s r. (
        Apply (FWLift (FWT s)) r (WrapLift (FWT s)),
        FWMonadTrans (FWT s) r
    ) => MonadTrans (FWT s) where
    lift = unwrapLift $ apply (undefined :: FWLift (FWT s)) (undefined :: r)

-- --- FWrapT

class FWrapT w a b | w a -> b where
    fWrapT :: w -> a -> b

data FWTagT

instance Apply FWTagT (FWT t f a) t
instance TypeCast r TNil => Apply FWTagT a r

class FWCon a (f :: * -> *) | a -> f

instance FWCon (FWT t f a) f
instance TypeCast (r a) (f a) => FWCon (f a) r

class FWIsWrappedT a r | a -> r

instance FWIsWrappedT (FWT s f a) FWAlreadyWrapped
instance TypeCast r FWNewWrapper => FWIsWrappedT a r

data FWFWrapT s (f :: * -> *) a = FWFWrapT

instance Apply (FWFWrapT u f (f a)) FWNewWrapper (f a -> FWT u f a) where
    apply _ _ = FlexiWrapT
instance Apply (FWFWrapT u f (FWT s f a)) FWAlreadyWrapped
            (FWT s f a -> FWT u f a)
  where
    apply _ _ = FlexiWrapT . unFlexiWrapT

instance forall a b f s t u w. (
        Apply FWTagT a t,
        FWCon a f,
        FWNormAppend s t u,
        FWIsWrappedT a w,
        Apply (FWFWrapT u f a) w (a -> FWT u f b)
    ) =>
    FWrapT s a (FWT u f b)
  where
    fWrapT _ = apply (undefined :: FWFWrapT u f a) (undefined :: w)

-- end FlexiWrapT

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