Commits

Sébastien Ferré committed b079095

Initial revision

Comments (0)

Files changed (1)

+#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)