Writing monadic Haskell to evaluate arithmetic expression

Question

I have been studying Haskell by myself for about a little over a year. And I have been stuck at monad/monad transformers for quite a while until recently some examples I read online enlightened me. So I decided to try on the following problem with writing monadic Haskell code.

The problem is to evaluate a string that contains only 0-9, +, - and *, which represents addition, subtraction and multiplication separately. The string itself should represent a valid math expression and starts with a number always.

"3+5" -> 8
"3+25*4" -> 103
"1-2*2*2+7" -> 0

The goal of the exercise is not to write a perfect parsing engine to evaluate any math expression but to try to learn to use monad as a tool to write program that could be relatively straight forward in an imperative language such as C++.

It is a linear algorithm and the main the idea is to use two stacks to track numbers and operators.

• On a new digit, update the current on-the-run number
• On any operator, push the on-the-run number to the number stack. Update the stacks if the existing operator on the top of the stack is '*'. If this new operator is a '+' or '-', update the stacks if only the existing operator is '+' or '-'. Once the update is done, push the new operator to the stack
• repeat the process until there is one number left.

This algorithm is used to develop the solutions in both C++ and Haskell.

C++ solution:

 #include <stack>
 #include <iostream>
 #include <string>
 #include <stdexcept>

 using namespace std;

 int calc(char c, int n1, int n2)
 {
     // cout << c << "-->" << n1 << " and " << n2 << endl;
     if (c == '+') return n1+n2;
     else if (c == '-') return n1-n2;
     else if (c == '*') return n1*n2;
     else throw runtime_error("bad operator");
 }

 void update(stack<int>& numbers, stack<char>& operators)
 {
     if (operators.size() + 1 != numbers.size()) throw runtime_error("bad");

     char op = operators.top();
     operators.pop();

     int n2 = numbers.top();
     numbers.pop();

     int n1 = numbers.top();
     numbers.pop();

     numbers.push(calc(op, n1, n2));
 }

 int processMath(const string& input) {
     int num = 0;

     stack<int> numbers;
     stack<char> operators;

     for (char c : input) {
         if (c == '+' || c == '-' || c == '*') {
             numbers.push(num);
             num = 0; // reset number
             if (c == '*' && !operators.empty() && operators.top() == '*') {
                 update(numbers, operators);
             } else if (c == '+' || c == '-') { // c is + or -
                 while (!operators.empty()) update(numbers, operators);

             }
             operators.push(c);
         } else {
             num = num*10+(c-'0');
             // cout << "num=" << num << endl;
         }
     }
     numbers.push(num);
     while (!operators.empty()) update(numbers, operators);
     return numbers.top();
 }

 // To execute C++, please define "int main()"
 int main() {

     string exp1 = "13+15";
     string exp2 = "3+25*4";
     string exp3 = "1-2*2*2+7";

     cout << exp1 << endl << processMath(exp1) << endl << endl;
     cout << exp2 << endl << processMath(exp2) << endl << endl;
     cout << exp3 << endl << processMath(exp3) << endl << endl;

     return 0;
 }

The following part is the Haskell program I came up with, without using anything specific for parsing or math evaluation.

import Control.Monad.State
import Data.Char

data MathStacks = MathStacks { numbers :: [Int]
                             , operators :: [Char] 
                             , current :: Int }
                             deriving Show

data EvalErr = ParseErr { position :: Int, reason :: String } 
             | StackErr String 
             | OpErr String
             deriving Show

collapseOn :: MathStacks -> [Char] -> Either EvalErr MathStacks
collapseOn ms@(MathStacks ns ops _) permittedOps
    | null ops = return ms
    | length ns < 2 = Left $ StackErr ("numbers length < 2:" ++ show ns)
    | not $ op `elem` "+-*" = Left $ OpErr ("invalid op=" ++ [op])
    | not $ op `elem` permittedOps = return ms
    | otherwise = do
        n <- calc op n1 n2
        return $ ms { numbers=(n:nrest), operators=oprest }
    where (n2:n1:nrest) = ns
          (op:oprest) = ops

calc :: Char -> Int -> Int -> Either EvalErr Int
calc c n1 n2 
    | c == '+' = return $ n1 + n2
    | c == '-' = return $ n1 - n2
    | c == '*' = return $ n1 * n2
    | otherwise = Left $ OpErr ("invalid op=" ++ [c])

exec :: MathStacks -> Either EvalErr MathStacks
exec ms@(MathStacks ns ops curr)
    | nlen /= olen + 1 = Left $ StackErr ("inconsistent stacks")
    | olen == 0 = Right ms
    | otherwise = do 
        let (n2:n1:nrest) = ns 
            (op:oprest) = ops
        n <- calc op n1 n2
        return $ MathStacks (n:nrest) oprest curr
    where nlen = length ns
          olen = length ops

