Re: [Caml-list] How to Create Sensible Debugging Information when Dynamically Typechecking Code Generated with camlp5 Quotations

[echinuz echinuz <echinuz@yahoo.com>]

[-- Attachment #1: Type: text/plain, Size: 7979 bytes --]

Without quotations, the code looks like:

---------------------------------------
$ cat alg.ml
#load "pa_extend.cmo";;
#load "q_MLast.cmo";;

(* Parser *)
type palg=
| PApp of Ploc.t*string*palg list 
| PInt of Ploc.t*string 
| PFlo of Ploc.t*string;;


let g=Grammar.gcreate (Plexer.gmake ());;
let exp_eoi = Grammar.Entry.create g "exp_eoi";;

EXTEND
    GLOBAL: exp_eoi;
    exp_eoi:
        [[ x = exp; EOI -> x ]] ;
    exp:
        [[x=INT -> PInt (loc,x)
        | x=FLOAT -> PFlo (loc,x)
        | (f,floc)=lident; "("; xs=LIST1 SELF SEP ","; ")"->PApp (floc,f,xs)]];
    lident:
        [[x = LIDENT -> (x, loc)]]; 
END;;

let parse s = Grammar.Entry.parse exp_eoi (Stream.of_string s);;

(* Type Checker *)
exception TypeError;;
type integer=[`Int];;
type real=[integer | `Real];;
let rec type_expr=function
    | PApp (loc,f,args) ->
        (match f with
        | "add" ->
            if List.length args != 2 then
                Ploc.raise loc TypeError
            else
                let args=List.map type_expr args in 
                (match (List.nth args 0,List.nth args 1) with
                | #integer,#integer -> `Int
                | #real,#real -> `Real)
        | _ -> Ploc.raise loc TypeError)
    | PInt _ -> `Int
    | PFlo _ -> `Real
;;


(* Quotations *)
type alg=
| App of string*alg list
| Int of int
| Flo of float;;

let loc=Ploc.dummy;;
let rec to_expr=function
    | PInt (loc,x)-> <:expr< Alg.Int $int:x$ >>
    | PFlo (loc,x)-> <:expr< Alg.Flo $flo:x$ >>
    | PApp (loc,f,el)->
        let rec make_el=function
            | x::xs -> <:expr< [$x$::$make_el xs$] >>
            | [] -> <:expr< [] >>
        in
        let el=List.map to_expr el in
        let el=make_el el in
        <:expr< Alg.App ($str:f$,$el$) >>
;;
let rec to_patt=function
    | PInt (loc,x)-> <:patt< Alg.Int $int:x$ >>
    | PFlo (loc,x)-> <:patt< Alg.Flo $flo:x$ >>
    | PApp (loc,f,el)->
        let rec make_el=function
            | x::xs -> <:patt< [$x$::$make_el xs$] >>
            | [] -> <:patt< [] >>
        in
        let el=List.map to_patt el in
        let el=make_el el in
        <:patt< Alg.App ($str:f$,$el$) >>
;;

let expand_expr s=
    let p=parse s in
    let t=type_expr p in
    to_expr p
;;
let expand_patt s=
    let p=parse s in
    let t=type_expr p in
    to_patt p
;;
Quotation.add "exp" (Quotation.ExAst (expand_expr,expand_patt));;
---------------------------------------

When run on the test file:

---------------------------------------
 $ cat test.ml
let x=2;; 
let x=3;;
let x=4;;
let y= <:exp< add(1,2,3) >>;;
---------------------------------------

We receive the error:

---------------------------------------
ocamlc -I +camlp5 -pp "camlp5o ./alg.cmo" test.ml -o test
File "test.ml", line 4, characters 14-17:
While expanding quotation "exp":
Uncaught exception: Alg.TypeError
Preprocessor error
make: *** [all] Error 2
---------------------------------------

This is a good error message and exactly what I want.  Now, we modify the above code to add quotations:

---------------------------------------
$ cat alg.ml
#load "pa_extend.cmo";;
#load "q_MLast.cmo";;

(* Parser *)
type palg=
| PApp of Ploc.t*string*palg list 
| PInt of Ploc.t*string 
| PFlo of Ploc.t*string
| PQuote of Ploc.t*string;;

let g=Grammar.gcreate (Plexer.gmake ());;
let exp_eoi = Grammar.Entry.create g "exp_eoi";;

EXTEND
    GLOBAL: exp_eoi;
    exp_eoi:
        [[ x = exp; EOI -> x ]] ;
    exp:
        [[x=INT -> PInt (loc,x)
        | x=FLOAT -> PFlo (loc,x)
        | (f,floc)=lident; "("; xs=LIST1 SELF SEP ","; ")"-> PApp (floc,f,xs)
        | x=ANTIQUOT-> PQuote(loc,x)]];
    lident:
        [[x = LIDENT -> (x, loc)]]; 
END;;

let parse s = Grammar.Entry.parse exp_eoi (Stream.of_string s);;

(* Quotations *)
type alg=
| App of Ploc.t*string*alg list
| Int of Ploc.t*int
| Flo of Ploc.t*float;;

let get_loc l=
    string_of_int (Ploc.line_nb l),
    string_of_int (Ploc.bol_pos l),
    string_of_int (Ploc.first_pos l),
    string_of_int (Ploc.last_pos l)
;;
let rec to_expr=function
    | PInt (loc,x)->
        let line_nb,bol_pos,bp,ep=get_loc loc in
        <:expr< Alg.Int (
            Ploc.make$int:line_nb$ $int:bol_pos$ ($int:bp$,$int:ep$),
            $int:x$) >>
    | PFlo (loc,x)-> 
        let line_nb,bol_pos,bp,ep=get_loc loc in
        <:expr< Alg.Flo (
            Ploc.make $int:line_nb$ $int:bol_pos$ ($int:bp$,$int:ep$),
            $flo:x$) >>
    | PApp (loc,f,el)->
        let line_nb,bol_pos,bp,ep=get_loc loc in
        let rec make_el=function
            | x::xs -> <:expr< [$x$::$make_el xs$] >>
            | [] -> <:expr< [] >>
        in
        let el=List.map to_expr el in
        let el=make_el el in
        <:expr< Alg.App(
            Ploc.make $int:line_nb$ $int:bol_pos$ ($int:bp$,$int:ep$),
            $str:f$,$el$) >>
    | PQuote (loc,x)->
        let loc=Ploc.make (Ploc.line_nb loc) (Ploc.bol_pos loc)
            (Ploc.first_pos loc + 1,Ploc.last_pos loc + 1)
        in
        let x=Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string x) in
        <:expr< $anti:x$ >>
;;
let rec to_patt=function
    | PInt (loc,x)-> 
        let line_nb,bol_pos,bp,ep=get_loc loc in
        <:patt< Alg.Int (
            Ploc.make $int:line_nb$ $int:bol_pos$ ($int:bp$,$int:ep$),
            $int:x$) >>
    | PFlo (loc,x)-> 
        let line_nb,bol_pos,bp,ep=get_loc loc in
        <:patt< Alg.Flo (
            Ploc.make $int:line_nb$ $int:bol_pos$ ($int:bp$,$int:ep$),
            $flo:x$) >>
    | PApp (loc,f,el)->
        let line_nb,bol_pos,bp,ep=get_loc loc in
        let rec make_el=function
            | x::xs -> <:patt< [$x$::$make_el xs$] >>
            | [] -> <:patt< [] >>
        in
        let el=List.map to_patt el in
        let el=make_el el in
        <:patt< Alg.App (
            Ploc.make $int:line_nb$ $int:bol_pos$ ($int:bp$,$int:ep$),
            $str:f$,$el$) >>
    | PQuote (loc,x)->
        let loc=Ploc.make (Ploc.line_nb loc) (Ploc.bol_pos loc)
            (Ploc.first_pos loc + 1,Ploc.last_pos loc + 1)
        in
        let x=Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string x) in
        <:patt< $anti:x$ >>
