Specializing bind for monads over special typeclasses in Haskell

Question

In the second last chapter For a Few Monads More of the very nice tutorial \"Learn You a Haskell for a Great Good\" the author defines the following monad:

impor         


        

Answer 1

Here another possibility based on Generalized Algebraic Datatypes using a technique by Ganesh Sittampalam:

{-# LANGUAGE GADTs #-}

import Control.Arrow (first, second)
import Data.Ratio
import Data.List (foldl')

-- monads over typeclass Eq
class EqMonad m where
  eqReturn :: Eq a => a -> m a
  eqBind :: (Eq a, Eq b) => m a -> (a -> m b) -> m b
  eqFail :: Eq a => String -> m a
  eqFail = error

data AsMonad m a where
  Embed :: (EqMonad m, Eq a) => m a -> AsMonad m a
  Return :: EqMonad m => a -> AsMonad m a
  Bind :: EqMonad m => AsMonad m a -> (a -> AsMonad m b) -> AsMonad m b

instance EqMonad m => Monad (AsMonad m) where
  return = Return
  (>>=) = Bind
  fail = error

unEmbed :: Eq a => AsMonad m a -> m a
unEmbed (Embed m) = m
unEmbed (Return v) = eqReturn v
unEmbed (Bind (Embed m) f) = m `eqBind` (unEmbed . f)
unEmbed (Bind (Return v) f) = unEmbed (f v)
unEmbed (Bind (Bind m f) g) = unEmbed (Bind m (\x -> Bind (f x) g))

-- the example monad from "Learn you a Haskell for a Great good"
newtype Prob a = Prob { getProb :: [(a, Rational)] }
  deriving Show

instance Functor Prob where
  fmap f (Prob as) = Prob $ map (first f) as

flatten :: Prob (Prob a) -> Prob a
flatten (Prob xs) = Prob $ concat $ map multAll xs
  where multAll (Prob innerxs, p) = map (\(x, r) -> (x, p*r)) innerxs

compress :: Eq a => Prob a -> Prob a
compress (Prob as) = Prob $ foldl' f [] as
  where f [] a = [a]
        f ((b, q):bs) (a, p) | a == b    = (a, p+q):bs
                             | otherwise = (b, q):f bs (a, p)

instance Eq a => Eq (Prob a) where
  (==) (Prob as) (Prob bs) = all (`elem` bs) as

instance EqMonad Prob where
  eqReturn x = Prob [(x, 1%1)]
  m `eqBind` f = compress $ flatten (fmap f m)
  eqFail _ = Prob []

newtype Probability a = Probability { getProbability :: AsMonad Prob a }

instance Monad Probability where
  return = Probability . Return
  a >>= f = Probability $ Bind (getProbability a) (getProbability . f)
  fail = error

instance (Show a, Eq a) => Show (Probability a) where
  show = show . getProb . unEmbed . getProbability

-- Example flipping four coins (now as 0/1)
prob :: Eq a => [(a, Rational)] -> Probability a
prob = Probability . Embed . Prob

coin :: Probability Int
coin = prob [(0, 1%2), (1, 1%2)]

loadedCoin :: Probability Int
loadedCoin = prob [(0, 1%10), (1, 9%10)]

flipFour :: Probability Int
flipFour = do
  a <- coin
  b <- coin
  c <- coin
  d <- loadedCoin
  return (a+b+c+d)