Gfrktyl

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.

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