Lifter.hs

{-# LANGUAGE IncoherentInstances, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeOperators, GeneralizedNewtypeDeriving, FunctionalDependencies, UndecidableInstances #-}

module Control.Monad.Lifter where

import Control.Monad.Plus
import Control.Monad.Trans
import Control.Monad.ST
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Applicative
import Control.Monad.Morph

-- | An automatic lifter. The idea of automatic lifting is due to Dan Piponi.
class Lifter m n where
	lift' :: m t -> n t

instance Lifter (ST RealWorld) IO where
	lift' = stToIO

instance Lifter IO IO where
	lift' = id

instance Lifter (ST s) (ST s) where
	lift' = id

instance Lifter Identity Identity where
	lift' = id

instance (MonadTrans n, Monad x, Lifter m x) => Lifter m (n x) where
	lift' = lift . lift'

instance (Monad x, MFunctor m) => Lifter (m Identity) (m x) where
	lift' = hoist (return . runIdentity)

instance (Lifter m x) => Lifter m (x ::+ n) where
	lift' = inl . lift'

-- | Declared lifts.
newtype Lifted m t = Lifted { runLifted :: m t } deriving (Monad, Applicative, Functor)

instance MFunctor Lifted where
	hoist f (Lifted m) = Lifted (f m)

class Convert m n | m -> n where
	convert :: m t -> Lifted n t

instance Convert (Lifted m) m where
	convert = id

instance (Lifter IO n) => Convert IO n where
	convert = Lifted . lift'

instance (Lifter (ST s) n) => Convert (ST s) n where
	convert = Lifted . lift'

instance (Lifter (ReaderT r m) n) => Convert (ReaderT r m) n where
	convert = Lifted . lift'

infixl 1 >-=
infixl 1 >-

-- Explicitly declared lifts are needed here, so I can declare a special-case lift for
-- Lifted. Lifted and its special case are needed so that I know how to unify types
-- through nested uses of >-=.
--
-- | Auto-lifting versions of monadic bind.
m >-= f = convert m >>= convert . f

m >- m2 = convert m >> convert m2