111 lines
3.9 KiB
Standard ML
111 lines
3.9 KiB
Standard ML
structure Operator = struct
|
|
datatype associativity = LEFT | RIGHT
|
|
type operator = { symbol : char, assoc : associativity, precedence : int }
|
|
|
|
val operators : operator list = [
|
|
{ symbol = #"^", precedence = 4, assoc = RIGHT },
|
|
{ symbol = #"*", precedence = 3, assoc = LEFT },
|
|
{ symbol = #"/", precedence = 3, assoc = LEFT },
|
|
{ symbol = #"+", precedence = 2, assoc = LEFT },
|
|
{ symbol = #"-", precedence = 2, assoc = LEFT }
|
|
]
|
|
|
|
fun find (c : char) : operator option = List.find (fn ({symbol, ...} : operator) => symbol = c) operators
|
|
|
|
infix cmp
|
|
fun ({precedence=p1, assoc=a1, ...} : operator) cmp ({precedence=p2, ...} : operator) =
|
|
case a1 of
|
|
LEFT => p1 <= p2
|
|
| RIGHT => p1 < p2
|
|
end
|
|
|
|
signature SHUNTING_YARD = sig
|
|
type 'a tree
|
|
type content
|
|
|
|
val parse : string -> content tree
|
|
end
|
|
|
|
structure ShuntingYard : SHUNTING_YARD = struct
|
|
structure O = Operator
|
|
val cmp = O.cmp
|
|
(* did you know infixity doesn't "carry out" of a structure unless you open it? TIL *)
|
|
infix cmp
|
|
fun pop2 (b::a::rest) = ((a, b), rest)
|
|
| pop2 _ = raise Fail "bad input"
|
|
|
|
datatype content = Op of char
|
|
| Int of int
|
|
datatype 'a tree = Leaf
|
|
| Node of 'a tree * 'a * 'a tree
|
|
|
|
fun parse_int' tokens curr = case tokens of
|
|
[] => (List.rev curr, [])
|
|
| t::ts => if Char.isDigit t then parse_int' ts (t::curr)
|
|
else (List.rev curr, t::ts)
|
|
|
|
fun parse_int tokens = let
|
|
val (int_chars, rest) = parse_int' tokens []
|
|
in
|
|
((Option.valOf o Int.fromString o String.implode) int_chars, rest)
|
|
end
|
|
|
|
fun parse (s : string) : content tree = let
|
|
val tokens = String.explode s
|
|
(* parse': tokens operator_stack trees *)
|
|
fun parse' [] [] [result] = result
|
|
| parse' [] (opr::os) trees =
|
|
if opr = #"(" orelse opr = #")" then raise Fail "bad input"
|
|
else let
|
|
val ((a,b), trees') = pop2 trees
|
|
val trees'' = (Node (a, Op opr, b)) :: trees'
|
|
in
|
|
parse' [] os trees''
|
|
end
|
|
| parse' (t::ts) operators trees =
|
|
if Char.isSpace t then parse' ts operators trees else
|
|
if t = #"(" then parse' ts (t::operators) (trees : content tree list) else
|
|
if t = #")" then let
|
|
(* process_operators : operators trees *)
|
|
fun process_operators [] _ = raise Fail "bad input"
|
|
| process_operators (opr::os) trees =
|
|
if opr = #"(" then (os, trees)
|
|
else let
|
|
val ((a, b), trees') = pop2 trees
|
|
val trees'' = (Node (a, Op opr, b)) :: trees'
|
|
in
|
|
process_operators os trees''
|
|
end
|
|
val (operators', trees') = process_operators (operators : char list) (trees : content tree list)
|
|
in
|
|
parse' ts operators' trees'
|
|
end else
|
|
(case O.find (t : char) of
|
|
SOME o1 => let
|
|
(* process_operators : operators trees *)
|
|
fun process_operators [] trees = ([], trees)
|
|
| process_operators (o2::os) trees = (case O.find o2 of
|
|
SOME o2 =>
|
|
if o1 cmp o2 then let
|
|
val ((a, b), trees') = pop2 trees
|
|
val trees'' = (Node (a, Op (#symbol o2), b)) :: trees'
|
|
in
|
|
process_operators os trees''
|
|
end
|
|
else ((#symbol o2)::os, trees)
|
|
| NONE => (o2::os, trees))
|
|
val (operators', trees') = process_operators operators trees
|
|
in
|
|
parse' ts ((#symbol o1)::operators') trees'
|
|
end
|
|
| NONE => let
|
|
val (n, tokens') = parse_int (t::ts)
|
|
in
|
|
parse' tokens' operators ((Node (Leaf, Int n, Leaf)) :: trees)
|
|
end)
|
|
| parse' _ _ _ = raise Fail "bad input"
|
|
in
|
|
parse' tokens [] []
|
|
end
|
|
end
|