The canonical 'Monad instance' for environment sharing plus nondeterminism is as follows (using pseudo-Haskell, since Haskell's Data.Set isn't, of course, monadic):
eta :: a -> r -> {a} -- '{a}' means the type of a set of a's
eta x = \r -> {x}
bind :: (r -> {a}) -> (a -> r -> {b}) -> r -> {b}
m `bind` f = \r -> {v | x ∈ m r, v ∈ f x r}
Generally, when trying to combine a 'container' monad like Powerset (List, Writer, etc) with a second monad m (here, roughly, Reader), one 'wraps' m around the container monad, as done above.
I wonder, then, about the following potential Powerset-over-Reader specification:
eta' :: a -> {r -> a}
eta' x = {\r -> x}
bind' :: {r -> a} -> (a -> {r -> b}) -> {r -> b}
m `bind'` f = {rb | x <- m, ∀r: ∃rb' ∈ f (x r): rb r == rb' r}
This doesn't seem obviously crazy (I do realize that GHCi can't check rb r == rb' r for many rb and rb'), but bind' is complicated enough to make it difficult (for me) to check whether the monad laws hold.
My question, then, is whether eta' and bind' really are monadic -- and, if not, which of the law(s) is violated, and what sort of unexpected behavior might this correspond to?
A secondary question, assuming that eta' and bind' aren't monadic, is how one might ascertain whether there are functions with these types that are?
Fun question. Here is my take -- let's see if I didn't goof anywhere!
To begin with, I will spell your signatures in (slightly less pseudo) Haskell:
return :: a -> PSet (r -> a)
(>>=) :: PSet (r -> a) -> (a -> PSet (r -> b)) -> PSet (r -> b))
Before continuing, it is worth mentioning two practical complications. Firstly, as you have already observed, thanks to Eq and/or Ord constraints it is non-trivial to give sets Functor or Monad instances; in any case, there are ways around it. Secondly, and more worryingly, with the type you propose for (>>=) it is necessary to extract as from PSet (r -> a) without having any obvious supply of rs -- or, in other words, your (>>=) demands a traversal of the function functor (->) r. That, of course, is not possible in the general case, and tends to be impractical even when possible -- at least as far as Haskell is concerned. In any case, for our speculative purposes it is fine to suppose we can traverse (->) r by applying the function to all possible r values. I will indicate this through a hand-wavy universe :: PSet r set, named in tribute to this package. I will also make use of an universe :: PSet (r -> b), and assume we can tell whether two r -> b functions agree on a certain r even without requiring an Eq constraint. (The pseudo-Haskell is getting quite fake indeed!)
Preliminary remarks made, here are my pseudo-Haskell versions of your methods:
return :: a -> PSet (r -> a)
return x = singleton (const x)
(>>=) :: PSet (r -> a) -> (a -> PSet (r -> b)) -> PSet (r -> b))
m >>= f = unionMap (\x ->
intersectionMap (\r ->
filter (\rb ->
any (\rb' -> rb' r == rb r) (f (x r)))
(universe :: PSet (r -> b)))
(universe :: PSet r)) m
where
unionMap f = unions . map f
intersectionMap f = intersections . map f
Next, the monad laws:
m >>= return = m
return y >>= f = f y
m >>= f >>= g = m >>= \y -> f y >>= g
(By the way, when doing this sort of thing it is good to keep in mind the other presentations of the class we are working with -- in this case, we have join and (>=>) as alternatives to (>>=) -- as switching presentations might make working with your instance of choice more pleasant. Here I will stick with the (>>=) presentation of Monad.)
Onwards to the first law...
m >>= return = m
m >>= return -- LHS
unionMap (\x ->
intersectionMap (\r ->
filter (\rb ->
any (\rb' -> rb' r == rb r) (singleton (const (x r))))
(universe :: PSet (r -> b)))
(universe :: PSet r)) m
unionMap (\x ->
intersectionMap (\r ->
filter (\rb ->
const (x r) r == rb r)
(universe :: PSet (r -> b)))
(universe :: PSet r)) m
unionMap (\x ->
intersectionMap (\r ->
filter (\rb ->
x r == rb r)
(universe :: PSet (r -> b)))
(universe :: PSet r)) m
-- In other words, rb has to agree with x for all r.
unionMap (\x -> singleton x) m
m -- RHS
One down, two to go.
return y >>= f = f y
return y -- LHS
unionMap (\x ->
intersectionMap (\r ->
filter (\rb ->
any (\rb' -> rb' r == rb r) (f (x r)))
(universe :: PSet (r -> b)))
(universe :: PSet r)) (singleton (const y))
(\x ->
intersectionMap (\r ->
filter (\rb ->
any (\rb' -> rb' r == rb r) (f (x r)))
(universe :: PSet (r -> b)))
(universe :: PSet r)) (const y)
intersectionMap (\r ->
filter (\rb ->
any (\rb' -> rb' r == rb r) (f (const y r)))
(universe :: PSet (r -> b)))
(universe :: PSet r)
intersectionMap (\r ->
filter (\rb ->
any (\rb' -> rb' r == rb r) (f y)))
(universe :: PSet (r -> b)))
(universe :: PSet r)
-- This set includes all functions that agree with at least one function
-- from (f y) at each r.
return y >>= f, therefore, might possibly be a much larger set than f y. We have a violation of the second law; therefore, we don't have a monad -- at least not with the instance proposed here.
Appendix: here is an actual, runnable implementation of your functions, which is usable enough at least for playing with small types. It takes advantage of the aforementioned universe package.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module FunSet where
import Data.Universe
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.Int
import Data.Bool
-- FunSet and its would-be monad instance
newtype FunSet r a = FunSet { runFunSet :: Set (Fun r a) }
deriving (Eq, Ord, Show)
fsreturn :: (Finite a, Finite r, Ord r) => a -> FunSet r a
fsreturn x = FunSet (S.singleton (toFun (const x)))
-- Perhaps we should think of a better name for this...
fsbind :: forall r a b.
(Ord r, Finite r, Ord a, Ord b, Finite b, Eq b)
=> FunSet r a -> (a -> FunSet r b) -> FunSet r b
fsbind (FunSet s) f = FunSet $
unionMap (\x ->
intersectionMap (\r ->
S.filter (\rb ->
any (\rb' -> funApply rb' r == funApply rb r)
((runFunSet . f) (funApply x r)))
(universeF' :: Set (Fun r b)))
(universeF' :: Set r)) s
toFunSet :: (Finite r, Finite a, Ord r, Ord a) => [r -> a] -> FunSet r a
toFunSet = FunSet . S.fromList . fmap toFun
-- Materialised functions
newtype Fun r a = Fun { unFun :: Map r a }
deriving (Eq, Ord, Show, Functor)
instance (Finite r, Ord r, Universe a) => Universe (Fun r a) where
universe = fmap (Fun . (\f ->
foldr (\x m ->
M.insert x (f x) m) M.empty universe))
universe
instance (Finite r, Ord r, Finite a) => Finite (Fun r a) where
universeF = universe
funApply :: Ord r => Fun r a -> r -> a
funApply f r = maybe
(error "funApply: Partial functions are not fun")
id (M.lookup r (unFun f))
toFun :: (Finite r, Finite a, Ord r) => (r -> a) -> Fun r a
toFun f = Fun (M.fromList (fmap ((,) <$> id <*> f) universeF))
-- Set utilities
unionMap :: (Ord a, Ord b) => (a -> Set b) -> (Set a -> Set b)
unionMap f = S.foldl S.union S.empty . S.map f
-- Note that this is partial. Since for our immediate purposes the only
-- consequence is that r in FunSet r a cannot be Void, I didn't bother
-- with making it cleaner.
intersectionMap :: (Ord a, Ord b) => (a -> Set b) -> (Set a -> Set b)
intersectionMap f s = case ss of
[] -> error "intersectionMap: Intersection of empty set of sets"
_ -> foldl1 S.intersection ss
where
ss = S.toList (S.map f s)
universeF' :: (Finite a, Ord a) => Set a
universeF' = S.fromList universeF
-- Demo
main :: IO ()
main = do
let andor = toFunSet [uncurry (&&), uncurry (||)]
print andor -- Two truth tables
print $ funApply (toFun (2+)) (3 :: Int8) -- 5
print $ (S.map (flip funApply (7 :: Int8)) . runFunSet)
(fsreturn (Just True)) -- fromList [Just True]
-- First monad law demo
print $ fsbind andor fsreturn == andor -- True
-- Second monad law demo
let twoToFour = [ bool (Left False) (Left True)
, bool (Left False) (Right False)]
decider b = toFunSet
(fmap (. bool (uncurry (&&)) (uncurry (||)) b) twoToFour)
print $ fsbind (fsreturn True) decider == decider True -- False (!)