That seems to have done the trick. Thanks for adding that function. The overall solution is a little awkward, so if you take requests, it would be nice if this process is streamlined in future versions. In other words, it would be nice if there was an easier way to pass through location information into the final AST and an easier way to throw errors with this information. In case anyone else wants to see the final solution, I'm attaching it below:
----------------------------------
$ 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)*string*alg list
| Int of (Ploc.t*string)*int
| Flo of (Ploc.t*string)*float;;
let get_loc l=
let l=
let qloc=Pcaml.quotation_location () in
Ploc.shift (Ploc.first_pos qloc) l
in
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$),
$str:!Pcaml.input_file$),
$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$),
$str:!Pcaml.input_file$),
$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:!Pcaml.input_file$),
$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$),
$str:!Pcaml.input_file$),
$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$),
$str:!Pcaml.input_file$),
$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:!Pcaml.input_file$),
$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=
let loc=Ploc.dummy in
<:expr< Alg.check_and_ret $to_expr (parse s)$ >>
;;
let expand_patt s=
let loc=Ploc.dummy in
<:patt< Alg.check_and_ret $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 report_err loc fname exc=
let loc_fmt =
match Sys.os_type with
| "MacOS" ->
("File \"%s\"; line %d; characters %d to %d\n### "
: ('a, 'b, 'c) format)
| _ -> ("File \"%s\", line %d, characters %d-%d:\n"
: ('a, 'b, 'c) format)
in
let (file, line, c1, c2)=Ploc.from_file fname loc in
Printf.eprintf loc_fmt file line c1 c2; flush
stderr;
raise exc
;;
let rec type_expr=function
| App ((loc,fname),f,args) ->
(match f with
| "add" ->
if List.length args != 2 then
report_err loc fname 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)
| _ -> report_err loc fname TypeError)
| Int _ -> `Int
| Flo _ -> `Real
;;
let rec check_and_ret e=
let _=type_expr e in e
;;
----------------------------------