diff options
Diffstat (limited to 'printing/prettyp.ml')
| -rw-r--r-- | printing/prettyp.ml | 68 |
1 files changed, 45 insertions, 23 deletions
diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 4a66c33d..84649e6e 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -73,8 +73,15 @@ let print_ref reduce ref = in it_mkProd_or_LetIn ccl ctx else typ in let univs = Global.universes_of_global ref in - hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ ++ - Printer.pr_universe_ctx univs) + let env = Global.env () in + let bl = Universes.universe_binders_of_global ref in + let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in + let inst = + if Global.is_polymorphic ref then Printer.pr_universe_instance sigma univs + else mt () + in + hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_ltype_env env sigma typ ++ + Printer.pr_universe_ctx sigma univs) (********************************) (** Printing implicit arguments *) @@ -180,16 +187,16 @@ let print_opacity ref = | None -> [] | Some s -> [pr_global ref ++ str " is " ++ - str (match s with - | FullyOpaque -> "opaque" + match s with + | FullyOpaque -> str "opaque" | TransparentMaybeOpacified Conv_oracle.Opaque -> - "basically transparent but considered opaque for reduction" + str "basically transparent but considered opaque for reduction" | TransparentMaybeOpacified lev when Conv_oracle.is_transparent lev -> - "transparent" + str "transparent" | TransparentMaybeOpacified (Conv_oracle.Level n) -> - "transparent (with expansion weight "^string_of_int n^")" + str "transparent (with expansion weight " ++ int n ++ str ")" | TransparentMaybeOpacified Conv_oracle.Expand -> - "transparent (with minimal expansion weight)")] + str "transparent (with minimal expansion weight)"] (*******************) (* *) @@ -205,16 +212,20 @@ let print_polymorphism ref = else "not universe polymorphic") ] else [] -let print_primitive_record mipv = function +let print_primitive_record recflag mipv = function | Some (Some (_, ps,_)) -> - [pr_id mipv.(0).mind_typename ++ str" is primitive and has eta conversion."] + let eta = match recflag with + | Decl_kinds.CoFinite -> mt () + | Decl_kinds.Finite | Decl_kinds.BiFinite -> str " and has eta conversion" + in + [pr_id mipv.(0).mind_typename ++ str" is primitive" ++ eta ++ str"."] | _ -> [] let print_primitive ref = match ref with | IndRef ind -> let mib,_ = Global.lookup_inductive ind in - print_primitive_record mib.mind_packets mib.mind_record + print_primitive_record mib.mind_finite mib.mind_packets mib.mind_record | _ -> [] let print_name_infos ref = @@ -386,9 +397,9 @@ let print_located_qualid name flags ref = | [] -> let (dir,id) = repr_qualid qid in if DirPath.is_empty dir then - str ("No " ^ name ^ " of basename") ++ spc () ++ pr_id id + str "No " ++ str name ++ str " of basename" ++ spc () ++ pr_id id else - str ("No " ^ name ^ " of suffix") ++ spc () ++ pr_qualid qid + str "No " ++ str name ++ str " of suffix" ++ spc () ++ pr_qualid qid | l -> prlist_with_sep fnl (fun (o,oqid) -> @@ -447,7 +458,7 @@ let gallina_print_inductive sp = let mipv = mib.mind_packets in pr_mutual_inductive_body env sp mib ++ with_line_skip - (print_primitive_record mipv mib.mind_record @ + (print_primitive_record mib.mind_finite mipv mib.mind_record @ print_inductive_renames sp mipv @ print_inductive_implicit_args sp mipv @ print_inductive_argument_scopes sp mipv) @@ -459,16 +470,21 @@ let gallina_print_section_variable id = print_named_decl id ++ with_line_skip (print_name_infos (VarRef id)) -let print_body = function - | Some c -> pr_lconstr c +let print_body env evd = function + | Some c -> pr_lconstr_env env evd c | None -> (str"<no body>") -let print_typed_body (val_0,typ) = - (print_body val_0 ++ fnl () ++ str " : " ++ pr_ltype typ) +let print_typed_body env evd (val_0,typ) = + (print_body env evd val_0 ++ fnl () ++ str " : " ++ pr_ltype_env env evd typ) let ungeneralized_type_of_constant_type t = Typeops.type_of_constant_type (Global.env ()) t +let print_instance sigma cb = + if cb.const_polymorphic then + pr_universe_instance sigma cb.const_universes + else mt() + let print_constant with_values sep sp = let cb = Global.lookup_constant sp in let val_0 = Global.body_of_constant_body cb in @@ -477,17 +493,23 @@ let print_constant with_values sep sp = let univs = Univ.instantiate_univ_context (Global.universes_of_constant_body cb) in + let ctx = + Evd.evar_universe_context_of_binders + (Universes.universe_binders_of_global (ConstRef sp)) + in + let env = Global.env () and sigma = Evd.from_ctx ctx in + let pr_ltype = pr_ltype_env env sigma in hov 0 (pr_polymorphic cb.const_polymorphic ++ match val_0 with | None -> str"*** [ " ++ - print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ + print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ - Printer.pr_universe_ctx univs + Printer.pr_universe_ctx sigma univs | _ -> - print_basename sp ++ str sep ++ cut () ++ - (if with_values then print_typed_body (val_0,typ) else pr_ltype typ)++ - Printer.pr_universe_ctx univs) + print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ + (if with_values then print_typed_body env sigma (val_0,typ) else pr_ltype typ)++ + Printer.pr_universe_ctx sigma univs) let gallina_print_constant_with_infos sp = print_constant true " = " sp ++ |