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

Question

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
    Add  -> "+"
    Sub  -> "-"
    Mult -> "*"
    Div  -> "/"
    _    -> "ERROR"

precedence :: Operator -> Int
precedence Add    = 1
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.

Answer 1

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