A brief play with monadic parsers in Haskell

This was some of the Hello World code when I was first introduced to Haskell and Monad, kinda interesting. It had a lot of impact on me later implementing parsers in other languages.

-- define a new data type to carry the parser funtion
-- this is necessary when you want to use do notation
type ParserFunction a = String -> ([a], String, [String])
data Parser a = Parser( ParserFunction a )

-- apply function extracts the parser function
apply :: Parser a -> ParserFunction a
apply (Parser p) = p

-- parse function produce human readable output
parse :: Show a => String -> Parser a -> IO ()
parse input parser = case apply parser input of
                     ([] ,y,e) -> do putStr "Error(s):\n"
                                     putStrList (map indent e)
                                     if y != "" then
                                        do putStr "When parsing:\n\t"
                                           putStr (show y)
                                     else
                                        return ()
                     (x:_,y,e) -> do putStr "Result:\n\t"
                                     putStr (show x)
                                     if y != "" then
                                        do putStr "\nRemaining:\n\t"
                                           putStr (show y)
                                     else
                                        return ()
                                     if e != [] then
                                        do putStr "\nWarning(s):\n"
                                           putStrList (map indent e)
                                     else
                                        return ()

putStrList []     = return ()
putStrList (x:xs) = do putStr (x++"\n")
                       putStrList xs

indent str = '\t':str

-- define Parser as instance of class Monad
-- & override the bind operator and two unit monads
instance Monad Parser where
  p >>= q =
   Parser
   (
    \inp -> case apply p inp of
             ([] ,y,e) -> ([],y,e)
             (x:_,y,w) -> (x',y',w')
                            where
                              (x',y',nw) = apply (q x) y
                              w' = w ++ nw
   )
  return v = Parser( \inp -> (v:[],inp,[]) )
  fail   s = Parser( \inp -> ([]  ,inp,s:[] ) )

-- define the "atom" monads
-- allowing composition of new monads later with do notation

warn msg = Parser( \inp -> ([[]],inp,msg:[]) )

pop = Parser
      (
       \inp -> case inp of
                ""     -> apply (fail "'pop' failed.") inp
                (x:xs) -> apply (return x) xs
      )

inspect n = Parser
            (
             \inp -> if length inp > n then
                        apply (return (inp!!n)) inp
                     else
                        apply (return '\0') inp
            )

peek = inspect 0

-- pops a Char if it satisfies the predicate
popif sat msg = do x <- peek
                   if sat x then
                     do pop
                        return x
                   else
                     fail ("Unexpected '"++x:"', expects "++msg++".")

char c = popif (c==) ("'"++c:"'")

digit = popif isDigit "'0'~'9'"

-- try apply p, if fail, apply q
p +++ q = Parser
          (
           \inp -> case apply p inp of
                   ([],_,_) -> apply q inp
                   (x ,y,z) -> (x,y,z)
          )

-- apply p 0+ times
star p = plus p +++ return ([],0)

-- apply p 1+ times
plus p = do x     <- p
            (y,t) <- star p
            return (x:y,t+1)

int = do n <- digit
         m <- peek
         if isDigit m then
           if m != '0' then
             do r <- int
                return ( (digitToInt n) * 10 ^ (numDigits r) + r )
           else
             do z <- plus (char '0')
                r <- int
                return ( (digitToInt n) * 10 ^ (numDigits r + snd z) + r )
         else
           return (digitToInt n)

numDigits i | i < 10 = 1
            | i > 9  = 1 + numDigits (i / 10)

-- a set of parsers to parse expression
expr = do { t <- term
          ; do char '+'
               e <- expr
               return (t+e)
            +++
            do char '-'
               e <- expr
               return (t-e)
            +++
            return t
          }

term = do { f <- factor
          ; do char '*'
               t <- term
               return (f*t)
            +++
            do char '/'
               t <- term
               return (f/t)
            +++
            return f
          }

factor = do i <- int
            return i
         +++
         do char '('
            e <- expr
            char ')'
            return e

-- functions not implemented in Hugs98
p != q = not (p==q)

isDigit '1' = True
isDigit '2' = True
isDigit '3' = True
isDigit '4' = True
isDigit '5' = True
isDigit '6' = True
isDigit '7' = True
isDigit '8' = True
isDigit '9' = True
isDigit '0' = True
isDigit _  = False

digitToInt '0' = 0
digitToInt '1' = 1
digitToInt '2' = 2
digitToInt '3' = 3
digitToInt '4' = 4
digitToInt '5' = 5
digitToInt '6' = 6
digitToInt '7' = 7
digitToInt '8' = 8
digitToInt '9' = 9