{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
-- .$Header: c:/Source/Haskell/Wrapper/Data/RCS/Wrap.hs,v 1.1 2010/03/12 23:41:16 dosuser Exp dosuser $
module Data.Wrap (
    Wrapper(..),
    circumpose,
    inCompose, inCompose2,
    inWrapping, inWrapping2,
    traverseWrapping, foldWrapping, foldWrapper,
    inWrapper, inWrapper2,
    asWrapped, asWrapped2,
    Wrap(..),
    InnerWrapT(..), OuterWrapT(..),
    inInnerWrapT, inInnerWrapT2,
    inOuterWrapT, inOuterWrapT2,
    fromInnerWrapT, mFromInnerWrapT, fromOuterWrapT,
    toInnerWrapT, mToInnerWrapT, toOuterWrapT,
    asInnerWrapT, mAsInnerWrapT, asOuterWrapT,
    asInnerWrapT2, mAsInnerWrapT2, asOuterWrapT2,
    -- traverseInnerWrapT, traverseOuterWrapT
    -- traverseWrapT
    traverseWrapper, sequenceWrapper,
    bindWrapper, contWrapper, catchWrapper, fixWrapper,
    readerWrapper, writerWrapper,
    result, argument
) where

import Control.Applicative (Applicative(..), Alternative(..), (<$>))
-- (<$>), liftA2, Alternative(..))
import Control.Compose (Cofunctor(..))
import Control.Monad (MonadPlus(..), liftM)
import Control.Monad.Cont (MonadCont(..))
import Control.Monad.Error (MonadError(..))
import Control.Monad.Fix (MonadFix(..))
import Control.Monad.Reader (MonadReader(..))
import Control.Monad.State(MonadState(..))
import Control.Monad.Trans (MonadTrans(..), MonadIO(..))
import Control.Monad.Writer (MonadWriter(..))
-- lift, 

import Data.Foldable as F (Foldable(..))
-- import Data.Generics (Data, Typeable2(..), mkTyCon, mkTyConApp)
import Data.Monoid (Monoid(..))
import qualified Data.Traversable as T (Traversable(..))

import Test.QuickCheck (Arbitrary(..))

class Wrapper f where
    wrap :: a -> f a
    unwrap :: f a -> a

circumpose :: (c -> d) -> (a -> b) -> (b -> c) -> (a -> d)
circumpose left right = (left .) . (. right)

-- inCompose :: (f b -> b) -> (c -> d) -> (b -> c) -> (f b -> d)
inCompose :: (a -> b) -> (c -> d) -> (b -> c) -> (a -> d)
-- inCompose unwrap wrap = (wrap .) . (. unwrap)
inCompose = flip circumpose

-- inCompose2 :: (a -> b) -> (c -> d) -> (b -> b -> c) -> (a -> a -> d)
inCompose2 :: (forall a. f a -> a) -> (d -> e) ->
    (b -> c -> d) -> (f b -> f c -> e)
inCompose2 unwrap wrap = inCompose unwrap $ inCompose unwrap wrap
-- inCompose2 unwrap wrap = (inCompose unwrap wrap .) . (. unwrap)

inWrapping :: (f a -> a) -> (b -> c) -> (a -> b) -> f a -> c
-- inWrapping unwrap wrap = circumpose wrap unwrap
-- inWrapping = flip circumpose
inWrapping = inCompose

inWrapping2 :: (forall a. f a -> a) -> (d -> e) ->
    (b -> c -> d) -> (f b -> f c -> e)
inWrapping2 unwrap wrap = inWrapping unwrap $ inWrapping unwrap wrap

{-
traverseWrapping :: Functor g => (f a -> a) -> (b -> c) -> (a -> g b) ->
    (f a -> g c)
-}
traverseWrapping :: Functor f => (a -> b) -> (c -> d) ->
    (b -> f c) -> (a -> f d)
traverseWrapping unwrap wrap = inCompose unwrap $ fmap wrap

inWrapper :: Wrapper f => (a -> b) -> f a -> f b
inWrapper = inWrapping unwrap wrap
-- inWrapper = (wrap .) . (. unwrap)

