Code examples for http://channel9.msdn.com/Series/C9-Lectures-Erik-Meijer-Functional-Programming-Fundamentals/C9-Lectures-Dr-Erik-Meijer-Functional-Programming-Fundamentals-Chapter-8-of-13

fparser.hs

import Control.Monad
import Data.Char

-- Code examples for
-- http://channel9.msdn.com/Series/C9-Lectures-Erik-Meijer-Functional-Programming-Fundamentals/C9-Lectures-Dr-Erik-Meijer-Functional-Programming-Fundamentals-Chapter-8-of-13

newtype Parser a = P( String -> [(a, String)])

instance Monad Parser where
   return v                   =  P (\inp -> [(v,inp)])
   p >>= f                    =  P (\inp -> case parse p inp of
                                               []        -> []
                                               [(v,out)] -> parse (f v) out)

instance MonadPlus Parser where
   mzero                      =  P (\inp -> [])
   p `mplus` q                =  P (\inp -> case parse p inp of
                                               []        -> parse q inp
                                               [(v,out)] -> [(v,out)])

item :: Parser Char
item = P (\inp -> case inp of
                []     -> []
                (x:xs) -> [(x,xs)])

failure :: Parser Char
failure = P (\inp -> [])

constant :: a -> Parser a
constant c = P (\inp -> [(c,inp)])


parse :: Parser a -> String -> [(a, String)]
parse (P p) inp = p inp

(+++) :: Parser a -> Parser a -> Parser a
p +++ q = p `mplus` q

p1 :: Parser (Char,Char,Char)
p1 = (item         >>= (\x ->
     (item         >>= (\_ ->
     (item         >>= (\y -> 
     ((return 'z') >>= (\z ->
     return (x,y,z)))))))))

p2 :: Parser (Char,Char,Char)
p2 = do { x <- item
        ; _ <- item
        ; y <- item
        ; z <- (return 'z')
        ; return (x,y,z)
        }

sat :: (Char -> Bool) -> Parser Char
sat p = do x <- item
           if p x then
             return x
           else
             failure


digit :: Parser Char
digit = sat isDigit
 
lower :: Parser Char
lower = sat isLower

upper :: Parser Char
upper = sat isUpper
 
letter :: Parser Char
letter = sat isAlpha
 
alphanum :: Parser Char
alphanum = sat isAlphaNum
 
char :: Char -> Parser Char
char x = sat (== x)

-- TODO implement this function using foldr
string :: String -> Parser String
string []     = return []
string (x:xs) =  do { char x
                    ; string xs
                    ; return (x:xs)
                    }

many :: Parser a -> Parser [a]
many p = many1 p +++ return []

many1 :: Parser a -> Parser [a]
many1 p =  do { v  <- p
              ; vs <- many p
              ; return (v:vs)
              }

-- TODO write parser for [1,23,45,678]
p3 :: Parser String
p3 = do { char '['
        ; d <- digit
        ; ds <- many (do { char ','
                         ; digit
                         })
        ; char ']'
        ; return (d:ds)
        }

ident :: Parser String
ident = do x  <- lower
           xs <- many alphanum
           return (x:xs)

nat :: Parser Int
nat = do xs <- many1 digit
         return (read xs)

int :: Parser Int
int = do char '-'
         n <- nat
         return (-n)
        +++ nat

space :: Parser ()
space =  do many (sat isSpace)
            return ()

token :: Parser a -> Parser a
token p = do space
             v <- p
             space
             return v

identifier :: Parser String
identifier =  token ident

natural :: Parser Int
natural =  token nat

integer :: Parser Int
integer =  token int

symbol :: String -> Parser String
symbol xs =  token (string xs)



expr :: Parser Int
expr = do t <- term
          do symbol "+"
             e <- expr
             return (t+e)
           +++ return t

term :: Parser Int
term = do f <- factor
          do symbol "*"
             t <- term
             return (f * t)
           +++ return f

factor :: Parser Int
factor = do symbol "("
            e <- expr
            symbol ")"
            return e
          +++ natural

eval :: String -> Int
eval xs = case (parse expr xs) of
          [(n,[])]  -> n
          [(_,out)] -> error ("unused input " ++ out)
          [] -> error "invalid input"