One pass Bob parser

Bob.hs

module Bob (responseFor) where
import Data.Char (isSpace, isLower, isAlpha)
import Control.Applicative ((<$>), (<*>), (<|>))
data Prompt = Silence | Yell | Question | Other
            deriving (Show, Eq)

data P a = P { pCanParse :: Char -> Bool
             , pParse :: Char -> Either (P a) (Maybe a)
             , pParseEOF :: Maybe a
             }

tryParse :: P a -> Char -> Either (P a) (Maybe a)
tryParse p c | pCanParse p c = pParse p c
             | otherwise     = Right Nothing

runParser :: P a -> String -> Maybe a
runParser p (x:xs) = either (`runParser` xs) id (tryParse p x)
runParser p []     = pParseEOF p

returnP :: a -> P b -> P a
returnP x p = P { pCanParse = pCanParse p
                , pParse = parse
                , pParseEOF = wrap (pParseEOF p) }
  where parse = either (Left . returnP x) (Right . wrap) . pParse p
        wrap = fmap (const x)

anything :: P ()
anything = allChar (const True)

allChar :: (Char -> Bool) -> P ()
allChar f = p
  where p = P { pCanParse = f
              , pParse = const (Left p)
              , pParseEOF = Just () }

anyChar :: (Char -> Bool) -> P ()
anyChar f = p
  where p = P { pCanParse = const True
              , pParse = parse
              , pParseEOF = Nothing }
        parse c | f c       = Right (Just ())
                | otherwise = Left p

lastChar :: (Char -> Bool) -> P ()
lastChar f = p
  where p = P { pCanParse = const True
              , pParse = go . f
              , pParseEOF = Nothing }
        go True  = Left p { pParseEOF = Just () }
        go False = Left p { pParseEOF = Nothing }

andP :: P a -> P b -> P (a, b)
a `andP` b = P { pCanParse = (&&) <$> pCanParse a <*> pCanParse b
               , pParse = go
               , pParseEOF = (,) <$> pParseEOF a <*> pParseEOF b }
  where go c = case (pParse a c, pParse b c) of
          (Right x, Right y) -> Right ((,) <$> x <*> y)
          (Right Nothing, _) -> Right Nothing
          (_, Right Nothing) -> Right Nothing
          (pa, pb)           -> Left $ toP pa `andP` toP pb
        toP (Left p)  = p
        toP (Right x) = maybe undefined (flip returnP anything) x

orP :: P a -> P a -> P a
a `orP` b = P { pCanParse = (||) <$> pCanParse a <*> pCanParse b
              , pParse = go
              , pParseEOF = pParseEOF a <|> pParseEOF b }
  where go c =
          let pa = tryParse a c
              pb = tryParse b c
              parseB a' = either (Left . orP a')
                          (maybe (Left a') (Right . Just))
                          pb
          in either parseB (maybe pb (Right . Just)) pa

silenceP, yellP, questionP :: P Prompt
silenceP = returnP Silence $ allChar isSpace
yellP = returnP Yell $ allChar (not . isLower) `andP` anyChar isAlpha
questionP = returnP Question $ lastChar (=='?')

classify :: String -> Prompt
classify = maybe Other id . runParser (silenceP `orP` yellP `orP` questionP)

response :: Prompt -> String
response Silence = "Fine. Be that way."
response Yell = "Woah, chill out!"
response Question = "Sure."
response Other = "Whatever."

responseFor :: String -> String
responseFor = response . classify