Commit 30dda877 authored by Andrei Paskevich's avatar Andrei Paskevich

qualified names + Add Rec LoadPath in Coq printer

parent b92e64bc
...@@ -104,6 +104,26 @@ type info = { ...@@ -104,6 +104,26 @@ type info = {
realization : (Theory.theory * ident_printer) Mid.t option; realization : (Theory.theory * ident_printer) Mid.t option;
} }
let print_path = print_list (constant_string ".") string
let print_id fmt id = string fmt (id_unique iprinter id)
let print_id_real info fmt id = match info.realization with
| Some m ->
begin
try let th,ipr = Mid.find id m in
fprintf fmt "%a.%s.%s"
print_path th.Theory.th_path
th.Theory.th_name.id_string
(id_unique ipr id)
with Not_found -> print_id fmt id
end
| None -> print_id fmt id
let print_ls_real info fmt ls = print_id_real info fmt ls.ls_name
let print_ts_real info fmt ts = print_id_real info fmt ts.ts_name
let print_pr_real info fmt pr = print_id_real info fmt pr.pr_name
(** Types *) (** Types *)
let rec print_ty info fmt ty = match ty.ty_node with let rec print_ty info fmt ty = match ty.ty_node with
...@@ -121,8 +141,8 @@ let rec print_ty info fmt ty = match ty.ty_node with ...@@ -121,8 +141,8 @@ let rec print_ty info fmt ty = match ty.ty_node with
| None -> | None ->
begin begin
match tl with match tl with
| [] -> print_ts fmt ts | [] -> (print_ts_real info) fmt ts
| l -> fprintf fmt "(%a@ %a)" print_ts ts | l -> fprintf fmt "(%a@ %a)" (print_ts_real info) ts
(print_list space (print_ty info)) l (print_list space (print_ty info)) l
end end
end end
...@@ -163,9 +183,9 @@ let rec print_pat info fmt p = match p.pat_node with ...@@ -163,9 +183,9 @@ let rec print_pat info fmt p = match p.pat_node with
| Papp (cs,pl) -> | Papp (cs,pl) ->
begin match query_syntax info.info_syn cs.ls_name with begin match query_syntax info.info_syn cs.ls_name with
| Some s -> syntax_arguments s (print_pat info) fmt pl | Some s -> syntax_arguments s (print_pat info) fmt pl
| _ when pl = [] -> print_ls fmt cs | _ when pl = [] -> (print_ls_real info) fmt cs
| _ -> fprintf fmt "(%a %a)" | _ -> fprintf fmt "(%a %a)"
print_ls cs (print_list space (print_pat info)) pl (print_ls_real info) cs (print_list space (print_pat info)) pl
end end
let print_vsty_nopar info fmt v = let print_vsty_nopar info fmt v =
...@@ -250,10 +270,10 @@ and print_tnode opl opr info fmt t = match t.t_node with ...@@ -250,10 +270,10 @@ and print_tnode opl opr info fmt t = match t.t_node with
syntax_arguments s (print_term info) fmt tl syntax_arguments s (print_term info) fmt tl
| _ -> if unambig_fs fs | _ -> if unambig_fs fs
then then
if tl = [] then fprintf fmt "%a" print_ls fs if tl = [] then fprintf fmt "%a" (print_ls_real info) fs
else fprintf fmt "(%a %a)" print_ls fs else fprintf fmt "(%a %a)" (print_ls_real info) fs
(print_space_list (print_term info)) tl (print_space_list (print_term info)) tl
else fprintf fmt (protect_on opl "(%a%a:%a)") print_ls fs else fprintf fmt (protect_on opl "(%a%a:%a)") (print_ls_real info) fs
(print_paren_r (print_term info)) tl (print_ty info) (t_type t) (print_paren_r (print_term info)) tl (print_ty info) (t_type t)
end end
| Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t)
...@@ -301,7 +321,7 @@ and print_fnode opl opr info fmt f = match f.t_node with ...@@ -301,7 +321,7 @@ and print_fnode opl opr info fmt f = match f.t_node with
| Tapp (ps, tl) -> | Tapp (ps, tl) ->
begin match query_syntax info.info_syn ps.ls_name with begin match query_syntax info.info_syn ps.ls_name with
| Some s -> syntax_arguments s (print_term info) fmt tl | Some s -> syntax_arguments s (print_term info) fmt tl
| _ -> fprintf fmt "(%a %a)" print_ls ps | _ -> fprintf fmt "(%a %a)" (print_ls_real info) ps
(print_space_list (print_term info)) tl (print_space_list (print_term info)) tl
end end
| Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f)
...@@ -665,24 +685,31 @@ let init_printer th = ...@@ -665,24 +685,31 @@ let init_printer th =
Sid.iter (fun id -> ignore (id_unique pr id)) th.Theory.th_local; Sid.iter (fun id -> ignore (id_unique pr id)) th.Theory.th_local;
pr pr
let print_task _env pr thpr realize ?old fmt task = let print_task env pr thpr realize ?old fmt task =
forget_all (); forget_all ();
print_prelude fmt pr; print_prelude fmt pr;
print_th_prelude task fmt thpr; print_th_prelude task fmt thpr;
let realization,decls = let realization,decls =
if realize then if realize then
let used = Task.used_theories task in let used = Task.used_theories task in
let used = Mid.filter (fun _ th -> th.Theory.th_path <> []) used in
(* 2 cases: goal is clone T with [] or goal is a real goal *) (* 2 cases: goal is clone T with [] or goal is a real goal *)
let used = match task with let used = match task with
| None -> assert false | None -> assert false
| Some { Task.task_decl = { Theory.td_node = Theory.Clone (th,_) }} -> | Some { Task.task_decl = { Theory.td_node = Theory.Clone (th,_) }} ->
Sid.iter (fun id -> ignore (id_unique iprinter id)) th.Theory.th_local; Sid.iter
(fun id -> ignore (id_unique iprinter id))
th.Theory.th_local;
Mid.remove th.Theory.th_name used Mid.remove th.Theory.th_name used
| _ -> used | _ -> used
in in
(* output the Require commands *) (* output the Require commands *)
List.iter
(fprintf fmt "Add Rec LoadPath \"%s\".@\n")
(Env.get_loadpath env);
Mid.iter Mid.iter
(fun id _th -> fprintf fmt "Require %s.@." id.id_string) (fun id th -> fprintf fmt "Require %a.%s.@\n"
print_path th.Theory.th_path id.id_string)
used; used;
let symbols = Task.used_symbols used in let symbols = Task.used_symbols used in
(* build the printers for each theories *) (* build the printers for each theories *)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment