ce/parser.ml

open Ast

module S = Set.Make(String)

exception Expected of string
exception Unexpected_token of string

let expected t =
  raise (Expected t)

let unexpected_token t =
  raise @@ Unexpected_token (Token.to_string t)

(* precedence table.
 * my first thought was using some sort of partially-ordered graph for
 * precedency, but infering precedence relation from the graph is hard
 * and the graph can be made to have loops, I just used plain table. *)
let precedence = [
  Add, 10;
  Sub, 10;
  Mul, 20;
  Div, 20;
  Mod, 30;
  Exp, 30;
] |> List.to_seq |> Hashtbl.of_seq

let precedence_of op =
  Hashtbl.find precedence op

let is_left_to_right = function
  | Add | Sub | Mul | Div -> true
  | _ -> assert false

let token_to_op = function
  | Token.Plus -> Add
  | Minus -> Sub
  | Asterisk -> Mul
  | Slash -> Div
  | Carret -> Exp
  | Percent -> Mod
  | _ -> failwith "Parser.token_to_op"

(* common parsers *)

let idents set seq =
  match seq () with
  | Seq.Nil ->
    let msg = "ident " ^ (S.elements set |> String.concat " or ") in
    expected msg
  | Seq.Cons (x, seq) -> begin
      match x with
      | Token.Ident id when S.mem id set -> id, seq
      | _ -> unexpected_token x
    end

let ident str seq =
  idents (S.singleton str) seq

let operator seq =
  match seq () with
  | Seq.Nil -> expected "operator"
  | Seq.Cons (x, seq) ->
    try token_to_op x, seq with
    | _ -> expected "operator"

(* parser combinators *)

let either f g seq =
  try f seq with _ -> g seq

let (@>) f g seq =
  let a, seq = f seq in
  g a seq

(* parse tokens *)
let parse ts =
  (* value := int | ( expr ) *)
  let rec value seq =
    match seq () with
    | Seq.Nil -> assert false
    | Seq.Cons (x, seq) -> begin match x with
        | Token.Int n -> Value (Int n), seq
        | Token.Float n -> Value (Float n), seq
        | LParen -> expr seq
        | _ -> unexpected_token x
      end

  (* binop := binop op binop *)
  and binop pre left seq =
    match seq () with
    | Seq.Nil -> left, Seq.empty
    | Seq.Cons (x, seq) -> begin match x with
        | Token.Plus | Minus | Asterisk | Slash | Percent as op ->
          let op = token_to_op op in
          let o = precedence_of op in 
          if o > pre then (* op has to be calculated first *)
            let v, seq = value seq in
            let right, seq = binop o v seq in
            binop pre (Ast.binop left op right) seq
          else
            left, Seq.cons x seq
        | Carret as op ->
          let op = token_to_op op in
          let o = precedence_of op in 
          if o >= pre then (* op has to be calculated first *)
            let v, seq = value seq in
            let right, seq = binop o v seq in
            binop pre (Ast.binop left op right) seq
          else
            left, Seq.cons x seq
        | RParen -> left, seq
        | _ -> unexpected_token x
      end

  and level _ seq =
    let id, seq = idents (S.of_list ["get"; "set"]) seq in
    let op, seq = operator seq in
    if id = "get" then
      Get_binop_pre op, seq
    else if id = "set" then
      let v, seq = value seq in
      Set_binop_pre (op, v), seq
    else
      failwith "Parser.level"

  and expr seq =
    seq |> either
      (ident "level" @> level)
      (value @> binop ~-1)
  in
  let ast, rest = expr ts in
  if rest () <> Seq.Nil then failwith "Parser.parse";
  ast