Applicative Parsing

Parser.hs

import Data.Maybe
import Text.Printf
import Control.Applicative

data Expr = Term Int | Op Operator Expr Expr | Var String
  deriving (Show, Eq)

data Operator = Sum | Mult | Sub | Div
  deriving (Show, Eq)
  
data Result a = Failure [String] | Success a
  deriving (Show, Eq)
  
sampleStr = "2 + a * 4 - b"

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

anyCharP :: Parser Char
anyCharP = Parser p
  where
    p []       = Nothing
    p (x : xs) = Just (x, xs)

charP :: Char -> Parser Char
charP c = Parser $ \inp -> case inp of
                             (x:xs) | x == c -> Just (c, xs)
                             _ -> Nothing

combP :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
combP f pa pb = f <$> pa <*> pb

instance Functor Parser where
  fmap f (Parser pa) = Parser $ \s -> case pa s of
                                       Nothing -> Nothing
                                       Just (a, s') -> Just (f a, s')

instance Applicative Parser where
  pure x = Parser $ \s -> Just (x, s)
  (Parser pf) <*> (Parser pa) = Parser $ \s -> case pf s of
                                                 Nothing -> Nothing
                                                 Just (f, s') -> case pa s' of
                                                   Nothing -> Nothing
                                                   Just (a, s'') -> Just (f a, s'')
instance Alternative Parser where
    empty = Parser $ \s -> Nothing
    (Parser pa) <|> (Parser pb) = Parser $ \s -> case pa s of
                                                   Just (a, s') -> Just (a, s')
                                                   Nothing -> pb s


digitP = foldr1 (<|>) (map charP ['0'..'9'])
symbolCharP = foldr1 (<|>) (map charP (['a'..'z'] ++ ['A'..'Z'])) <|> digitP

-- lift char into a string
str :: Char -> String
str = \x -> [x]

-- zero or many
manyP :: Parser String -> Parser String
manyP p =  many1P p  <|> pure ""

-- one or many
many1P :: Parser String -> Parser String
many1P p = (++) <$> p <*> manyP p

-- parse an int
intP :: Parser Int
intP = read <$> many1P (str <$> digitP)

-- parse a non-whitespace string 
symbolP :: Parser String
symbolP = many1P (str <$> symbolCharP)

operator1P :: Parser Operator
operator1P = (const Mult) <$> charP '*' <|>
             (const Div) <$> charP '/'

operator2P :: Parser Operator
operator2P = (const Sum) <$> charP '+' <|>
             (const Sub) <$> charP '-'
             
termP :: Parser Expr
termP = Term <$> intP

varP :: Parser Expr
varP = Var <$> symbolP

opP :: Parser Expr -> Parser Operator -> Parser Expr -> Parser Expr
opP pa op pb = (\a o b -> Op o a b) <$> pa <*> op <*> pb

bracketedOpP :: Parser Expr
bracketedOpP = charP '(' *> exprP <* charP ')'

-- left associative operator chaining, e.g. 1+2-3
chainlP :: Parser Expr -> Parser Operator -> Parser Expr
p `chainlP` op = (opP p op) (chainlP p op) <|> p

node :: Parser Expr
node = termP <|> varP <|> bracketedOpP

-- precedence is encoded in here
exprP :: Parser Expr
exprP = (node `chainlP` operator1P <|> node) `chainlP` operator2P

parseExpr :: String -> Maybe Expr
parseExpr s = maybe Nothing (Just . fst) (runParser exprP (filter (/=' ') s))