Re: [Caml-list] Two Different Exception Behaviors in camlp4 on the toplevel

[Joseph Young <ocaml@optimojoe.com>]

 	The type checking using phantom types worked great.  Thanks.  In 
case it helps anyone else, I'm attaching complete working code below.

Joe

----------------------------
$ cat calc.ml
open Camlp4.PreCast;;
module CamlSyntax=
     Camlp4OCamlParser.Make(
         Camlp4OCamlRevisedParser.Make(
             Camlp4.PreCast.Syntax));;

(* The AST for the small calculator *)
type loc=CamlSyntax.Loc.t
type nonterminal=[`Add | `Sub | `Or | `And | `MixedFn];;
type terminal=[`Int of int | `Bool of bool | `Ocaml of (loc*string)];;
type calc=
| Nonterm of loc*nonterminal*(calc list)
| Term of loc*terminal;;

module TypeChecker : sig
     type 'a t
     val add : loc->int t->int t->int t
     val sub : loc->int t->int t->int t
     val or_: loc->bool t->bool t->bool t
     val and_: loc->bool t->bool t->bool t
     val mixed: loc->bool t->int t->int t
     val int_: loc->int -> int t
     val bool_: loc->bool -> bool t
     val expose : 'a t->calc
end = struct
     type 'a t=calc
     let add loc e1 e2 = Nonterm (loc,`Add,[e1;e2])
     let sub loc e1 e2 = Nonterm (loc,`Sub,[e1;e2])
     let or_ loc e1 e2 = Nonterm (loc,`Or,[e1;e2])
     let and_ loc e1 e2 = Nonterm (loc,`And,[e1;e2])
     let mixed loc e1 e2 = Nonterm (loc,`MixedFn,[e1;e2])
     let int_ loc i = Term (loc,`Int i)
     let bool_ loc b = Term (loc,`Bool b)
     let expose e=e
end;;

open TypeChecker;;

(* Grammar for a simple calculator *)
module CalcGram = Camlp4.PreCast.MakeGram(Camlp4.PreCast.Lexer);;
let (term:calc CalcGram.Entry.t)= CalcGram.Entry.mk "term";;
let term_eoi = CalcGram.Entry.mk "Simple calculator quotation";;
EXTEND CalcGram
     GLOBAL: term term_eoi;
     term:
     [ "alg"
         [ e1 = SELF; "+"; e2 = SELF -> Nonterm(_loc,`Add,[e1;e2])
         | e1 = SELF; "-"; e2 = SELF -> Nonterm(_loc,`Sub,[e1;e2])]
     | "bool"
         [ e1 = SELF; "or"; e2 = SELF -> Nonterm(_loc,`Or,[e1;e2])
         | e1 = SELF; "and"; e2 = SELF -> Nonterm(_loc,`And,[e1;e2])]
     | "other"
         [ e1 = SELF; "mix"; e2= SELF -> Nonterm(_loc,`MixedFn,[e1;e2])]
     | "simple"
         [ "$"; `STRING (e,_); "$" -> Term(_loc,`Ocaml (_loc,e))
         | `INT (i, _)  -> Term(_loc,`Int i)
         | "true" -> Term(_loc,`Bool true)
         | "false" -> Term(_loc,`Bool false)
         | "("; e = term; ")" -> e ]
     ];
     term_eoi:
     [[ t = term; `EOI -> t ]];
END;;

(* Generates an expression with the location information *)
let expr_of_loc _loc=
     let (a, b, c, d, e, f, g, h) = CamlSyntax.Loc.to_tuple _loc in
     <:expr< Loc.of_tuple ($`str:a$, $`int:b$, $`int:c$, $`int:d$,
         $`int:e$, $`int:f$, $`int:g$, $`bool:h$) >>
;;

(* Generates an expression with the nonterminal information *)
let expr_of_nonterm _loc name=
     match name with
     | `Add -> <:expr< add >>
     | `Sub -> <:expr< sub >>
     | `Or -> <:expr< or_ >>
     | `And -> <:expr< and_ >>
     | `MixedFn -> <:expr< mixed >>
;;

(* Generates an expression with the terminal information *)
let expr_of_term _loc e=
     let expr_loc=expr_of_loc _loc in
     match e with
     | `Int i -> <:expr< int_ $expr_loc$ $`int:i$ >>
     | `Bool b -> <:expr< bool_ $expr_loc$ $`bool:b$ >>
     | `Ocaml(l,e) -> CamlSyntax.Gram.parse_string CamlSyntax.expr_eoi l e
;;

(* Converts a calculator AST into an OCaml AST *)
let to_expr base_loc prog=
     let e=CalcGram.parse_string term_eoi base_loc prog in
     let rec to_expr e=
         match e with
         | Nonterm (_loc,name,[e1;e2]) ->
             let constr= expr_of_nonterm _loc name in
             let e1=to_expr e1 in
             let e2=to_expr e2 in
             <:expr< $constr$ $expr_of_loc _loc$ $e1$ $e2$>>
         | Term (_loc,data) ->
             let data= expr_of_term _loc data in
             <:expr< $data$ >>
         | _ -> failwith ("Wrong number of arguments.")
     in
     to_expr e
;;

let expand_calc_quot loc lopt e= to_expr loc e;;

Syntax.Quotation.add "calc" Syntax.Quotation.DynAst.expr_tag 
expand_calc_quot;;

----------------------------

$  cat Makefile
all:
         ocamlc -c -I +camlp4 -I +camlp4/Camlp4Parsers -pp camlp4of -o 
calc.cmo calc.ml

----------------------------