Parsing a stream of commands. Uses the trick for effectful parsers described here: https://github.com/Gabriel439/Haskell-Pipes-Parse-Library/issues/31

parsing_trick2.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Main where

import qualified Data.ByteString as B
import Pipes
import qualified Pipes.Parse as P
import qualified Pipes.Prelude as P
import qualified Pipes.Attoparsec as P
import Data.Attoparsec.ByteString.Char8 as A
import Control.Applicative --
import Control.Monad.Trans.State.Strict -- 

data Foo = Foo deriving Show
data Bar = Bar deriving Show
data Baz = Baz deriving Show
data Command = Command Foo Bar Baz deriving Show
data Escape = Escape deriving Show

fooParser :: Parser Foo
fooParser = string "foo\n" >> return Foo

barParser :: Parser Bar
barParser = string "bar\n" >> return Bar

bazParser :: Parser Baz
bazParser = string "baz\n" >> return Baz

exitParser :: Parser Escape
exitParser = string "escape\n" >> return Escape

invalidParser :: Parser ()
invalidParser = many (notChar '\n') *> char '\n' *> pure ()

data CommandToken = 
      FooToken Foo
    | BarToken Bar
    | BazToken Baz
    deriving (Show)

commandTokenParser :: Parser CommandToken
commandTokenParser =
    fmap FooToken fooParser <|> fmap BarToken barParser <|> fmap BazToken bazParser

exitOrCommandTokenParser :: Parser (Either Escape CommandToken)
exitOrCommandTokenParser =
    fmap Right commandTokenParser <|> fmap Left exitParser

invalidOrExitOrCommandTokenParser :: Parser (Either () (Either Escape CommandToken))
invalidOrExitOrCommandTokenParser =
    fmap Right exitOrCommandTokenParser <|> fmap Left invalidParser

-- This uses the "hoist trick" defined here https://github.com/Gabriel439/Haskell-Pipes-Parse-Library/issues/31
-- to build a "Producer raw -> Producer parsed" function.
type Transducer a b m r = forall x. StateT (Producer a m x) (Producer b m) r

-- Return value is Nothing when EOF is reached, Just Escape if Escape is reached.
stopAtEscape :: Transducer (Either Escape CommandToken) CommandToken IO (Maybe Escape)
stopAtEscape = do
    mtoken <- hoist lift P.draw
    case mtoken of
        Nothing -> return Nothing 
        Just (Left Escape) -> return (Just Escape)
        Just (Right token) -> do
            lift (yield token)
            stopAtEscape

parseCommands :: Transducer CommandToken Command IO ()
parseCommands = do
    m1 <- hoist lift P.draw
    m2 <- hoist lift P.draw
    m3 <- hoist lift P.draw
    case (m1,m2,m3) of
       (Just (FooToken c1),Just (BarToken c2),Just (BazToken c3)) -> do
            lift (yield (Command c1 c2 c3))
            parseCommands
       _ -> return ()

-- The overcomplicated return type is casued by the multiple levels of parsing,
-- each with their own leftovers...
completeParser 
    :: Producer B.ByteString IO r
    -> Producer Command IO ((),Producer CommandToken IO (Maybe Escape, Producer (Either Escape CommandToken) IO (Either (P.ParsingError, Producer B.ByteString IO r) r))) 
completeParser producer =
    runStateT parseCommands $
    runStateT stopAtEscape $
    -- the "mapFoldable" is to filter the "invalid" left branches in the token stream
    P.parsed invalidOrExitOrCommandTokenParser producer >-> P.mapFoldable id

example :: Producer B.ByteString IO ()
example = do
  yield "foo\nbar\nbaz\n"
  yield "foo\n"
  yield "bar\n"
  yield "invalid\n" -- skip over invalid input
  yield "baz\n"
  yield "foo\n"
  yield "escape\n" -- exit early from parse based on specific value
  yield "foo\nbar\nbaz\n"

main :: IO ()
main = do
  runEffect $ completeParser example >-> P.print
  return ()