inWrapper2 :: Wrapper f => (a -> b -> c) -> f a -> f b -> f c
inWrapper2 = inWrapping2 unwrap wrap

asWrapped :: (Wrap f a -> Wrap f b) -> (f a -> f b)
asWrapped = inCompose Wrapped unWrapped

asWrapped2 :: (Wrap f a -> Wrap f b -> Wrap f c) -> (f a -> f b -> f c)
asWrapped2 = inCompose Wrapped asWrapped

{-
asWrapped :: Wrapper f => (f a -> f b) -> (a -> b)
asWrapped = inCompose wrap unwrap

asWrapped2 :: Wrapper f => (f a -> f b -> f c) -> (a -> b -> c)
asWrapped2 = inCompose wrap asWrapped
-}

newtype Wrap f a = Wrapped {unWrapped :: f a}
    deriving (Eq, Ord, Monoid)
    -- , Show, Read)
    -- Functor, Applicative, Monad
    -- Foldable, Traversable
    -- Monoid
    -- Arbitrary
    -- Data, Typeable
    -- CoMonad
    -- but NOT
    -- Cofunctor
    -- Alternative, MonadPlus
    -- MonadTrans, MonadState, MonadIO, ...

app_prec = 10

instance Show (f a) => Show (Wrap f a) where
    showsPrec d (Wrapped w) = showParen (d > app_prec) $
        showString "Wrapped " . showsPrec (app_prec+1) w

instance Read (f a) => Read (Wrap f a) where
    readsPrec d r = readParen
        (d > app_prec)
        (\r -> [(Wrapped m, t) |
            ("Wrapped", s) <- lex r,
            (m, t) <- readsPrec (app_prec+1) s
        ])
        r

instance Wrapper f => Wrapper (Wrap f) where
    wrap = Wrapped . wrap
    unwrap = unwrap . unWrapped

instance Wrapper f => Functor (Wrap f) where
    fmap = inWrapper

instance Wrapper f => Applicative (Wrap f) where
    pure = wrap
    (<*>) = inWrapper . unwrap

instance Wrapper f => F.Foldable (Wrap f) where
    foldr f z = flip f z . unwrap

instance Wrapper f => T.Traversable (Wrap f) where
    traverse = traverseWrapping unwrap wrap
    -- traverse = inWrapping unwrap $ fmap wrap
    -- traverse = (fmap wrap .) . (. unwrap)
    sequenceA = fmap wrap . unwrap

instance Wrapper f => Monad (Wrap f) where
    return = wrap
    (>>=) = flip (. unwrap)

instance (Wrapper f, Arbitrary a) => Arbitrary (Wrap f a) where
    arbitrary = wrap <$> arbitrary
    coarbitrary = coarbitrary . unwrap

-- Utility function to construct (>>=) for a target monad <t> from the (>>=)
-- for an implementation monad <i>
-- Parameters:
--   wrap:   function from target monad to implementation monad (t a -> i a)
--   unwrap: vice versa (i a -> t a)
bindWrapper :: (forall a. f a -> g a) -> (d -> e) -> (g a -> (c -> g b) -> d) ->
    f a -> (c -> f b) -> e
bindWrapper wrap unwrap = inCompose wrap $ inCompose (result wrap) unwrap

newtype InnerWrapT f g a = InnerWrapT {runInnerWrapT :: g (Wrap f a)}
    deriving (Eq, Ord, Monoid)
    -- , Show, Read)
    -- deriving (Functor, Applicative, Monad, MonadTrans)
    -- Alternative, MonadPlus
    -- MonadState, MonadIO, ...
    -- Foldable, Traversable
    -- Cofunctor
    -- Monoid
    -- Arbitrary
    -- Data, Typeable
    -- CoMonad

newtype OuterWrapT f g a = OuterWrapT {runOuterWrapT :: Wrap f (g a)}
    deriving (Eq, Ord, Monoid)
    -- , Show, Read)
    -- deriving (Functor, Applicative, Foldable, T.Traversable, Monad,
    -- MonadTrans)
    -- Alternative, MonadPlus
    -- MonadState, MonadIO, ...
    -- Cofunctor, CoMonad
    -- Monoid
    -- Arbitrary
    -- Data, Typeable

