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.