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)
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
data FWTDefaultFunctor = FWTDefaultFunctor
instance TypeCast r FWTDefaultFunctor => FWFunctor (FWT t f) r
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)
data FWTDefaultApplicative = FWTDefaultApplicative
instance TypeCast r FWTDefaultApplicative => FWApplicative (FWT t f) r
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)
data FWTDefaultMonad = FWTDefaultMonad
data FWTDefaultMonadAll = FWTDefaultMonadAll
instance TypeCast r FWTDefaultMonad => FWMonad (FWT t m) r
instance FWMonad (FWT (FWTDefaultMonad :*: s) m) FWTDefaultMonad
instance FWMonad (FWT (FWTDefaultMonadAll :*: s) m) FWTDefaultMonad
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)
data FWTDefaultMonadState = FWTDefaultMonadState
instance TypeCast r FWTDefaultMonadState => FWMonadState (FWT t m) r
instance FWMonadState (FWT (FWTDefaultMonadState :*: s) m) FWTDefaultMonadState
instance FWMonadState (FWT (FWTDefaultMonadAll :*: s) m) FWTDefaultMonadState
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. (
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
instance TypeCast r FWDefaultMonadTrans => FWMonadTrans (FWT t) r
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)
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)