Source

planck / test / expr.ml

Full commit
open Spotlib.Spot
open Planck

(* Stream of chars with buffering and memoization *)
module Stream = Schar

module Parser = struct

  module Base = Pbase.Make(Stream) (* Base parser *)
  include Base
  include Pbuffer.Extend(Stream)(Base) (* Extend Base with parser operators for buffered streams *)
end    

open Parser (* open Parser namespace *)

module Tree = struct
  type t = 
    | Const of int
    | Binop of char * t * t
    | Unop of char * t

  let rec eval = function
    | Const n -> n
    | Binop ('+', t1, t2) -> eval t1 + eval t2
    | Binop ('-', t1, t2) -> eval t1 - eval t2
    | Binop ('*', t1, t2) -> eval t1 * eval t2
    | Binop ('/', t1, t2) -> eval t1 / eval t2
    | Unop ('~', t1) -> - eval t1
    | _ -> assert false

  let rec show = function
    | Const n -> string_of_int n
    | Binop (char, t1, t2) -> "(" ^ show t1 ^ " " ^ String.make 1 char ^ " " ^ show t2 ^ ")"
    | Unop (char, t1) -> "(" ^ String.make 1 char ^ " " ^ show t1  ^ ")"
end

module Op = Op_prec.Make(struct
  type t = Tree.t
  type op = char
  let show_op = Printf.sprintf "(%c)"
  let app _f _a = assert false
  let binop op a1 a2 = Tree.Binop(op, a1, a2)
  let unop op a1 = Tree.Unop(op, a1)
end)

let tbl = 
  let open Op_prec.Operator in
  Hashtbl.of_list 11 [
    '+',  { prec = 2.0; kind = `Infix `Left };
    '-',  { prec = 2.0; kind = `Infix `Left };
    '*',  { prec = 3.0; kind = `Infix `Left };
    '/',  { prec = 3.0; kind = `Infix `Left };
    '~',  { prec = 5.0; kind = `Prefix }; (* unary minus *)
  ]
  
(* parsing rules *)
let blank = void (one_of [' '; '\t'; '\n'; '\r'])

let rec simple_expr st = (fun e -> e st) & 
  
  (* Skip spaces *)
  ?* blank >>= fun () -> 

  constant

  <|> (tokenp (function '+' | '-' | '*' | '/' | '~' -> true | _ -> false)
         >>= fun char -> return (`Op (Hashtbl.find tbl char, char) ))

  <|> (token '(' >>= fun () ->
       expr >>= fun e ->
       ?* blank >>= fun () ->
       token ')' >>= fun () -> 
       return (`Term e))

and constant st = begin
  (* [0-9]+ *)
  matched (?+ (tokenp (function '0'..'9' -> true | _ -> false) <?> "decimal")) 
  >>= fun s -> return (`Term (Tree.Const (int_of_string s)))
end st

and expr st = begin
  option (token '-') >>= fun unary_minus ->
  ?++ simple_expr >>= fun es -> 
  match unary_minus with
  | Some () -> return (Op.parse (`Op (Hashtbl.find tbl '~', '~') :: es))
  | None -> return (Op.parse es)
end st

(* For test *)

let rec random size = 
  let key = if size = 0 then 0 else Random.int 6 in
  match key with
  | 0 -> string_of_int (Random.int 10)
  | 1 -> "(- " ^ random (size-1)  ^ ")" (* unary minus is different from ocaml *)
  | 2 -> "(" ^ random (size-1) ^ ")"
  | 3 -> random (size-1) ^ " + " ^ random (size-1)
  | 4 -> random (size-1) ^ " - " ^ random (size-1)
  | 5 -> random (size-1) ^ " * " ^ random (size-1)
  | _ -> assert false

let test s = 
  Format.eprintf "input=%S@." s;
  let stream = Stream.from_string ~filename:"stdin" s in
  match expr stream with
  | `Ok (res, _) -> 
      (* Check whether the original and parsed are identical *)
      (* Check of computed values are done outside of this program. See OMakefile. *)
      Format.eprintf "%s@." (Tree.show res);
      let n = Tree.eval res in
      Format.printf "assert (%s = %d);;@." s n;

  | `Error (pos, s) ->
      Format.eprintf "%a: syntax error: %s@." Position.File.format pos s;
      raise Exit

let _ = 
  for _i = 0 to 100 do
    test (random 20)
  done;