inInnerWrapT :: (g (Wrap f a) -> g (Wrap f b)) ->
    InnerWrapT f g a -> InnerWrapT f g b
inInnerWrapT = circumpose InnerWrapT runInnerWrapT

inInnerWrapT2 :: (g (Wrap f a) -> g (Wrap f b) -> g (Wrap f c)) ->
    InnerWrapT f g a -> InnerWrapT f g b -> InnerWrapT f g c
inInnerWrapT2 = circumpose inInnerWrapT runInnerWrapT

inOuterWrapT :: (Wrap f (g a) -> Wrap f (g b)) ->
    OuterWrapT f g a -> OuterWrapT f g b
inOuterWrapT = circumpose OuterWrapT runOuterWrapT

inOuterWrapT2 :: (Wrap f (g a) -> Wrap f (g b) -> Wrap f (g c)) ->
    OuterWrapT f g a -> OuterWrapT f g b -> OuterWrapT f g c
inOuterWrapT2 = circumpose inOuterWrapT runOuterWrapT

fromInnerWrapT :: Functor g => InnerWrapT f g a -> g (f a)
fromInnerWrapT = fmap unWrapped . runInnerWrapT

fromOuterWrapT :: OuterWrapT f g a -> f (g a)
fromOuterWrapT = unWrapped . runOuterWrapT

mFromInnerWrapT :: Monad g => InnerWrapT f g a -> g (f a)
mFromInnerWrapT = liftM unWrapped . runInnerWrapT

toInnerWrapT :: Functor g => g (f a) -> InnerWrapT f g a
toInnerWrapT = InnerWrapT . fmap Wrapped

toOuterWrapT :: f (g a) -> OuterWrapT f g a
toOuterWrapT = OuterWrapT . Wrapped

mToInnerWrapT :: Monad g => g (f a) -> InnerWrapT f g a
mToInnerWrapT = InnerWrapT . liftM Wrapped

asInnerWrapT :: Functor g => (InnerWrapT f g a -> InnerWrapT f g b) ->
    g (f a) -> g (f b)
asInnerWrapT = circumpose fromInnerWrapT toInnerWrapT
-- asInnerWrapT = inCompose (InnerWrapT . fmap Wrapped) fromInnerWrapT

asOuterWrapT :: (OuterWrapT f g a -> OuterWrapT f g b) ->
    f (g a) -> f (g b)
asOuterWrapT = circumpose fromOuterWrapT toOuterWrapT

mAsInnerWrapT :: Monad g => (InnerWrapT f g a -> InnerWrapT f g b) ->
    g (f a) -> g (f b)
mAsInnerWrapT = circumpose mFromInnerWrapT mToInnerWrapT
-- mAsInnerWrapT = inCompose (InnerWrapT . liftM Wrapped) mFromInnerWrapT

asInnerWrapT2 :: Functor g =>
    (InnerWrapT f g a -> InnerWrapT f g b -> InnerWrapT f g c) ->
    g (f a) -> g (f b) -> g (f c)
asInnerWrapT2 = circumpose asInnerWrapT toInnerWrapT

asOuterWrapT2 :: (OuterWrapT f g a -> OuterWrapT f g b -> OuterWrapT f g c) ->
    f (g a) -> f (g b) -> f (g c)
asOuterWrapT2 = circumpose asOuterWrapT toOuterWrapT

mAsInnerWrapT2 :: Monad g =>
    (InnerWrapT f g a -> InnerWrapT f g b -> InnerWrapT f g c) ->
    g (f a) -> g (f b) -> g (f c)
mAsInnerWrapT2 = circumpose mAsInnerWrapT mToInnerWrapT

instance Show (g (Wrap f a)) => Show (InnerWrapT f g a) where
    showsPrec d (InnerWrapT w) = showParen (d > app_prec) $
        showString "InnerWrapT " . showsPrec (app_prec+1) w

