Difference between revisions of "Shunting yard algorithm/foo.hs"
From PEGWiki
(Created page with "<syntaxhighlight lang="haskell"> {- Reference implementation of shunting yard algorithm. Requires: Data.Char, Data.List. This implementation is not error-tolerant; an exception w...") |
(No difference)
|
Latest revision as of 19:01, 31 July 2012
{- Reference implementation of shunting yard algorithm. Requires: Data.Char, Data.List. This implementation is not error-tolerant; an exception will occur on any incorrect input. Note: Unary + and - have precedence higher than * and / but lower than ^. -} data (Num a) => Token a = Plus | Minus | Add | Subtract | Multiply | Divide | Exp | LeftParen | RightParen | Operand a isLeftParen LeftParen = True; isLeftParen _ = False instance (Num a) => Show (Token a) where { show Plus = "+"; show Minus = "-"; show Add = "+"; show Subtract = "-"; show Multiply = "*"; show Divide = "/"; show Exp = "^"; show LeftParen = "("; show RightParen = ")"; show (Operand x) = show x } prec Add = 1; prec Subtract = 1; prec Multiply = 2; prec Divide = 2; prec Plus = 3; prec Minus = 3; prec Exp = 4; prec _ = 0 tokenize s = reverse $ f s [] where f [] l = l f ('(':s') l = f s' (LeftParen:l) f (')':s') l = f s' (RightParen:l) f ('/':s') l = f s' (Divide:l) f ('^':s') l = f s' (Exp:l) f ('+':s') l = f s' (op:l) where op = if null l || precedesUnary (head l) then Plus else Add f ('-':s') l = f s' (op:l) where op = if null l || precedesUnary (head l) then Minus else Subtract f ('*':s') l = if "*" `isPrefixOf` s' then f (tail s') (Exp:l) else f s' (Multiply:l) f s@(c:s') l | isSpace c = f (dropWhile isSpace s) l | otherwise = let (number, rest) = break (\x -> not (isDigit x || x == '.')) s in f rest ((Operand (read number)):l) precedesUnary LeftParen = True precedesUnary RightParen = False precedesUnary (Operand _) = False precedesUnary _ = True data (Num a) => AST a = Leaf (Token a) | Unary (Token a) (AST a) | Binary (Token a) (AST a) (AST a) instance (Num a) => Show (AST a) where show (Leaf t) = show t show (Unary t a) = "(" ++ show t ++ " " ++ show a ++ ")" show (Binary t a1 a2) = "(" ++ show t ++ " " ++ show a1 ++ " " ++ show a2 ++ ")" shuntingYard l = f ([LeftParen] ++ l ++ [RightParen]) [] [] where f [] st os = head os f (Operand x : ts) st os = f ts st (Leaf (Operand x) : os) f (LeftParen:ts) st os = f ts (LeftParen:st) os f (RightParen:ts) st os = f ts (tail after) (helper before os) where (before, after) = break isLeftParen st f (Exp:ts) st os = f ts (Exp:st) os f (Plus:ts) st os = f ts (Plus:st) os f (Minus:ts) st os = f ts (Minus:st) os f (op:ts) st os = f ts (op:after) (helper before os) where (before, after) = break ((>) (prec op) . prec) st helper [] os = os helper (Plus:st') (o:os) = helper st' (Unary Plus o : os) helper (Minus: st') (o:os) = helper st' (Unary Minus o : os) helper (o':st') (o2:o1:os) = helper st' (Binary o' o1 o2 : os)