Infix to postfix notation in Haskell (Shunting-yard algorithm)

I've written an infix to postfix converter in Haskell using the Shunting-yard algorithm. Example of how it works:

$./in2post 2 + 2 2 2 +$ ./in2post
1 + 2 * 3
1 2 3 * +
$./in2post (5 - 4) * 3+1005/(12-6*(12 -8) ) 5 4 - 3 * 1005 12 6 12 8 - * - / +$ ./in2post
(2 + 45
2 45 + ERROR


And the source code:

Main.hs

module Main (main) where

import System.IO
import InToPost

main :: IO ()
main = do
line <- getLine
let tokens  = tokenise line
newexpr = shuntYard [] [] tokens
putStrLn $untokenise newexpr  InToPost.hs module InToPost ( Token(TNum, TOp) , Operator , splitTok , tokenise , untokenise , shuntYard ) where import Data.Char (isSpace, isDigit) import Data.List (groupBy) data Token = TNum Int | TOp Operator deriving (Show) data Operator = Add | Sub | Mult | Div | LBrace | RBrace deriving (Show, Eq) splitTok :: String -> [String] splitTok = groupBy (\x y -> isDigit x && isDigit y) . filter (not . isSpace) str2tok :: String -> Either String Token str2tok tkn@(c:_) | isDigit c = Right$ TNum $read tkn | otherwise = case tkn of "+" -> Right$ TOp Add
"-" -> Right $TOp Sub "*" -> Right$ TOp Mult
"/" -> Right $TOp Div "(" -> Right$ TOp LBrace
")" -> Right $TOp RBrace _ -> Left$ "No such operator: \"" ++ tkn ++ "\""

tok2str :: Token -> String
tok2str (TNum t) = show t
tok2str (TOp t) = case t of
Sub  -> "-"
Mult -> "*"
Div  -> "/"
_    -> "ERROR"

precedence :: Operator -> Int
precedence Sub    = 1
precedence Mult   = 2
precedence Div    = 2
precedence LBrace = 3
precedence RBrace = 3

-- shuntYard (Operator stack) (Token Queue) (Token Buffer) = new Token Queue
shuntYard :: [Operator] -> [Token] -> [Either String Token] -> Either String [Token]
shuntYard _ _ (Left s:_) = Left s
shuntYard stack queue [] = Right $queue ++ map TOp stack shuntYard stack queue (Right (TNum t):ts) = shuntYard stack (queue ++ [TNum t]) ts shuntYard stack queue (Right (TOp t):ts) = shuntYard ustack uqueue ts where (ustack, uqueue) = case t of LBrace -> (t : stack, queue) RBrace -> (stail srest, queue ++ map TOp sstart) _ -> (t : ssend, queue ++ map TOp ssops) (sstart, srest) = break (==LBrace) stack currprec = precedence t (ssops, ssend) = span (\op -> precedence op > currprec && op /= LBrace) stack stail :: [a] -> [a] stail (x:xs) = xs stail [] = [] tokenise :: String -> [Either String Token] tokenise = map str2tok . splitTok untokenise :: Either String [Token] -> String untokenise (Left s) = s untokenise (Right ts) = unwords . map tok2str$ ts


Please tell me, what are my bad practices here? For example, the use of Either felt really awkward and I'm sure it can be done better. Also, the case expression in str2tok is quite ugly.

• I would rather recommend not to use explicit recursion in your yard. It might look like this. May 10, 2023 at 5:49

main :: IO ()
main = do
line <- getLine
putStrLn $case traverse str2tok$ splitTok line of
Left s -> s
Right ts -> unwords $map tok2str$ shuntYard ts

-- shuntYard (Token Buffer) = new Token Queue
shuntYard :: [Token] -> [Token]
shuntYard ts = concat queue ++ stack where
(queue, stack) = (runState []) $for ts$ state . \case
TNum t -> ([TNum t],)
TOp LBrace -> ([],) . (LBrace :)
TOp RBrace -> (map TOp *** drop 1) . break (==LBrace)
TOp t -> (map TOp *** (t:)) . span (\op -> precedence op > precedence t && op /= LBrace)


Or perhaps:

(queue, stack) = (runState []) $for ts$ \case
TNum t -> return [TNum t]
TOp LBrace -> [] <$modify (LBrace:) TOp RBrace -> do sstart <- state$ break (==LBrace)
modify (drop 1)
return $map TOp sstart TOp t -> do ssops <- state$ span $\op -> precedence op > precedence t && op /= LBrace modify (t:) return$ map TOp ssops

• Hey, thank you for your answer, but I can't get this code to compile. I've pasted it into the InToPost.hs file and compiled with ghc -dynamic -XLambdaCase -O2 InToPost.hs, but ghc spits out errors: Illegal tuple section: use TupleSections. Jan 8, 2019 at 22:06
• You'll need to enable the TupleSections language extension. Also LambdaCase and I didn't list the imports - hoogle unknown identifiers. Jan 9, 2019 at 14:37