instance Read (g (Wrap f a)) => Read (InnerWrapT f g a) where
    readsPrec d r = readParen
        (d > app_prec)
        (\r -> [(InnerWrapT m, t) |
            ("InnerWrapT", s) <- lex r,
            (m, t) <- readsPrec (app_prec+1) s
        ])
        r

instance Show (f (g a)) => Show (OuterWrapT f g a) where
    showsPrec d (OuterWrapT w) = showParen (d > app_prec) $
        showString "OuterWrapT " . showsPrec (app_prec+1) w

instance Read (f (g a)) => Read (OuterWrapT f g a) where
    readsPrec d r = readParen
        (d > app_prec)
        (\r -> [(OuterWrapT m, t) |
            ("OuterWrapT", s) <- lex r,
            (m, t) <- readsPrec (app_prec+1) s
        ])
        r

instance (Wrapper f, Functor g) => Functor (InnerWrapT f g) where
    fmap = inInnerWrapT . fmap . inWrapper

instance (Wrapper f, Functor g) => Functor (OuterWrapT f g) where
    fmap = inOuterWrapT . inWrapper . fmap

instance (Wrapper f, Cofunctor g) => Cofunctor (InnerWrapT f g) where
    -- cofmap h = InnerWrapT . cofmap (fmap h) . runInnerWrapT
    -- cofmap h = inInnerWrapT $ cofmap $ fmap h
    cofmap = inInnerWrapT . cofmap . fmap

-- cofmapCF h (O gf) = O (cofmap (fmap h) gf)

instance (Wrapper f, Cofunctor g) => Cofunctor (OuterWrapT f g) where
    cofmap = inOuterWrapT . fmap . cofmap

-- cofmapFC = inO.fmap.cofmap

instance (Wrapper f, Applicative g) => Applicative (InnerWrapT f g) where
    pure = InnerWrapT . pure . wrap
    (<*>) = inInnerWrapT2 $ (<*>) . fmap (<*>)
    -- (<*>) = inInnerWrapT2 $ inCompose2 (fmap unwrap) (fmap wrap) (<*>)
    {-
    (<*>) :: Wrap f (a -> b) -> Wrap f a -> Wrap f b
    fmap (<*>) :: g (Wrap f (a -> b)) -> g (Wrap f a -> Wrap f b)
    (<*>) . fmap (<*>) :: g (Wrap f (a -> b)) -> g (Wrap f a) -> g (Wrap f b)
    -}

instance (Wrapper f, Applicative g) => Applicative (OuterWrapT f g) where
    pure = OuterWrapT . wrap . pure
    (<*>) = inOuterWrapT2 $ (<*>) . fmap (<*>)
    {-
    (<*>) :: g (a -> b) -> g a -> g b
    fmap (<*>) :: Wrap f (g (a -> b)) -> Wrap f (g a -> g b)
    (<*>) . fmap (<*>) :: Wrap f (g (a -> b)) -> Wrap f (g a) -> Wrap f (g b)
    -}

instance (Wrapper f, Alternative g) => Alternative (InnerWrapT f g) where
    empty = InnerWrapT empty
    (<|>) = inInnerWrapT2 (<|>)

instance (Wrapper f, Alternative g) => Alternative (OuterWrapT f g) where
    empty = OuterWrapT $ wrap empty
    (<|>) = inOuterWrapT2 $ inWrapper2 (<|>)

result = (.)
argument = flip (.)

foldWrapping :: (Foldable f, Foldable g) => (a -> b -> b) -> b -> f (g a) -> b
foldWrapping f z = flip F.foldr z . flip $ F.foldr f

foldWrapper :: (Foldable f, Foldable g) => (c -> f (g a)) ->
    (a -> b -> b) -> b -> c -> b
-- foldWrapper = flip flip foldWrapping $ result . result . argument
foldWrapper = flip (result . result . argument) foldWrapping
-- foldWrapper = result . result . argument `flip` foldWrapping

instance (Wrapper f, Foldable g) => Foldable (InnerWrapT f g) where
    foldr = foldWrapper runInnerWrapT
    -- foldr = (result . result . argument) runInnerWrapT foldWrapping
    -- foldr f z = foldWrapping f z . runInnerWrapT
    -- foldr f z = F.foldr (flip $ F.foldr f) z . runInnerWrapT

