{-# LANGUAGE TypeFamilies, NoMonomorphismRestriction, MultiParamTypeClasses, FlexibleInstances #-}
-- |This module provides an alternative 'RMonad' and 'RMonadPlus' type class that
-- allows for constraints on the contained type (a restricted monad)
-- It makes use of associated datatypes (available in GHC 6.8).
--
-- To make your own type an instance of 'Monad', first define
-- the 'Suitable' type class for it. For example,
--
--   @
--     instance Ord a => Suitable Set a where
--        data Constraints Set a = Ord a => SetConstraints
--        constraints _ = SetConstraints
--   @
--
-- You need to change @Set@ to your own type, @Ord a@ to your own
-- constraints, and @SetConstraints@ to some distinguished name (this name
-- will not normally be visible to users of your type)
--
-- Next you can make an instance of 'RMonad' and if appropriate 'RMonadPlus'
-- by defining the members in the usual way. When you need to make use of the
-- constraint on the contained type, you will need to get hold of the constraint
-- wrapped up in the 'Constraints' datatype. For example here are the instances
-- for @Set@:
--
--   @
--    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
--   @
--
-- Once you have made your type an instance of 'RMonad', you can
-- use it in two ways.
-- Firstly, import this module directly and use the @NoImplicitPrelude@ extension
-- so that do-syntax is rebound.
-- Secondly, use the wrapper type in "Control.RMonad.AsMonad" which supports
-- the normal 'Monad' operations.
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