That's very close to what I'd like, but quotations cause a problem. With quotations, it's impossible to type check during preprocessing. It must occur after the AST has been formed. In this case, Ploc.raise doesn't generate nice error messages like it does during preprocessing. Here's the offending code:
------------------------------
#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,loc)=lident; "("; xs=LIST1 SELF SEP ","; ")"-> PApp (loc,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< 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< 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< 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< 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< 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< 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
;;
------------------------------
How do you generate nice error messages with location information as they occur during preprocessing? As a corollary, is there an easier way to extract location information into the final AST other than removing each of the four integers, converting them to strings, and inserting them with antiquotations manually (Ploc.make $int:line_nb$ $int:bol_pos$
($int:bp$,$int:ep$))?