summaryrefslogtreecommitdiff
path: root/dev/top_printers.ml
diff options
context:
space:
mode:
Diffstat (limited to 'dev/top_printers.ml')
-rw-r--r--dev/top_printers.ml206
1 files changed, 103 insertions, 103 deletions
diff --git a/dev/top_printers.ml b/dev/top_printers.ml
index a3d5cf5c..ba0c5440 100644
--- a/dev/top_printers.ml
+++ b/dev/top_printers.ml
@@ -1,24 +1,25 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
(* Printers for the ocaml toplevel. *)
+open Sorts
open Util
open Pp
open Names
open Libnames
open Globnames
-open Nameops
open Univ
open Environ
open Printer
-open Term
-open Evd
+open Constr
open Goptions
open Genarg
open Clenv
@@ -26,85 +27,82 @@ open Clenv
let _ = Detyping.print_evar_arguments := true
let _ = Detyping.print_universes := true
let _ = set_bool_option_value ["Printing";"Matching"] false
-let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found)
+let _ = Detyping.set_detype_anonymous (fun ?loc _ -> raise Not_found)
(* std_ppcmds *)
-let pp x = Pp.pp_with !Pp_control.std_ft x
+let pp x = Pp.pp_with !Topfmt.std_ft x
(** Future printer *)
let ppfuture kx = pp (Future.print (fun _ -> str "_") kx)
(* name printers *)
-let ppid id = pp (pr_id id)
-let pplab l = pp (pr_lab l)
+let ppid id = pp (Id.print id)
+let pplab l = pp (Label.print l)
let ppmbid mbid = pp (str (MBId.debug_to_string mbid))
-let ppdir dir = pp (pr_dirpath dir)
+let ppdir dir = pp (DirPath.print dir)
let ppmp mp = pp(str (ModPath.debug_to_string mp))
-let ppcon con = pp(debug_pr_con con)
-let ppproj con = pp(debug_pr_con (Projection.constant con))
+let ppcon con = pp(Constant.debug_print con)
+let ppproj con = pp(Constant.debug_print (Projection.constant con))
let ppkn kn = pp(str (KerName.to_string kn))
-let ppmind kn = pp(debug_pr_mind kn)
-let ppind (kn,i) = pp(debug_pr_mind kn ++ str"," ++int i)
+let ppmind kn = pp(MutInd.debug_print kn)
+let ppind (kn,i) = pp(MutInd.debug_print kn ++ str"," ++int i)
let ppsp sp = pp(pr_path sp)
let ppqualid qid = pp(pr_qualid qid)
let ppclindex cl = pp(Classops.pr_cl_index cl)
let ppscheme k = pp (Ind_tables.pr_scheme_kind k)
-let pprecarg = function
+let prrecarg = function
| Declarations.Norec -> str "Norec"
| Declarations.Mrec (mind,i) ->
str "Mrec[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]"
| Declarations.Imbr (mind,i) ->
str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]"
-let ppwf_paths x = pp (Rtree.pp_tree pprecarg x)
-
-let pprecarg = function
- | Declarations.Norec -> str "Norec"
- | Declarations.Mrec (mind,i) ->
- str "Mrec[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]"
- | Declarations.Imbr (mind,i) ->
- str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]"
-let ppwf_paths x = pp (Rtree.pp_tree pprecarg x)
+let ppwf_paths x = pp (Rtree.pp_tree prrecarg x)
(* term printers *)
+let envpp pp = let sigma,env = Pfedit.get_current_context () in pp env sigma
let rawdebug = ref false
-let ppevar evk = pp (str (Evd.string_of_existential evk))
-let ppconstr x = pp (Termops.print_constr x)
+let ppevar evk = pp (Evar.print evk)
+let ppconstr x = pp (Termops.print_constr (EConstr.of_constr x))
+let ppeconstr x = pp (Termops.print_constr x)
let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x)
-let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr x)
-let ppterm = ppconstr
let ppsconstr x = ppconstr (Mod_subst.force_constr x)
let ppconstr_univ x = Constrextern.with_universes ppconstr x
-let ppglob_constr = (fun x -> pp(pr_lglob_constr x))
-let pppattern = (fun x -> pp(pr_constr_pattern x))
-let pptype = (fun x -> try pp(pr_ltype x) with e -> pp (str (Printexc.to_string e)))
+let ppglob_constr = (fun x -> pp(pr_lglob_constr_env (Global.env()) x))
+let pppattern = (fun x -> pp(envpp pr_constr_pattern_env x))
+let pptype = (fun x -> try pp(envpp pr_ltype_env x) with e -> pp (str (Printexc.to_string e)))
let ppfconstr c = ppconstr (CClosure.term_of_fconstr c)
let ppbigint n = pp (str (Bigint.to_string n));;
let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]"
let ppintset l = pp (prset int (Int.Set.elements l))
-let ppidset l = pp (prset pr_id (Id.Set.elements l))
+let ppidset l = pp (prset Id.print (Id.Set.elements l))
let prset' pr l = str "[" ++ hov 0 (prlist_with_sep pr_comma pr l) ++ str "]"
let pridmap pr l =
- let pr (id,b) = pr_id id ++ str "=>" ++ pr id b in
+ let pr (id,b) = Id.print id ++ str "=>" ++ pr id b in
prset' pr (Id.Map.fold (fun a b l -> (a,b)::l) l [])
-
let ppidmap pr l = pp (pridmap pr l)
+let pridmapgen l =
+ let dom = Id.Set.elements (Id.Map.domain l) in
+ if dom = [] then str "[]" else
+ str "[domain= " ++ hov 0 (prlist_with_sep spc Id.print dom) ++ str "]"
+let ppidmapgen l = pp (pridmapgen l)
+
let ppevarsubst = ppidmap (fun id0 -> prset (fun (c,copt,id) ->
hov 0
- (Termops.print_constr c ++
+ (Termops.print_constr (EConstr.of_constr c) ++
(match copt with None -> mt () | Some c -> spc () ++ str "<expanded: " ++
- Termops.print_constr c ++ str">") ++
+ Termops.print_constr (EConstr.of_constr c) ++ str">") ++
(if id = id0 then mt ()
- else spc () ++ str "<canonical: " ++ pr_id id ++ str ">"))))
+ else spc () ++ str "<canonical: " ++ Id.print id ++ str ">"))))
-let prididmap = pridmap (fun _ -> pr_id)
-let ppididmap = ppidmap (fun _ -> pr_id)
+let prididmap = pridmap (fun _ -> Id.print)
+let ppididmap = ppidmap (fun _ -> Id.print)
let prconstrunderbindersidmap = pridmap (fun _ (l,c) ->
hov 1 (str"[" ++ prlist_with_sep spc Id.print l ++ str"]")
@@ -113,10 +111,9 @@ let prconstrunderbindersidmap = pridmap (fun _ (l,c) ->
let ppconstrunderbindersidmap l = pp (prconstrunderbindersidmap l)
let ppunbound_ltac_var_map l = ppidmap (fun _ arg ->
- str"<genarg:" ++ pr_argument_type(genarg_tag arg) ++ str">")
-
-open Glob_term
+ str"<genarg:" ++ pr_argument_type(genarg_tag arg) ++ str">") l
+open Ltac_pretype
let rec pr_closure {idents=idents;typed=typed;untyped=untyped} =
hov 1 (str"{idents=" ++ prididmap idents ++ str";" ++ spc() ++
str"typed=" ++ prconstrunderbindersidmap typed ++ str";" ++ spc() ++
@@ -124,7 +121,7 @@ let rec pr_closure {idents=idents;typed=typed;untyped=untyped} =
and pr_closed_glob_constr_idmap x =
pridmap (fun _ -> pr_closed_glob_constr) x
and pr_closed_glob_constr {closure=closure;term=term} =
- pr_closure closure ++ pr_lglob_constr term
+ pr_closure closure ++ (pr_lglob_constr_env Global.(env ())) term
let ppclosure x = pp (pr_closure x)
let ppclosedglobconstr x = pp (pr_closed_glob_constr x)
@@ -133,40 +130,40 @@ let ppclosedglobconstridmap x = pp (pr_closed_glob_constr_idmap x)
let pP s = pp (hov 0 s)
let safe_pr_global = function
- | ConstRef kn -> pp (str "CONSTREF(" ++ debug_pr_con kn ++ str ")")
- | IndRef (kn,i) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++
+ | ConstRef kn -> pp (str "CONSTREF(" ++ Constant.debug_print kn ++ str ")")
+ | IndRef (kn,i) -> pp (str "INDREF(" ++ MutInd.debug_print kn ++ str "," ++
int i ++ str ")")
- | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++
+ | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ MutInd.debug_print kn ++ str "," ++
int i ++ str "," ++ int j ++ str ")")
- | VarRef id -> pp (str "VARREF(" ++ pr_id id ++ str ")")
+ | VarRef id -> pp (str "VARREF(" ++ Id.print id ++ str ")")
let ppglobal x = try pp(pr_global x) with _ -> safe_pr_global x
let ppconst (sp,j) =
- pp (str"#" ++ pr_kn sp ++ str"=" ++ pr_lconstr j.uj_val)
+ pp (str"#" ++ KerName.print sp ++ str"=" ++ envpp pr_lconstr_env j.uj_val)
let ppvar ((id,a)) =
- pp (str"#" ++ pr_id id ++ str":" ++ pr_lconstr a)
+ pp (str"#" ++ Id.print id ++ str":" ++ envpp pr_lconstr_env a)
let genppj f j = let (c,t) = f j in (c ++ str " : " ++ t)
-let ppj j = pp (genppj pr_ljudge j)
+let ppj j = pp (genppj (envpp pr_ljudge_env) j)
-let prsubst s = pp (Mod_subst.debug_pr_subst s)
-let prdelta s = pp (Mod_subst.debug_pr_delta s)
+let ppsubst s = pp (Mod_subst.debug_pr_subst s)
+let ppdelta s = pp (Mod_subst.debug_pr_delta s)
let pp_idpred s = pp (pr_idpred s)
let pp_cpred s = pp (pr_cpred s)
let pp_transparent_state s = pp (pr_transparent_state s)
-let pp_stack_t n = pp (Reductionops.Stack.pr Termops.print_constr n)
+let pp_stack_t n = pp (Reductionops.Stack.pr (EConstr.of_constr %> Termops.print_constr) n)
let pp_cst_stack_t n = pp (Reductionops.Cst_stack.pr n)
let pp_state_t n = pp (Reductionops.pr_state n)
(* proof printers *)
let pr_evar ev = Pp.int (Evar.repr ev)
-let ppmetas metas = pp(pr_metaset metas)
-let ppevm evd = pp(pr_evar_map ~with_univs:!Flags.univ_print (Some 2) evd)
-let ppevmall evd = pp(pr_evar_map ~with_univs:!Flags.univ_print None evd)
+let ppmetas metas = pp(Termops.pr_metaset metas)
+let ppevm evd = pp(Termops.pr_evar_map ~with_univs:!Flags.univ_print (Some 2) evd)
+let ppevmall evd = pp(Termops.pr_evar_map ~with_univs:!Flags.univ_print None evd)
let pr_existentialset evars =
prlist_with_sep spc pr_evar (Evar.Set.elements evars)
let ppexistentialset evars =
@@ -177,14 +174,14 @@ let ppexistentialfilter filter = match Evd.Filter.repr filter with
let ppclenv clenv = pp(pr_clenv clenv)
let ppgoalgoal gl = pp(Goal.pr_goal gl)
let ppgoal g = pp(Printer.pr_goal g)
-let ppgoalsigma g = pp(Printer.pr_goal g ++ pr_evar_map None (Refiner.project g))
-let pphintdb db = pp(Hints.pr_hint_db db)
+let ppgoalsigma g = pp(Printer.pr_goal g ++ Termops.pr_evar_map None (Refiner.project g))
+let pphintdb db = pp(envpp Hints.pr_hint_db_env db)
let ppproofview p =
let gls,sigma = Proofview.proofview p in
- pp(pr_enum Goal.pr_goal gls ++ fnl () ++ pr_evar_map (Some 1) sigma)
+ pp(pr_enum Goal.pr_goal gls ++ fnl () ++ Termops.pr_evar_map (Some 1) sigma)
let ppopenconstr (x : Evd.open_constr) =
- let (evd,c) = x in pp (pr_evar_map (Some 2) evd ++ pr_constr c)
+ let (evd,c) = x in pp (Termops.pr_evar_map (Some 2) evd ++ envpp pr_constr_env c)
(* spiwack: deactivated until a replacement is found
let pppftreestate p = pp(print_pftreestate p)
*)
@@ -200,11 +197,11 @@ let pppftreestate p = pp(print_pftreestate p)
(* let ppsigmagoal g = pp(pr_goal (sig_it g)) *)
(* let prgls gls = pp(pr_gls gls) *)
(* let prglls glls = pp(pr_glls glls) *)
-(* let pproof p = pp(print_proof Evd.empty empty_named_context p) *)
-let ppuni u = pp(pr_uni u)
+let pproof p = pp(Proof.pr_proof p)
+
+let ppuni u = pp(Universe.pr u)
let ppuni_level u = pp (Level.pr u)
-let ppuniverse u = pp (str"[" ++ Universe.pr u ++ str"]")
let prlev = Universes.pr_with_global_universes
let ppuniverse_set l = pp (LSet.pr prlev l)
@@ -214,12 +211,14 @@ let ppuniverse_context_set l = pp (pr_universe_context_set prlev l)
let ppuniverse_subst l = pp (Univ.pr_universe_subst l)
let ppuniverse_opt_subst l = pp (Universes.pr_universe_opt_subst l)
let ppuniverse_level_subst l = pp (Univ.pr_universe_level_subst l)
-let ppevar_universe_context l = pp (Evd.pr_evar_universe_context l)
+let ppevar_universe_context l = pp (Termops.pr_evar_universe_context l)
let ppconstraints c = pp (pr_constraints Level.pr c)
let ppuniverseconstraints c = pp (Universes.Constraints.pr c)
let ppuniverse_context_future c =
let ctx = Future.force c in
ppuniverse_context ctx
+let ppcumulativity_info c = pp (Univ.pr_cumulativity_info Univ.Level.pr c)
+let ppabstract_cumulativity_info c = pp (Univ.pr_abstract_cumulativity_info Univ.Level.pr c)
let ppuniverses u = pp (UGraph.pr_universes Level.pr u)
let ppnamedcontextval e =
pp (pr_named_context (Global.env ()) Evd.empty (named_context_of_val e))
@@ -231,9 +230,9 @@ let ppenv e = pp
let ppenvwithcst e = pp
(str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++
str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]" ++ spc() ++
- str "{" ++ Cmap_env.fold (fun a _ s -> pr_con a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}")
+ str "{" ++ Cmap_env.fold (fun a _ s -> Constant.print a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}")
-let pptac = (fun x -> pp(Pptactic.pr_glob_tactic (Global.env()) x))
+let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (Global.env()) x))
let ppobj obj = Format.print_string (Libobject.object_tag obj)
@@ -247,7 +246,7 @@ let cast_kind_display k =
| NATIVEcast -> "NATIVEcast"
let constr_display csr =
- let rec term_display c = match kind_of_term c with
+ let rec term_display c = match kind c with
| Rel n -> "Rel("^(string_of_int n)^")"
| Meta n -> "Meta("^(string_of_int n)^")"
| Var id -> "Var("^(Id.to_string id)^")"
@@ -262,14 +261,14 @@ let constr_display csr =
"LetIn("^(name_display na)^","^(term_display b)^","
^(term_display t)^","^(term_display c)^")"
| App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n"
- | Evar (e,l) -> "Evar("^(string_of_existential e)^","^(array_display l)^")"
- | Const (c,u) -> "Const("^(string_of_con c)^","^(universes_display u)^")"
+ | Evar (e,l) -> "Evar("^(Pp.string_of_ppcmds (Evar.print e))^","^(array_display l)^")"
+ | Const (c,u) -> "Const("^(Constant.to_string c)^","^(universes_display u)^")"
| Ind ((sp,i),u) ->
- "MutInd("^(string_of_mind sp)^","^(string_of_int i)^","^(universes_display u)^")"
+ "MutInd("^(MutInd.to_string sp)^","^(string_of_int i)^","^(universes_display u)^")"
| Construct (((sp,i),j),u) ->
- "MutConstruct(("^(string_of_mind sp)^","^(string_of_int i)^"),"
+ "MutConstruct(("^(MutInd.to_string sp)^","^(string_of_int i)^"),"
^","^(universes_display u)^(string_of_int j)^")"
- | Proj (p, c) -> "Proj("^(string_of_con (Projection.constant p))^","^term_display c ^")"
+ | Proj (p, c) -> "Proj("^(Constant.to_string (Projection.constant p))^","^term_display c ^")"
| Case (ci,p,c,bl) ->
"MutCase(<abs>,"^(term_display p)^","^(term_display c)^","
^(array_display bl)^")"
@@ -316,10 +315,12 @@ let constr_display csr =
in
pp (str (term_display csr) ++fnl ())
+let econstr_display c = constr_display EConstr.Unsafe.(to_constr c) ;;
+
open Format;;
let print_pure_constr csr =
- let rec term_display c = match kind_of_term c with
+ let rec term_display c = match Constr.kind c with
| Rel n -> print_string "#"; print_int n
| Meta n -> print_string "Meta("; print_int n; print_string ")"
| Var id -> print_string (Id.to_string id)
@@ -437,7 +438,7 @@ let print_pure_constr csr =
| ("Coq"::_::l) -> l
| l -> l
in List.iter (fun x -> print_string x; print_string ".") ls;*)
- print_string (debug_string_of_mind sp)
+ print_string (MutInd.debug_to_string sp)
and sp_con_display sp =
(* let dir,l = decode_kn sp in
let ls =
@@ -446,7 +447,7 @@ let print_pure_constr csr =
| ("Coq"::_::l) -> l
| l -> l
in List.iter (fun x -> print_string x; print_string ".") ls;*)
- print_string (debug_string_of_con sp)
+ print_string (Constant.debug_to_string sp)
in
try
@@ -455,7 +456,7 @@ let print_pure_constr csr =
print_string (Printexc.to_string e);print_flush ();
raise e
-let ppfconstr c = ppconstr (CClosure.term_of_fconstr c)
+let print_pure_econstr c = print_pure_constr EConstr.Unsafe.(to_constr c) ;;
let pploc x = let (l,r) = Loc.unloc x in
print_string"(";print_int l;print_string",";print_int r;print_string")"
@@ -490,7 +491,7 @@ let in_current_context f c =
let (evmap,sign) = Pfedit.get_current_context () in
f (fst (Constrintern.interp_constr sign evmap c))(*FIXME*)
-(* We expand the result of preprocessing to be independent of camlp4
+(* We expand the result of preprocessing to be independent of camlp5
VERNAC COMMAND EXTEND PrintPureConstr
| [ "PrintPureConstr" constr(c) ] -> [ in_current_context print_pure_constr c ]
@@ -500,9 +501,8 @@ VERNAC COMMAND EXTEND PrintConstr
END
*)
-open Pcoq
open Genarg
-open Constrarg
+open Stdarg
open Egramml
let _ =
@@ -511,7 +511,7 @@ let _ =
(function
[c] when genarg_tag c = unquote (topwit wit_constr) && true ->
let c = out_gen (rawwit wit_constr) c in
- (fun () -> in_current_context constr_display c)
+ (fun ~atts ~st -> in_current_context econstr_display c; st)
| _ -> failwith "Vernac extension: cannot occur")
with
e -> pp (CErrors.print e)
@@ -519,7 +519,7 @@ let _ =
extend_vernac_command_grammar ("PrintConstr", 0) None
[GramTerminal "PrintConstr";
GramNonTerminal
- (Loc.ghost,rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr)]
+ (Loc.tag (Some (rawwit wit_constr),Extend.Aentry Pcoq.Constr.constr))]
let _ =
try
@@ -527,7 +527,7 @@ let _ =
(function
[c] when genarg_tag c = unquote (topwit wit_constr) && true ->
let c = out_gen (rawwit wit_constr) c in
- (fun () -> in_current_context print_pure_constr c)
+ (fun ~atts ~st -> in_current_context print_pure_econstr c; st)
| _ -> failwith "Vernac extension: cannot occur")
with
e -> pp (CErrors.print e)
@@ -535,47 +535,47 @@ let _ =
extend_vernac_command_grammar ("PrintPureConstr", 0) None
[GramTerminal "PrintPureConstr";
GramNonTerminal
- (Loc.ghost,rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr)]
+ (Loc.tag (Some (rawwit wit_constr),Extend.Aentry Pcoq.Constr.constr))]
(* Setting printer of unbound global reference *)
open Names
open Libnames
-let encode_path loc prefix mpdir suffix id =
+let encode_path ?loc prefix mpdir suffix id =
let dir = match mpdir with
| None -> []
| Some (mp,dir) ->
- (DirPath.repr (dirpath_of_string (string_of_mp mp))@
+ (DirPath.repr (dirpath_of_string (ModPath.to_string mp))@
DirPath.repr dir) in
- Qualid (loc, make_qualid
+ CAst.make ?loc @@ Qualid (make_qualid
(DirPath.make (List.rev (Id.of_string prefix::dir@suffix))) id)
-let raw_string_of_ref loc _ = function
+let raw_string_of_ref ?loc _ = function
| ConstRef cst ->
- let (mp,dir,id) = repr_con cst in
- encode_path loc "CST" (Some (mp,dir)) [] (Label.to_id id)
+ let (mp,dir,id) = Constant.repr3 cst in
+ encode_path ?loc "CST" (Some (mp,dir)) [] (Label.to_id id)
| IndRef (kn,i) ->
- let (mp,dir,id) = repr_mind kn in
- encode_path loc "IND" (Some (mp,dir)) [Label.to_id id]
+ let (mp,dir,id) = MutInd.repr3 kn in
+ encode_path ?loc "IND" (Some (mp,dir)) [Label.to_id id]
(Id.of_string ("_"^string_of_int i))
| ConstructRef ((kn,i),j) ->
- let (mp,dir,id) = repr_mind kn in
- encode_path loc "CSTR" (Some (mp,dir))
+ let (mp,dir,id) = MutInd.repr3 kn in
+ encode_path ?loc "CSTR" (Some (mp,dir))
[Label.to_id id;Id.of_string ("_"^string_of_int i)]
(Id.of_string ("_"^string_of_int j))
| VarRef id ->
- encode_path loc "SECVAR" None [] id
+ encode_path ?loc "SECVAR" None [] id
-let short_string_of_ref loc _ = function
- | VarRef id -> Ident (loc,id)
- | ConstRef cst -> Ident (loc,Label.to_id (pi3 (repr_con cst)))
- | IndRef (kn,0) -> Ident (loc,Label.to_id (pi3 (repr_mind kn)))
+let short_string_of_ref ?loc _ = function
+ | VarRef id -> CAst.make ?loc @@ Ident id
+ | ConstRef cst -> CAst.make ?loc @@ Ident (Label.to_id (pi3 (Constant.repr3 cst)))
+ | IndRef (kn,0) -> CAst.make ?loc @@ Ident (Label.to_id (pi3 (MutInd.repr3 kn)))
| IndRef (kn,i) ->
- encode_path loc "IND" None [Label.to_id (pi3 (repr_mind kn))]
+ encode_path ?loc "IND" None [Label.to_id (pi3 (MutInd.repr3 kn))]
(Id.of_string ("_"^string_of_int i))
| ConstructRef ((kn,i),j) ->
- encode_path loc "CSTR" None
- [Label.to_id (pi3 (repr_mind kn));Id.of_string ("_"^string_of_int i)]
+ encode_path ?loc "CSTR" None
+ [Label.to_id (pi3 (MutInd.repr3 kn));Id.of_string ("_"^string_of_int i)]
(Id.of_string ("_"^string_of_int j))
(* Anticipate that printers can be used from ocamldebug and that