{-# LANGUAGE TypeFamilies, NoMonomorphismRestriction, NoImplicitPrelude, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__>=700
{-# LANGUAGE RebindableSyntax #-}
#endif

module Control.RMonad.Trans.Set where

import Control.RMonad.Prelude
import Control.RMonad
import Control.RMonad.Trans

import Data.Suitable

import Data.Set (Set)
import qualified Data.Set as Set

newtype SetT m a = SetT { runSetT :: m (Set a) }

data instance Constraints (SetT m) a = (Ord a, Suitable m a, Suitable m (Set a)) => SetTConstraints

instance (Ord a, Suitable m a, Suitable m (Set a)) => Suitable (SetT m) a where
   constraints = SetTConstraints

instance RMonad m => RMonad (SetT m) where
   return a = withResConstraints $ \SetTConstraints -> SetT $ return (Set.singleton a)
   m >>= f = withConstraintsOf m $ \SetTConstraints ->
             withResConstraints $ \SetTConstraints ->
             SetT $ do as <- runSetT m
                       foldr (liftM2 Set.union) (return Set.empty) $ map (runSetT . f) $ Set.elems as

instance RMonad m => RMonadPlus (SetT m) where
   mzero = withResConstraints $ \SetTConstraints -> SetT (return Set.empty)
   mplus (SetT ma) (SetT mb) = withResConstraints $ \SetTConstraints -> SetT $ liftM2 Set.union ma mb

instance RMonadTrans SetT where
   lift ma = withResConstraints $ \SetTConstraints -> SetT $ liftM Set.singleton ma

instance RMonadIO m => RMonadIO (SetT m) where
   liftIO ma = withResConstraints $ \SetTConstraints -> lift $ liftIO ma