{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Monad.Trans.Either
import Control.Monad.Trans.State
import Control.Pipe
import Control.Pipe.Category
import Control.Pipe.Trans
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text (Text)

newtype ParseP p a b r = ParseP {
    unParseP :: StateP Text (EitherP String p) a b r }
    deriving (Monad, MonadPipe)

instance PipeTrans ParseP where
    liftP = ParseP . liftP . liftP

runParseP = runEitherP . (`runStateP` T.empty) . unParseP

-- This can be made more efficient by hand-writing the state passing instead of
-- using calls to to 'put' and 'get'
take' :: Monad m => Int -> ParseP (Pipe m) Text b Text
take' n = ParseP go  where
    go = do
        s <- P get
        if (T.length s < n)
        then do
            s' <- liftP $ liftP await
            P $ put (s <> s')
            go
        else do
            let (h, t) = T.splitAt n s
            P $ put t
            return h

parseFail str = ParseP $ liftP $ P $ left str

string :: (Monad m) => Text -> ParseP (Pipe m) Text b Text
string str = do
    str' <- take' (T.length str)
    if (str' == str)
    then return str
    else parseFail $ concat [
        "Expected: '", T.unpack str, "' -- Found: ", T.unpack str', "'"]

source :: (Monad m) => Pipe m x Text ()
source = do
    yield $ T.pack "Hell"
    yield $ T.pack "o, world!"

sink :: ParseP (Pipe IO) Text x ()
sink = do
    string $ T.pack "Hello"
    str <- take' 5
    liftP $ liftPipe $ T.putStrLn str

{-
>>> runPipe $ runParseP $ sink <-< liftP source
, wor
Right ((),"ld!")
>>> runPipe $ runParseP $ sink <-< liftP (yield $ T.pack "AAAAAAAAA")
Left "Expected: 'Hello' -- Found: AAAAA'"
-}