Parser combinators from scratch in Haskell

parser.hs

import Control.Applicative
import Data.List

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

parseConst :: a -> Parser a
parseConst a = Parser $ \s -> [(a, s)]

parseString :: String -> Parser String
parseString target = Parser p where
  p str | target `isPrefixOf` str = [(target, drop (length target) str)]
        | otherwise               = []


instance Functor Parser where
  fmap f (Parser p) = Parser $ \s -> [(f a, s') | (a, s') <- p s]

instance Applicative Parser where
  pure a = Parser $ \s -> [(a, s)]
  Parser pf <*> Parser pa = Parser p where
    p s = [(f a, s'') | (f, s') <- pf s, (a, s'') <- pa s']

instance Alternative Parser where
  empty = Parser $ const []
  Parser p1 <|> Parser p2 = Parser $ \s -> p1 s ++ p2 s

runParserSimple :: Parser a -> String ->  Maybe a
runParserSimple (Parser p) s = let complete = [a | (a, s') <- p s, null s']
                               in  if null complete
                                   then Nothing
                                   else Just (head complete)

---------------------------------------

star :: Parser a -> Parser [a]
star p = ((:) <$> p <*> star p) <|> (parseConst [])

plus :: Parser a -> Parser [a]
plus p = (:) <$> p <*> star p


parseAny :: [Parser a] -> Parser a
parseAny = foldr (<|>) empty

---------------------------------------

data Expr = Number Integer
          | Sum Expr Expr
          | Product Expr Expr
          deriving (Eq, Show)

evalExpr :: Expr -> Integer
evalExpr (Number n) = n
evalExpr (Sum e1 e2) = evalExpr e1 + evalExpr e2
evalExpr (Product e1 e2) = evalExpr e1 * evalExpr e2

parseDigit :: Parser String
parseDigit = parseAny $ parseString <$> ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]

parseNumber :: Parser Expr
parseNumber = Number . read . concat  <$> plus parseDigit

parseBinary :: String -> (Expr -> Expr -> Expr) -> Parser Expr -> Parser Expr
parseBinary op f base = go where
  go = (f <$> base <* parseString op <*> go) <|> base

parseSum :: Parser Expr
parseSum = parseBinary "+" Sum parseProduct

parseProduct :: Parser Expr
parseProduct = parseBinary "*" Product parseNumber

parseParened :: Parser Expr
parseParened = parseString "(" *> parseExpr <* parseString ")"

parseExpr :: Parser Expr
parseExpr = parseSum

evalStrExpr :: String -> Maybe Integer
evalStrExpr s = evalExpr <$> runParserSimple parseExpr s

repl :: IO ()
repl = do
  putStr "enter epression: "
  input <- getLine
  print $ evalStrExpr input
  repl

parser_simple.hs

import Data.List

type Parser a = String -> [(a, String)]

parseEmpty :: Parser ()
parseEmpty s = [((), s)]

parseNothing :: Parser a
parseNothing _ = []

parseString :: String -> Parser String
parseString target str | target `isPrefixOf` str = [(target, drop (length target) str)]
                       | otherwise               = []

parseEither :: Parser a -> Parser a -> Parser a
parseEither p1 p2 s = p1 s ++ p2 s

parseBoth :: Parser a -> Parser b -> Parser (a, b)
parseBoth p1 p2 s = [((a,b), s'') | (a, s') <- p1 s, (b, s'') <- p2 s']

mapParser :: (a -> b) -> Parser a -> Parser b
mapParser f p s = [(f a, s') | (a, s') <- p s]

runParser :: Parser a -> String ->  Maybe a
runParser p s = let complete = [a | (a, s') <- p s, null s']
                in  if null complete
                    then Nothing
                    else Just (head complete)

---------------------------------------

star :: Parser a -> Parser [a]
star p = parseEither cons nil where
  cons = mapParser (\(h,t) -> h:t) $ parseBoth p (star p)
  nil = mapParser (const []) parseEmpty

plus :: Parser a -> Parser [a]
plus p = mapParser (\(h,t) -> h:t) $ parseBoth p (star p)

parseAny :: [Parser a] -> Parser a
parseAny = foldr parseEither parseNothing


---------------------------------------

data Expr = Number Integer
          | Sum Expr Expr
          | Product Expr Expr
          deriving (Eq, Show)

evalExpr :: Expr -> Integer
evalExpr (Number n) = n
evalExpr (Sum e1 e2) = evalExpr e1 + evalExpr e2
evalExpr (Product e1 e2) = evalExpr e1 * evalExpr e2

parseDigit :: Parser String
parseDigit = parseAny $ map parseString ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]

-- |
-- >>> parseNumber "123"
-- [(Number 123,""),(Number 12,"3"),(Number 1,"23")]
parseNumber :: Parser Expr
parseNumber = mapParser (Number . read . concat) $ plus parseDigit

parseBinary :: String -> (Expr -> Expr -> Expr) -> Parser Expr -> Parser Expr
parseBinary op f base = multiple `parseEither` single where
  single = base
  multiple = mapParser (\((a,_), b) -> f a b) $
    single `parseBoth` parseString op `parseBoth` parseBinary op f base

parseSum :: Parser Expr
parseSum = parseBinary "+" Sum parseProduct

parseProduct :: Parser Expr
parseProduct = parseBinary "*" Product (parseNumber `parseEither` parseParened)

parseParened :: Parser Expr
parseParened = mapParser (\((_, e), _) -> e) $
  parseString "(" `parseBoth` parseExpr `parseBoth` parseString ")"


parseExpr :: Parser Expr
parseExpr = parseSum

-- |
-- >>> evalStrExpr "1+x"
-- Nothing
-- >>> evalStrExpr "1+2*3"
-- Just 7
-- >>> evalStrExpr "1+2*3*(4+5)"
-- Just 55
evalStrExpr :: String -> Maybe Integer
evalStrExpr s = evalExpr <$> runParser parseExpr s

repl :: IO ()
repl = do
  putStr "enter epression: "
  input <- getLine
  print $ evalStrExpr input
  repl

main = repl