exec' :: MathStacks -> Either EvalErr MathStacks
exec' ms@(MathStacks ns ops _) 
    | null ops = return ms
    | otherwise = (exec ms) >>= exec'

eval :: MathStacks -> Either EvalErr Int
eval (MathStacks ns ops curr) 
    | nlen /= 1 || olen /= 0 = Left $ StackErr ("inconsistent stacks")
    | otherwise = Right $ head ns
    where nlen = length ns
          olen = length ops

horner :: Int -> Int -> Int
horner digit num = num * 10 + digit

updateCurr :: Int -> MathStacks -> MathStacks
updateCurr digit ms@(MathStacks _ _ curr) = ms { current=horner digit curr }

updateOps :: Char -> MathStacks -> Either EvalErr MathStacks
updateOps op ms@(MathStacks _ ops _) 
    | op `elem` ['+', '-', '*'] = return $ ms { operators=(op:ops) }
    | otherwise = Left $ OpErr ("invalid op=" ++ [op])

updateNum :: MathStacks -> MathStacks
updateNum ms@(MathStacks ns _ curr) = ms { numbers=(curr:ns), current=0 }

parse :: (Char, Int) -> MathStacks -> Either EvalErr MathStacks
parse (c, idx) ms@(MathStacks ns ops curr) 
    | c `elem` ['+', '-', '*'] = do
        -- current number run is done
        let ms0 = updateNum ms
        -- if there is existing multiplication on top. collapse it
        ms1 <- collapseOn ms0 "*"
        ms2 <- if c == '+' || c == '-' 
            -- if there is existing addition or subtraction, do it
            then collapseOn ms1 "+-"
            else return ms1 
        updateOps c ms2
    | isDigit c = Right $ updateCurr (digitToInt c) ms
    | otherwise = Left $ 
        ParseErr idx ("err char at pos=" ++ show idx ++ " char:" ++ [c])
    where nlen = length ns
          olen = length ops

updateOnceT :: StateT MathStacks (Either EvalErr) ()
updateOnceT = do --  in side of StateT MathStacks (Either EvalErr) monad
    ms <- get
    ms' <- lift $ exec ms
    put ms'

evalCharT :: (Char, Int) -> StateT MathStacks (Either EvalErr) ()
evalCharT (c, idx) = do
    ms <- get -- ms :: MathStacks
    -- promotes from Either EvalErr MathStacks type to StateT monad
    ms' <- lift $ parse (c, idx) ms 
    put ms'


evalStringT :: String -> StateT MathStacks (Either EvalErr) ()
evalStringT s = mapM_ evalCharT $ zip s [1..]

evalStringE :: String -> Either EvalErr MathStacks
evalStringE s = foldM (flip parse) emptyStack $ zip s [1..]

calcStringE :: String -> Either EvalErr MathStacks
calcStringE s = do
    (_, ms) <- (runStateT $ evalStringT s) emptyStack 
    return ms


top :: MathStacks -> Either EvalErr Int
top ms = do
    let ns = numbers ms
    if null ns 
        then Left $ StackErr "no value left"
        else return $ head ns

calcString :: String -> Either EvalErr Int
calcString s = do 
    ms <- evalStringE s -- or use ms <- calcStringE s
    ms' <- exec' $ updateNum ms
    top ms'

emptyStack = MathStacks [] [] 0

main :: IO ()
main = do 
    print $ calcString "13+15"
    print $ calcString "3+25*4"
    print $ calcString "1-2*2*2+7"

The solution is a much longer program than the C++ counterpart, which is not the impression I got with Haskell program. The part that I used StateT monad transformer is probably not necessary (function evalStringT and function calcStringE), however even without these functions I don't think my solution will get much shorter. I thought using State monad could be a natural solution as it involves quite some state updates in the whole process but it looks like foldM over Either monad seems doable. Overall I am not even sure my solution is Haskellish enough so please point out anything that I can improve on my code.

Answer 1

Update: Zeta suggested that what I gave was not really a review. So I present a review first:

• The data type EvalErr has both ParseErr, StackErr and OpErr. A common error type for your entire pipeline seems like an OK idea, since the individual parts (parser, evaluator) will not be used independently.

• Your error values are all parameterised with a String, which can be super useful as you write the parser, but this makes testing negative cases more difficult. A StackErr may be parameterised with the actual stack that broke. This also makes negative testing easier; a good sign of code quality is testability. You can always produce meaningful error messages based on StackErr ns (and whatever remaining context that makes for a good message; what was the operator that failed?).

  Similarly, OpErr could take a single Char.

