Fetch monad with runFetch

fetch.hs

{-# LANGUAGE ApplicativeDo #-}
import Control.Monad

data Fetch a = Done a | Blocked (Fetch a)

instance Functor Fetch where
  fmap = liftM

instance Applicative Fetch where
  pure = Done
 -- (<*>) = ap
  Done a <*> Done b = Done (a b)
  Done a <*> Blocked b = Blocked (a <$> b)
  Blocked a <*> Done b = Blocked (a <*> Done b)
  Blocked a <*> Blocked b = Blocked (a <*> b)

instance Monad Fetch where
  return = pure

  Done a >>= f = f a
  Blocked c >>= f = Blocked (c >>= f)

runFetch :: Fetch a -> IO a
runFetch f = case f of
  Done a -> return a
  Blocked c -> putStrLn "Blocked" >> runFetch c

prog = do --Blocked (Done (+1)) <*> Blocked (Done 1)
  f <- Blocked (Done (+1))
  x <- Blocked (Done 1)
  return $ f x

main = do
  a <- runFetch prog
  print a