instance (Wrapper f, Foldable g) => Foldable (OuterWrapT f g) where
    foldr = foldWrapper runOuterWrapT
    -- foldr = (result . result . argument) runOuterWrapT foldWrapping
    -- foldr f z = foldWrapping f z . runOuterWrapT
    -- foldr f z = F.foldr (flip $ F.foldr f) z . runOuterWrapT

traverseInnerWrapT :: Functor h => (g (Wrap f a) -> h (g' (Wrap f' b))) ->
    InnerWrapT f g a -> h (InnerWrapT f' g' b)
traverseInnerWrapT = traverseWrapping runInnerWrapT InnerWrapT
-- traverseInnerWrapT = (fmap InnerWrapT .) . (. runInnerWrapT)

traverseWrapT :: (T.Traversable t, Applicative f) =>
    ((t a -> f (t b)) -> c) -> (a -> f b) -> c
traverseWrapT wrapper mapper = wrapper $ T.sequenceA . fmap mapper

traverseWrapper :: (T.Traversable t, T.Traversable u, Applicative f) =>
    ((t (u a) -> f (t (u b))) -> c) -> (a -> f b) -> c
traverseWrapper wrapper = traverseWrapT wrapper . T.traverse

sequenceWrapper :: (T.Traversable t, T.Traversable u, Applicative f) =>
    ((t (u (f a)) -> f (t (u a))) -> c) -> c
sequenceWrapper wrapper = traverseWrapT wrapper T.sequenceA

instance (Wrapper f, T.Traversable g) => T.Traversable (InnerWrapT f g) where
    traverse = traverseWrapper traverseInnerWrapT
    -- traverse = traverseWrapT traverseInnerWrapT . T.traverse
    -- traverse f = traverseWrapT traverseInnerWrapT $ T.traverse f
    -- traverse f = traverseInnerWrapT $ T.sequenceA . fmap (T.traverse f)
    {-
    traverse f = fmap InnerWrapT . T.sequenceA .
        fmap (T.traverse f) . runInnerWrapT
    -}
    {-
    InnerWrapT f g a
    -> runInnerWrapT ->
    g (Wrap f a)
    -> fmap (traverse f) ->
    g (h (Wrap f b))
    -> sequenceA ->
    h (g (Wrap f b))
    -> fmap InnerWrapT ->
    h (InnerWrapT f g b)
    -}
    sequenceA = sequenceWrapper traverseInnerWrapT
    -- sequenceA = traverseWrapT traverseInnerWrapT T.sequenceA
    -- sequenceA = traverseInnerWrapT $ T.sequenceA . fmap T.sequenceA
    {-
    sequenceA = fmap InnerWrapT . T.sequenceA .
        fmap T.sequenceA . runInnerWrapT
    -}
    {-
    InnerWrapT f g (h a)
    -> runInnerWrapT ->
    g (Wrap f (h a))
    -> fmap sequenceA ->
    g (h (Wrap f a))
    -> sequenceA ->
    h (g (Wrap f a))
    -> fmap InnerWrapT ->
    h (InnerWrapT f g a)
    -}

traverseOuterWrapT :: Functor h => (Wrap f (g a) -> h (Wrap f' (g' b))) ->
    OuterWrapT f g a -> h (OuterWrapT f' g' b)
traverseOuterWrapT = traverseWrapping runOuterWrapT OuterWrapT
-- traverseOuterWrapT = (fmap OuterWrapT .) . (. runOuterWrapT)

instance (Wrapper f, T.Traversable g) => T.Traversable (OuterWrapT f g) where
    traverse = traverseWrapper traverseOuterWrapT
    {-
    traverse f = fmap OuterWrapT . T.sequenceA .
        fmap (T.traverse f) . runOuterWrapT
    -}
    {-
    OuterWrapT f g a
    -> runOuterWrapT ->
    Wrap f (g a)
    -> fmap (traverse f) ->
    Wrap f (h (g b))
    -> sequenceA ->
    h (Wrap f (g b))
    -> fmap OuterWrapT ->
    h (OuterWrapT f g b)
    -}
    sequenceA = sequenceWrapper traverseOuterWrapT
    {-
    sequenceA = fmap OuterWrapT . T.sequenceA .
        fmap T.sequenceA . runOuterWrapT
    -}
    {-
    OuterWrapT f g (h a)
    -> runOuterWrapT ->
    Wrap f (g (h a))
    -> fmap sequenceA ->
    Wrap f (h (g a))
    -> sequenceA ->
    h (Wrap f (g a))
    -> fmap OuterWrapT ->
    h (OuterWrapT f g a)
    -}

