diff options
Diffstat (limited to 'printing')
| -rw-r--r-- | printing/dune | 1 | ||||
| -rw-r--r-- | printing/ppconstr.ml | 6 | ||||
| -rw-r--r-- | printing/ppconstr.mli | 2 | ||||
| -rw-r--r-- | printing/prettyp.ml | 70 | ||||
| -rw-r--r-- | printing/prettyp.mli | 4 | ||||
| -rw-r--r-- | printing/printer.ml | 106 | ||||
| -rw-r--r-- | printing/printer.mli | 49 | ||||
| -rw-r--r-- | printing/printmod.ml | 170 | ||||
| -rw-r--r-- | printing/proof_diffs.ml | 2 |
9 files changed, 127 insertions, 283 deletions
diff --git a/printing/dune b/printing/dune index 3392342165..837ac48009 100644 --- a/printing/dune +++ b/printing/dune @@ -2,5 +2,6 @@ (name printing) (synopsis "Coq's Term Pretty Printing Library") (public_name coq.printing) + (flags :standard -open Gramlib) (wrapped false) (libraries parsing proofs)) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 418e13759b..6d53349fa1 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -194,7 +194,6 @@ let tag_var = tag Tag.variable sl ++ id let pr_id = Id.print - let pr_name = Name.print let pr_qualid = pr_qualid let pr_patvar = pr_id @@ -395,7 +394,7 @@ let tag_var = tag Tag.variable kw n ++ pr_binder false pr_c (nal,k,t) | (CLocalAssum _ | CLocalPattern _ | CLocalDef _) :: _ as bdl -> kw n ++ pr_undelimited_binders sep pr_c bdl - | [] -> assert false + | [] -> anomaly (Pp.str "The ast is malformed, found lambda/prod without proper binders.") let pr_binders_gen pr_c sep is_open = if is_open then pr_delimited_binders pr_com_at sep pr_c @@ -675,9 +674,6 @@ let tag_var = tag Tag.variable return (pr_prim_token p, prec_of_prim_token p) | CDelimiters (sc,a) -> return (pr_delimiters sc (pr mt (ldelim,E) a), ldelim) - | CProj (p,c) -> - let p = pr_proj (pr mt) pr_app c (CAst.make (CRef (p,None))) [] in - return (p, lproj) in let loc = constr_loc a in pr_with_comments ?loc diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index bca419c9ac..e7f71849a5 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -34,8 +34,6 @@ val pr_sep_com : constr_expr -> Pp.t val pr_id : Id.t -> Pp.t -val pr_name : Name.t -> Pp.t -[@@ocaml.deprecated "alias of Names.Name.print"] val pr_qualid : qualid -> Pp.t val pr_patvar : Pattern.patvar -> Pp.t diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 9ed985195f..4619e049e0 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -71,17 +71,17 @@ let int_or_no n = if Int.equal n 0 then str "no" else int n let print_basename sp = pr_global (ConstRef sp) let print_ref reduce ref udecl = - let typ, ctx = Global.type_of_global_in_context (Global.env ()) ref in - let typ = Vars.subst_instance_constr (Univ.AUContext.instance ctx) typ in + let typ, univs = Typeops.type_of_global_in_context (Global.env ()) ref in + let inst = Univ.make_abstract_instance univs in + let bl = UnivNames.universe_binders_with_opt_names ref udecl in + let sigma = Evd.from_ctx (UState.of_binders bl) in let typ = EConstr.of_constr typ in let typ = if reduce then let env = Global.env () in - let sigma = Evd.from_env env in let ctx,ccl = Reductionops.splay_prod_assum env sigma typ in EConstr.it_mkProd_or_LetIn ccl ctx else typ in - let univs = Global.universes_of_global ref in let variance = match ref with | VarRef _ | ConstRef _ -> None | IndRef (ind,_) | ConstructRef ((ind,_),_) -> @@ -91,19 +91,14 @@ let print_ref reduce ref udecl = | Declarations.Cumulative_ind cumi -> Some (Univ.ACumulativityInfo.variance cumi) end in - let inst = Univ.AUContext.instance univs in - let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in let env = Global.env () in - let bl = UnivNames.universe_binders_with_opt_names ref - (Array.to_list (Univ.Instance.to_array inst)) udecl in - let sigma = Evd.from_ctx (UState.of_binders bl) in let inst = if Global.is_polymorphic ref - then Printer.pr_universe_instance sigma (Univ.UContext.instance univs) + then Printer.pr_universe_instance sigma inst else mt () in hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ - Printer.pr_universe_ctx sigma ?variance univs) + Printer.pr_abstract_universe_ctx sigma ?variance univs) (********************************) (** Printing implicit arguments *) @@ -152,7 +147,7 @@ let print_renames_list prefix l = hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map Name.print l))] let need_expansion impl ref = - let typ, _ = Global.type_of_global_in_context (Global.env ()) ref in + let typ, _ = Typeops.type_of_global_in_context (Global.env ()) ref in let ctx = Term.prod_assum typ in let nprods = List.count is_local_assum ctx in not (List.is_empty impl) && List.length impl >= nprods && @@ -552,48 +547,31 @@ let print_typed_body env evd (val_0,typ) = let print_instance sigma cb = if Declareops.constant_is_polymorphic cb then let univs = Declareops.constant_polymorphic_context cb in - let inst = Univ.AUContext.instance univs in + let inst = Univ.make_abstract_instance univs in pr_universe_instance sigma inst else mt() let print_constant with_values sep sp udecl = let cb = Global.lookup_constant sp in let val_0 = Global.body_of_constant_body cb in - let typ = - match cb.const_universes with - | Monomorphic_const _ -> cb.const_type - | Polymorphic_const univs -> - let inst = Univ.AUContext.instance univs in - Vars.subst_instance_constr inst cb.const_type - in - let univs, ulist = - let open Entries in + let typ = cb.const_type in + let univs = let open Univ in let otab = Global.opaque_tables () in match cb.const_body with - | Undef _ | Def _ -> - begin - match cb.const_universes with - | Monomorphic_const ctx -> Monomorphic_const_entry ctx, [] - | Polymorphic_const ctx -> - let inst = AUContext.instance ctx in - Polymorphic_const_entry (UContext.make (inst, AUContext.instantiate inst ctx)), - Array.to_list (Instance.to_array inst) - end + | Undef _ | Def _ -> cb.const_universes | OpaqueDef o -> let body_uctxs = Opaqueproof.force_constraints otab o in match cb.const_universes with | Monomorphic_const ctx -> - Monomorphic_const_entry (ContextSet.union body_uctxs ctx), [] + Monomorphic_const (ContextSet.union body_uctxs ctx) | Polymorphic_const ctx -> assert(ContextSet.is_empty body_uctxs); - let inst = AUContext.instance ctx in - Polymorphic_const_entry (UContext.make (inst, AUContext.instantiate inst ctx)), - Array.to_list (Instance.to_array inst) + Polymorphic_const ctx in let ctx = UState.of_binders - (UnivNames.universe_binders_with_opt_names (ConstRef sp) ulist udecl) + (UnivNames.universe_binders_with_opt_names (ConstRef sp) udecl) in let env = Global.env () and sigma = Evd.from_ctx ctx in let pr_ltype = pr_ltype_env env sigma in @@ -605,7 +583,6 @@ let print_constant with_values sep sp udecl = str" ]" ++ Printer.pr_constant_universes sigma univs | Some (c, ctx) -> - let c = Vars.subst_instance_constr (Univ.AUContext.instance ctx) c in print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ Printer.pr_constant_universes sigma univs) @@ -640,10 +617,10 @@ let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = | (_,"INDUCTIVE") -> Some (gallina_print_inductive (MutInd.make1 kn) None) | (_,"MODULE") -> - let (mp,_,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in Some (print_module with_values (MPdot (mp,l))) | (_,"MODULE TYPE") -> - let (mp,_,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in Some (print_modtype (MPdot (mp,l))) | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None @@ -712,11 +689,6 @@ let print_eval x = !object_pr.print_eval x (**** Printing declarations and judgments *) (**** Abstract layer *****) -let print_typed_value x = - let env = Global.env () in - let sigma = Evd.from_env env in - print_typed_value_in_env env sigma x - let print_judgment env sigma {uj_val=trm;uj_type=typ} = print_typed_value_in_env env sigma (trm, typ) @@ -762,12 +734,12 @@ let print_full_pure_context env sigma = str "." ++ fnl () ++ fnl () | "MODULE" -> (* TODO: make it reparsable *) - let (mp,_,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in print_module true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | "MODULE TYPE" -> (* TODO: make it reparsable *) (* TODO: make it reparsable *) - let (mp,_,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in print_modtype (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | _ -> mt () in prec rest ++ pp @@ -851,12 +823,10 @@ let print_opaque_name env sigma qid = | IndRef (sp,_) -> print_inductive sp None | ConstructRef cstr as gr -> - let ty, ctx = Global.type_of_global_in_context env gr in - let inst = Univ.AUContext.instance ctx in - let ty = Vars.subst_instance_constr inst ty in + let ty, ctx = Typeops.type_of_global_in_context env gr in let ty = EConstr.of_constr ty in let open EConstr in - print_typed_value (mkConstruct cstr, ty) + print_typed_value_in_env env sigma (mkConstruct cstr, ty) | VarRef id -> env |> lookup_named id |> print_named_decl env sigma diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 58606db019..9213bc8561 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -19,7 +19,7 @@ val assumptions_for_print : Name.t list -> Termops.names_context val print_closed_sections : bool ref val print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t -val print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option +val print_library_entry : env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option val print_full_context : env -> Evd.evar_map -> Pp.t val print_full_context_typ : env -> Evd.evar_map -> Pp.t val print_full_pure_context : env -> Evd.evar_map -> Pp.t @@ -89,7 +89,7 @@ type object_pr = { print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_library_entry : env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; diff --git a/printing/printer.ml b/printing/printer.ml index 67d71332b0..3cf995a005 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -15,9 +15,7 @@ open Names open Constr open Environ open Globnames -open Nametab open Evd -open Proof_type open Refiner open Constrextern open Ppconstr @@ -87,7 +85,6 @@ let pr_leconstr_core = Proof_diffs.pr_leconstr_core let pr_constr_n_env env sigma n c = pr_econstr_n_core false env sigma n (EConstr.of_constr c) let pr_lconstr_env = Proof_diffs.pr_lconstr_env let pr_constr_env env sigma c = pr_econstr_core false env sigma (EConstr.of_constr c) -let _ = Hook.set Refine.pr_constr pr_constr_env let pr_lconstr_goal_style_env env sigma c = pr_leconstr_core true env sigma (EConstr.of_constr c) let pr_constr_goal_style_env env sigma c = pr_econstr_core true env sigma (EConstr.of_constr c) @@ -99,20 +96,6 @@ let pr_econstr_env env sigma c = pr_econstr_core false env sigma c let pr_open_lconstr_env env sigma (_,c) = pr_leconstr_env env sigma c let pr_open_constr_env env sigma (_,c) = pr_econstr_env env sigma c -(* NB do not remove the eta-redexes! Global.env() has side-effects... *) -let pr_lconstr t = - let (sigma, env) = Pfedit.get_current_context () in - pr_lconstr_env env sigma t -let pr_constr t = - let (sigma, env) = Pfedit.get_current_context () in - pr_constr_env env sigma t - -let pr_leconstr c = pr_lconstr (EConstr.Unsafe.to_constr c) -let pr_econstr c = pr_constr (EConstr.Unsafe.to_constr c) - -let pr_open_lconstr (_,c) = pr_leconstr c -let pr_open_constr (_,c) = pr_econstr c - let pr_constr_under_binders_env_gen pr env sigma (ids,c) = (* Warning: clashes can occur with variables of same name in env but *) (* we also need to preserve the actual names of the patterns *) @@ -123,13 +106,6 @@ let pr_constr_under_binders_env_gen pr env sigma (ids,c) = let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_econstr_env let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_leconstr_env -let pr_constr_under_binders c = - let (sigma, env) = Pfedit.get_current_context () in - pr_constr_under_binders_env env sigma c -let pr_lconstr_under_binders c = - let (sigma, env) = Pfedit.get_current_context () in - pr_lconstr_under_binders_env env sigma c - let pr_etype_core goal_concl_style env sigma t = pr_constr_expr (extern_type goal_concl_style env sigma t) let pr_letype_core = Proof_diffs.pr_letype_core @@ -137,13 +113,6 @@ let pr_letype_core = Proof_diffs.pr_letype_core let pr_ltype_env env sigma c = pr_letype_core false env sigma (EConstr.of_constr c) let pr_type_env env sigma c = pr_etype_core false env sigma (EConstr.of_constr c) -let pr_ltype t = - let (sigma, env) = Pfedit.get_current_context () in - pr_ltype_env env sigma t -let pr_type t = - let (sigma, env) = Pfedit.get_current_context () in - pr_type_env env sigma t - let pr_etype_env env sigma c = pr_etype_core false env sigma c let pr_letype_env env sigma c = pr_letype_core false env sigma c let pr_goal_concl_style_env env sigma c = pr_letype_core true env sigma c @@ -151,29 +120,15 @@ let pr_goal_concl_style_env env sigma c = pr_letype_core true env sigma c let pr_ljudge_env env sigma j = (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type) -let pr_ljudge j = - let (sigma, env) = Pfedit.get_current_context () in - pr_ljudge_env env sigma j - let pr_lglob_constr_env env c = pr_lconstr_expr (extern_glob_constr (Termops.vars_of_env env) c) let pr_glob_constr_env env c = pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c) -let pr_lglob_constr c = - let (sigma, env) = Pfedit.get_current_context () in - pr_lglob_constr_env env c -let pr_glob_constr c = - let (sigma, env) = Pfedit.get_current_context () in - pr_glob_constr_env env c - let pr_closed_glob_n_env env sigma n c = pr_constr_expr_n n (extern_closed_glob false env sigma c) let pr_closed_glob_env env sigma c = pr_constr_expr (extern_closed_glob false env sigma c) -let pr_closed_glob c = - let (sigma, env) = Pfedit.get_current_context () in - pr_closed_glob_env env sigma c let pr_lconstr_pattern_env env sigma c = pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) @@ -183,16 +138,9 @@ let pr_constr_pattern_env env sigma c = let pr_cases_pattern t = pr_cases_pattern_expr (extern_cases_pattern Names.Id.Set.empty t) -let pr_lconstr_pattern t = - let (sigma, env) = Pfedit.get_current_context () in - pr_lconstr_pattern_env env sigma t -let pr_constr_pattern t = - let (sigma, env) = Pfedit.get_current_context () in - pr_constr_pattern_env env sigma t - let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) -let _ = Termops.set_print_constr +let _ = Termops.Internal.set_print_constr (fun env sigma t -> pr_lconstr_expr (extern_constr ~lax:true false env sigma t)) let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" @@ -248,13 +196,6 @@ let safe_gen f env sigma c = let safe_pr_lconstr_env = safe_gen pr_lconstr_env let safe_pr_constr_env = safe_gen pr_constr_env -let safe_pr_lconstr t = - let (sigma, env) = Pfedit.get_current_context () in - safe_pr_lconstr_env env sigma t - -let safe_pr_constr t = - let (sigma, env) = Pfedit.get_current_context () in - safe_pr_constr_env env sigma t let pr_universe_ctx_set sigma c = if !Detyping.print_universes && not (Univ.ContextSet.is_empty c) then @@ -270,9 +211,16 @@ let pr_universe_ctx sigma ?variance c = else mt() +let pr_abstract_universe_ctx sigma ?variance c = + if !Detyping.print_universes && not (Univ.AUContext.is_empty c) then + fnl()++pr_in_comment (fun c -> v 0 + (Univ.pr_abstract_universe_context (Termops.pr_evd_level sigma) ?variance c)) c + else + mt() + let pr_constant_universes sigma = function - | Entries.Monomorphic_const_entry ctx -> pr_universe_ctx_set sigma ctx - | Entries.Polymorphic_const_entry ctx -> pr_universe_ctx sigma ctx + | Declarations.Monomorphic_const ctx -> pr_universe_ctx_set sigma ctx + | Declarations.Polymorphic_const ctx -> pr_abstract_universe_ctx sigma ctx let pr_cumulativity_info sigma cumi = if !Detyping.print_universes @@ -282,10 +230,18 @@ let pr_cumulativity_info sigma cumi = else mt() +let pr_abstract_cumulativity_info sigma cumi = + if !Detyping.print_universes + && not (Univ.AUContext.is_empty (Univ.ACumulativityInfo.univ_context cumi)) then + fnl()++pr_in_comment (fun uii -> v 0 + (Univ.pr_abstract_cumulativity_info (Termops.pr_evd_level sigma) uii)) cumi + else + mt() + (**********************************************************************) (* Global references *) -let pr_global_env = pr_global_env +let pr_global_env = Nametab.pr_global_env let pr_global = pr_global_env Id.Set.empty let pr_universe_instance evd inst = @@ -875,19 +831,6 @@ let pr_goal_by_id ~proof id = pr_selected_subgoal (pr_id id) sigma g) with Not_found -> user_err Pp.(str "No such goal.") -(* Elementary tactics *) - -let pr_prim_rule = function - | Refine c -> - (** FIXME *) - str(if Termops.occur_meta Evd.empty (EConstr.of_constr c) then "refine " else "exact ") ++ - Constrextern.with_meta_as_hole pr_constr c - -(* Backwards compatibility *) - -let prterm = pr_lconstr - - (* Printer function for sets of Assumptions.assumptions. It is used primarily by the Print Assumptions command. *) @@ -944,9 +887,16 @@ let pr_assumptionset env sigma s = let safe_pr_constant env kn = try pr_constant env kn with Not_found -> - let mp,_,lab = Constant.repr3 kn in + (* FIXME? *) + let mp,lab = Constant.repr2 kn in str (ModPath.to_string mp) ++ str "." ++ Label.print lab in + let safe_pr_inductive env kn = + try pr_inductive env (kn,0) + with Not_found -> + (* FIXME? *) + MutInd.print kn + in let safe_pr_ltype env sigma typ = try str " : " ++ pr_ltype_env env sigma typ with e when CErrors.noncritical e -> mt () @@ -961,7 +911,7 @@ let pr_assumptionset env sigma s = | Constant kn -> safe_pr_constant env kn ++ safe_pr_ltype env sigma typ | Positive m -> - hov 2 (MutInd.print m ++ spc () ++ strbrk"is positive.") + hov 2 (safe_pr_inductive env m ++ spc () ++ strbrk"is positive.") | Guarded kn -> hov 2 (safe_pr_constant env kn ++ spc () ++ strbrk"is positive.") in diff --git a/printing/printer.mli b/printing/printer.mli index 518c5b930b..f9d1a62895 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -27,13 +27,9 @@ val enable_goal_names_printing : bool ref (** Terms *) val pr_lconstr_env : env -> evar_map -> constr -> Pp.t -val pr_lconstr : constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_goal_style_env : env -> evar_map -> constr -> Pp.t val pr_constr_env : env -> evar_map -> constr -> Pp.t -val pr_constr : constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_goal_style_env : env -> evar_map -> constr -> Pp.t val pr_constr_n_env : env -> evar_map -> Notation_gram.tolerability -> constr -> Pp.t @@ -43,19 +39,11 @@ val pr_constr_n_env : env -> evar_map -> Notation_gram.tolerability -> co in case of remaining issues (such as reference not in env). *) val safe_pr_lconstr_env : env -> evar_map -> constr -> Pp.t -val safe_pr_lconstr : constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val safe_pr_constr_env : env -> evar_map -> constr -> Pp.t -val safe_pr_constr : constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr_env : env -> evar_map -> EConstr.t -> Pp.t -val pr_econstr : EConstr.t -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_leconstr_env : env -> evar_map -> EConstr.t -> Pp.t -val pr_leconstr : EConstr.t -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr_n_env : env -> evar_map -> Notation_gram.tolerability -> EConstr.t -> Pp.t @@ -63,54 +51,30 @@ val pr_etype_env : env -> evar_map -> EConstr.types -> Pp.t val pr_letype_env : env -> evar_map -> EConstr.types -> Pp.t val pr_open_constr_env : env -> evar_map -> open_constr -> Pp.t -val pr_open_constr : open_constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_open_lconstr_env : env -> evar_map -> open_constr -> Pp.t -val pr_open_lconstr : open_constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t -val pr_constr_under_binders : constr_under_binders -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t -val pr_lconstr_under_binders : constr_under_binders -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_goal_concl_style_env : env -> evar_map -> EConstr.types -> Pp.t val pr_ltype_env : env -> evar_map -> types -> Pp.t -val pr_ltype : types -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_type_env : env -> evar_map -> types -> Pp.t -val pr_type : types -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_closed_glob_n_env : env -> evar_map -> Notation_gram.tolerability -> closed_glob_constr -> Pp.t val pr_closed_glob_env : env -> evar_map -> closed_glob_constr -> Pp.t -val pr_closed_glob : closed_glob_constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_ljudge_env : env -> evar_map -> EConstr.unsafe_judgment -> Pp.t * Pp.t -val pr_ljudge : EConstr.unsafe_judgment -> Pp.t * Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lglob_constr_env : env -> 'a glob_constr_g -> Pp.t -val pr_lglob_constr : 'a glob_constr_g -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_glob_constr_env : env -> 'a glob_constr_g -> Pp.t -val pr_glob_constr : 'a glob_constr_g -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t -val pr_lconstr_pattern : constr_pattern -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t -val pr_constr_pattern : constr_pattern -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_cases_pattern : cases_pattern -> Pp.t @@ -123,9 +87,12 @@ val pr_cumulative : bool -> bool -> Pp.t val pr_universe_instance : evar_map -> Univ.Instance.t -> Pp.t val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> Univ.UContext.t -> Pp.t +val pr_abstract_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> + Univ.AUContext.t -> Pp.t val pr_universe_ctx_set : evar_map -> Univ.ContextSet.t -> Pp.t -val pr_constant_universes : evar_map -> Entries.constant_universes_entry -> Pp.t +val pr_constant_universes : evar_map -> Declarations.constant_universes -> Pp.t val pr_cumulativity_info : evar_map -> Univ.CumulativityInfo.t -> Pp.t +val pr_abstract_cumulativity_info : evar_map -> Univ.ACumulativityInfo.t -> Pp.t (** Printing global references using names as short as possible *) @@ -219,16 +186,8 @@ val pr_evars : evar_map -> evar_info Evar.Map.t -> Pp.t val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> Evar.Set.t -> Pp.t -val pr_prim_rule : prim_rule -> Pp.t -[@@ocaml.deprecated "[pr_prim_rule] is scheduled to be removed along with the legacy proof engine"] - val print_and_diff : Proof.t option -> Proof.t option -> unit -(** Backwards compatibility *) - -val prterm : constr -> Pp.t (** = pr_lconstr *) -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - (** Declarations for the "Print Assumption" command *) type axiom = | Constant of Constant.t (* An axiom or a constant. *) diff --git a/printing/printmod.ml b/printing/printmod.ml index e2d9850bf8..20e0a989f3 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -23,8 +23,6 @@ open Goptions - The "rich" one, that also tries to print the types of the fields. The short version used to be the default behavior, but now we print types by default. The following option allows changing this. - Technically, the environments in this file are either None in - the "short" mode or (Some env) in the "rich" one. *) module Tag = @@ -39,6 +37,8 @@ let tag t s = Pp.tag t s let tag_definition s = tag Tag.definition s let tag_keyword s = tag Tag.keyword s +type short = OnlyNames | WithContents + let short = ref false let _ = @@ -90,9 +90,7 @@ let build_ind_type env mip = Inductive.type_of_inductive env mip let print_one_inductive env sigma mib ((_,i) as ind) = - let u = if Declareops.inductive_is_polymorphic mib then - Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) - else Univ.Instance.empty in + let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let mip = mib.mind_packets.(i) in let params = Inductive.inductive_paramdecls (mib,u) in let nparamdecls = Context.Rel.length params in @@ -111,16 +109,6 @@ let print_one_inductive env sigma mib ((_,i) as ind) = str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ str " :=") ++ brk(0,2) ++ print_constructors envpar sigma mip.mind_consnames cstrtypes -let instantiate_cumulativity_info cumi = - let open Univ in - let univs = ACumulativityInfo.univ_context cumi in - let expose ctx = - let inst = AUContext.instance ctx in - let cst = AUContext.instantiate inst ctx in - UContext.make (inst, cst) - in - CumulativityInfo.make (expose univs, ACumulativityInfo.variance cumi) - let print_mutual_inductive env mind mib udecl = let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x)) in @@ -131,14 +119,7 @@ let print_mutual_inductive env mind mib udecl = | BiFinite -> "Variant" | CoFinite -> "CoInductive" in - let univs = - let open Univ in - if Declareops.inductive_is_polymorphic mib then - Array.to_list (Instance.to_array - (AUContext.instance (Declareops.inductive_polymorphic_context mib))) - else [] - in - let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind, 0)) univs udecl in + let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind, 0)) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in hov 0 (Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ Printer.pr_cumulative @@ -150,8 +131,7 @@ let print_mutual_inductive env mind mib udecl = match mib.mind_universes with | Monomorphic_ind _ | Polymorphic_ind _ -> str "" | Cumulative_ind cumi -> - Printer.pr_cumulativity_info - sigma (instantiate_cumulativity_info cumi)) + Printer.pr_abstract_cumulativity_info sigma cumi) let get_fields = let rec prodec_rec l subst c = @@ -167,11 +147,7 @@ let get_fields = prodec_rec [] [] let print_record env mind mib udecl = - let u = - if Declareops.inductive_is_polymorphic mib then - Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) - else Univ.Instance.empty - in + let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let mip = mib.mind_packets.(0) in let params = Inductive.inductive_paramdecls (mib,u) in let nparamdecls = Context.Rel.length params in @@ -181,8 +157,7 @@ let print_record env mind mib udecl = let cstrtype = hnf_prod_applist_assum env nparamdecls cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in - let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind,0)) - (Array.to_list (Univ.Instance.to_array u)) udecl in + let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind,0)) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in let keyword = let open Declarations in @@ -210,8 +185,7 @@ let print_record env mind mib udecl = match mib.mind_universes with | Monomorphic_ind _ | Polymorphic_ind _ -> str "" | Cumulative_ind cumi -> - Printer.pr_cumulativity_info - sigma (instantiate_cumulativity_info cumi) + Printer.pr_abstract_cumulativity_info sigma cumi ) let pr_mutual_inductive_body env mind mib udecl = @@ -308,43 +282,36 @@ let nametab_register_modparam mbid mtb = List.iter (nametab_register_body mp dir) struc; id -let print_body is_impl env mp (l,body) = +let print_body is_impl extent env mp (l,body) = let name = Label.print l in hov 2 (match body with | SFBmodule _ -> keyword "Module" ++ spc () ++ name | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name | SFBconst cb -> let ctx = Declareops.constant_polymorphic_context cb in - let u = - if Declareops.constant_is_polymorphic cb then - Univ.AUContext.instance ctx - else Univ.Instance.empty - in - let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u ctx) in (match cb.const_body with | Def _ -> def "Definition" ++ spc () | OpaqueDef _ when is_impl -> def "Theorem" ++ spc () | _ -> def "Parameter" ++ spc ()) ++ name ++ - (match env with - | None -> mt () - | Some env -> + (match extent with + | OnlyNames -> mt () + | WithContents -> + let bl = UnivNames.universe_binders_with_opt_names (ConstRef (Constant.make2 mp l)) None in + let sigma = Evd.from_ctx (UState.of_binders bl) in str " :" ++ spc () ++ - hov 0 (Printer.pr_ltype_env env (Evd.from_env env) - (Vars.subst_instance_constr u - cb.const_type)) ++ + hov 0 (Printer.pr_ltype_env env sigma cb.const_type) ++ (match cb.const_body with | Def l when is_impl -> spc () ++ hov 2 (str ":= " ++ - Printer.pr_lconstr_env env (Evd.from_env env) - (Vars.subst_instance_constr u (Mod_subst.force_constr l))) + Printer.pr_lconstr_env env sigma (Mod_subst.force_constr l)) | _ -> mt ()) ++ str "." ++ - Printer.pr_universe_ctx (Evd.from_env env) ctx) + Printer.pr_abstract_universe_ctx sigma ctx) | SFBmind mib -> - try - let env = Option.get env in + match extent with + | WithContents -> pr_mutual_inductive_body env (MutInd.make2 mp l) mib None - with e when CErrors.noncritical e -> + | OnlyNames -> let keyword = let open Declarations in match mib.mind_finite with @@ -354,15 +321,14 @@ let print_body is_impl env mp (l,body) = in keyword ++ spc () ++ name) -let print_struct is_impl env mp struc = - prlist_with_sep spc (print_body is_impl env mp) struc +let print_struct is_impl extent env mp struc = + prlist_with_sep spc (print_body is_impl extent env mp) struc -let print_structure is_type env mp locals struc = - let env' = Option.map - (Modops.add_structure mp struc Mod_subst.empty_delta_resolver) env in +let print_structure is_type extent env mp locals struc = + let env' = Modops.add_structure mp struc Mod_subst.empty_delta_resolver env in nametab_register_module_body mp struc; let kwd = if is_type then "Sig" else "Struct" in - hv 2 (keyword kwd ++ spc () ++ print_struct false env' mp struc ++ + hv 2 (keyword kwd ++ spc () ++ print_struct false extent env' mp struc ++ brk (1,-2) ++ keyword "End") let rec flatten_app mexpr l = match mexpr with @@ -370,7 +336,7 @@ let rec flatten_app mexpr l = match mexpr with | MEident mp -> mp::l | MEwith _ -> assert false -let rec print_typ_expr env mp locals mty = +let rec print_typ_expr extent env mp locals mty = match mty with | MEident kn -> print_kn locals kn | MEapply _ -> @@ -380,19 +346,23 @@ let rec print_typ_expr env mp locals mty = hov 3 (str"(" ++ (print_kn locals fapp) ++ spc () ++ prlist_with_sep spc (print_modpath locals) mapp ++ str")") | MEwith(me,WithDef(idl,(c, _)))-> - let env' = None in (* TODO: build a proper environment if env <> None *) let s = String.concat "." (List.map Id.to_string idl) in - (* XXX: What should env and sigma be here? *) - let env = Global.env () in - let sigma = Evd.from_env env in - hov 2 (print_typ_expr env' mp locals me ++ spc() ++ str "with" ++ spc() - ++ def "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc() - ++ Printer.pr_lconstr_env env sigma c) + let body = match extent with + | WithContents -> + let sigma = Evd.from_env env in + spc() ++ str ":=" ++ spc() ++ Printer.pr_lconstr_env env sigma c + | OnlyNames -> + mt() in + hov 2 (print_typ_expr extent env mp locals me ++ spc() ++ str "with" ++ spc() + ++ def "Definition"++ spc() ++ str s ++ body) | MEwith(me,WithMod(idl,mp'))-> let s = String.concat "." (List.map Id.to_string idl) in - hov 2 (print_typ_expr env mp locals me ++ spc() ++ str "with" ++ spc() ++ - keyword "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc() - ++ print_modpath locals mp') + let body = match extent with + | WithContents -> + spc() ++ str ":="++ spc() ++ print_modpath locals mp' + | OnlyNames -> mt () in + hov 2 (print_typ_expr extent env mp locals me ++ spc() ++ str "with" ++ spc() ++ + keyword "Module"++ spc() ++ str s ++ body) let print_mod_expr env mp locals = function | MEident mp -> print_modpath locals mp @@ -402,31 +372,31 @@ let print_mod_expr env mp locals = function (str"(" ++ prlist_with_sep spc (print_modpath locals) lapp ++ str")") | MEwith _ -> assert false (* No 'with' syntax for modules *) -let rec print_functor fty fatom is_type env mp locals = function - |NoFunctor me -> fatom is_type env mp locals me - |MoreFunctor (mbid,mtb1,me2) -> +let rec print_functor fty fatom is_type extent env mp locals = function + | NoFunctor me -> fatom is_type extent env mp locals me + | MoreFunctor (mbid,mtb1,me2) -> let id = nametab_register_modparam mbid mtb1 in let mp1 = MPbound mbid in - let pr_mtb1 = fty env mp1 locals mtb1 in - let env' = Option.map (Modops.add_module_type mp1 mtb1) env in + let pr_mtb1 = fty extent env mp1 locals mtb1 in + let env' = Modops.add_module_type mp1 mtb1 env in let locals' = (mbid, get_new_id locals (MBId.to_id mbid))::locals in let kwd = if is_type then "Funsig" else "Functor" in hov 2 (keyword kwd ++ spc () ++ str "(" ++ Id.print id ++ str ":" ++ pr_mtb1 ++ str ")" ++ - spc() ++ print_functor fty fatom is_type env' mp locals' me2) + spc() ++ print_functor fty fatom is_type extent env' mp locals' me2) let rec print_expression x = print_functor print_modtype - (function true -> print_typ_expr | false -> print_mod_expr) x + (function true -> print_typ_expr | false -> fun _ -> print_mod_expr) x and print_signature x = print_functor print_modtype print_structure x -and print_modtype env mp locals mtb = match mtb.mod_type_alg with - | Some me -> print_expression true env mp locals me - | None -> print_signature true env mp locals mtb.mod_type +and print_modtype extent env mp locals mtb = match mtb.mod_type_alg with + | Some me -> print_expression true extent env mp locals me + | None -> print_signature true extent env mp locals mtb.mod_type let rec printable_body dir = let dir = pop_dirpath dir in @@ -442,28 +412,28 @@ let rec printable_body dir = (** Since we might play with nametab above, we should reset to prior state after the printing *) -let print_expression' is_type env mp me = +let print_expression' is_type extent env mp me = States.with_state_protection - (fun e -> print_expression is_type env mp [] e) me + (fun e -> print_expression is_type extent env mp [] e) me -let print_signature' is_type env mp me = +let print_signature' is_type extent env mp me = States.with_state_protection - (fun e -> print_signature is_type env mp [] e) me + (fun e -> print_signature is_type extent env mp [] e) me -let unsafe_print_module env mp with_body mb = +let unsafe_print_module extent env mp with_body mb = let name = print_modpath [] mp in let pr_equals = spc () ++ str ":= " in let body = match with_body, mb.mod_expr with | false, _ | true, Abstract -> mt() - | _, Algebraic me -> pr_equals ++ print_expression' false env mp me - | _, Struct sign -> pr_equals ++ print_signature' false env mp sign - | _, FullStruct -> pr_equals ++ print_signature' false env mp mb.mod_type + | _, Algebraic me -> pr_equals ++ print_expression' false extent env mp me + | _, Struct sign -> pr_equals ++ print_signature' false extent env mp sign + | _, FullStruct -> pr_equals ++ print_signature' false extent env mp mb.mod_type in let modtype = match mb.mod_expr, mb.mod_type_alg with | FullStruct, _ -> mt () - | _, Some ty -> brk (1,1) ++ str": " ++ print_expression' true env mp ty - | _, _ -> brk (1,1) ++ str": " ++ print_signature' true env mp mb.mod_type + | _, Some ty -> brk (1,1) ++ str": " ++ print_expression' true extent env mp ty + | _, _ -> brk (1,1) ++ str": " ++ print_signature' true extent env mp mb.mod_type in hv 0 (keyword "Module" ++ spc () ++ name ++ modtype ++ body) @@ -473,19 +443,21 @@ let print_module with_body mp = let me = Global.lookup_module mp in try if !short then raise ShortPrinting; - unsafe_print_module (Some (Global.env ())) mp with_body me ++ fnl () + unsafe_print_module WithContents + (Global.env ()) mp with_body me ++ fnl () with e when CErrors.noncritical e -> - unsafe_print_module None mp with_body me ++ fnl () + unsafe_print_module OnlyNames + (Global.env ()) mp with_body me ++ fnl () let print_modtype kn = let mtb = Global.lookup_modtype kn in let name = print_kn [] kn in hv 1 (keyword "Module Type" ++ spc () ++ name ++ str " =" ++ spc () ++ - (try - if !short then raise ShortPrinting; - print_signature' true (Some (Global.env ())) kn mtb.mod_type - with e when CErrors.noncritical e -> - print_signature' true None kn mtb.mod_type)) - - + try + if !short then raise ShortPrinting; + print_signature' true WithContents + (Global.env ()) kn mtb.mod_type + with e when CErrors.noncritical e -> + print_signature' true OnlyNames + (Global.env ()) kn mtb.mod_type) diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 5bb1053645..0b630b39b5 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -523,8 +523,6 @@ let match_goals ot nt = | CPrim p, CPrim p2 -> () | CDelimiters (key,e), CDelimiters (key2,e2) -> constr_expr ogname e e2 - | CProj (pr,c), CProj (pr2,c2) -> - constr_expr ogname c c2 | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (5)") end in |