Consumer.hs

{-# OPTIONS -Wall -O2 #-}

module Consumer(ConsumerState(..), Consumer(..), allowsMore, done, returnI, main) where

-- TODO: When "m" is a strict monad, we can't really output
-- intermediate results in consumers!  May be better to also have
-- Translator that produces a result after every input.

data ConsumerState m i o =
    AllowsMore {
      wmTakeMore :: i -> Consumer m i o,
      wmNoMore   :: m o
    }
  | Done o

newtype Consumer m i o = Consumer { unConsumer :: m (ConsumerState m i o) }

instance Monad m => Monad (Consumer m i) where
  return = done
  (Consumer a) >>= f = Consumer $ do
    state <- a
    case state of
      Done x -> unConsumer (f x)
      AllowsMore takeMore noMore ->
        return $ AllowsMore (takeMore' takeMore) (noMore' noMore)
    where
      takeMore' takeMore i = takeMore i >>= f
      noMore' noMore = noMore >>= unConsumer . f >>= \state ->
                       case state of
                         Done x -> return x
                         AllowsMore _ x -> x

returnI :: Monad m => ConsumerState m i o -> Consumer m i o
returnI = Consumer . return

allowsMore :: Monad m => (i -> Consumer m i o) -> m o -> Consumer m i o
allowsMore takeMore noMore = returnI $ AllowsMore takeMore noMore

done :: Monad m => o -> Consumer m i o
done = returnI . Done

sumNums :: (Num n, Monad m) => Consumer m n n
sumNums = go 0
  where
    go n = allowsMore (nextNum n) (return n)
    nextNum n i = go (i + n)

type Producer m i o = ConsumerState m i o -> Consumer m i o

readM :: Read r => String -> Maybe r
readM s = case reads s of
            [(res, "")] -> Just res
            _ -> Nothing

readLine :: Read r => IO (Maybe r)
readLine = do
  line <- getLine
  if line == "q"
    then
      return Nothing
    else
      maybe (err line) (return . Just) (readM line)
  where
    err line = do
      putStrLn ("Error parsing: " ++ show line)
      readLine

-- TODO: Define readLines using a higher-order function that disallows
-- it from seeing the noMore field
readLines :: Read r => Producer IO r o
readLines s@(AllowsMore takeMore _) = Consumer loop
  where
    loop = do
      line <- readLine
      maybe (return s) (\res -> unConsumer (takeMore res) >>=
                           (unConsumer . readLines)) line
readLines s = returnI s

-- -- TODO: Iteratee is just a nice Consumer type for ListT producers?
-- makeProducer :: Monad m => ListT m i o -> Producer m i o

run :: Monad m => Producer m i o -> Consumer m i o -> m o
run producer consumer = do
    result <- unConsumer . producer =<< unConsumer consumer
    case result of
      AllowsMore _ noMore -> noMore
      Done d -> return d

main :: IO ()
main = do
    x <- run readLines sumNums :: IO Integer
    print x

gistfile2.txt