module Control.RMonad (Suitable(..), RMonad(..), RMonadPlus(..)) where
import Prelude hiding (return, fail, (>>=), (>>))
import qualified Control.Monad as M
import Data.Set (Set)
import qualified Data.Set as Set
class Suitable m a where
data Constraints m a
constraints :: m a -> Constraints m a
class RMonad m where
return :: Suitable m a => a -> m a
(>>=) :: (Suitable m a, Suitable m b) => m a -> (a -> m b) -> m b
(>>) :: (Suitable m a, Suitable m b) => m a -> m b -> m b
m1 >> m2 = m1 >>= \_ -> m2
fail :: Suitable m a => String -> m a
fail = error
class RMonad m => RMonadPlus m where
mzero :: Suitable m a => m a
mplus :: Suitable m a => m a -> m a -> m a
instance Suitable ((->) r) a where
data Constraints ((->) r) a = FuncConstraints
constraints _ = FuncConstraints
instance RMonad ((->) r) where
return = M.return
(>>=) = (M.>>=)
fail = M.fail
instance Suitable Maybe a where
data Constraints Maybe a = MaybeConstraints
constraints _ = MaybeConstraints
instance RMonad Maybe where
return = M.return
(>>=) = (M.>>=)
fail = M.fail
instance RMonadPlus Maybe where
mzero = M.mzero
mplus = M.mplus
instance Suitable [] a where
data Constraints [] a = ListConstraints
constraints _ = ListConstraints
instance RMonad [] where
return = M.return
(>>=) = (M.>>=)
fail = M.fail
instance RMonadPlus [] where
mzero = M.mzero
mplus = M.mplus
instance Suitable IO a where
data Constraints IO a = IOConstraints
constraints _ = IOConstraints
instance RMonad IO where
return = M.return
(>>=) = (M.>>=)
fail = M.fail
instance Ord a => Suitable Set a where
data Constraints Set a = Ord a => SetConstraints
constraints _ = SetConstraints
instance RMonad Set where
return = Set.singleton
s >>= f = let res = case constraints res of
SetConstraints -> Set.fold (\a s' -> Set.union (f a) s') Set.empty s
in res
fail _ = Set.empty
instance RMonadPlus Set where
mzero = Set.empty
mplus s1 s2 = let res = case constraints res of
SetConstraints -> Set.union s1 s2
in res