• You perform unsafe pattern matching in the where of collapseOn:

  where (n2:n1:nrest) = ns
        (op:oprest) = ops
  

  You justify this by guarding against too short lists.

  But this creates a dependency between multiple lines.

  You can avoid this either by using pattern matching to restrict access to executing code: A function body that will only execute once a pattern matches is safe. Or you can extract values monadically, providing for more abstraction (including implicit error handling). For example, a monadic stack may work like:

  eval Add = do
    v1 <- pop
    v2 <- pop
    push (v1 + v2)
  

• I'm not sure exactly what collapseOn does. It handles a bunch of types of errors that are at different levels of abstraction. And then it calls eval, pushes the result to the stack, and removes an operator from a list of operators for some reason or other.

  Is collapse a metaphor for error handling? Or for reducing the stack?

  So I'd say it does too many things.

• You can check that there are enough elements via pattern matching or monadic popping from the stack without calculating the entire length (a full traversal of the stack) every time you handle a new element.

• Your list of supported operators is repeated many times. This makes adding new ones difficult and error-prone. The precedence and associativity of your operators is embedded in the ordering of your code and makes it hard to derive, extend or verify that they're right.

• The following StateT functions seem a little off:

  updateOnceT :: StateT MathStacks (Either EvalErr) ()
  updateOnceT = do
    ms <- get
    ms' <- lift $ exec ms
    put ms'
  
  evalCharT :: (Char, Int) -> StateT MathStacks (Either EvalErr) ()
  evalCharT (c, idx) = do
    ms <- get -- ms :: MathStacks
    ms' <- lift $ parse (c, idx) ms 
    put ms'
  

  There is a modify combinator. But I would probably ditch the StateT altogether to begin with and either

  1. Build a non-monadic stack-based parser from scratch, simplify it and extend it. (You'll eventually end up with something that is somewhat equivalent to parser combinators, since they're also recursive descent parsers, but not explicitly recursive.)

  2. Build a parser using parser combinators (see below) and either construct a syntax tree or make the parser produce the evaluator directly.

• I'd recommend reading up on separation of concerns.

---

Previous: I wrote this suggestion to solve the problem by dividing the problem into parsing and evaluation, and to use other abstractions than a stack-based algorithm.

What you can do is convert the expression into a syntax tree using a parser combinator library like Megaparsec and evaluate that syntax tree. The author of Megaparsec, Mark Karpov, wrote a tutorial called Parsing a simple imperative language. It has a section called Expressions where he demonstrates the makeExprParser combinator:

aExpr :: Parser AExpr
aExpr = makeExprParser aTerm aOperators

aOperators :: [[Operator Parser AExpr]]
aOperators =
  [ [ Prefix (Neg <$ symbol "-") ]
  , [ InfixL (ABinary Multiply <$ symbol "*")
    , InfixL (ABinary Divide   <$ symbol "/") ]
  , [ InfixL (ABinary Add      <$ symbol "+")
    , InfixL (ABinary Subtract <$ symbol "-") ]
  ]

As for building a monadic evaluator, I'd read The Monadic Way on the Haskell Wiki. It starts by building a regular evaluator and then adds features that are greatly complicated by the lack of monads, and then it introduces them.

It seems that your examples do not mention division, which is a pretty good example of something that may fail during evaluation because of division by zero. If you had the following syntax tree,

data AExpr
  = IntConst Integer
  | Neg AExpr
  | ABinary ABinOp AExpr AExpr
  deriving (Show)

data ABinOp
  = Add
  | Subtract
  | Multiply
  | Divide
  deriving (Show, Eq)

data Error
  = DivisionByZero
  deriving (Show, Eq)

you could write something like,

eval :: AExpr -> Either Error Integer
eval (IntConst i) = return i
eval (Neg e) = negate <$> eval e
eval (ABinary op e1 e2) = do
  i1 <- eval e1
  i2 <- eval e2
  if op == Divide && i2 == 0 then Left DivisionByZero else
    return $ binop op i1 i2

binop :: ABinOp -> (Integer -> Integer -> Integer)
binop Add = (+)
binop Subtract = (-)
binop Multiply = (*)
binop Divide = quot

This separates the concerns of syntax analysis and evaluation. This also means that different kinds of errors are handled at different layers of abstraction. And it means you get a declarative, high-level way of expressing the precedence and associativity of your operators.

---

More: I added this after to suggest a middle ground.

If you think makeExprParser feels like cheating, and you think the intermediate syntax-tree representation is redundant, you can

1. Make your life harder by writing your expression parser using the chainl, chainr etc. combinators, or write your own hierarchy of nested combinators (makes precedence and associativity slightly more obscure, but much less so than an explicitly recursive function would).

2. Make the program simpler by writing a parser that generates a function that evaluates:

   evalP :: Parser (String -> Integer)
   evalP = ...