Implementing Parsec Like combinators using the Oleg's spec of Iteratee

Iteratee.hs

{-# LANGUAGE TypeSynonymInstances, NoMonomorphismRestriction #-}

module Iteratee where
  import Control.Applicative hiding (many)
  import Control.Monad (liftM, ap)
  import Data.Char (isSpace, isAlpha)
  import Data.Monoid
  import qualified Prelude as P
  import Prelude hiding (head, break)

  type ChunkSize = Int
  type ErrMsg = String

  data Stream a 
    = EOF (Maybe ErrMsg)
    | Chunk a
    deriving (Show)


  data IterateeV s a 
    = Finally a
    | Continue (Maybe ErrMsg) (Stream s -> (IterateeV s a, Stream s))

  itFin = Finally
  itCont = Continue Nothing
  itErr msg kn = Continue (Just msg) kn

  instance (Monoid s, Eq s) => Monoid (Stream s) where
    mempty = Chunk mempty
    e@(EOF _) `mappend` _ = e
    s@(Chunk c) `mappend` e@(EOF (Just _)) 
      | c == mempty = e
      | otherwise = s
    (Chunk c) `mappend` (Chunk c') = Chunk (c `mappend` c')


  instance Monad (IterateeV s) where
    return = Finally
    Finally a >>= fn = fn a
    (Continue e kn) >>= fn = itCont (helper . kn)
      where
        helper (Finally a, s) = 
          case fn a of
            Continue Nothing kn -> kn s
            it -> (it, s)
        helper (it, s) = (it >>= fn, s)

  instance Functor (IterateeV s) where
    fmap = liftM

  instance Applicative (IterateeV s) where
    pure  = return
    (<*>) = ap
  
  class StreamLike s where
    emptyStream :: Stream s
    run :: IterateeV s a -> Either ErrMsg a
    enumChunk :: s -> ChunkSize -> IterateeV s a -> IterateeV s a
    head :: IterateeV s Char
    peek :: IterateeV s (Maybe Char)
    break :: (Char -> Bool) -> IterateeV s String
    heads :: s -> IterateeV s Int
    charP :: (Char -> Bool) -> IterateeV s Char
    letter :: IterateeV s Char
    space :: IterateeV s Char
    many1 :: IterateeV s a -> IterateeV s [a]
    many :: IterateeV s a -> IterateeV s [a]

  instance StreamLike String where
    emptyStream = Chunk []
    
    run (Finally a) = Right a
    run (Continue (Just e) _) = Left e
    run (Continue _ kn) = 
      case kn (EOF Nothing) of
        (Finally a, _) -> Right a
        (Continue (Just e) _, _) -> Left e
        it -> Left "Iteratee didn't terminate on EOF"

    enumChunk _ _ it@(Finally _) = it
    enumChunk str size it@(Continue (Just _) _) = it
    enumChunk str size it@(Continue Nothing kn) = 
      let (h, t) = P.splitAt size str
          (it', (Chunk r)) = kn (Chunk h)
      in enumChunk (r ++ t) size it'

    head = itCont step
      where
        step (Chunk [])    = (head, emptyStream)
        step (Chunk (h:t)) = (itFin h, Chunk t)
        step stream        = (itErr "head: unexepected EOF" step, stream)

    peek = itCont step
      where
        step (Chunk [])           = (peek, emptyStream)
        step stream@(Chunk (h:t)) = (itFin (Just h), stream)
        step stream               = (itFin Nothing, stream)

    break pn = itCont (step [])
      where
        step xs (Chunk []) = (itCont (step xs), emptyStream)
        step xs (Chunk c)  = 
          case P.break pn c of
            (_, []) -> (itCont (step (xs ++ c)), emptyStream)
            (h, t)  -> (itFin (xs ++ h), Chunk t)
        step xs stream     = (itErr "break: unexpected EOF" (step xs), stream)

    heads [] = itFin 0
    heads xs = itCont (step 0 xs)
      where
        step c xs (Chunk []) = (itCont (step c xs), emptyStream)
        step c (x:xs) s@(Chunk (y:ys))
          | x /= y           = (Finally c, s)
          | otherwise        = (itCont (step (c+1) xs), Chunk ys)
        step c xs stream     = (itErr "heads: unexpected EOF" (step c xs), stream)


    charP pn = itCont step
      where
        step (Chunk []) = (letter, emptyStream)
        step s@(Chunk (x:xs)) 
          | pn x = (Finally x, Chunk xs)
          | otherwise = (itErr ("charP: unexpected " ++ show x) step, s)
        step stream = (itErr "charP: unexpected EOF" step, stream)

    letter = charP isAlpha
    space  = charP isSpace


    many1 (Finally x) = itFin [x]
    many1 it@(Continue Nothing kn) = 
      let 
        step (Chunk []) = (itCont step, emptyStream)
        step s@(Chunk _) = 
          case kn s of
            ((Continue (Just err) _), s') -> (itErr "many1: failed to match" step, s)
            ((Finally x), s') -> ((:) <$> pure x <*> many it, s')
            _ -> (many it, s)
        step stream = (itErr "many1: unexpected EOF" step, stream)
      in 
        itCont step
       
    many fit = many' fit []
      where
        many' (Finally x) xs = (++) <$> pure (x:xs) <*> many fit
        many' (Continue (Just err) kn) xs = itFin xs
        many' it@(Continue _ kn) xs = itCont step
          where
            step (Chunk [])  = (itFin xs, emptyStream)
            step c@(Chunk _) = let (it', s') = kn c
                               in (many' it' xs, s')
            step stream      = (itFin xs, stream)
    
    
      
  twoWords = (,) <$> (many letter) <*> (space *> (many letter))