Iteratee implementation example by @tanakh http://d.hatena.ne.jp/tanakh/20100824

gistfile1.hs

-- http://d.hatena.ne.jp/tanakh/20100824

module Iteratee where
import Control.Applicative (Applicative, pure, (<*>))
import Data.Maybe (catMaybes)
import System.IO (Handle, hIsEOF, hGetChar, openFile, hClose)
import System.IO (IOMode (ReadMode))
import Control.Exception (bracket)
import Control.Monad ((>=>))
import Control.Monad.Trans (MonadTrans, lift)

data StreamG el = Empty | El el | EOF

data IterV el a
     = Done a (StreamG el)
     | Cont (StreamG el -> IterV el a)

enum :: IterV el a -> [el] -> IterV el a
enum i [] = i
enum i@(Done _ _) _ = i
enum (Cont k) (x:xs) = enum (k (El x)) xs

run :: IterV el a -> Maybe a
run (Done x _) = Just x
run (Cont k) = run' (k EOF)
  where
    run' (Done x _) = Just x
    run' _ = Nothing

head :: IterV el (Maybe el)
head = Cont step
  where
    step (El el) = Done (Just el) Empty
    step Empty = Cont step
    step EOF = Done Nothing EOF

peek :: IterV el (Maybe el)
peek = Cont step
  where
    step c@(El el) = Done (Just el) c
    step Empty = Cont step
    step EOF = Done Nothing EOF

drop :: Int -> IterV el ()
drop 0 = Done () Empty
drop n = Cont step
  where
    step (El _) = Iteratee.drop (n-1)
    step Empty = Cont step
    step EOF = Done () EOF

length :: IterV el Int
length = Cont (step 0)
  where
    step acc (El _) = Cont (step (acc+1))
    step acc Empty = Cont (step acc)
    step acc EOF = Done acc EOF

instance Monad (IterV el) where
  return x = Done x Empty
  m >>= f = case m of
    Done x str -> case f x of
      Done x' _ -> Done x' str
      Cont k -> k str
    Cont k -> Cont (\str -> k str >>= f)

instance Functor (IterV el) where
  fmap f (Done x str) = Done (f x) str
  fmap f (Cont k) = Cont (fmap f . k)

instance Applicative (IterV el) where
  pure x = Done x Empty
  (Done f str) <*> i2 = fmap f i2
  (Cont k) <*> i2 = Cont (\str -> k str <*> i2)

drop1keep1 :: IterV el (Maybe el)
drop1keep1 = Iteratee.drop 1 >> Iteratee.head

alternates :: IterV el [el]
alternates = fmap catMaybes . sequence . replicate 5 $ drop1keep1

type EnumeratorM el m a = IterV el a -> m (IterV el a)

enumHandle :: Handle -> EnumeratorM Char IO a
enumHandle h iter = loop iter
  where
    loop i@(Done _ _) = return i
    loop i@(Cont k) = do
      isEOF <- hIsEOF h
      if isEOF then return i else hGetChar h >>= loop . k . El

enumFile :: FilePath -> EnumeratorM Char IO a
enumFile fp i =
  bracket
    (openFile fp ReadMode)
    (hClose)
    (flip enumHandle i)

lengthOfTwoFiles :: FilePath -> FilePath -> IO (Maybe Int)
lengthOfTwoFiles fp1 fp2 =
  fmap run $ ((enumFile fp1) >=> (enumFile fp2)) Iteratee.length

data IterVM el m a
  = DoneM a (StreamG el)
  | ContM (StreamG el -> Iteratee el m a)

newtype Iteratee el m a
  = Iteratee { runIter :: m (IterVM el m a) }

liftIter :: Monad m => IterV el a -> Iteratee el m a
littIter (Done x str) = Iteratee . return $ DoneM x str
liftIter (Cont k) = Iteratee . return $ ContM (liftIter . k)

instance MonadTrans (Iteratee el) where
  lift m = Iteratee $ m >>= \x -> return (DoneM x Empty)