SetMonad.hs

{-# LANGUAGE Rank2Types, FunctionalDependencies, FlexibleInstances #-}
import Control.Monad (liftM, ap)
import qualified Data.Set as S

newtype SM a = SM {fromSM :: forall r. SetM a r => r}

class SetM a r | r -> a where
{-Instances of 'SetM' must satisfy the following laws:

* @'fromSet' s = 'fromList' $ 'Data.Set.toList' s@
* @'fromList' l = 'fromSet' $ 'Data.Set.fromList' l@-}
    fromSet :: Ord a => S.Set a -> r
    fromSet s = fromList $ S.toList s
    fromList :: [a] -> r

instance SetM a (SM a) where
    fromSet s = SM $ fromSet s
    fromList l = SM $ fromList l

instance Ord a => SetM a (S.Set a) where
    fromSet = id
    fromList = S.fromList

newtype Shower a = Shower {unShower :: String}

instance (Show a, Ord a) => SetM a (Shower a) where
    fromSet s = Shower $ "fromList " ++ show (S.toList s)
    fromList l = fromSet (S.fromList l)

instance (Show a, Ord a) => Show (SM a) where
    show (SM s) = unShower s

newtype Bind a b = Bind {unBind :: (a -> SM b) -> SM b}

instance SetM a (Bind a b) where
    fromList l = Bind $ \f -> collect $ map f l

newtype Collect a = Collect {withOne :: [a] -> [SM a] -> SM a}

instance SetM a (Collect a) where
    fromList l = Collect $ \l' sms -> collect' (l++l') sms
    fromSet s = Collect $ \l' sms -> fromSet $ s `S.union` (fromSM $ collect' l' sms)

fromOrdList :: (SetM a r, Ord a) => [a] -> r
fromOrdList = fromSet . S.fromList

collect' l [] = fromList l
collect' l (s:ms) = withOne (fromSM s) l ms
collect sms = collect' [] sms --Will use fromSet if any of sms uses fromSet. Otherwise uses fromList.

instance Monad SM where
    a >>= f = unBind (fromSM a) f
    a >> b = a *> b --Will be more efficient when (<$) is implemented.

instance Functor SM where
    fmap = liftM
    --Todo: Implement more efficient (<$) operation (only 'a <$ fromSet s' can be made more efficient).

instance Applicative SM where
    pure a = fromList [a]
    (<*>) = ap