pipe that echoes stdin while ignoring any input it has seen before, but timeouts if user is taking too long, and offers a chance to try again

TryAgainPipe.hs

{-# LANGUAGE ExistentialQuantification #-}

import Control.Monad.Error
import Control.Monad.Trans.State.Strict
import Data.Time.Clock
import Pipes
import qualified Pipes.Prelude as P
import qualified Pipes.Lift    as P


newtype Log = Log [String]
  deriving Show

data Crumb = Seen Log
  deriving Show

data Err = Timeout Crumb | Other String
  deriving Show

instance Error Err where
  noMsg = Other "hm"

newtype Fix f = Mu { out :: f (Fix f) }

data ResultF a m r = ResultF { resume :: Producer a m r }

newtype Result a m = Result { result :: Fix (ResultF a m) }

impatientStdin :: [String] -> Producer String (StateT (UTCTime, Log) (ErrorT Err IO)) ()
impatientStdin blacklist = for P.stdinLn $ \x -> do
  t <- liftIO $ getCurrentTime
  (s,l) <- lift get
  if t > addUTCTime 3 s
  then liftIO (putStrLn "timeout!") >> throwError (Timeout $ Seen l)
  else if x `elem` blacklist
       then return ()
       else yield x >> lift get >>= \(_, Log seen) -> lift $ put $ (t, Log (x:seen))

hm :: [String] -> Result String (ErrorT Err IO)
hm blacklist = Result $ Mu $ ResultF $ P.catchError
  (do t <- liftIO $ getCurrentTime
      (_, Log l) <- P.execStateP (t, Log []) $ impatientStdin blacklist
      resume $ out $ result $ hm (blacklist ++ l))
  -- return the rest so user can try again:
  (\(Timeout (Seen (Log l))) -> lift $ return $ result $ hm (blacklist ++ l))
  -- automatically try again:
  --(\(Timeout (Seen (Log l))) -> resume $ out $ result $ hm (blacklist ++ l))

--main = undefined
main = do
 t <- getCurrentTime
 x <- runErrorT $ runEffect $ for (resume $ out $ result $ hm []) (liftIO . print . ("got "++))
 case x of Left _ -> putStrLn "unrecoverable error"
           Right rest -> do putStrLn "try only one more time"
                            runErrorT $ runEffect $ for (resume $ out rest)
                                                        (liftIO . print . ("second chance, got "++))
                            putStrLn "that's it"