haskell parser combinator

Parser.hs

import Data.Char (isDigit, isLower, isUpper, isAlpha, isAlphaNum, isSpace)
import Test.HUnit
import Test.HUnit.Tools (assertRaises)
import Control.Exception (ErrorCall(ErrorCall), evaluate)

newtype Parser a =  Parser {getParser :: String -> [(a, String)]}

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

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

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

(+++) :: Parser a -> Parser a -> Parser a
p +++ q = Parser $ \ inp -> case parse p inp of
                             [] -> parse q inp
                             [(v, out)] -> [(v, out)]

tests1 :: Test
tests1 = "+++" ~: TestList ["test1" ~: (parse (item +++ return 'd') "abc") ~?= [('a', "bc")],
                            "test2" ~: (parse (fail "" +++ return 'd') "abc") ~?= [('d', "abc")],
                            "test3" ~: (parse (fail "" +++ fail "") "abc") ~?= ([] :: [(Char, String)])]

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

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)

tests2 :: Test
tests2 = "testForSat" ~:
         TestList ["test1" ~: (parse digit "123") ~?= [('1', "23")],
                   "test2" ~: (parse digit "abc") ~?= [],
                   "test3" ~: (parse (char 'a') "abc") ~?= [('a', "bc")],
                   "test4" ~: (parse (char 'a') "123") ~?= []]


string :: String -> Parser String
string [] = return []
string (x:xs) = do char x
                   string xs
                   return (x:xs)

tests3 :: Test
tests3 = "testForString" ~:
         TestList ["test1" ~: (parse (string "abc") "abcdef") ~?= [("abc", "def")],
                   "test2" ~: (parse (string "abc") "ab123") ~?= []]


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)

tests4 :: Test
tests4 = "testForManyAndMany1" ~:
         TestList ["test1" ~: (parse (many digit) "123abc") ~?= [("123", "abc")],
                   "test2" ~: (parse (many digit) "abcdef") ~?= [("", "abcdef")],
                   "test3" ~: (parse (many1 digit) "abcdef") ~?= []]

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

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

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

tests5 :: Test
tests5 = "for ident nat space" ~:
         TestList ["test1" ~: (parse ident "abc def") ~?= [("abc", " def")],
                   "test2" ~: (parse nat "123 abc") ~?= [(123, " abc")],
                   "test3" ~: (parse space " abc" ~?= [((), "abc")])]

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

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

p :: Parser [Int]
p = do symbol "["
       n <- natural
       ns <- many (do symbol ","
                      natural)
       symbol "]"
       return (n:ns)

tests6 :: Test
tests6 = "test:p" ~:
         TestList ["test1" ~: (parse p " [1, 2, 3] ") ~?= [([1,2,3], "")],
                   "test2" ~: (parse p " [1, 2, ]") ~?= []]

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, String)]
eval' xs = parse expr xs

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

tests7 :: Test
tests7 = "test for eval" ~:
         TestList ["test1" ~: (eval "2*3+4") ~?= 10,
                   "test2" ~: (eval "2*(3+4)") ~?= 14,
                   "test3" ~: (eval "2 * (3 + 4)" ~?= 14),
                   "test4" ~: (assertRaises "assert" (ErrorCall "unused input wie") $ evaluate (eval "1*2wie"))]

main :: IO Counts
main = do
  runTestTT . TestList $ [tests1, tests2, tests3, tests4, tests5, tests6, tests7]