set_is_functor.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}

import           GHC.Prim (Constraint)
import qualified Data.Set as S
import qualified Data.Array.Unboxed as UA

--------------------------------------------------------------------------------
-- RFunctor

class RFunctor f where
    type RSubCats f a :: Constraint
    type RSubCats f a = ()
    rfmap :: (RSubCats f a, RSubCats f b) => (a -> b) -> f a -> f b

instance RFunctor [] where
    rfmap = map

instance RFunctor S.Set where
    type RSubCats S.Set a = (Ord a)
    rfmap = S.map

instance UA.Ix i => RFunctor (UA.UArray i) where
    type RSubCats (UA.UArray i) a = UA.IArray UA.UArray a
    rfmap = UA.amap

--------------------------------------------------------------------------------
-- RMonad

class RFunctor m => RMonad m where
    rreturn :: (RSubCats m a) => a -> m a
    rbind :: (RSubCats m a, RSubCats m b) => m a -> (a -> m b) -> m b

instance RMonad S.Set where
    rreturn = S.singleton
    m `rbind` f = S.unions $ map f (S.toList m)


--------------------------------------------------------------------------------
main = do
    print $ rfmap abs (S.fromList [-2, -1, 0, 1, 2])
    print $ (S.fromList [-2 .. 2 :: Int]) `rbind` \x ->
            (S.fromList [-3 .. 3 :: Int]) `rbind` \y ->
            rreturn $ x * y