Constrained Monads

Monad-constrained.hs

{-# LANGUAGE ConstraintKinds, TypeFamilies #-}
{-# LANGUAGE RebindableSyntax #-}
-- {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}

import Data.Set (Set, unions, toList, singleton)
import qualified Data.Set as S
import GHC.Prim

import qualified Prelude as P

import Data.Vector.Unboxed as U


class Monadic m where
    type MBind m a b :: Constraint
    type MBind m a b = ()

    type MRet m a :: Constraint
    type MRet m a = ()

    return :: MRet m a  => a -> m a
    (>>=)  :: MBind m a b => m a -> (a -> m b) -> m b
    fail   :: MRet m a  => P.String -> m a

-- instance Monad m => Monadic m where
--  return' = return
--  (>>==) = (>>=)

instance Monadic Set where
    
    type MBind Set a b = (P.Ord b)
    type MRet Set a = ()

    return x = S.singleton x
    s >>= f  = S.foldl S.union S.empty (S.map f s)
    fail s   = S.empty


instance Monadic U.Vector where
    type MBind U.Vector a b = (U.Unbox a, U.Unbox b)
    type MRet U.Vector a = (U.Unbox a)
    
    return x = U.singleton x
    v >>= f  = U.concatMap f v
    fail s   = U.empty

-- instance P.Monad m => Monadic m where
--     (>>=) = (P.>>=)
--     return = P.return

-- instance Monadic [] where
--     return = (:[])
--     m >>= f = P.concatMap f m
--     fail _ = []

-- instance Monadic P.Maybe where
--     return = P.Just
--     P.Nothing >>= _ = P.Nothing
--     (P.Just a) >>= f = f a
--     fail _ = P.Nothing

fromInteger = P.fromInteger


foo :: Set P.String
foo = do
    n <- S.fromList [1..100 :: P.Int]
    m <- S.fromList [2, 4 .. 200 :: P.Int]
    return (P.show (n,m))

bar :: U.Vector P.Int
bar = do
    n <- U.fromList [1..100 :: P.Int]
    m <- U.fromList [2, 4 .. 200 :: P.Int]
    return ((n P.* m) :: P.Int)