I created a monad in Haskell that lets you sample without replacement from user-defined urns, and then at the end gives you a list of all possible outcomes. It looks like it's similar to the list monad (except that one only ever samples with replacement), and to the ST monad. Here's the interface I want to present:
data Draw s a
data Urn s a
instance MonadPlus (Draw s)
newUrn :: [a] -> Draw s (Urn s a)
drawFrom :: Urn s a -> Draw s a
drawList :: [a] -> Draw s a -- so that you can still sample with replacement, like in the list monad
runDraw :: (forall s. Draw s a) -> [a]
Here's an example of how I want to use it:
runDraw $ do
l <- newUrn [1,2,3,3]
x <- drawFrom l
y <- drawFrom l
return (x, y)
-- produces [(1,2),(1,3),(1,3),(2,1),(2,3),(2,3),(3,1),(3,2),(3,3),(3,1),(3,2),(3,3)]
And here's what I came up with to implement that:
{-# LANGUAGE MagicHash, RankNTypes, RoleAnnotations #-}
module Draw (Draw, Urn, newUrn, drawFrom, drawList, runDraw) where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus, ap, liftM)
import Data.List (genericSplitAt)
import GHC.Exts (Any, unsafeCoerce#)
import Numeric.Natural (Natural)
newtype Draw s a = Draw { unDraw :: (Natural, [Any]) -> [(a, (Natural, [Any]))] }
type role Draw nominal representational
newtype Urn s a = Urn Natural
type role Urn nominal representational
instance Functor (Draw s) where
fmap = liftM
instance Applicative (Draw s) where
pure = drawList . pure
(<*>) = ap
instance Alternative (Draw s) where
empty = drawList empty
Draw m1 <|> Draw m2 = Draw $ \s -> m1 s <|> m2 s
instance Monad (Draw s) where
Draw m >>= f = Draw $ \s -> m s >>= uncurry (unDraw . f)
instance MonadPlus (Draw s)
drawList :: [a] -> Draw s a
drawList xs = Draw $ \s -> flip (,) s <$> xs
runDraw :: (forall s. Draw s a) -> [a]
runDraw (Draw f) = map fst (f (0, []))
newUrn :: [a] -> Draw s (Urn s a)
newUrn xs = Draw $ \(n, us) -> pure (Urn n, (n + 1, us ++ [toAny xs]))
drawFrom :: Urn s a -> Draw s a
drawFrom (Urn i) = Draw go where
go :: (Natural, [Any]) -> [(a, (Natural, [Any]))]
go (n, us) = map (\(x, remainingContents) -> (x, (n, before ++ toAny remainingContents : after))) (removeEach (fromAny urnContents)) where
(before, urnContents:after) = genericSplitAt i us
fromAny :: Any -> [a]
fromAny = unsafeCoerce#
toAny :: [a] -> Any
toAny = unsafeCoerce#
removeEach :: [a] -> [(a, [a])]
removeEach [] = []
removeEach (x:xs) = (x, xs):map (fmap (x:)) (removeEach xs)
This seems to work, at least with the example I posted above.
Here's my concerns:
- I'm doing a lot of
unsafeCoerce#
, which is obviously not very safe (before, urnContents:after) = genericSplitAt i us
is an incomplete pattern match, which may be able to fail at runtime- I'm building the list of urns with
xs ++ [x]
, which is quadratically slow I'm not confident that this satisfies all of the typeclass laws, in particular the monad law of associativityI now realize that my type is isomorphic toStateT (Natural, [Any]) []
, with equivalent instances, so I'm no longer concerned about this.- I'm not sure if the way I'm handling the urns is correct, or if it's somehow possible to use an urn where it doesn't belong and thus break type safety
STRef
but forStateT s []
. However, this review question is still relevant, since the monstrosity I built to do that is the core of this. \$\endgroup\$