Arithmetic expression parser

Parser.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}

module Arith where

-- do not import other stuff here
import Control.Applicative
    ( Alternative (empty, (<|>))
    , many
    )
import Data.Char (ord)

-- a parser is a function that maybe reduce the input and return a vaule in place
-- of the consumed input
newtype Parser s a = Parser {runParser :: s -> Maybe (s, a)}
    deriving (Functor)

instance Applicative (Parser s) where
    pure x = Parser $ \input -> Just (input, x)
    Parser p1 <*> Parser p2 = Parser $ \input -> do
        (input', f) <- p1 input
        (input'', a) <- p2 input'
        Just (input'', f a)

instance Monad (Parser s) where
    Parser p >>= f = Parser $ \input -> do
        (input', a) <- p input
        runParser (f a) input'

instance Alternative (Parser s) where
    empty = Parser $ const Nothing
    Parser p1 <|> Parser p2 = Parser $ \input -> p1 input <|> p2 input

instance MonadFail (Parser s) where
    fail _ = empty

---- primitives

-- take next token from input
consume :: Parser [a] a
consume = Parser $ \case
    [] -> Nothing
    (x : xs) -> Just (xs, x)

-- match end of input
eof :: Parser [a] ()
eof = Parser $ \case
    [] -> Just ([], ())
    _ -> Nothing

---- combinators

-- match next token of input if it satisfies the predicate
satisfy :: (a -> Bool) -> Parser [a] a
satisfy f = do
    x <- consume
    if f x then pure x else empty

-- match next token of input if it is equal to the given token
item :: (Eq a) => a -> Parser [a] a
item c = satisfy (== c)

-- parse a value enclosed by two ignored parsers
between :: Parser s a -> Parser s b -> Parser s c -> Parser s c
between open close p = open *> p <* close

---- Aritmetic parser tokens


-- arithmetic tokens
data Token
    = OpenParens
    | ClosedParens
    | Number DoubleToken
    | Operator Operator
    | Space -- discuss why Space is good to have
    deriving (Show, Eq)

-- tokenize a string
-- hint: use foldr!
-- think hard about how to tokenize numbers with more that one digit
-- allowed symbols in the expression are "0123456789 ()+-*/"
-- only (multiple digits) integers are allowed
tokenize :: String -> [Token]
tokenize = foldr f []
  where
    f :: Char -> [Token] -> [Token]
    f = error "TBD"


cleanSpaces :: [Token] -> [Token]
cleanSpaces = filter (/= Space)

----  Expresions

-- arithmetic operators
data Operator = Plus | Minus | Times | Div
    deriving (Show, Eq)

operation :: Operator -> Int -> Int -> Int
operation Plus = (+)
operation Minus = (-)
operation Times = (*)
operation Div = div

-- arithmetic expressions, we support operations on multiple operands
data Expression = Value Int | Operation Expression [(Operator, Expression)]
    deriving (Show, Eq)

data Precedence = Low | High
    deriving (Show, Eq, Ord)

precedence :: Operator -> Precedence
precedence Plus = Low
precedence Minus = Low
precedence Times = High
precedence Div = High

-- evaluate an expression respecting operator precedence inside multiple operands
-- operations
-- our operations are all left associatives so we can evaluate them in a single
-- pass from left to right
-- hint: use pattern matching to inspect the "next" operation

evaluate :: Expression -> Int
evaluate = error "TBD"

------- Parser

-- a parser from a list of tokens to an expression
expressionP :: Parser [Token] Expression
expressionP = error "TBD"
--- Runner

-- try to parse an arithmetic expression from a whole string
parse :: String -> Maybe ([Token], Int)
parse = parse' $ expressionP <* eof

-- use this to test your sub parsers
parse' :: Parser [Token] Expression -> String -> Maybe ([Token], Int)
parse' f = fmap (fmap evaluate) . runParser f . cleanSpaces . tokenize

----- Tests

t :: String -> Int -> IO ()
t x r =
    if parse x == Just ([], r)
        then pure ()
        else
            error
                $ "assertion failed: "
                    ++ x
                    ++ " should be "
                    ++ show r
                    ++ " but we got "
                    ++ show
                        (parse x)

tests :: IO ()
tests = do
    t "1" 1
    t "(1)" 1
    t "10 + 2" 12
    t "1+2 + 3" 6
    t "1 + 2* 3" 7
    t "1 * 2 + 3" 5
    t "1 * 2 * 3" 6
    t "1 + 2 * 3 + 4" 11
    t "1 + 2 * 3 + 4 * 5" 27
    t "(1 + 2) * 3 + 4 * 5" 29
    t "((1 + 5))" 6
    t "((1 + 5) * 3)" 18
    t "((1+5)*3)+(4)" 22
    putStrLn "all tests passed"