module Data.Equivalence.Monad
(
MonadEquiv(..),
EquivT(..),
EquivT',
EquivM,
EquivM',
runEquivT,
runEquivT',
runEquivM,
runEquivM'
) where
import Data.Equivalence.STT hiding (equate, equateAll, equivalent, classDesc, removeClass,
getClass , combine, combineAll, same , desc , remove )
import qualified Data.Equivalence.STT as S
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Trans
import Control.Monad.Identity
import Control.Monad.ST.Trans
newtype EquivT s c v m a = EquivT {unEquivT :: ReaderT (Equiv s c v) (STT s m) a}
type EquivT' s = EquivT s ()
type EquivM s c v = EquivT s c v Identity
type EquivM' s v = EquivM s () v
instance (Monad m) => Monad (EquivT s c v m) where
EquivT m >>= f = EquivT (m >>= (unEquivT . f))
return = EquivT . return
instance MonadTrans (EquivT s c v) where
lift = EquivT . lift . lift
instance (MonadReader r m) => MonadReader r (EquivT s c v m) where
ask = EquivT $ lift ask
local f (EquivT (ReaderT m)) = EquivT $ ReaderT $ (\ r -> local f (m r))
instance (Monoid w, MonadWriter w m) => MonadWriter w (EquivT s c v m) where
tell w = EquivT $ tell w
listen (EquivT m) = EquivT $ listen m
pass (EquivT m) = EquivT $ pass m
instance (MonadState st m) => MonadState st (EquivT s c v m) where
get = EquivT get
put s = EquivT $ put s
instance (MonadError e m) => MonadError e (EquivT s c v m) where
throwError e = lift $ throwError e
catchError (EquivT m) f = EquivT $ catchError m (unEquivT . f)
runEquivT :: (Monad m)
=> (v -> c)
-> (c -> c -> c)
-> (forall s. EquivT s c v m a)
-> m a
runEquivT mk com m = runST $ do
p <- leastEquiv mk com
(`runReaderT` p) $ unEquivT m
runEquivT' :: (Monad m) => (forall s. EquivT' s v m a) -> m a
runEquivT' = runEquivT (const ()) (\_ _-> ())
runEquivM :: (v -> c)
-> (c -> c -> c)
-> (forall s. EquivM s c v a)
-> a
runEquivM sing comb m = runIdentity $ runEquivT sing comb m
runEquivM' :: (forall s. EquivM' s v a) -> a
runEquivM' = runEquivM (const ()) (\_ _ -> ())
class (Monad m, Ord v) => MonadEquiv c v d m | m -> v, m -> c, m -> d where
equivalent :: v -> v -> m Bool
classDesc :: v -> m d
equateAll :: [v] -> m ()
equate :: v -> v -> m ()
equate x y = equateAll [x,y]
removeClass :: v -> m Bool
getClass :: v -> m c
combineAll :: [c] -> m ()
combine :: c -> c -> m c
combine x y = combineAll [x,y] >> return x
(===) :: c -> c -> m Bool
desc :: c -> m d
remove :: c -> m Bool
instance (Monad m, Ord v) => MonadEquiv (Class s d v) v d (EquivT s d v m) where
equivalent x y = EquivT $ do
part <- ask
lift $ S.equivalent part x y
classDesc x = EquivT $ do
part <- ask
lift $ S.classDesc part x
equateAll x = EquivT $ do
part <- ask
lift $ S.equateAll part x
equate x y = EquivT $ do
part <- ask
lift $ S.equate part x y
removeClass x = EquivT $ do
part <- ask
lift $ S.removeClass part x
getClass x = EquivT $ do
part <- ask
lift $ S.getClass part x
combineAll x = EquivT $ do
part <- ask
lift $ S.combineAll part x
combine x y = EquivT $ do
part <- ask
lift $ S.combine part x y
x === y = EquivT $ do
part <- ask
lift $ S.same part x y
desc x = EquivT $ do
part <- ask
lift $ S.desc part x
remove x = EquivT $ do
part <- ask
lift $ S.remove part x
instance (MonadEquiv c v d m, Monoid w) => MonadEquiv c v d (WriterT w m) where
equivalent x y = lift $ equivalent x y
classDesc = lift . classDesc
equateAll x = lift $ equateAll x
equate x y = lift $ equate x y
removeClass x = lift $ removeClass x
getClass x = lift $ getClass x
combineAll x = lift $ combineAll x
combine x y = lift $ combine x y
x === y = lift $ (===) x y
desc x = lift $ desc x
remove x = lift $ remove x
instance (MonadEquiv c v d m, Error e) => MonadEquiv c v d (ErrorT e m) where
equivalent x y = lift $ equivalent x y
classDesc = lift . classDesc
equateAll x = lift $ equateAll x
equate x y = lift $ equate x y
removeClass x = lift $ removeClass x
getClass x = lift $ getClass x
combineAll x = lift $ combineAll x
combine x y = lift $ combine x y
x === y = lift $ (===) x y
desc x = lift $ desc x
remove x = lift $ remove x
instance (MonadEquiv c v d m) => MonadEquiv c v d (StateT s m) where
equivalent x y = lift $ equivalent x y
classDesc = lift . classDesc
equateAll x = lift $ equateAll x
equate x y = lift $ equate x y
removeClass x = lift $ removeClass x
getClass x = lift $ getClass x
combineAll x = lift $ combineAll x
combine x y = lift $ combine x y
x === y = lift $ (===) x y
desc x = lift $ desc x
remove x = lift $ remove x
instance (MonadEquiv c v d m) => MonadEquiv c v d (ReaderT r m) where
equivalent x y = lift $ equivalent x y
classDesc = lift . classDesc
equateAll x = lift $ equateAll x
equate x y = lift $ equate x y
removeClass x = lift $ removeClass x
getClass x = lift $ getClass x
combineAll x = lift $ combineAll x
combine x y = lift $ combine x y
x === y = lift $ (===) x y
desc x = lift $ desc x
remove x = lift $ remove x