instance (Wrapper f, Monad g) => Monad (InnerWrapT f g) where
    return = InnerWrapT . return . wrap
    a >>= f = InnerWrapT $ runInnerWrapT a >>= runInnerWrapT . f . unwrap

instance (Wrapper f, Monad g) => Monad (OuterWrapT f g) where
    return = OuterWrapT . wrap . return
    a >>= f = OuterWrapT . wrap $
        unwrap (runOuterWrapT a) >>= unwrap . runOuterWrapT . f

instance (Wrapper f, MonadPlus g) => MonadPlus (InnerWrapT f g) where
    mzero = InnerWrapT mzero
    mplus = inInnerWrapT2 mplus

instance (Wrapper f, MonadPlus g) => MonadPlus (OuterWrapT f g) where
    mzero = OuterWrapT $ wrap mzero
    mplus = inOuterWrapT2 $ inWrapper2 mplus

instance Wrapper f => MonadTrans (InnerWrapT f) where
    lift = InnerWrapT . liftM wrap

instance Wrapper f => MonadTrans (OuterWrapT f) where
    lift = OuterWrapT . wrap

instance (Wrapper f, MonadState s g) => MonadState s (InnerWrapT f g) where
    get = lift get
    put = lift . put

instance (Wrapper f, MonadState s g) => MonadState s (OuterWrapT f g) where
    get = lift get
    put = lift . put

instance (Wrapper f, MonadIO g) => MonadIO (InnerWrapT f g) where
    liftIO = lift . liftIO

instance (Wrapper f, MonadIO g) => MonadIO (OuterWrapT f g) where
    liftIO = lift . liftIO

{-
contWrapper :: (b -> d) -> (e -> c) ->
    (((a -> b) -> c) -> b) -> (((a -> d) -> e) -> d)
-}
contWrapper :: (forall b. m b -> n b) -> (n c -> m c) ->
    (((a -> m b) -> m c) -> m d) -> (((a -> n b) -> n c) -> n d)
contWrapper lift unlift = circumpose lift . circumpose unlift $ result lift
{-
contWrapper lift unlift = ((argument $ circumpose unlift (result lift)) .
        result lift
    )
contWrapper lift unlift = ((argument $ inCompose (result lift) unlift) .
        result lift
    )
contWrapper lift unlift = ((argument $
            argument (result lift) . result unlift) .
        result lift
    )
contWrapper lift unlift = ((argument $
            (argument . result) lift . result unlift) .
        result lift
    )
contWrapper lift unlift = ((argument . argument . result) lift .
        (argument . result) unlift .
        result lift
    )
-}

unliftInner :: (Wrapper f, Monad g) => InnerWrapT f g a -> g a
unliftInner = liftM unwrap . runInnerWrapT

innerWrapper :: (Wrapper f, Monad g) => (
        (forall a. g a -> InnerWrapT f g a) ->
        (InnerWrapT f g a -> g a) ->
        b
    ) -> b
innerWrapper w = w lift unliftInner

instance (Wrapper f, MonadCont g) => MonadCont (InnerWrapT f g) where
    callCC = innerWrapper contWrapper callCC
    -- callCC = contWrapper lift unliftInner callCC
    -- callCC = contWrapper lift (liftM unwrap . runInnerWrapT) callCC
    {-
    callCC = ((argument . argument . result) lift .
            (argument . result) (liftM unwrap . runInnerWrapT) .
            result lift
        ) callCC
    -}

unliftOuter :: Wrapper f => OuterWrapT f g a -> g a
unliftOuter = unwrap . runOuterWrapT

