Source

ocaml-lib / syndesc / ex_expr.ml

Full commit
#load "monad.cmo"
#load "iso.cmo"
#load "syndesc.cmo"

(* example from the paper of Rendel and Ostermann *)

open Monad

type op =
  | AddOp
  | MulOp

let mulOp : (unit, op) Iso.t = Iso.elt MulOp
let addOp : (unit, op) Iso.t = Iso.elt AddOp

type expr =
  | Variable of string
  | Literal of int
  | BinOp of expr * op * expr
  | IfZero of expr * expr * expr

let variable : (string,expr) Iso.t =
  object
    method apply v = Some (Variable v)
    method unapply = function Variable v -> Some v | _ -> None
  end

let literal : (int,expr) Iso.t =
  object
    method apply i = Some (Literal i)
    method unapply = function Literal i -> Some i | _ -> None
  end

let binOp : (expr * (op * expr), expr) Iso.t =
  object
    method apply (e1,(op,e2)) = Some (BinOp (e1,op,e2))
    method unapply = function BinOp (e1,op,e2) -> Some (e1, (op, e2)) | _ -> None
  end

let ifZero : (expr * (expr * expr), expr) Iso.t =
  object
    method apply (e0, (e1,e2)) = Some (IfZero (e0,e1,e2))
    method unapply = function IfZero (e0,e1,e2) -> Some (e0, (e1,e2)) | _ -> None
  end

let keywords = ["ifzero"; "else"]

let is_letter = function 'a'..'z' | 'A'..'Z' -> true | _ -> false
let is_digit = function '0'..'9' -> true | _ -> false

open Syndesc

let letter : char Syndesc.t = map token (Iso.subset is_letter)
let digit : char Syndesc.t = map token (Iso.subset is_digit)

let identifier : string Syndesc.t =
  map
    (seq letter (many (alt letter digit)))
    (Iso.seq Iso.cons (Iso.seq Iso.string_of_list (Iso.subset (fun id -> not (List.mem id keywords)))))

let keyword (kwd : string) : unit Syndesc.t =
  map
    (either identifier (text kwd))
    (Iso.inverse Iso.right)

let integer : int Syndesc.t =
  map
    (some digit)
    (Iso.seq Iso.string_of_list Iso.int_of_string)

let parens (p : 'a t) : 'a Syndesc.t = between (text "(") p (text ")")

let ops =
  alt
    (map (text "*") mulOp)
    (map (text "+") addOp)

let spaced_ops = between opt_space ops opt_space

let priority = function
  | MulOp -> 1
  | AddOp -> 2

let binOpPrio n =
  Iso.seq
    (Iso.subset (fun (x, (op, y)) -> priority op = n))
    binOp

let del_exp2 = delegate ()

let rec exp0 () =
  alt (map integer literal)
    (alt (map identifier variable)
       (alt (map (ifzero ()) ifZero)
	  (parens (between skip_space (del_exp2 :> expr Syndesc.t) skip_space))))
and exp1 () =
  chainl1 (exp0 ()) spaced_ops (binOpPrio 1)
and exp2 () =
  chainl1 (exp1 ()) spaced_ops (binOpPrio 2)
and ifzero () =
  prefix (keyword "ifzero")
    (prefix opt_space
       (seq (parens (del_exp2 :> expr Syndesc.t))
	  (prefix opt_space
	     (seq (parens (del_exp2 :> expr Syndesc.t))
		(prefix opt_space
		   (prefix (keyword "else")
		      (prefix opt_space
			 (parens (del_exp2 :> expr Syndesc.t)))))))))


let expression =
  del_exp2#set (exp2 ());
  close (del_exp2 :> expr Syndesc.t)