do-notation works for Fay

Main.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE CPP #-}

module Main where

import Prelude

#ifndef FAY
-- Fake stuff for RebindableSyntax
fromInteger :: Integer -> Int
fromInteger = undefined

fromRational :: a -> Double
fromRational = undefined

ifThenElse True  a _ = a
ifThenElse False _ b = b
fail = undefined
#endif

type FmapType f = forall a b . (a -> b) -> f a -> f b

data Functor' f = Functor' {
  fmap'   :: FmapType f }

type ReturnType m = forall a   . a -> m a
type JoinType m   = forall a   . m (m a) -> m a
type BindType m   = forall a b . m a -> (a -> m b) -> m b
type ShiftType m  = forall a b . m a -> m b -> m b

data Monad' m = Monad' {
  functorOfM :: Functor' m,
  return' :: ReturnType m,
  bind'   :: BindType m,
  join'   :: JoinType m }

-- RankNTypes needs explicit type annotations
withM :: Monad' m -> (ReturnType m -> BindType m -> ShiftType m -> r) -> r
withM (Monad' _ ret' bind' _) f = f ret' bind' (>>)
  where ma >> mb = ma `bind'` const mb

withMF :: Monad' m -> (ReturnType m -> BindType m -> ShiftType m -> FmapType m -> r) -> r
withMF m f =
  case m of
    Monad' functor ret' bind' _ -> withM m $ \r b s -> f r b s (fmap' functor)

liftM' :: Monad' m -> (a -> b) -> m a -> m b
liftM' m f = fmap' (functorOfM m) f

liftM2' :: Monad' m -> (a -> b -> r) -> m a -> m b -> m r
liftM2' m f ma mb = withMF m (\return (>>=) _ fmap ->
  ma >>= \a ->
  mb >>= \b ->
  return (f a b))

sequence' :: Monad' m -> [m a] -> m [a]
sequence' m mas =
  rev $ foldl f initAcc mas
  where f acc ma  = liftM2' m (:) ma acc
        rev       = liftM' m reverse
        initAcc   = return' m []

-- List

listFunctor = Functor' map

listMonad = Monad' {
  functorOfM = listFunctor,
  return' = \a -> [a],
  bind'   = \xs -> concat . flip map xs,
  join'   = concat }

-- Either

mapEither :: (a -> b) -> Either e a -> Either e b
mapEither f e = case e of
  Left e  -> Left e
  Right a -> Right (f a)

eitherFunctor = Functor' mapEither

joinEither :: Either e (Either e a) -> Either e a
joinEither (Left e) = Left e
joinEither (Right r) = r

eitherMonad :: Monad' (Either e)
eitherMonad = Monad' {
  functorOfM = eitherFunctor,
  return' = Right,
  bind'   = \ma f -> joinEither (mapEither f ma),
  join'   = joinEither }

-- transformers

type EitherW m e a = m (Either e a)

returnEitherW :: Monad' m -> ReturnType (EitherW m e)
returnEitherW m = return' m . Right

bindEitherW :: Monad' m -> BindType (EitherW m e)
bindEitherW m = \mea f ->
    bind' m mea (either (const mea) f)

eitherW :: Monad' m -> Monad' (EitherW m e) -- type lambdas missing? nooo.. will need newtyping
eitherW m = Monad' {
  functorOfM = undefined,
  return' = returnEitherW m,
  bind'   = bindEitherW m,
  join'   = joinDefault bindEitherW
}

-- Example

monadic :: Monad' [] -> [Int] -> [Int]
monadic m ma = withMF m (\return (>>=) (>>) fmap ->
  fmap (*2) ma >>= dups >>= dups)
  where dups x = [x, x]

monadic2 :: Monad' m -> m Int -> m Int
monadic2 m ma = withM m (\return (>>=) (>>) -> do
  a <- ma
  b <- ma
  return $ a * b)

main = do
  let xs = monadic listMonad [1,2,3]
  let sm = sum xs
  putStrLn $ show (sm == 48)
  putStrLn $ show (if 1 < 2 then 3.4 else 4.2) -- to test RebindableSyntax
  putStrLn $ show (sum (monadic2 listMonad [1,2,3]) == 36)
  putStrLn $ show $ monadic2 eitherMonad (Right 2)
  putStrLn $ show $ mapEither (sum) $ sequence' eitherMonad [Right 2, Right 3, Left "ouch"]