;;

let expand_expr s=to_expr (parse s);;
let expand_patt s=to_patt (parse s);;

Quotation.add "exp" (Quotation.ExAst (expand_expr,expand_patt));;

(* Type Checker *)
exception TypeError;;
type integer=[`Int];;
type real=[integer | `Real];;
let rec type_expr=function
    | App (loc,f,args) ->
        (match f with
        | "add" ->
            if List.length args != 2 then
                Ploc.raise loc TypeError
            else
                let args=List.map type_expr args in 
                (match (List.nth args 0,List.nth args 1) with
                | #integer,#integer -> `Int
                | #real,#real -> `Real)
        | _ -> Ploc.raise loc TypeError)
    | Int _ -> `Int
    | Flo _ -> `Real
;;
---------------------------------------

Then, we use this program with the test file:

---------------------------------------
$ cat test.ml
let x=2;; 
let x=3;;
let x=4;;
let y= <:exp< add(1,2,3) >>;;
let z= Alg.type_expr y;;
---------------------------------------

Everything compiles fine since we no longer type check during compilation:

---------------------------------------
ocamlc -I +camlp5 -pp "camlp5o ./alg.cmo" camlp5.cma alg.cmo test.ml -o test
---------------------------------------

However, when we run the following executable, we receive the error:

---------------------------------------
$ ./test
Fatal error: exception Ploc.Exc(_, _)
---------------------------------------

This contains no location information since Plot.Exc is not caught and handled in the same manner as it is during preprocessing.  I would like an error similar to the first case, when there were no quotations, to be shown in the second case, when there are quotations.

Thanks for your help.

       
---------------------------------
Looking for last minute shopping deals?  Find them fast with Yahoo! Search.

[-- Attachment #2: Type: text/html, Size: 14037 bytes --]