outerWrapper :: (Wrapper f, Monad g) => (
        (forall a. g a -> OuterWrapT f g a) ->
        (OuterWrapT f g a -> g a) ->
        b
    ) -> b
outerWrapper w = w lift unliftOuter

instance (Wrapper f, MonadCont g) => MonadCont (OuterWrapT f g) where
    callCC = outerWrapper contWrapper callCC
    -- callCC = contWrapper lift unliftOuter callCC
    -- callCC = contWrapper lift (unwrap . runOuterWrapT) callCC
    {-
    callCC = ((argument . argument . result) lift .
            (argument . result) (unwrap . runOuterWrapT) .
            result lift
        ) callCC
    -}

{-
catchWrapper :: (m a -> n a) -> (n a -> m a) ->
    (m a -> (e -> m a) -> m a) -> (n a -> (e -> n a) -> n a)
-}
catchWrapper :: (a -> b) -> (b -> a) ->
    (a -> (e -> a) -> a) -> (b -> (e -> b) -> b)
catchWrapper lift unlift = inCompose unlift . circumpose lift $ result unlift

instance (Wrapper f, MonadError e g) => MonadError e (InnerWrapT f g) where
    throwError = lift . throwError
    catchError = innerWrapper catchWrapper catchError
    -- catchError = catchWrapper lift unliftInner catchError
    {-
    catchError = (inCompose unliftInner . circumpose lift $ result unliftInner)
        catchError
    -}

instance (Wrapper f, MonadError e g) => MonadError e (OuterWrapT f g) where
    throwError = lift . throwError
    catchError = outerWrapper catchWrapper catchError
    -- catchError = catchWrapper lift unliftOuter catchError
    {-
    catchError = (inCompose unliftOuter . circumpose lift $ result unliftOuter)
        catchError
    -}

fixWrapper :: (m a -> n a) -> (n a -> m a) ->
    ((a -> m a) -> m a) -> ((a -> n a) -> n a)
fixWrapper lift unlift = circumpose lift $ result unlift

instance (Wrapper f, MonadFix g) => MonadFix (InnerWrapT f g) where
    mfix = innerWrapper fixWrapper mfix
    -- mfix = fixWrapper lift unliftInner mfix

instance (Wrapper f, MonadFix g) => MonadFix (OuterWrapT f g) where
    mfix = outerWrapper fixWrapper mfix
    -- mfix = fixWrapper lift unliftOuter mfix

readerWrapper :: (m a -> n a) -> (n a -> m a) ->
    ((r -> r) -> m a -> m a) -> ((r -> r) -> n a -> n a)
readerWrapper lift unlift = result $ inCompose unlift lift

instance (Wrapper f, MonadReader r g) => MonadReader r (InnerWrapT f g) where
    ask = lift ask
    local = innerWrapper readerWrapper local

instance (Wrapper f, MonadReader r g) => MonadReader r (OuterWrapT f g) where
    ask = lift ask
    local = outerWrapper readerWrapper local

writerWrapper :: (m b -> n b) -> (n a -> m a) ->
    (m a -> m b) -> (n a -> n b)
writerWrapper = circumpose

instance (Wrapper f, MonadWriter w g) => MonadWriter w (InnerWrapT f g) where
    tell = lift . tell
    listen = innerWrapper writerWrapper listen
    pass = innerWrapper writerWrapper pass

instance (Wrapper f, MonadWriter w g) => MonadWriter w (OuterWrapT f g) where
    tell = lift . tell
    listen = outerWrapper writerWrapper listen
    pass = outerWrapper writerWrapper pass

instance (Wrapper f, Functor g, Arbitrary (g a)) =>
        Arbitrary (InnerWrapT f g a) where
    arbitrary = InnerWrapT . fmap wrap <$> arbitrary
    coarbitrary = coarbitrary . fmap unwrap . runInnerWrapT

instance (Wrapper f, Arbitrary (g a)) => Arbitrary (OuterWrapT f g a) where
    arbitrary = OuterWrapT . wrap <$> arbitrary
    coarbitrary = coarbitrary . unwrap . runOuterWrapT

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