Online parser transformer

{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving, FlexibleInstances, LambdaCase, DeriveFunctor, ConstraintKinds #-}

import Control.Applicative
import Control.Monad.State
import Control.Monad.Trans
import qualified Data.ByteString as BS
import Data.Conduit
import Data.Monoid
import qualified Data.Sequence as S
import Data.Word

class (Functor s, Applicative s, Monad s) => Stream s where
  type Element s :: *
  consume' :: s (Maybe (Element s))

instance (Functor m, Monad m) => Stream (StateT [ s ] m) where
  type Element (StateT [ s ] m) = s
  consume' = get >>= \case
    [] -> return Nothing
    x : xs -> put xs >> return (Just x)

instance (Functor m, Monad m) => Stream (StateT BS.ByteString m) where
  type Element (StateT BS.ByteString m) = Word8
  consume' = do
    bs <- get
    case BS.uncons bs of
      Nothing -> return Nothing
      Just ( x, xs ) -> put xs >> return (Just x)

instance Monad m => Stream (ConduitM i o m) where
  type Element (ConduitM i o m) = i
  consume' = await

type Buf s = S.Seq (Element s)

newtype Parser s a
  -- take a buffer, in s return a buffer of consumed values and maybe a result and the next buffer to use
  = Parser { runParser :: Buf s -> s ( Buf s, Maybe ( Buf s, a ) ) }
  deriving ( Functor )

consume :: Stream s => Parser s (Maybe (Element s))
consume = Parser $ \buf -> case S.viewl buf of
  S.EmptyL -> consume' >>= \m'x -> return $ case m'x of
    Nothing -> ( S.empty, Just ( S.empty, Nothing ) )
    Just x -> ( S.singleton x, Just ( S.empty, Just x) )
  x S.:< xs -> return ( S.empty, Just ( xs, Just x) )

instance (Applicative s, Monad s) => Monad (Parser s) where
  return x = Parser $ \buf -> return ( S.empty, Just ( buf, x ) )
  Parser p >>= f = Parser $ \buf -> do
    ( fbuf, m'r ) <- p buf
    case m'r of
      Nothing -> return ( fbuf, Nothing )
      Just ( sbuf, r ) -> do
        let Parser p' = f r
        ( fbuf', m'r') <- p' sbuf
        return ( fbuf <> fbuf', m'r' )

instance (Functor s, Monad s, Applicative s) => Applicative (Parser s) where
  pure = return
  fp <*> p = do
    f <- fp
    f <$> p

instance (Monad s, Applicative s) => Alternative (Parser s) where
  empty = reject
  Parser p <|> Parser p' = Parser $ \buf -> do
    ( fbuf, m'r ) <- p buf
    case m'r of
      Nothing -> do
        ( fbuf', m'r' ) <- p' (buf <> fbuf)
        return ( fbuf <> fbuf', m'r' )
      Just r -> return ( fbuf, Just r)

instance MonadTrans Parser where
  lift m = Parser $ \buf -> do
    x <- m
    return ( S.empty, Just ( buf, x ) )

evalParser :: Functor s => Parser s a -> s (Maybe a)
evalParser p = (\(fbuf, m'r) -> snd <$> m'r ) <$> runParser p S.empty

execParser :: Functor s => Parser s a -> s ()
execParser p = (const ()) <$> runParser p S.empty

type StreamOf t s = (Stream s, Element s ~ t)

-- parsers
reject :: Monad s => Parser s a
reject = Parser $ \buf -> return ( S.empty, Nothing )

pull :: Stream s => Parser s (Element s)
pull = do
  m'x <- consume
  case m'x of
    Nothing -> reject
    Just x -> return x

pullN :: Stream s => Int -> Parser s [ Element s ]
pullN n = replicateM n pull 

expect :: (Eq a, StreamOf a s) => a -> Parser s ()
expect x = do
  x' <- pull
  when (x /= x') reject

expects :: (Eq a, StreamOf a s) => [ a ] -> Parser s ()
expects = mapM_ expect

-- example
cheats :: StreamOf Char s => Parser s String
cheats
  = cheat "hesoyam" <|>
    cheat "baguvix" <|>
    cheat "aezakmi"
    where cheat c = expects c >> return c

main :: IO ()
main = forever (lift getChar >>= yield) $= execParser cheatParser $$ awaitForever (lift . print)
  where
    cheatParser = forever $ ((cheats >>= lift . yield) <|> void pull)