Evaluator of arithmetic expressions

Arith.hs

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

-- do not import other stuff here
import Control.Applicative
    ( Alternative (empty, (<|>))
    , many
    )
import Control.Monad (forever)
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 s (a -> b) -> Parser s a -> Parser s b
    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

-- arithmetic tokens
data Token
    = OpenParens
    | ClosedParens
    | Digit Int
    | Natural Int Int
    | Double Double
    | Dot
    | Operator Operator
    | Space
    deriving (Show, Eq)

-- this is removing digits
compressNatural :: [Token] -> [Token]
compressNatural = foldr f []
  where
    f (Digit x) (Natural m y : xs) = Natural (10 * m) (10 * y + x) : xs
    f (Digit x) xs = Natural 10 x : xs
    f x xs = x : xs

-- this is removing the dot, why we cannot remove Naturals already ?
mkDouble :: [Token] -> [Token]
mkDouble = foldr f []
  where
    f (Natural _ x) (Dot : Natural m y : xs) =
        Double (fromIntegral x + fromIntegral y / fromIntegral m) : xs
    f x xs = x : xs

rmNatural :: [Token] -> [Token]
rmNatural = map $ \case
    Natural _ x -> Double $ fromIntegral x
    x -> x

-- tokenize a string

tokenize :: String -> [Token]
tokenize = fmap $ \case
    '(' -> OpenParens
    ')' -> ClosedParens
    '+' -> Operator Plus
    '-' -> Operator Minus
    '*' -> Operator Times
    '/' -> Operator Div
    ' ' -> Space
    '.' -> Dot
    x ->
        if x `elem` ['0' .. '9']
            then Digit $ ord x - ord '0'
            else error "unexpected character"

lexer :: String -> [Token]
lexer =
    rmNatural
        . mkDouble
        . compressNatural
        . rmSpaces
        . tokenize

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

----  Expresions

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

operation :: (Fractional a) => Operator -> a -> a -> a
operation Plus = (+)
operation Minus = (-)
operation Times = (*)
operation Div = (/)

-- arithmetic expressions, we support operations on multiple operands
data Expression
    = Value Double
    | Operation Expression [(Operator, Expression)]
    | Negative 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 -> Double
evaluate (Value n) = n
evaluate (Negative x) = negate $ evaluate x
evaluate (Operation p []) = evaluate p
evaluate (Operation p [(op, x)]) = operation op (evaluate p) (evaluate x)
evaluate (Operation p ((op1, x) : (op2, y) : xs))
    | precedence op1 >= precedence op2 =
        let
            u = operation op1 (evaluate p) (evaluate x)
            o = operation op2
            v = evaluate (Operation (Value $ evaluate y) xs)
         in
            u `o` v
    | otherwise =
        let
            u = evaluate p
            o = operation op1
            v = evaluate (Operation (Value $ evaluate x) ((op2, y) : xs))
         in
            u `o` v

------- Parser

-- parse a 'Negative' constructor
negativeP :: Parser [Token] Expression -> Parser [Token] Expression
negativeP x = Negative <$> (item (Operator Minus) *> x) <|> x

-- parse a 'Value' constructor
valueP :: Parser [Token] Expression
valueP = do
    -- why fmap would be wrong here ?
    Double r <- consume
    pure $ Value r

operandP :: Parser [Token] Expression
operandP =
    negativeP
        $ between (item OpenParens) (item ClosedParens) expressionP <|> valueP

-- parse an element of an operation
operationP :: Parser [Token] (Operator, Expression)
operationP = do
    Operator op <- consume
    (op,) <$> operandP

-- we do not need to produce a Value because it's subsumed by Operation
expressionP :: Parser [Token] Expression
expressionP = Operation <$> operandP <*> many operationP

--- Runner

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

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

----- Tests

t :: String -> Double -> 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 "1 + 2" 3
    t "1 + 2 + -3" 0
    t "1.55 + 2 * 3" 7.55
    t "1 * -2.5 + 3" 0.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
    t "-4" (-4)
    t "- 4 - 4" (-8)
    t "-4 * 4" (-16)
    t "-4 * (-4)" 16
    t "-4 * (- 4) + 4" 20
    t "-4 * (-(3 * 2)) + 4 * 4" 40
    t "-4 * ((- (3 * 2))) + 4 * 4 + 4" 44
    t "-(4)" (-4)
    putStrLn "all tests passed"

main :: IO ()
main = do
    tests
    forever $ do
        putStr "> "
        x <- getLine
        case parse x of
            Nothing -> putStrLn "parse error"
            Just ([], r) -> print r
            Just (ts, _) -> putStrLn $ "trailings: " ++ show ts