Does a Powerset-over-Reader monad exist?

Question

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?

Answer 1

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 (!)

Answer 2

It is somewhat easier to verify the laws in Kleisli notation.

kleisli' :: (a -> {r -> b}) -> (b -> {r -> c}) -> (a -> {r -> c})
g `kleisli'` f = \z -> {rb | x <- g z, ∀r: ∃rb' ∈ f (x r): rb r == rb' r}

Let's try to verify return `kleisli'` f = f.

(\a -> {\r->a}) `kleisli'` f = 
\z -> {rb | x <- {\r->z}, ∀r: ∃rb' ∈ f (x r): rb r == rb' r} = 
\z -> {rb | ∀r: ∃rb' ∈ f z: rb r == rb' r}

Say all of our types a, b, c and r are Integer and f x = {const x, const -x}. What functions are in (return `kleisli'` f) 5? This set should be f 5, that is, {const 5, const -5}.

Is it? Naturally const 5 and const -5 are both in, but not only. For example, \r->if even r then 5 else -5 is also in.