summaryrefslogtreecommitdiff
path: root/printing
diff options
context:
space:
mode:
authorGravatar Benjamin Barenblat <bbaren@debian.org>2018-12-29 14:31:27 -0500
committerGravatar Benjamin Barenblat <bbaren@debian.org>2018-12-29 14:31:27 -0500
commit9043add656177eeac1491a73d2f3ab92bec0013c (patch)
tree2b0092c84bfbf718eca10c81f60b2640dc8cab05 /printing
parenta4c7f8bd98be2a200489325ff7c5061cf80ab4f3 (diff)
Imported Upstream version 8.8.2upstream/8.8.2
Diffstat (limited to 'printing')
-rw-r--r--printing/genprint.ml133
-rw-r--r--printing/genprint.mli52
-rw-r--r--printing/miscprint.ml49
-rw-r--r--printing/miscprint.mli24
-rw-r--r--printing/ppannotation.ml39
-rw-r--r--printing/ppannotation.mli32
-rw-r--r--printing/ppconstr.ml499
-rw-r--r--printing/ppconstr.mli92
-rw-r--r--printing/ppconstrsig.mli95
-rw-r--r--printing/pptactic.ml1479
-rw-r--r--printing/pptactic.mli67
-rw-r--r--printing/pptacticsig.mli83
-rw-r--r--printing/pputils.ml174
-rw-r--r--printing/pputils.mli46
-rw-r--r--printing/ppvernac.ml533
-rw-r--r--printing/ppvernac.mli30
-rw-r--r--printing/ppvernacsig.mli20
-rw-r--r--printing/prettyp.ml507
-rw-r--r--printing/prettyp.mli115
-rw-r--r--printing/printer.ml553
-rw-r--r--printing/printer.mli270
-rw-r--r--printing/printing.mllib2
-rw-r--r--printing/printmod.ml206
-rw-r--r--printing/printmod.mli16
-rw-r--r--printing/printmodsig.mli17
25 files changed, 1909 insertions, 3224 deletions
diff --git a/printing/genprint.ml b/printing/genprint.ml
index 0ec35e07..1bb7838a 100644
--- a/printing/genprint.ml
+++ b/printing/genprint.ml
@@ -1,31 +1,128 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
open Pp
open Genarg
+open Geninterp
-type ('raw, 'glb, 'top) printer = {
- raw : 'raw -> std_ppcmds;
- glb : 'glb -> std_ppcmds;
- top : 'top -> std_ppcmds;
+(* We register printers at two levels:
+ - generic arguments for general printers
+ - generic values for printing ltac values *)
+
+(* Printing generic values *)
+
+type 'a with_level =
+ { default_already_surrounded : Notation_term.tolerability;
+ default_ensure_surrounded : Notation_term.tolerability;
+ printer : 'a }
+
+type printer_result =
+| PrinterBasic of (unit -> Pp.t)
+| PrinterNeedsLevel of (Notation_term.tolerability -> Pp.t) with_level
+
+type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t
+
+type top_printer_result =
+| TopPrinterBasic of (unit -> Pp.t)
+| TopPrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t)
+| TopPrinterNeedsContextAndLevel of printer_fun_with_level with_level
+
+type 'a printer = 'a -> printer_result
+
+type 'a top_printer = 'a -> top_printer_result
+
+module ValMap = ValTMap (struct type 'a t = 'a -> top_printer_result end)
+
+let print0_val_map = ref ValMap.empty
+
+let find_print_val_fun tag =
+ try ValMap.find tag !print0_val_map
+ with Not_found ->
+ let msg s = Pp.(str "print function not found for a value interpreted as " ++ str s ++ str ".") in
+ CErrors.anomaly (msg (Val.repr tag))
+
+let generic_val_print v =
+ let Val.Dyn (tag,v) = v in
+ find_print_val_fun tag v
+
+let register_val_print0 s pr =
+ print0_val_map := ValMap.add s pr !print0_val_map
+
+let combine_dont_needs pr_pair pr1 = function
+ | TopPrinterBasic pr2 ->
+ TopPrinterBasic (fun () -> pr_pair (pr1 ()) (pr2 ()))
+ | TopPrinterNeedsContext pr2 ->
+ TopPrinterNeedsContext (fun env sigma ->
+ pr_pair (pr1 ()) (pr2 env sigma))
+ | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
+ TopPrinterNeedsContext (fun env sigma ->
+ pr_pair (pr1 ()) (printer env sigma default_ensure_surrounded))
+
+let combine_needs pr_pair pr1 = function
+ | TopPrinterBasic pr2 ->
+ TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (pr2 ()))
+ | TopPrinterNeedsContext pr2 ->
+ TopPrinterNeedsContext (fun env sigma ->
+ pr_pair (pr1 env sigma) (pr2 env sigma))
+ | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
+ TopPrinterNeedsContext (fun env sigma ->
+ pr_pair (pr1 env sigma) (printer env sigma default_ensure_surrounded))
+
+let combine pr_pair pr1 v2 =
+ match pr1 with
+ | TopPrinterBasic pr1 ->
+ combine_dont_needs pr_pair pr1 (generic_val_print v2)
+ | TopPrinterNeedsContext pr1 ->
+ combine_needs pr_pair pr1 (generic_val_print v2)
+ | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
+ combine_needs pr_pair (fun env sigma -> printer env sigma default_ensure_surrounded)
+ (generic_val_print v2)
+
+let _ =
+ let pr_cons a b = Pp.(a ++ spc () ++ b) in
+ register_val_print0 Val.typ_list
+ (function
+ | [] -> TopPrinterBasic mt
+ | a::l ->
+ List.fold_left (combine pr_cons) (generic_val_print a) l)
+
+let _ =
+ register_val_print0 Val.typ_opt
+ (function
+ | None -> TopPrinterBasic Pp.mt
+ | Some v -> generic_val_print v)
+
+let _ =
+ let pr_pair a b = Pp.(a ++ spc () ++ b) in
+ register_val_print0 Val.typ_pair
+ (fun (v1,v2) -> combine pr_pair (generic_val_print v1) v2)
+
+(* Printing generic arguments *)
+
+type ('raw, 'glb, 'top) genprinter = {
+ raw : 'raw -> printer_result;
+ glb : 'glb -> printer_result;
+ top : 'top -> top_printer_result;
}
module PrintObj =
struct
- type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) printer
+ type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) genprinter
let name = "printer"
let default wit = match wit with
| ExtraArg tag ->
let name = ArgT.repr tag in
let printer = {
- raw = (fun _ -> str "<genarg:" ++ str name ++ str ">");
- glb = (fun _ -> str "<genarg:" ++ str name ++ str ">");
- top = (fun _ -> str "<genarg:" ++ str name ++ str ">");
+ raw = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">"));
+ glb = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">"));
+ top = (fun _ -> TopPrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">"));
} in
Some printer
| _ -> assert false
@@ -35,6 +132,18 @@ module Print = Register (PrintObj)
let register_print0 wit raw glb top =
let printer = { raw; glb; top; } in
+ Print.register0 wit printer;
+ match val_tag (Topwit wit), wit with
+ | Val.Base t, ExtraArg t' when Geninterp.Val.repr t = ArgT.repr t' ->
+ register_val_print0 t top
+ | _ ->
+ (* An alias, thus no primitive printer attached *)
+ ()
+
+let register_vernac_print0 wit raw =
+ let glb _ = CErrors.anomaly (Pp.str "vernac argument needs not globwit printer.") in
+ let top _ = CErrors.anomaly (Pp.str "vernac argument needs not wit printer.") in
+ let printer = { raw; glb; top; } in
Print.register0 wit printer
let raw_print wit v = (Print.obj wit).raw v
diff --git a/printing/genprint.mli b/printing/genprint.mli
index 6e6626f2..fd5dd725 100644
--- a/printing/genprint.mli
+++ b/printing/genprint.mli
@@ -1,28 +1,54 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
(** Entry point for generic printers *)
-open Pp
open Genarg
-val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw -> std_ppcmds
+type 'a with_level =
+ { default_already_surrounded : Notation_term.tolerability;
+ default_ensure_surrounded : Notation_term.tolerability;
+ printer : 'a }
+
+type printer_result =
+| PrinterBasic of (unit -> Pp.t)
+| PrinterNeedsLevel of (Notation_term.tolerability -> Pp.t) with_level
+
+type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t
+
+type top_printer_result =
+| TopPrinterBasic of (unit -> Pp.t)
+| TopPrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t)
+| TopPrinterNeedsContextAndLevel of printer_fun_with_level with_level
+
+type 'a printer = 'a -> printer_result
+
+type 'a top_printer = 'a -> top_printer_result
+
+val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw printer
(** Printer for raw level generic arguments. *)
-val glb_print : ('raw, 'glb, 'top) genarg_type -> 'glb -> std_ppcmds
+val glb_print : ('raw, 'glb, 'top) genarg_type -> 'glb printer
(** Printer for glob level generic arguments. *)
-val top_print : ('raw, 'glb, 'top) genarg_type -> 'top -> std_ppcmds
+val top_print : ('raw, 'glb, 'top) genarg_type -> 'top top_printer
(** Printer for top level generic arguments. *)
-val generic_raw_print : rlevel generic_argument -> std_ppcmds
-val generic_glb_print : glevel generic_argument -> std_ppcmds
-val generic_top_print : tlevel generic_argument -> std_ppcmds
-
val register_print0 : ('raw, 'glb, 'top) genarg_type ->
- ('raw -> std_ppcmds) -> ('glb -> std_ppcmds) -> ('top -> std_ppcmds) -> unit
+ 'raw printer -> 'glb printer -> 'top top_printer -> unit
+val register_val_print0 : 'top Geninterp.Val.typ ->
+ 'top top_printer -> unit
+val register_vernac_print0 : ('raw, 'glb, 'top) genarg_type ->
+ 'raw printer -> unit
+
+val generic_raw_print : rlevel generic_argument printer
+val generic_glb_print : glevel generic_argument printer
+val generic_top_print : tlevel generic_argument top_printer
+val generic_val_print : Geninterp.Val.t top_printer
diff --git a/printing/miscprint.ml b/printing/miscprint.ml
deleted file mode 100644
index 7b2c5695..00000000
--- a/printing/miscprint.ml
+++ /dev/null
@@ -1,49 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Misctypes
-open Pp
-
-(** Printing of [intro_pattern] *)
-
-let rec pr_intro_pattern prc (_,pat) = match pat with
- | IntroForthcoming true -> str "*"
- | IntroForthcoming false -> str "**"
- | IntroNaming p -> pr_intro_pattern_naming p
- | IntroAction p -> pr_intro_pattern_action prc p
-
-and pr_intro_pattern_naming = function
- | IntroIdentifier id -> Nameops.pr_id id
- | IntroFresh id -> str "?" ++ Nameops.pr_id id
- | IntroAnonymous -> str "?"
-
-and pr_intro_pattern_action prc = function
- | IntroWildcard -> str "_"
- | IntroOrAndPattern pll -> pr_or_and_intro_pattern prc pll
- | IntroInjection pl ->
- str "[=" ++ hv 0 (prlist_with_sep spc (pr_intro_pattern prc) pl) ++
- str "]"
- | IntroApplyOn (c,pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c
- | IntroRewrite true -> str "->"
- | IntroRewrite false -> str "<-"
-
-and pr_or_and_intro_pattern prc = function
- | IntroAndPattern pl ->
- str "(" ++ hv 0 (prlist_with_sep pr_comma (pr_intro_pattern prc) pl) ++ str ")"
- | IntroOrPattern pll ->
- str "[" ++
- hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc (pr_intro_pattern prc)) pll)
- ++ str "]"
-
-(** Printing of [move_location] *)
-
-let pr_move_location pr_id = function
- | MoveAfter id -> brk(1,1) ++ str "after " ++ pr_id id
- | MoveBefore id -> brk(1,1) ++ str "before " ++ pr_id id
- | MoveFirst -> str " at top"
- | MoveLast -> str " at bottom"
diff --git a/printing/miscprint.mli b/printing/miscprint.mli
deleted file mode 100644
index fe8c779f..00000000
--- a/printing/miscprint.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Misctypes
-
-(** Printing of [intro_pattern] *)
-
-val pr_intro_pattern :
- ('a -> Pp.std_ppcmds) -> 'a intro_pattern_expr Loc.located -> Pp.std_ppcmds
-
-val pr_or_and_intro_pattern :
- ('a -> Pp.std_ppcmds) -> 'a or_and_intro_pattern_expr -> Pp.std_ppcmds
-
-val pr_intro_pattern_naming : intro_pattern_naming_expr -> Pp.std_ppcmds
-
-(** Printing of [move_location] *)
-
-val pr_move_location :
- ('a -> Pp.std_ppcmds) -> 'a move_location -> Pp.std_ppcmds
diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml
deleted file mode 100644
index 511f9356..00000000
--- a/printing/ppannotation.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Ppextend
-open Constrexpr
-open Vernacexpr
-open Tacexpr
-
-type t =
- | AKeyword
- | AUnparsing of unparsing
- | AConstrExpr of constr_expr
- | AVernac of vernac_expr
- | AGlobTacticExpr of glob_tactic_expr
- | AGlobAtomicTacticExpr of glob_atomic_tactic_expr
- | ARawTacticExpr of raw_tactic_expr
- | ARawAtomicTacticExpr of raw_atomic_tactic_expr
- | AAtomicTacticExpr of atomic_tactic_expr
-
-let tag_of_annotation = function
- | AKeyword -> "keyword"
- | AUnparsing _ -> "unparsing"
- | AConstrExpr _ -> "constr_expr"
- | AVernac _ -> "vernac_expr"
- | AGlobTacticExpr _ -> "glob_tactic_expr"
- | AGlobAtomicTacticExpr _ -> "glob_atomic_tactic_expr"
- | ARawTacticExpr _ -> "raw_tactic_expr"
- | ARawAtomicTacticExpr _ -> "raw_atomic_tactic_expr"
- | AAtomicTacticExpr _ -> "atomic_tactic_expr"
-
-let attributes_of_annotation a =
- []
-
-let tag = Pp.Tag.create "ppannotation"
diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli
deleted file mode 100644
index a0fef1a7..00000000
--- a/printing/ppannotation.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** This module defines the annotations that are attached to
- semi-structured pretty-printing of Coq syntactic objects. *)
-
-open Ppextend
-open Constrexpr
-open Vernacexpr
-open Tacexpr
-
-type t =
- | AKeyword
- | AUnparsing of unparsing
- | AConstrExpr of constr_expr
- | AVernac of vernac_expr
- | AGlobTacticExpr of glob_tactic_expr
- | AGlobAtomicTacticExpr of glob_atomic_tactic_expr
- | ARawTacticExpr of raw_tactic_expr
- | ARawAtomicTacticExpr of raw_atomic_tactic_expr
- | AAtomicTacticExpr of atomic_tactic_expr
-
-val tag_of_annotation : t -> string
-
-val attributes_of_annotation : t -> (string * string) list
-
-val tag : t Pp.Tag.key
diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml
index aa94fb7b..4c5d955c 100644
--- a/printing/ppconstr.ml
+++ b/printing/ppconstr.ml
@@ -1,38 +1,55 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
(*i*)
open CErrors
open Util
open Pp
+open CAst
open Names
open Nameops
open Libnames
open Pputils
open Ppextend
+open Notation_term
open Constrexpr
open Constrexpr_ops
open Decl_kinds
open Misctypes
(*i*)
-module Make (Taggers : sig
- val tag_keyword : std_ppcmds -> std_ppcmds
- val tag_evar : std_ppcmds -> std_ppcmds
- val tag_type : std_ppcmds -> std_ppcmds
- val tag_path : std_ppcmds -> std_ppcmds
- val tag_ref : std_ppcmds -> std_ppcmds
- val tag_var : std_ppcmds -> std_ppcmds
- val tag_constr_expr : constr_expr -> std_ppcmds -> std_ppcmds
- val tag_unparsing : unparsing -> std_ppcmds -> std_ppcmds
-end) = struct
+module Tag =
+struct
+ let keyword = "constr.keyword"
+ let evar = "constr.evar"
+ let univ = "constr.type"
+ let notation = "constr.notation"
+ let variable = "constr.variable"
+ let reference = "constr.reference"
+ let path = "constr.path"
+
+end
+
+let do_not_tag _ x = x
+let tag t s = Pp.tag t s
+let tag_keyword = tag Tag.keyword
+let tag_evar = tag Tag.evar
+let tag_type = tag Tag.univ
+let tag_unparsing = function
+| UnpTerminal s -> tag Tag.notation
+| _ -> do_not_tag ()
+let tag_constr_expr = do_not_tag
+let tag_path = tag Tag.path
+let tag_ref = tag Tag.reference
+let tag_var = tag Tag.variable
- open Taggers
let keyword s = tag_keyword (str s)
let sep_v = fun _ -> str"," ++ spc()
@@ -67,13 +84,13 @@ end) = struct
| Any -> true
let prec_of_prim_token = function
- | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint
+ | Numeral (_,b) -> if b then lposint else lnegint
| String _ -> latom
open Notation
- let print_hunks n pr pr_binders (terms, termlists, binders) unps =
- let env = ref terms and envlist = ref termlists and bll = ref binders in
+ let print_hunks n pr pr_patt pr_binders (terms, termlists, binders, binderlists) unps =
+ let env = ref terms and envlist = ref termlists and bl = ref binders and bll = ref binderlists in
let pop r = let a = List.hd !r in r := List.tl !r; a in
let return unp pp1 pp2 = (tag_unparsing unp pp1) ++ pp2 in
(* Warning:
@@ -88,6 +105,11 @@ end) = struct
let pp2 = aux l in
let pp1 = pr (n, prec) c in
return unp pp1 pp2
+ | UnpBinderMetaVar (_, prec) as unp :: l ->
+ let c = pop bl in
+ let pp2 = aux l in
+ let pp1 = pr_patt (n, prec) c in
+ return unp pp1 pp2
| UnpListMetaVar (_, prec, sl) as unp :: l ->
let cl = pop envlist in
let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in
@@ -103,7 +125,7 @@ end) = struct
let pp1 = str s in
return unp pp1 pp2
| UnpBox (b,sub) as unp :: l ->
- let pp1 = ppcmd_of_box b (aux sub) in
+ let pp1 = ppcmd_of_box b (aux (List.map snd sub)) in
let pp2 = aux l in
return unp pp1 pp2
| UnpCut cut as unp :: l ->
@@ -113,9 +135,9 @@ end) = struct
in
aux unps
- let pr_notation pr pr_binders s env =
+ let pr_notation pr pr_patt pr_binders s env =
let unpl, level = find_notation_printing_rule s in
- print_hunks level pr pr_binders env unpl, level
+ print_hunks level pr pr_patt pr_binders env unpl, level
let pr_delimiters key strm =
strm ++ str ("%"^key)
@@ -129,17 +151,22 @@ end) = struct
str "`" ++ str hd ++ c ++ str tl
let pr_com_at n =
- if !Flags.beautify && not (Int.equal n 0) then comment (CLexer.extract_comments n)
+ if !Flags.beautify && not (Int.equal n 0) then comment (Pputils.extract_comments n)
else mt()
- let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
+ let pr_with_comments ?loc pp = pr_located (fun x -> x) (loc, pp)
- let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c)
+ let pr_sep_com sep f c = pr_with_comments ?loc:(constr_loc c) (sep() ++ f c)
+
+ let pr_univ_expr = function
+ | Some (x,n) ->
+ pr_reference x ++ (match n with 0 -> mt () | _ -> str"+" ++ int n)
+ | None -> str"_"
let pr_univ l =
match l with
- | [_,x] -> str x
- | l -> str"max(" ++ prlist_with_sep (fun () -> str",") (fun x -> str (snd x)) l ++ str")"
+ | [x] -> pr_univ_expr x
+ | l -> str"max(" ++ prlist_with_sep (fun () -> str",") pr_univ_expr l ++ str")"
let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}"
@@ -152,22 +179,23 @@ end) = struct
let pr_glob_level = function
| GProp -> tag_type (str "Prop")
| GSet -> tag_type (str "Set")
- | GType None -> tag_type (str "Type")
- | GType (Some (_, u)) -> tag_type (str u)
+ | GType UUnknown -> tag_type (str "Type")
+ | GType UAnonymous -> tag_type (str "_")
+ | GType (UNamed u) -> tag_type (pr_reference u)
let pr_qualid sp =
let (sl, id) = repr_qualid sp in
- let id = tag_ref (pr_id id) in
+ let id = tag_ref (Id.print id) in
let sl = match List.rev (DirPath.repr sl) with
| [] -> mt ()
| sl ->
- let pr dir = tag_path (pr_id dir) ++ str "." in
+ let pr dir = tag_path (Id.print dir) ++ str "." in
prlist pr sl
in
sl ++ id
- let pr_id = pr_id
- let pr_name = pr_name
+ let pr_id = Id.print
+ let pr_name = Name.print
let pr_qualid = pr_qualid
let pr_patvar = pr_id
@@ -178,15 +206,16 @@ end) = struct
tag_type (str "Set")
| GType u ->
(match u with
- | Some (_,u) -> str u
- | None -> tag_type (str "Type"))
+ | UNamed u -> pr_reference u
+ | UAnonymous -> tag_type (str "Type")
+ | UUnknown -> tag_type (str "_"))
let pr_universe_instance l =
pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_sort_instance)) l
- let pr_reference = function
- | Qualid (_, qid) -> pr_qualid qid
- | Ident (_, id) -> tag_var (pr_id id)
+ let pr_reference = CAst.with_val (function
+ | Qualid qid -> pr_qualid qid
+ | Ident id -> tag_var (pr_id id))
let pr_cref ref us =
pr_reference ref ++ pr_universe_instance us
@@ -194,36 +223,31 @@ end) = struct
let pr_expl_args pr (a,expl) =
match expl with
| None -> pr (lapp,L) a
- | Some (_,ExplByPos (n,_id)) ->
- anomaly (Pp.str "Explicitation by position not implemented")
- | Some (_,ExplByName id) ->
+ | Some {v=ExplByPos (n,_id)} ->
+ anomaly (Pp.str "Explicitation by position not implemented.")
+ | Some {v=ExplByName id} ->
str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")"
- let pr_opt_type pr = function
- | CHole (_,_,Misctypes.IntroAnonymous,_) -> mt ()
- | t -> cut () ++ str ":" ++ pr t
-
let pr_opt_type_spc pr = function
- | CHole (_,_,Misctypes.IntroAnonymous,_) -> mt ()
+ | { CAst.v = CHole (_,Misctypes.IntroAnonymous,_) } -> mt ()
| t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t
- let pr_lident (loc,id) =
- if not (Loc.is_ghost loc) then
- let (b,_) = Loc.unloc loc in
- pr_located pr_id (Loc.make_loc (b,b + String.length (Id.to_string id)), id)
- else
- pr_id id
+ let pr_lident {loc; v=id} =
+ match loc with
+ | None -> pr_id id
+ | Some loc -> let (b,_) = Loc.unloc loc in
+ pr_located pr_id (Some (Loc.make_loc (b,b + String.length (Id.to_string id))), id)
let pr_lname = function
- | (loc,Name id) -> pr_lident (loc,id)
- | lna -> pr_located pr_name lna
+ | {CAst.loc; v=Name id} -> pr_lident CAst.(make ?loc id)
+ | x -> pr_ast Name.print x
let pr_or_var pr = function
| ArgArg x -> pr x
- | ArgVar (loc,s) -> pr_lident (loc,s)
+ | ArgVar id -> pr_lident id
let pr_prim_token = function
- | Numeral n -> str (Bigint.to_string n)
+ | Numeral (n,s) -> str (if s then n else "-"^n)
| String s -> qs s
let pr_evar pr id l =
@@ -240,73 +264,74 @@ end) = struct
let lpatrec = 0
let rec pr_patt sep inh p =
- let (strm,prec) = match p with
- | CPatRecord (_, l) ->
+ let (strm,prec) = match CAst.(p.v) with
+ | CPatRecord l ->
let pp (c, p) =
pr_reference c ++ spc() ++ str ":=" ++ pr_patt spc (lpatrec, Any) p
in
str "{| " ++ prlist_with_sep pr_semicolon pp l ++ str " |}", lpatrec
- | CPatAlias (_, p, id) ->
- pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
+ | CPatAlias (p, na) ->
+ pr_patt mt (las,E) p ++ str " as " ++ pr_lname na, las
- | CPatCstr (_,c, None, []) ->
+ | CPatCstr (c, None, []) ->
pr_reference c, latom
- | CPatCstr (_, c, None, args) ->
+ | CPatCstr (c, None, args) ->
pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
- | CPatCstr (_, c, Some args, []) ->
+ | CPatCstr (c, Some args, []) ->
str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
- | CPatCstr (_, c, Some expl_args, extra_args) ->
+ | CPatCstr (c, Some expl_args, extra_args) ->
surround (str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) expl_args)
++ prlist (pr_patt spc (lapp,L)) extra_args, lapp
- | CPatAtom (_, None) ->
+ | CPatAtom (None) ->
str "_", latom
- | CPatAtom (_,Some r) ->
+ | CPatAtom (Some r) ->
pr_reference r, latom
- | CPatOr (_,pl) ->
- hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator
+ | CPatOr pl ->
+ hov 0 (prlist_with_sep pr_spcbar (pr_patt mt (lpator,L)) pl), lpator
- | CPatNotation (_,"( _ )",([p],[]),[]) ->
+ | CPatNotation ("( _ )",([p],[]),[]) ->
pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom
- | CPatNotation (_,s,(l,ll),args) ->
- let strm_not, l_not = pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[]) in
+ | CPatNotation (s,(l,ll),args) ->
+ let strm_not, l_not = pr_notation (pr_patt mt) (fun _ _ -> mt ()) (fun _ _ _ -> mt()) s (l,ll,[],[]) in
(if List.is_empty args||prec_less l_not (lapp,L) then strm_not else surround strm_not)
++ prlist (pr_patt spc (lapp,L)) args, if not (List.is_empty args) then lapp else l_not
- | CPatPrim (_,p) ->
+ | CPatPrim p ->
pr_prim_token p, latom
- | CPatDelimiters (_,k,p) ->
+ | CPatDelimiters (k,p) ->
pr_delimiters k (pr_patt mt lsimplepatt p), 1
| CPatCast _ ->
assert false
in
- let loc = cases_pattern_expr_loc p in
- pr_with_comments loc
+ let loc = p.CAst.loc in
+ pr_with_comments ?loc
(sep() ++ if prec_less prec inh then strm else surround strm)
let pr_patt = pr_patt mt
- let pr_eqn pr (loc,pl,rhs) =
- let pl = List.map snd pl in
+ let pr_eqn pr {loc;v=(pl,rhs)} =
spc() ++ hov 4
- (pr_with_comments loc
+ (pr_with_comments ?loc
(str "| " ++
- hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl
+ hov 0 (prlist_with_sep pr_spcbar (prlist_with_sep sep_v (pr_patt ltop)) pl
++ str " =>") ++
pr_sep_com spc (pr ltop) rhs))
- let begin_of_binder = function
- LocalRawDef((loc,_),_) -> fst (Loc.unloc loc)
- | LocalRawAssum((loc,_)::_,_,_) -> fst (Loc.unloc loc)
- | LocalPattern(loc,_,_) -> fst (Loc.unloc loc)
+ let begin_of_binder l_bi =
+ let b_loc l = fst (Option.cata Loc.unloc (0,0) l) in
+ match l_bi with
+ | CLocalDef({loc},_,_) -> b_loc loc
+ | CLocalAssum({loc}::_,_,_) -> b_loc loc
+ | CLocalPattern{loc} -> b_loc loc
| _ -> assert false
let begin_of_binders = function
@@ -328,18 +353,18 @@ end) = struct
| Generalized (b, b', t') ->
assert (match b with Implicit -> true | _ -> false);
begin match nal with
- |[loc,Anonymous] ->
+ |[{loc; v=Anonymous}] ->
hov 1 (str"`" ++ (surround_impl b'
((if t' then str "!" else mt ()) ++ pr t)))
- |[loc,Name id] ->
+ |[{loc; v=Name id}] ->
hov 1 (str "`" ++ (surround_impl b'
- (pr_lident (loc,id) ++ str " : " ++
+ (pr_lident CAst.(make ?loc id) ++ str " : " ++
(if t' then str "!" else mt()) ++ pr t)))
|_ -> anomaly (Pp.str "List of generalized binders have alwais one element.")
end
| Default b ->
match t with
- | CHole (_,_,Misctypes.IntroAnonymous,_) ->
+ | { CAst.v = CHole (_,Misctypes.IntroAnonymous,_) } ->
let s = prlist_with_sep spc pr_lname nal in
hov 1 (surround_implicit b s)
| _ ->
@@ -347,15 +372,13 @@ end) = struct
hov 1 (if many then surround_impl b s else surround_implicit b s)
let pr_binder_among_many pr_c = function
- | LocalRawAssum (nal,k,t) ->
+ | CLocalAssum (nal,k,t) ->
pr_binder true pr_c (nal,k,t)
- | LocalRawDef (na,c) ->
- let c,topt = match c with
- | CCast(_,c, (CastConv t|CastVM t|CastNative t)) -> c, t
- | _ -> c, CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in
- surround (pr_lname na ++ pr_opt_type pr_c topt ++
- str":=" ++ cut() ++ pr_c c)
- | LocalPattern (loc,p,tyo) ->
+ | CLocalDef (na,c,topt) ->
+ surround (pr_lname na ++
+ pr_opt_no_spc (fun t -> str " :" ++ ws 1 ++ pr_c t) topt ++
+ str" :=" ++ spc() ++ pr_c c)
+ | CLocalPattern {CAst.loc; v = p,tyo} ->
let p = pr_patt lsimplepatt p in
match tyo with
| None ->
@@ -369,80 +392,20 @@ end) = struct
let pr_delimited_binders kw sep pr_c bl =
let n = begin_of_binders bl in
match bl with
- | [LocalRawAssum (nal,k,t)] ->
+ | [CLocalAssum (nal,k,t)] ->
kw n ++ pr_binder false pr_c (nal,k,t)
- | (LocalRawAssum _ | LocalPattern _) :: _ as bdl ->
+ | (CLocalAssum _ | CLocalPattern _ | CLocalDef _) :: _ as bdl ->
kw n ++ pr_undelimited_binders sep pr_c bdl
- | _ -> assert false
+ | [] -> assert false
let pr_binders_gen pr_c sep is_open =
if is_open then pr_delimited_binders pr_com_at sep pr_c
else pr_undelimited_binders sep pr_c
- let rec extract_prod_binders = function
- (* | CLetIn (loc,na,b,c) as x ->
- let bl,c = extract_prod_binders c in
- if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
- | CProdN (loc,[],c) ->
- extract_prod_binders c
- | CProdN (loc,[[_,Name id],bk,t],
- CCases (_,LetPatternStyle,None, [CRef (Ident (_,id'),None),None,None],[(_,[_,[p]],b)]))
- when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) ->
- let bl,c = extract_prod_binders b in
- LocalPattern (loc,p,None) :: bl, c
- | CProdN (loc,(nal,bk,t)::bl,c) ->
- let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in
- LocalRawAssum (nal,bk,t) :: bl, c
- | c -> [], c
-
- let rec extract_lam_binders = function
- (* | CLetIn (loc,na,b,c) as x ->
- let bl,c = extract_lam_binders c in
- if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
- | CLambdaN (loc,[],c) ->
- extract_lam_binders c
- | CLambdaN (loc,[[_,Name id],bk,t],
- CCases (_,LetPatternStyle,None, [CRef (Ident (_,id'),None),None,None],[(_,[_,[p]],b)]))
- when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) ->
- let bl,c = extract_lam_binders b in
- LocalPattern (loc,p,None) :: bl, c
- | CLambdaN (loc,(nal,bk,t)::bl,c) ->
- let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in
- LocalRawAssum (nal,bk,t) :: bl, c
- | c -> [], c
-
- let split_lambda = function
- | CLambdaN (loc,[[na],bk,t],c) -> (na,t,c)
- | CLambdaN (loc,([na],bk,t)::bl,c) -> (na,t,CLambdaN(loc,bl,c))
- | CLambdaN (loc,(na::nal,bk,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,bk,t)::bl,c))
- | _ -> anomaly (Pp.str "ill-formed fixpoint body")
-
- let rename na na' t c =
- match (na,na') with
- | (_,Name id), (_,Name id') ->
- (na',t,Topconstr.replace_vars_constr_expr (Id.Map.singleton id id') c)
- | (_,Name id), (_,Anonymous) -> (na,t,c)
- | _ -> (na',t,c)
-
- let split_product na' = function
- | CProdN (loc,[[na],bk,t],c) -> rename na na' t c
- | CProdN (loc,([na],bk,t)::bl,c) -> rename na na' t (CProdN(loc,bl,c))
- | CProdN (loc,(na::nal,bk,t)::bl,c) ->
- rename na na' t (CProdN(loc,(nal,bk,t)::bl,c))
- | _ -> anomaly (Pp.str "ill-formed fixpoint body")
-
- let rec split_fix n typ def =
- if Int.equal n 0 then ([],typ,def)
- else
- let (na,_,def) = split_lambda def in
- let (na,t,typ) = split_product na typ in
- let (bl,typ,def) = split_fix (n-1) typ def in
- (LocalRawAssum ([na],default_binder_kind,t)::bl,typ,def)
-
let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c =
let pr_body =
if dangling_with_for then pr_dangling else pr in
- pr_id id ++ str" " ++
+ pr_id id ++ (if bl = [] then mt () else str" ") ++
hov 0 (pr_undelimited_binders spc (pr ltop) bl ++ annot) ++
pr_opt_type_spc pr t ++ str " :=" ++
pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
@@ -450,13 +413,13 @@ end) = struct
let pr_guard_annot pr_aux bl (n,ro) =
match n with
| None -> mt ()
- | Some (loc, id) ->
+ | Some {loc; v = id} ->
match (ro : Constrexpr.recursion_order_expr) with
| CStructRec ->
let names_of_binder = function
- | LocalRawAssum (nal,_,_) -> nal
- | LocalRawDef (_,_) -> []
- | LocalPattern _ -> assert false
+ | CLocalAssum (nal,_,_) -> nal
+ | CLocalDef (_,_,_) -> []
+ | CLocalPattern _ -> assert false
in let ids = List.flatten (List.map names_of_binder bl) in
if List.length ids > 1 then
spc() ++ str "{" ++ keyword "struct" ++ spc () ++ pr_id id ++ str"}"
@@ -467,15 +430,15 @@ end) = struct
spc() ++ str "{" ++ keyword "measure" ++ spc () ++ pr_aux m ++ spc() ++ pr_id id++
(match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}"
- let pr_fixdecl pr prd dangling_with_for ((_,id),ro,bl,t,c) =
+ let pr_fixdecl pr prd dangling_with_for ({v=id},ro,bl,t,c) =
let annot = pr_guard_annot (pr lsimpleconstr) bl ro in
pr_recursive_decl pr prd dangling_with_for id bl annot t c
- let pr_cofixdecl pr prd dangling_with_for ((_,id),bl,t,c) =
+ let pr_cofixdecl pr prd dangling_with_for ({v=id},bl,t,c) =
pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c
let pr_recursive pr_decl id = function
- | [] -> anomaly (Pp.str "(co)fixpoint with no definition")
+ | [] -> anomaly (Pp.str "(co)fixpoint with no definition.")
| [d1] -> pr_decl false d1
| dl ->
prlist_with_sep (fun () -> fnl() ++ keyword "with" ++ spc ())
@@ -495,13 +458,13 @@ end) = struct
let pr_case_type pr po =
match po with
- | None | Some (CHole (_,_,Misctypes.IntroAnonymous,_)) -> mt()
+ | None | Some { CAst.v = CHole (_,Misctypes.IntroAnonymous,_) } -> mt()
| Some p ->
spc() ++ hov 2 (keyword "return" ++ pr_sep_com spc (pr lsimpleconstr) p)
let pr_simple_return_type pr na po =
(match na with
- | Some (_,Name id) ->
+ | Some {v=Name id} ->
spc () ++ keyword "as" ++ spc () ++ pr_id id
| _ -> mt ()) ++
pr_case_type pr po
@@ -532,33 +495,32 @@ end) = struct
let pr_fun_sep = spc () ++ str "=>"
let pr_dangling_with_for sep pr inherited a =
- match a with
- | (CFix (_,_,[_])|CCoFix(_,_,[_])) ->
+ match a.v with
+ | (CFix (_,[_])|CCoFix(_,[_])) ->
pr sep (latom,E) a
| _ ->
pr sep inherited a
let pr pr sep inherited a =
let return (cmds, prec) = (tag_constr_expr a cmds, prec) in
- let (strm, prec) = match a with
+ let (strm, prec) = match CAst.(a.v) with
| CRef (r, us) ->
return (pr_cref r us, latom)
- | CFix (_,id,fix) ->
+ | CFix (id,fix) ->
return (
hov 0 (keyword "fix" ++ spc () ++
pr_recursive
- (pr_fixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) fix),
+ (pr_fixdecl (pr mt) (pr_dangling_with_for mt pr)) id.v fix),
lfix
)
- | CCoFix (_,id,cofix) ->
+ | CCoFix (id,cofix) ->
return (
hov 0 (keyword "cofix" ++ spc () ++
pr_recursive
- (pr_cofixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) cofix),
+ (pr_cofixdecl (pr mt) (pr_dangling_with_for mt pr)) id.v cofix),
lfix
)
- | CProdN _ ->
- let (bl,a) = extract_prod_binders a in
+ | CProdN (bl,a) ->
return (
hov 0 (
hov 2 (pr_delimited_binders pr_forall spc
@@ -566,8 +528,7 @@ end) = struct
str "," ++ pr spc ltop a),
lprod
)
- | CLambdaN _ ->
- let (bl,a) = extract_lam_binders a in
+ | CLambdaN (bl,a) ->
return (
hov 0 (
hov 2 (pr_delimited_binders pr_fun spc
@@ -575,7 +536,8 @@ end) = struct
pr_fun_sep ++ pr spc ltop a),
llambda
)
- | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b)
+ | CLetIn ({v=Name x}, ({ v = CFix({v=x'},[_])}
+ | { v = CCoFix({v=x'},[_]) } as fx), t, b)
when Id.equal x x' ->
return (
hv 0 (
@@ -585,16 +547,17 @@ end) = struct
pr spc ltop b),
lletin
)
- | CLetIn (_,x,a,b) ->
+ | CLetIn (x,a,t,b) ->
return (
hv 0 (
- hov 2 (keyword "let" ++ spc () ++ pr_lname x ++ str " :="
- ++ pr spc ltop a ++ spc ()
+ hov 2 (keyword "let" ++ spc () ++ pr_lname x
+ ++ pr_opt_no_spc (fun t -> str " :" ++ ws 1 ++ pr mt ltop t) t
+ ++ str " :=" ++ pr spc ltop a ++ spc ()
++ keyword "in") ++
pr spc ltop b),
lletin
)
- | CAppExpl (_,(Some i,f,us),l) ->
+ | CAppExpl ((Some i,f,us),l) ->
let l1,l2 = List.chop i l in
let c,l1 = List.sep_last l1 in
let p = pr_proj (pr mt) pr_appexpl c (f,us) l1 in
@@ -602,16 +565,16 @@ end) = struct
return (p ++ prlist (pr spc (lapp,L)) l2, lapp)
else
return (p, lproj)
- | CAppExpl (_,(None,Ident (_,var),us),[t])
- | CApp (_,(_,CRef(Ident(_,var),us)),[t,None])
+ | CAppExpl ((None,{v=Ident var},us),[t])
+ | CApp ((_, {v = CRef({v=Ident var},us)}),[t,None])
when Id.equal var Notation_ops.ldots_var ->
return (
hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."),
larg
)
- | CAppExpl (_,(None,f,us),l) ->
+ | CAppExpl ((None,f,us),l) ->
return (pr_appexpl (pr mt) (f,us) l, lapp)
- | CApp (_,(Some i,f),l) ->
+ | CApp ((Some i,f),l) ->
let l1,l2 = List.chop i l in
let c,l1 = List.sep_last l1 in
assert (Option.is_empty (snd c));
@@ -623,14 +586,14 @@ end) = struct
)
else
return (p, lproj)
- | CApp (_,(None,a),l) ->
+ | CApp ((None,a),l) ->
return (pr_app (pr mt) a l, lapp)
- | CRecord (_,l) ->
+ | CRecord l ->
return (
hv 0 (str"{|" ++ pr_record_body_gen (pr spc) l ++ str" |}"),
latom
)
- | CCases (_,LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[(_,[(loc,[p])],b)]) ->
+ | CCases (LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[{v=([[p]],b)}]) ->
return (
hv 0 (
keyword "let" ++ spc () ++ str"'" ++
@@ -641,7 +604,7 @@ end) = struct
spc () ++ keyword "in" ++ pr spc ltop b)),
lletpattern
)
- | CCases(_,_,rtntypopt,c,eqns) ->
+ | CCases(_,rtntypopt,c,eqns) ->
return (
v 0
(hv 0 (keyword "match" ++ brk (1,2) ++
@@ -654,7 +617,7 @@ end) = struct
++ keyword "end"),
latom
)
- | CLetTuple (_,nal,(na,po),c,b) ->
+ | CLetTuple (nal,(na,po),c,b) ->
return (
hv 0 (
hov 2 (keyword "let" ++ spc () ++
@@ -667,7 +630,7 @@ end) = struct
pr spc ltop b),
lletin
)
- | CIf (_,c,(na,po),b1,b2) ->
+ | CIf (c,(na,po),b1,b2) ->
(* On force les parenthèses autour d'un "if" sous-terme (même si le
parsing est lui plus tolérant) *)
return (
@@ -681,19 +644,19 @@ end) = struct
lif
)
- | CHole (_,_,Misctypes.IntroIdentifier id,_) ->
+ | CHole (_,Misctypes.IntroIdentifier id,_) ->
return (str "?[" ++ pr_id id ++ str "]", latom)
- | CHole (_,_,Misctypes.IntroFresh id,_) ->
+ | CHole (_,Misctypes.IntroFresh id,_) ->
return (str "?[?" ++ pr_id id ++ str "]", latom)
- | CHole (_,_,_,_) ->
+ | CHole (_,_,_) ->
return (str "_", latom)
- | CEvar (_,n,l) ->
+ | CEvar (n,l) ->
return (pr_evar (pr mt) n l, latom)
- | CPatVar (_,p) ->
- return (str "?" ++ pr_patvar p, latom)
- | CSort (_,s) ->
+ | CPatVar p ->
+ return (str "@?" ++ pr_patvar p, latom)
+ | CSort s ->
return (pr_glob_sort s, latom)
- | CCast (_,a,b) ->
+ | CCast (a,b) ->
return (
hv 0 (pr mt (lcast,L) a ++ spc () ++
match b with
@@ -703,56 +666,65 @@ end) = struct
| CastCoerce -> str ":>"),
lcast
)
- | CNotation (_,"( _ )",([t],[],[])) ->
+ | CNotation ("( _ )",([t],[],[],[])) ->
return (pr (fun()->str"(") (max_int,L) t ++ str")", latom)
- | CNotation (_,s,env) ->
- pr_notation (pr mt) (pr_binders_gen (pr mt ltop)) s env
- | CGeneralization (_,bk,ak,c) ->
+ | CNotation (s,env) ->
+ pr_notation (pr mt) pr_patt (pr_binders_gen (pr mt ltop)) s env
+ | CGeneralization (bk,ak,c) ->
return (pr_generalization bk ak (pr mt ltop c), latom)
- | CPrim (_,p) ->
+ | CPrim p ->
return (pr_prim_token p, prec_of_prim_token p)
- | CDelimiters (_,sc,a) ->
+ | CDelimiters (sc,a) ->
return (pr_delimiters sc (pr mt (ldelim,E) a), ldelim)
in
let loc = constr_loc a in
- pr_with_comments loc
+ pr_with_comments ?loc
(sep() ++ if prec_less prec inherited then strm else surround strm)
type term_pr = {
- pr_constr_expr : constr_expr -> std_ppcmds;
- pr_lconstr_expr : constr_expr -> std_ppcmds;
- pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds;
- pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
+ pr_constr_expr : constr_expr -> Pp.t;
+ pr_lconstr_expr : constr_expr -> Pp.t;
+ pr_constr_pattern_expr : constr_pattern_expr -> Pp.t;
+ pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t
}
- type precedence = Ppextend.precedence * Ppextend.parenRelation
let modular_constr_pr = pr
let rec fix rf x = rf (fix rf) x
let pr = fix modular_constr_pr mt
- let transf env c =
+ let pr prec = function
+ (* A toplevel printer hack mimicking parsing, incidentally meaning
+ that we cannot use [pr] correctly anymore in a recursive loop
+ if the current expr is followed by other exprs which would be
+ interpreted as arguments *)
+ | { CAst.v = CAppExpl ((None,f,us),[]) } -> str "@" ++ pr_cref f us
+ | c -> pr prec c
+
+ let transf env sigma c =
if !Flags.beautify_file then
- let r = Constrintern.for_grammar (Constrintern.intern_constr env) c in
+ let r = Constrintern.for_grammar (Constrintern.intern_constr env sigma) c in
Constrextern.extern_glob_constr (Termops.vars_of_env env) r
else c
- let pr prec c = pr prec (transf (Global.env()) c)
+ let pr_expr prec c =
+ let env = Global.env () in
+ let sigma = Evd.from_env env in
+ pr prec (transf env sigma c)
- let pr_simpleconstr = function
- | CAppExpl (_,(None,f,us),[]) -> str "@" ++ pr_cref f us
- | c -> pr lsimpleconstr c
+ let pr_simpleconstr = pr_expr lsimpleconstr
let default_term_pr = {
pr_constr_expr = pr_simpleconstr;
- pr_lconstr_expr = pr ltop;
+ pr_lconstr_expr = pr_expr ltop;
pr_constr_pattern_expr = pr_simpleconstr;
- pr_lconstr_pattern_expr = pr ltop
+ pr_lconstr_pattern_expr = pr_expr ltop
}
let term_pr = ref default_term_pr
let set_term_pr = (:=) term_pr
+ let pr_constr_expr_n n c = pr_expr n c
let pr_constr_expr c = !term_pr.pr_constr_expr c
let pr_lconstr_expr c = !term_pr.pr_lconstr_expr c
let pr_constr_pattern_expr c = !term_pr.pr_constr_pattern_expr c
@@ -762,88 +734,5 @@ end) = struct
let pr_record_body = pr_record_body_gen pr
- let pr_binders = pr_undelimited_binders spc (pr ltop)
-
-end
-
-module Tag =
-struct
- let keyword =
- let style = Terminal.make ~bold:true () in
- Ppstyle.make ~style ["constr"; "keyword"]
-
- let evar =
- let style = Terminal.make ~fg_color:`LIGHT_BLUE () in
- Ppstyle.make ~style ["constr"; "evar"]
-
- let univ =
- let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in
- Ppstyle.make ~style ["constr"; "type"]
-
- let notation =
- let style = Terminal.make ~fg_color:`WHITE () in
- Ppstyle.make ~style ["constr"; "notation"]
-
- let variable =
- Ppstyle.make ["constr"; "variable"]
-
- let reference =
- let style = Terminal.make ~fg_color:`LIGHT_GREEN () in
- Ppstyle.make ~style ["constr"; "reference"]
-
- let path =
- let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in
- Ppstyle.make ~style ["constr"; "path"]
-
-end
-
-let do_not_tag _ x = x
-
-let split_token tag s =
- let len = String.length s in
- let rec parse_string off i =
- if Int.equal i len then
- if Int.equal off i then mt () else tag (str (String.sub s off (i - off)))
- else if s.[i] == ' ' then
- if Int.equal off i then parse_space 1 (succ i)
- else tag (str (String.sub s off (i - off))) ++ parse_space 1 (succ i)
- else parse_string off (succ i)
- and parse_space spc i =
- if Int.equal i len then str (String.make spc ' ')
- else if s.[i] == ' ' then parse_space (succ spc) (succ i)
- else str (String.make spc ' ') ++ parse_string i (succ i)
- in
- parse_string 0 0
-
-(** Instantiating Make with tagging functions that only add style
- information. *)
-include Make (struct
- let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s
- let tag_keyword = tag Tag.keyword
- let tag_evar = tag Tag.evar
- let tag_type = tag Tag.univ
- let tag_unparsing = function
- | UnpTerminal s -> fun _ -> split_token (fun pp -> tag Tag.notation pp) s
- | _ -> do_not_tag ()
- let tag_constr_expr = do_not_tag
- let tag_path = tag Tag.path
- let tag_ref = tag Tag.reference
- let tag_var = tag Tag.variable
-end)
-
-module Richpp = struct
-
- include Make (struct
- open Ppannotation
- let tag_keyword = Pp.tag (Pp.Tag.inj AKeyword tag)
- let tag_type = Pp.tag (Pp.Tag.inj AKeyword tag)
- let tag_evar = do_not_tag ()
- let tag_unparsing unp = Pp.tag (Pp.Tag.inj (AUnparsing unp) tag)
- let tag_constr_expr e = Pp.tag (Pp.Tag.inj (AConstrExpr e) tag)
- let tag_path = do_not_tag ()
- let tag_ref = do_not_tag ()
- let tag_var = do_not_tag ()
- end)
-
-end
+ let pr_binders = pr_undelimited_binders spc (pr_expr ltop)
diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli
index 0241633c..1f1308b0 100644
--- a/printing/ppconstr.mli
+++ b/printing/ppconstr.mli
@@ -1,21 +1,89 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
(** This module implements pretty-printers for constr_expr syntactic
objects and their subcomponents. *)
-(** The default pretty-printers produce {!Pp.std_ppcmds} that are
- interpreted as raw strings. *)
-include Ppconstrsig.Pp
+(** The default pretty-printers produce pretty-printing commands ({!Pp.t}). *)
+open Libnames
+open Constrexpr
+open Names
+open Misctypes
+open Notation_term
-(** The rich pretty-printers produce {!Pp.std_ppcmds} that are
- interpreted as annotated strings. The annotations can be
- retrieved using {!RichPp.rich_pp}. Their definitions are
- located in {!Ppannotation.t}. *)
+val prec_less : precedence -> tolerability -> bool
-module Richpp : Ppconstrsig.Pp
+val pr_tight_coma : unit -> Pp.t
+
+val pr_or_var : ('a -> Pp.t) -> 'a or_var -> Pp.t
+
+val pr_lident : lident -> Pp.t
+val pr_lname : lname -> Pp.t
+
+val pr_with_comments : ?loc:Loc.t -> Pp.t -> Pp.t
+val pr_com_at : int -> Pp.t
+val pr_sep_com :
+ (unit -> Pp.t) ->
+ (constr_expr -> Pp.t) ->
+ 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 : patvar -> Pp.t
+
+val pr_glob_level : glob_level -> Pp.t
+val pr_glob_sort : glob_sort -> Pp.t
+val pr_guard_annot : (constr_expr -> Pp.t) ->
+ local_binder_expr list ->
+ lident option * recursion_order_expr ->
+ Pp.t
+
+val pr_record_body : (reference * constr_expr) list -> Pp.t
+val pr_binders : local_binder_expr list -> Pp.t
+val pr_constr_pattern_expr : constr_pattern_expr -> Pp.t
+val pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t
+val pr_constr_expr : constr_expr -> Pp.t
+val pr_lconstr_expr : constr_expr -> Pp.t
+val pr_cases_pattern_expr : cases_pattern_expr -> Pp.t
+val pr_constr_expr_n : tolerability -> constr_expr -> Pp.t
+
+type term_pr = {
+ pr_constr_expr : constr_expr -> Pp.t;
+ pr_lconstr_expr : constr_expr -> Pp.t;
+ pr_constr_pattern_expr : constr_pattern_expr -> Pp.t;
+ pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t
+}
+
+val set_term_pr : term_pr -> unit
+val default_term_pr : term_pr
+
+(* The modular constr printer.
+ [modular_constr_pr pr s p t] prints the head of the term [t] and calls
+ [pr] on its subterms.
+ [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers
+ and [ltop] for "lconstr" printers (spiwack: we might need more
+ specification here).
+ We can make a new modular constr printer by overriding certain branches,
+ for instance if we want to build a printer which prints "Prop" as "Omega"
+ instead we can proceed as follows:
+ let my_modular_constr_pr pr s p = function
+ | CSort (_,GProp Null) -> str "Omega"
+ | t -> modular_constr_pr pr s p t
+ Which has the same type. We can turn a modular printer into a printer by
+ taking its fixpoint. *)
+
+val lsimpleconstr : tolerability
+val ltop : tolerability
+val modular_constr_pr :
+ ((unit->Pp.t) -> tolerability -> constr_expr -> Pp.t) ->
+ (unit->Pp.t) -> tolerability -> constr_expr -> Pp.t
diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli
deleted file mode 100644
index 3de0d805..00000000
--- a/printing/ppconstrsig.mli
+++ /dev/null
@@ -1,95 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Loc
-open Pp
-open Libnames
-open Constrexpr
-open Names
-open Misctypes
-
-module type Pp = sig
-
- val extract_lam_binders :
- constr_expr -> local_binder list * constr_expr
- val extract_prod_binders :
- constr_expr -> local_binder list * constr_expr
- val split_fix :
- int -> constr_expr -> constr_expr ->
- local_binder list * constr_expr * constr_expr
-
- val prec_less : int -> int * Ppextend.parenRelation -> bool
-
- val pr_tight_coma : unit -> std_ppcmds
-
- val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
-
- val pr_lident : Id.t located -> std_ppcmds
- val pr_lname : Name.t located -> std_ppcmds
-
- val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds
- val pr_com_at : int -> std_ppcmds
- val pr_sep_com :
- (unit -> std_ppcmds) ->
- (constr_expr -> std_ppcmds) ->
- constr_expr -> std_ppcmds
-
- val pr_id : Id.t -> std_ppcmds
- val pr_name : Name.t -> std_ppcmds
- val pr_qualid : qualid -> std_ppcmds
- val pr_patvar : patvar -> std_ppcmds
-
- val pr_glob_level : glob_level -> std_ppcmds
- val pr_glob_sort : glob_sort -> std_ppcmds
- val pr_guard_annot : (constr_expr -> std_ppcmds) ->
- local_binder list ->
- ('a * Names.Id.t) option * recursion_order_expr ->
- std_ppcmds
-
- val pr_record_body : (reference * constr_expr) list -> std_ppcmds
- val pr_binders : local_binder list -> std_ppcmds
- val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds
- val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
- val pr_constr_expr : constr_expr -> std_ppcmds
- val pr_lconstr_expr : constr_expr -> std_ppcmds
- val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds
-
- type term_pr = {
- pr_constr_expr : constr_expr -> std_ppcmds;
- pr_lconstr_expr : constr_expr -> std_ppcmds;
- pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds;
- pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
- }
-
- val set_term_pr : term_pr -> unit
- val default_term_pr : term_pr
-
-(** The modular constr printer.
- [modular_constr_pr pr s p t] prints the head of the term [t] and calls
- [pr] on its subterms.
- [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers
- and [ltop] for "lconstr" printers (spiwack: we might need more
- specification here).
- We can make a new modular constr printer by overriding certain branches,
- for instance if we want to build a printer which prints "Prop" as "Omega"
- instead we can proceed as follows:
- let my_modular_constr_pr pr s p = function
- | CSort (_,GProp Null) -> str "Omega"
- | t -> modular_constr_pr pr s p t
- Which has the same type. We can turn a modular printer into a printer by
- taking its fixpoint. *)
-
- type precedence
- val lsimpleconstr : precedence
- val ltop : precedence
- val modular_constr_pr :
- ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) ->
- (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds
-
-end
-
diff --git a/printing/pptactic.ml b/printing/pptactic.ml
deleted file mode 100644
index fcc30d70..00000000
--- a/printing/pptactic.ml
+++ /dev/null
@@ -1,1479 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Names
-open Namegen
-open CErrors
-open Util
-open Constrexpr
-open Tacexpr
-open Genarg
-open Geninterp
-open Constrarg
-open Libnames
-open Ppextend
-open Misctypes
-open Locus
-open Decl_kinds
-open Genredexpr
-open Ppconstr
-open Printer
-
-let pr_global x = Nametab.pr_global_env Id.Set.empty x
-
-type 'a grammar_tactic_prod_item_expr =
-| TacTerm of string
-| TacNonTerm of Loc.t * 'a * Names.Id.t
-
-type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
-
-type pp_tactic = {
- pptac_level : int;
- pptac_prods : grammar_terminals;
-}
-
-(* Tactic notations *)
-let prnotation_tab = Summary.ref ~name:"pptactic-notation" KNmap.empty
-
-let declare_notation_tactic_pprule kn pt =
- prnotation_tab := KNmap.add kn pt !prnotation_tab
-
-type 'a raw_extra_genarg_printer =
- (constr_expr -> std_ppcmds) ->
- (constr_expr -> std_ppcmds) ->
- (tolerability -> raw_tactic_expr -> std_ppcmds) ->
- 'a -> std_ppcmds
-
-type 'a glob_extra_genarg_printer =
- (glob_constr_and_expr -> std_ppcmds) ->
- (glob_constr_and_expr -> std_ppcmds) ->
- (tolerability -> glob_tactic_expr -> std_ppcmds) ->
- 'a -> std_ppcmds
-
-type 'a extra_genarg_printer =
- (Term.constr -> std_ppcmds) ->
- (Term.constr -> std_ppcmds) ->
- (tolerability -> Val.t -> std_ppcmds) ->
- 'a -> std_ppcmds
-
-let genarg_pprule = ref String.Map.empty
-
-let declare_extra_genarg_pprule wit f g h =
- let s = match wit with
- | ExtraArg s -> ArgT.repr s
- | _ -> error
- "Can declare a pretty-printing rule only for extra argument types."
- in
- let f prc prlc prtac x = f prc prlc prtac (out_gen (rawwit wit) x) in
- let g prc prlc prtac x = g prc prlc prtac (out_gen (glbwit wit) x) in
- let h prc prlc prtac x = h prc prlc prtac (out_gen (topwit wit) x) in
- genarg_pprule := String.Map.add s (f,g,h) !genarg_pprule
-
-module Make
- (Ppconstr : Ppconstrsig.Pp)
- (Taggers : sig
- val tag_keyword
- : std_ppcmds -> std_ppcmds
- val tag_primitive
- : std_ppcmds -> std_ppcmds
- val tag_string
- : std_ppcmds -> std_ppcmds
- val tag_glob_tactic_expr
- : glob_tactic_expr -> std_ppcmds -> std_ppcmds
- val tag_glob_atomic_tactic_expr
- : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds
- val tag_raw_tactic_expr
- : raw_tactic_expr -> std_ppcmds -> std_ppcmds
- val tag_raw_atomic_tactic_expr
- : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds
- val tag_atomic_tactic_expr
- : atomic_tactic_expr -> std_ppcmds -> std_ppcmds
- end)
-= struct
-
- open Taggers
-
- let keyword x = tag_keyword (str x)
- let primitive x = tag_primitive (str x)
-
- let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with
- | None -> false
- | Some _ -> true
-
- let unbox : type a. Val.t -> a Val.typ -> a= fun (Val.Dyn (tag, x)) t ->
- match Val.eq tag t with
- | None -> assert false
- | Some Refl -> x
-
- let rec pr_value lev v : std_ppcmds =
- if has_type v Val.typ_list then
- pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list)
- else if has_type v Val.typ_opt then
- pr_opt_no_spc (fun x -> pr_value lev x) (unbox v Val.typ_opt)
- else if has_type v Val.typ_pair then
- let (v1, v2) = unbox v Val.typ_pair in
- str "(" ++ pr_value lev v1 ++ str ", " ++ pr_value lev v2 ++ str ")"
- else
- let Val.Dyn (tag, x) = v in
- let name = Val.repr tag in
- let default = str "<" ++ str name ++ str ">" in
- match ArgT.name name with
- | None -> default
- | Some (ArgT.Any arg) ->
- let wit = ExtraArg arg in
- match val_tag (Topwit wit) with
- | Val.Base t ->
- begin match Val.eq t tag with
- | None -> default
- | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x)
- end
- | _ -> default
-
- let pr_with_occurrences pr (occs,c) =
- match occs with
- | AllOccurrences ->
- pr c
- | NoOccurrences ->
- failwith "pr_with_occurrences: no occurrences"
- | OnlyOccurrences nl ->
- hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++
- hov 0 (prlist_with_sep spc (pr_or_var int) nl))
- | AllOccurrencesBut nl ->
- hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++
- hov 0 (prlist_with_sep spc (pr_or_var int) nl))
-
- exception ComplexRedFlag
-
- let pr_short_red_flag pr r =
- if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then
- raise ComplexRedFlag
- else if List.is_empty r.rConst then
- if r.rDelta then mt () else raise ComplexRedFlag
- else (if r.rDelta then str "-" else mt ()) ++
- hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")
-
- let pr_red_flag pr r =
- try pr_short_red_flag pr r
- with complexRedFlags ->
- (if r.rBeta then pr_arg str "beta" else mt ()) ++
- (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else
- (if r.rMatch then pr_arg str "match" else mt ()) ++
- (if r.rFix then pr_arg str "fix" else mt ()) ++
- (if r.rCofix then pr_arg str "cofix" else mt ())) ++
- (if r.rZeta then pr_arg str "zeta" else mt ()) ++
- (if List.is_empty r.rConst then
- if r.rDelta then pr_arg str "delta"
- else mt ()
- else
- pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++
- hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]"))
-
- let pr_union pr1 pr2 = function
- | Inl a -> pr1 a
- | Inr b -> pr2 b
-
- let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) = function
- | Red false -> keyword "red"
- | Hnf -> keyword "hnf"
- | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f)
- ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o
- | Cbv f ->
- if f.rBeta && f.rMatch && f.rFix && f.rCofix &&
- f.rZeta && f.rDelta && List.is_empty f.rConst then
- keyword "compute"
- else
- hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f)
- | Lazy f ->
- hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f)
- | Cbn f ->
- hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f)
- | Unfold l ->
- hov 1 (keyword "unfold" ++ spc() ++
- prlist_with_sep pr_comma (pr_with_occurrences pr_ref) l)
- | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l)
- | Pattern l ->
- hov 1 (keyword "pattern" ++
- pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr)) l)
-
- | Red true ->
- error "Shouldn't be accessible from user."
- | ExtraRedExpr s ->
- str s
- | CbvVm o ->
- keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o
- | CbvNative o ->
- keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o
-
- let pr_may_eval test prc prlc pr2 pr3 = function
- | ConstrEval (r,c) ->
- hov 0
- (keyword "eval" ++ brk (1,1) ++
- pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++
- keyword "in" ++ spc() ++ prc c)
- | ConstrContext ((_,id),c) ->
- hov 0
- (keyword "context" ++ spc () ++ pr_id id ++ spc () ++
- str "[ " ++ prlc c ++ str " ]")
- | ConstrTypeOf c ->
- hov 1 (keyword "type of" ++ spc() ++ prc c)
- | ConstrTerm c when test c ->
- h 0 (str "(" ++ prc c ++ str ")")
- | ConstrTerm c ->
- prc c
-
- let pr_may_eval a =
- pr_may_eval (fun _ -> false) a
-
- let pr_arg pr x = spc () ++ pr x
-
- let pr_or_var pr = function
- | ArgArg x -> pr x
- | ArgVar (_,s) -> pr_id s
-
- let pr_and_short_name pr (c,_) = pr c
-
- let pr_or_by_notation f = function
- | AN v -> f v
- | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
-
- let pr_located pr (loc,x) = pr x
-
- let pr_evaluable_reference = function
- | EvalVarRef id -> pr_id id
- | EvalConstRef sp -> pr_global (Globnames.ConstRef sp)
-
- let pr_quantified_hypothesis = function
- | AnonHyp n -> int n
- | NamedHyp id -> pr_id id
-
- let pr_binding prc = function
- | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c)
- | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
-
- let pr_bindings prc prlc = function
- | ImplicitBindings l ->
- brk (1,1) ++ keyword "with" ++ brk (1,1) ++
- hv 0 (prlist_with_sep spc prc l)
- | ExplicitBindings l ->
- brk (1,1) ++ keyword "with" ++ brk (1,1) ++
- hv 0 (prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l)
- | NoBindings -> mt ()
-
- let pr_bindings_no_with prc prlc = function
- | ImplicitBindings l ->
- brk (0,1) ++
- prlist_with_sep spc prc l
- | ExplicitBindings l ->
- brk (0,1) ++
- prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
- | NoBindings -> mt ()
-
- let pr_clear_flag clear_flag pp x =
- match clear_flag with
- | Some false -> surround (pp x)
- | Some true -> str ">" ++ pp x
- | None -> pp x
-
- let pr_with_bindings prc prlc (c,bl) =
- prc c ++ pr_bindings prc prlc bl
-
- let pr_with_bindings_arg prc prlc (clear_flag,c) =
- pr_clear_flag clear_flag (pr_with_bindings prc prlc) c
-
- let pr_with_constr prc = function
- | None -> mt ()
- | Some c -> spc () ++ hov 1 (keyword "with" ++ spc () ++ prc c)
-
- let pr_message_token prid = function
- | MsgString s -> tag_string (qs s)
- | MsgInt n -> int n
- | MsgIdent id -> prid id
-
- let pr_fresh_ids =
- prlist (fun s -> spc() ++ pr_or_var (fun s -> tag_string (qs s)) s)
-
- let with_evars ev s = if ev then "e" ^ s else s
-
- let hov_if_not_empty n p = if Pp.ismt p then p else hov n p
-
- let rec pr_raw_generic_rec prc prlc prtac prpat prref (GenArg (Rawwit wit, x)) =
- match wit with
- | ListArg wit ->
- let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in
- let ans = pr_sequence map x in
- hov_if_not_empty 0 ans
- | OptArg wit ->
- let ans = match x with
- | None -> mt ()
- | Some x -> pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x)
- in
- hov_if_not_empty 0 ans
- | PairArg (wit1, wit2) ->
- let p, q = x in
- let p = in_gen (rawwit wit1) p in
- let q = in_gen (rawwit wit2) q in
- hov_if_not_empty 0 (pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q])
- | ExtraArg s ->
- try pi1 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (rawwit wit) x)
- with Not_found -> Genprint.generic_raw_print (in_gen (rawwit wit) x)
-
-
- let rec pr_glb_generic_rec prc prlc prtac prpat (GenArg (Glbwit wit, x)) =
- match wit with
- | ListArg wit ->
- let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in
- let ans = pr_sequence map x in
- hov_if_not_empty 0 ans
- | OptArg wit ->
- let ans = match x with
- | None -> mt ()
- | Some x -> pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x)
- in
- hov_if_not_empty 0 ans
- | PairArg (wit1, wit2) ->
- let p, q = x in
- let p = in_gen (glbwit wit1) p in
- let q = in_gen (glbwit wit2) q in
- let ans = pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] in
- hov_if_not_empty 0 ans
- | ExtraArg s ->
- try pi2 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (glbwit wit) x)
- with Not_found -> Genprint.generic_glb_print (in_gen (glbwit wit) x)
-
- let rec tacarg_using_rule_token pr_gen = function
- | [] -> []
- | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l
- | TacNonTerm (_, (symb, arg), _) :: l ->
- pr_gen symb arg :: tacarg_using_rule_token pr_gen l
-
- let pr_tacarg_using_rule pr_gen l =
- let l = match l with
- | TacTerm s :: l ->
- (** First terminal token should be considered as the name of the tactic,
- so we tag it differently than the other terminal tokens. *)
- primitive s :: tacarg_using_rule_token pr_gen l
- | _ -> tacarg_using_rule_token pr_gen l
- in
- pr_sequence (fun x -> x) l
-
- let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l =
- let name =
- str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++
- str "@" ++ int i
- in
- let args = match l with
- | [] -> mt ()
- | _ -> spc() ++ pr_sequence pr_gen l
- in
- str "<" ++ name ++ str ">" ++ args
-
- let rec pr_user_symbol = function
- | Extend.Ulist1 tkn -> "ne_" ^ pr_user_symbol tkn ^ "_list"
- | Extend.Ulist1sep (tkn, _) -> "ne_" ^ pr_user_symbol tkn ^ "_list"
- | Extend.Ulist0 tkn -> pr_user_symbol tkn ^ "_list"
- | Extend.Ulist0sep (tkn, _) -> pr_user_symbol tkn ^ "_list"
- | Extend.Uopt tkn -> pr_user_symbol tkn ^ "_opt"
- | Extend.Uentry tag ->
- let ArgT.Any tag = tag in
- ArgT.repr tag
- | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl
-
- let pr_alias_key key =
- try
- let prods = (KNmap.find key !prnotation_tab).pptac_prods in
- let rec pr = function
- | TacTerm s -> primitive s
- | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb))
- in
- pr_sequence pr prods
- with Not_found ->
- KerName.print key
-
- let pr_alias_gen pr_gen lev key l =
- try
- let pp = KNmap.find key !prnotation_tab in
- let rec pack prods args = match prods, args with
- | [], [] -> []
- | TacTerm s :: prods, args -> TacTerm s :: pack prods args
- | TacNonTerm (loc, symb, id) :: prods, arg :: args ->
- TacNonTerm (loc, (symb, arg), id) :: pack prods args
- | _ -> raise Not_found
- in
- let prods = pack pp.pptac_prods l in
- let p = pr_tacarg_using_rule pr_gen prods in
- if pp.pptac_level > lev then surround p else p
- with Not_found ->
- let pr arg = str "_" in
- KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)"
-
- let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg))
-
- let is_genarg tag wit =
- let ArgT.Any tag = tag in
- argument_type_eq (ArgumentType (ExtraArg tag)) wit
-
- let get_list : type l. l generic_argument -> l generic_argument list option =
- function (GenArg (wit, arg)) -> match wit with
- | Rawwit (ListArg wit) -> Some (List.map (in_gen (rawwit wit)) arg)
- | Glbwit (ListArg wit) -> Some (List.map (in_gen (glbwit wit)) arg)
- | _ -> None
-
- let get_opt : type l. l generic_argument -> l generic_argument option option =
- function (GenArg (wit, arg)) -> match wit with
- | Rawwit (OptArg wit) -> Some (Option.map (in_gen (rawwit wit)) arg)
- | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg)
- | _ -> None
-
- let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds =
- fun prtac symb arg -> match symb with
- | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg
- | Extend.Ulist1 s | Extend.Ulist0 s ->
- begin match get_list arg with
- | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
- | Some l -> pr_sequence (pr_any_arg prtac s) l
- end
- | Extend.Ulist1sep (s, sep) | Extend.Ulist0sep (s, sep) ->
- begin match get_list arg with
- | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
- | Some l -> prlist_with_sep (fun () -> str sep) (pr_any_arg prtac s) l
- end
- | Extend.Uopt s ->
- begin match get_opt arg with
- | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
- | Some l -> pr_opt (pr_any_arg prtac s) l
- end
- | Extend.Uentry _ | Extend.Uentryl _ ->
- str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
-
- let rec pr_targ prtac symb arg = match symb with
- | Extend.Uentry tag when is_genarg tag (ArgumentType wit_tactic) ->
- prtac (1, Any) arg
- | Extend.Uentryl (_, l) -> prtac (l, Any) arg
- | _ ->
- match arg with
- | TacGeneric arg ->
- let pr l arg = prtac l (TacGeneric arg) in
- pr_any_arg pr symb arg
- | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
-
- let pr_raw_extend_rec prc prlc prtac prpat =
- pr_extend_gen (pr_farg prtac)
- let pr_glob_extend_rec prc prlc prtac prpat =
- pr_extend_gen (pr_farg prtac)
-
- let pr_raw_alias prc prlc prtac prpat lev key args =
- pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args
- let pr_glob_alias prc prlc prtac prpat lev key args =
- pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args
-
- (**********************************************************************)
- (* The tactic printer *)
-
- let strip_prod_binders_expr n ty =
- let rec strip_ty acc n ty =
- match ty with
- Constrexpr.CProdN(_,bll,a) ->
- let nb =
- List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in
- let bll = List.map (fun (x, _, y) -> x, y) bll in
- if nb >= n then (List.rev (bll@acc)), a
- else strip_ty (bll@acc) (n-nb) a
- | _ -> error "Cannot translate fix tactic: not enough products" in
- strip_ty [] n ty
-
- let pr_ltac_or_var pr = function
- | ArgArg x -> pr x
- | ArgVar (loc,id) -> pr_with_comments loc (pr_id id)
-
- let pr_ltac_constant kn =
- if !Flags.in_debugger then pr_kn kn
- else try
- pr_qualid (Nametab.shortest_qualid_of_tactic kn)
- with Not_found -> (* local tactic not accessible anymore *)
- str "<" ++ pr_kn kn ++ str ">"
-
- let pr_evaluable_reference_env env = function
- | EvalVarRef id -> pr_id id
- | EvalConstRef sp ->
- Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp)
-
- let pr_esubst prc l =
- let pr_qhyp = function
- (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")"
- | (_,NamedHyp id,c) ->
- str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")"
- in
- prlist_with_sep spc pr_qhyp l
-
- let pr_bindings_gen for_ex prc prlc = function
- | ImplicitBindings l ->
- spc () ++
- hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++
- prlist_with_sep spc prc l)
- | ExplicitBindings l ->
- spc () ++
- hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++
- pr_esubst prlc l)
- | NoBindings -> mt ()
-
- let pr_bindings prc prlc = pr_bindings_gen false prc prlc
-
- let pr_with_bindings prc prlc (c,bl) =
- hov 1 (prc c ++ pr_bindings prc prlc bl)
-
- let pr_as_disjunctive_ipat prc ipatl =
- keyword "as" ++ spc () ++
- pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl
-
- let pr_eqn_ipat (_,ipat) = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat
-
- let pr_with_induction_names prc = function
- | None, None -> mt ()
- | Some eqpat, None -> hov 1 (pr_eqn_ipat eqpat)
- | None, Some ipat -> hov 1 (pr_as_disjunctive_ipat prc ipat)
- | Some eqpat, Some ipat ->
- hov 1 (pr_as_disjunctive_ipat prc ipat ++ spc () ++ pr_eqn_ipat eqpat)
-
- let pr_as_intro_pattern prc ipat =
- spc () ++ hov 1 (keyword "as" ++ spc () ++ Miscprint.pr_intro_pattern prc ipat)
-
- let pr_with_inversion_names prc = function
- | None -> mt ()
- | Some ipat -> pr_as_disjunctive_ipat prc ipat
-
- let pr_as_ipat prc = function
- | None -> mt ()
- | Some ipat -> pr_as_intro_pattern prc ipat
-
- let pr_as_name = function
- | Anonymous -> mt ()
- | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.ghost,id)
-
- let pr_pose_as_style prc na c =
- spc() ++ prc c ++ pr_as_name na
-
- let pr_pose prc prlc na c = match na with
- | Anonymous -> spc() ++ prc c
- | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c)
-
- let pr_assertion prc prdc _prlc ipat c = match ipat with
- (* Use this "optimisation" or use only the general case ?
- | IntroIdentifier id ->
- spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
- *)
- | ipat ->
- spc() ++ prc c ++ pr_as_ipat prdc ipat
-
- let pr_assumption prc prdc prlc ipat c = match ipat with
- (* Use this "optimisation" or use only the general case ?*)
- (* it seems that this "optimisation" is somehow more natural *)
- | Some (_,IntroNaming (IntroIdentifier id)) ->
- spc() ++ surround (pr_id id ++ str " :" ++ spc() ++ prlc c)
- | ipat ->
- spc() ++ prc c ++ pr_as_ipat prdc ipat
-
- let pr_by_tactic prt = function
- | Some tac -> keyword "by" ++ spc () ++ prt tac
- | None -> mt()
-
- let pr_hyp_location pr_id = function
- | occs, InHyp -> pr_with_occurrences pr_id occs
- | occs, InHypTypeOnly ->
- pr_with_occurrences (fun id ->
- str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")"
- ) occs
- | occs, InHypValueOnly ->
- pr_with_occurrences (fun id ->
- str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")"
- ) occs
-
- let pr_in pp = hov 0 (keyword "in" ++ pp)
-
- let pr_simple_hyp_clause pr_id = function
- | [] -> mt ()
- | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l)
-
- let pr_in_hyp_as prc pr_id = function
- | None -> mt ()
- | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat
-
- let pr_in_clause pr_id = function
- | { onhyps=None; concl_occs=NoOccurrences } ->
- (str "* |-")
- | { onhyps=None; concl_occs=occs } ->
- (pr_with_occurrences (fun () -> str "*") (occs,()))
- | { onhyps=Some l; concl_occs=NoOccurrences } ->
- prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l
- | { onhyps=Some l; concl_occs=occs } ->
- let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in
- (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs)
-
- let pr_clauses default_is_concl pr_id = function
- | { onhyps=Some []; concl_occs=occs }
- when (match default_is_concl with Some true -> true | _ -> false) ->
- pr_with_occurrences mt (occs,())
- | { onhyps=None; concl_occs=AllOccurrences }
- when (match default_is_concl with Some false -> true | _ -> false) -> mt ()
- | { onhyps=None; concl_occs=NoOccurrences } ->
- pr_in (str " * |-")
- | { onhyps=None; concl_occs=occs } ->
- pr_in (pr_with_occurrences (fun () -> str " *") (occs,()))
- | { onhyps=Some l; concl_occs=occs } ->
- let pr_occs = match occs with
- | NoOccurrences -> mt ()
- | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,())
- in
- pr_in
- (prlist_with_sep (fun () -> str",")
- (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs)
-
- let pr_orient b = if b then mt () else str "<- "
-
- let pr_multi = function
- | Precisely 1 -> mt ()
- | Precisely n -> int n ++ str "!"
- | UpTo n -> int n ++ str "?"
- | RepeatStar -> str "?"
- | RepeatPlus -> str "!"
-
- let pr_core_destruction_arg prc prlc = function
- | ElimOnConstr c -> pr_with_bindings prc prlc c
- | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id)
- | ElimOnAnonHyp n -> int n
-
- let pr_destruction_arg prc prlc (clear_flag,h) =
- pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h
-
- let pr_inversion_kind = function
- | SimpleInversion -> primitive "simple inversion"
- | FullInversion -> primitive "inversion"
- | FullInversionClear -> primitive "inversion_clear"
-
- let pr_range_selector (i, j) =
- if Int.equal i j then int i
- else int i ++ str "-" ++ int j
-
- let pr_goal_selector = function
- | SelectNth i -> int i ++ str ":"
- | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++
- str "]" ++ str ":"
- | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":"
- | SelectAll -> str "all" ++ str ":"
-
- let pr_lazy = function
- | General -> keyword "multi"
- | Select -> keyword "lazy"
- | Once -> mt ()
-
- let pr_match_pattern pr_pat = function
- | Term a -> pr_pat a
- | Subterm (b,None,a) ->
- (** ppedrot: we don't make difference between [appcontext] and [context]
- anymore, and the interpretation is governed by a flag instead. *)
- keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]"
- | Subterm (b,Some id,a) ->
- keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]"
-
- let pr_match_hyps pr_pat = function
- | Hyp (nal,mp) ->
- pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp
- | Def (nal,mv,mp) ->
- pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv
- ++ str ":" ++ pr_match_pattern pr_pat mp
-
- let pr_match_rule m pr pr_pat = function
- | Pat ([],mp,t) when m ->
- pr_match_pattern pr_pat mp ++
- spc () ++ str "=>" ++ brk (1,4) ++ pr t
- (*
- | Pat (rl,mp,t) ->
- hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++
- (if rl <> [] then spc () else mt ()) ++
- hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
- str "=>" ++ brk (1,4) ++ pr t))
- *)
- | Pat (rl,mp,t) ->
- hov 0 (
- hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++
- (if not (List.is_empty rl) then spc () else mt ()) ++
- hov 0 (
- str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
- str "=>" ++ brk (1,4) ++ pr t))
- | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t
-
- let pr_funvar = function
- | None -> spc () ++ str "_"
- | Some id -> spc () ++ pr_id id
-
- let pr_let_clause k pr (id,(bl,t)) =
- hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++
- str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.ghost,t)))
-
- let pr_let_clauses recflag pr = function
- | hd::tl ->
- hv 0
- (pr_let_clause (if recflag then "let rec" else "let") pr hd ++
- prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl)
- | [] -> anomaly (Pp.str "LetIn must declare at least one binding")
-
- let pr_seq_body pr tl =
- hv 0 (str "[ " ++
- prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
- str " ]")
-
- let pr_dispatch pr tl =
- hv 0 (str "[>" ++
- prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
- str " ]")
-
- let pr_opt_tactic pr = function
- | TacId [] -> mt ()
- | t -> pr t
-
- let pr_tac_extend_gen pr tf tm tl =
- prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++
- pr_opt_tactic pr tm ++ str ".." ++
- prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl
-
- let pr_then_gen pr tf tm tl =
- hv 0 (str "[ " ++
- pr_tac_extend_gen pr tf tm tl ++
- str " ]")
-
- let pr_tac_extend pr tf tm tl =
- hv 0 (str "[>" ++
- pr_tac_extend_gen pr tf tm tl ++
- str " ]")
-
- let pr_hintbases = function
- | None -> keyword "with" ++ str" *"
- | Some [] -> mt ()
- | Some l -> hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l)
-
- let pr_auto_using prc = function
- | [] -> mt ()
- | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
-
- let pr_then () = str ";"
-
- let ltop = (5,E)
- let lseq = 4
- let ltactical = 3
- let lorelse = 2
- let llet = 5
- let lfun = 5
- let lcomplete = 1
- let labstract = 3
- let lmatch = 1
- let latom = 0
- let lcall = 1
- let leval = 1
- let ltatom = 1
- let linfo = 5
-
- let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq
-
- (** A printer for tactics that polymorphically works on the three
- "raw", "glob" and "typed" levels *)
-
- type 'a printer = {
- pr_tactic : tolerability -> 'tacexpr -> std_ppcmds;
- pr_constr : 'trm -> std_ppcmds;
- pr_lconstr : 'trm -> std_ppcmds;
- pr_dconstr : 'dtrm -> std_ppcmds;
- pr_pattern : 'pat -> std_ppcmds;
- pr_lpattern : 'pat -> std_ppcmds;
- pr_constant : 'cst -> std_ppcmds;
- pr_reference : 'ref -> std_ppcmds;
- pr_name : 'nam -> std_ppcmds;
- pr_generic : 'lev generic_argument -> std_ppcmds;
- pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds;
- pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds;
- }
-
- constraint 'a = <
- term :'trm;
- dterm :'dtrm;
- pattern :'pat;
- constant :'cst;
- reference :'ref;
- name :'nam;
- tacexpr :'tacexpr;
- level :'lev
- >
-
- let pr_atom pr strip_prod_binders tag_atom =
- let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in
- let pr_with_bindings_arg_full = pr_with_bindings_arg in
- let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in
- let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in
-
- let _pr_constrarg c = spc () ++ pr.pr_constr c in
- let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in
- let pr_intarg n = spc () ++ int n in
-
- (* Some printing combinators *)
- let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in
-
- let pr_binder_fix (nal,t) =
- (* match t with
- | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
- | _ ->*)
- let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in
- spc() ++ hov 1 (str"(" ++ s ++ str")") in
-
- let pr_fix_tac (id,n,c) =
- let rec set_nth_name avoid n = function
- (nal,ty)::bll ->
- if n <= List.length nal then
- match List.chop (n-1) nal with
- _, (_,Name id) :: _ -> id, (nal,ty)::bll
- | bef, (loc,Anonymous) :: aft ->
- let id = next_ident_away (Id.of_string"y") avoid in
- id, ((bef@(loc,Name id)::aft, ty)::bll)
- | _ -> assert false
- else
- let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
- (id,(nal,ty)::bll')
- | [] -> assert false in
- let (bll,ty) = strip_prod_binders n c in
- let names =
- List.fold_left
- (fun ln (nal,_) -> List.fold_left
- (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
- ln nal)
- [] bll in
- let idarg,bll = set_nth_name names n bll in
- let annot = match names with
- | [_] ->
- mt ()
- | _ ->
- spc() ++ str"{"
- ++ keyword "struct" ++ spc ()
- ++ pr_id idarg ++ str"}"
- in
- hov 1 (str"(" ++ pr_id id ++
- prlist pr_binder_fix bll ++ annot ++ str" :" ++
- pr_lconstrarg ty ++ str")") in
- (* spc() ++
- hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ _pr_constrarg
- c)
- *)
- let pr_cofix_tac (id,c) =
- hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in
-
- (* Printing tactics as arguments *)
- let rec pr_atom0 a = tag_atom a (match a with
- | TacIntroPattern (false,[]) -> primitive "intros"
- | TacIntroPattern (true,[]) -> primitive "eintros"
- | t -> str "(" ++ pr_atom1 t ++ str ")"
- )
-
- (* Main tactic printer *)
- and pr_atom1 a = tag_atom a (match a with
- (* Basic tactics *)
- | TacIntroPattern (ev,[]) as t ->
- pr_atom0 t
- | TacIntroPattern (ev,(_::_ as p)) ->
- hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++
- prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)
- | TacApply (a,ev,cb,inhyp) ->
- hov 1 (
- (if a then mt() else primitive "simple ") ++
- primitive (with_evars ev "apply") ++ spc () ++
- prlist_with_sep pr_comma pr_with_bindings_arg cb ++
- pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp
- )
- | TacElim (ev,cb,cbo) ->
- hov 1 (
- primitive (with_evars ev "elim")
- ++ pr_arg pr_with_bindings_arg cb
- ++ pr_opt pr_eliminator cbo)
- | TacCase (ev,cb) ->
- hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb)
- | TacMutualFix (id,n,l) ->
- hov 1 (
- primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc()
- ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l)
- | TacMutualCofix (id,l) ->
- hov 1 (
- primitive "cofix" ++ spc () ++ pr_id id ++ spc()
- ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l
- )
- | TacAssert (b,Some tac,ipat,c) ->
- hov 1 (
- primitive (if b then "assert" else "enough") ++
- pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++
- pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac
- )
- | TacAssert (_,None,ipat,c) ->
- hov 1 (
- primitive "pose proof"
- ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c
- )
- | TacGeneralize l ->
- hov 1 (
- primitive "generalize" ++ spc ()
- ++ prlist_with_sep pr_comma (fun (cl,na) ->
- pr_with_occurrences pr.pr_constr cl ++ pr_as_name na)
- l
- )
- | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl ->
- hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c)
- | TacLetTac (na,c,cl,b,e) ->
- hov 1 (
- (if b then primitive "set" else primitive "remember") ++
- (if b then pr_pose pr.pr_constr pr.pr_lconstr na c
- else pr_pose_as_style pr.pr_constr na c) ++
- pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++
- pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl)
- (* | TacInstantiate (n,c,ConclLocation ()) ->
- hov 1 (str "instantiate" ++ spc() ++
- hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
- pr_lconstrarg c ++ str ")" ))
- | TacInstantiate (n,c,HypLocation (id,hloc)) ->
- hov 1 (str "instantiate" ++ spc() ++
- hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
- pr_lconstrarg c ++ str ")" )
- ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None)))
- *)
-
- (* Derived basic tactics *)
- | TacInductionDestruct (isrec,ev,(l,el)) ->
- hov 1 (
- primitive (with_evars ev (if isrec then "induction" else "destruct"))
- ++ spc ()
- ++ prlist_with_sep pr_comma (fun (h,ids,cl) ->
- pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++
- pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++
- pr_opt (pr_clauses None pr.pr_name) cl) l ++
- pr_opt pr_eliminator el
- )
-
- (* Conversion *)
- | TacReduce (r,h) ->
- hov 1 (
- pr_red_expr r
- ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h
- )
- | TacChange (op,c,h) ->
- hov 1 (
- primitive "change" ++ brk (1,1)
- ++ (
- match op with
- None ->
- mt ()
- | Some p ->
- pr.pr_pattern p ++ spc ()
- ++ keyword "with" ++ spc ()
- ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h
- )
-
- (* Equality and inversion *)
- | TacRewrite (ev,l,cl,tac) ->
- hov 1 (
- primitive (with_evars ev "rewrite") ++ spc ()
- ++ prlist_with_sep
- (fun () -> str ","++spc())
- (fun (b,m,c) ->
- pr_orient b ++ pr_multi m ++
- pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c)
- l
- ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl
- ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac
- )
- | TacInversion (DepInversion (k,c,ids),hyp) ->
- hov 1 (
- primitive "dependent " ++ pr_inversion_kind k ++ spc ()
- ++ pr_quantified_hypothesis hyp
- ++ pr_with_inversion_names pr.pr_dconstr ids
- ++ pr_with_constr pr.pr_constr c
- )
- | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
- hov 1 (
- pr_inversion_kind k ++ spc ()
- ++ pr_quantified_hypothesis hyp
- ++ pr_non_empty_arg (pr_with_inversion_names pr.pr_dconstr) ids
- ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl
- )
- | TacInversion (InversionUsing (c,cl),hyp) ->
- hov 1 (
- primitive "inversion" ++ spc()
- ++ pr_quantified_hypothesis hyp ++ spc ()
- ++ keyword "using" ++ spc () ++ pr.pr_constr c
- ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl
- )
- )
- in
- pr_atom1
-
- let make_pr_tac pr strip_prod_binders tag_atom tag =
-
- let extract_binders = function
- | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body)
- | body -> ([],body) in
- let rec pr_tac inherited tac =
- let return (doc, l) = (tag tac doc, l) in
- let (strm, prec) = return (match tac with
- | TacAbstract (t,None) ->
- keyword "abstract " ++ pr_tac (labstract,L) t, labstract
- | TacAbstract (t,Some s) ->
- hov 0 (
- keyword "abstract"
- ++ str" (" ++ pr_tac (labstract,L) t ++ str")" ++ spc ()
- ++ keyword "using" ++ spc () ++ pr_id s),
- labstract
- | TacLetIn (recflag,llc,u) ->
- let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in
- v 0
- (hv 0 (
- pr_let_clauses recflag (pr_tac ltop) llc
- ++ spc () ++ keyword "in"
- ) ++ fnl () ++ pr_tac (llet,E) u),
- llet
- | TacMatch (lz,t,lrul) ->
- hov 0 (
- pr_lazy lz ++ keyword "match" ++ spc ()
- ++ pr_tac ltop t ++ spc () ++ keyword "with"
- ++ prlist (fun r ->
- fnl () ++ str "| "
- ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r
- ) lrul
- ++ fnl() ++ keyword "end"),
- lmatch
- | TacMatchGoal (lz,lr,lrul) ->
- hov 0 (
- pr_lazy lz
- ++ keyword (if lr then "match reverse goal with" else "match goal with")
- ++ prlist (fun r ->
- fnl () ++ str "| "
- ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r
- ) lrul ++ fnl() ++ keyword "end"),
- lmatch
- | TacFun (lvar,body) ->
- hov 2 (
- keyword "fun"
- ++ prlist pr_funvar lvar ++ str " =>" ++ spc ()
- ++ pr_tac (lfun,E) body),
- lfun
- | TacThens (t,tl) ->
- hov 1 (
- pr_tac (lseq,E) t ++ pr_then () ++ spc ()
- ++ pr_seq_body (pr_opt_tactic (pr_tac ltop)) tl),
- lseq
- | TacThen (t1,t2) ->
- hov 1 (
- pr_tac (lseq,E) t1 ++ pr_then () ++ spc ()
- ++ pr_tac (lseq,L) t2),
- lseq
- | TacDispatch tl ->
- pr_dispatch (pr_tac ltop) tl, lseq
- | TacExtendTac (tf,t,tr) ->
- pr_tac_extend (pr_tac ltop) tf t tr , lseq
- | TacThens3parts (t1,tf,t2,tl) ->
- hov 1 (
- pr_tac (lseq,E) t1 ++ pr_then () ++ spc ()
- ++ pr_then_gen (pr_tac ltop) tf t2 tl),
- lseq
- | TacTry t ->
- hov 1 (
- keyword "try" ++ spc () ++ pr_tac (ltactical,E) t),
- ltactical
- | TacDo (n,t) ->
- hov 1 (
- str "do" ++ spc ()
- ++ pr_or_var int n ++ spc ()
- ++ pr_tac (ltactical,E) t),
- ltactical
- | TacTimeout (n,t) ->
- hov 1 (
- keyword "timeout "
- ++ pr_or_var int n ++ spc ()
- ++ pr_tac (ltactical,E) t),
- ltactical
- | TacTime (s,t) ->
- hov 1 (
- keyword "time"
- ++ pr_opt str s ++ spc ()
- ++ pr_tac (ltactical,E) t),
- ltactical
- | TacRepeat t ->
- hov 1 (
- keyword "repeat" ++ spc ()
- ++ pr_tac (ltactical,E) t),
- ltactical
- | TacProgress t ->
- hov 1 (
- keyword "progress" ++ spc ()
- ++ pr_tac (ltactical,E) t),
- ltactical
- | TacShowHyps t ->
- hov 1 (
- keyword "infoH" ++ spc ()
- ++ pr_tac (ltactical,E) t),
- ltactical
- | TacInfo t ->
- hov 1 (
- keyword "info" ++ spc ()
- ++ pr_tac (ltactical,E) t),
- linfo
- | TacOr (t1,t2) ->
- hov 1 (
- pr_tac (lorelse,L) t1 ++ spc ()
- ++ str "+" ++ brk (1,1)
- ++ pr_tac (lorelse,E) t2),
- lorelse
- | TacOnce t ->
- hov 1 (
- keyword "once" ++ spc ()
- ++ pr_tac (ltactical,E) t),
- ltactical
- | TacExactlyOnce t ->
- hov 1 (
- keyword "exactly_once" ++ spc ()
- ++ pr_tac (ltactical,E) t),
- ltactical
- | TacIfThenCatch (t,tt,te) ->
- hov 1 (
- str"tryif" ++ spc() ++ pr_tac (ltactical,E) t ++ brk(1,1) ++
- str"then" ++ spc() ++ pr_tac (ltactical,E) tt ++ brk(1,1) ++
- str"else" ++ spc() ++ pr_tac (ltactical,E) te ++ brk(1,1)),
- ltactical
- | TacOrelse (t1,t2) ->
- hov 1 (
- pr_tac (lorelse,L) t1 ++ spc ()
- ++ str "||" ++ brk (1,1)
- ++ pr_tac (lorelse,E) t2),
- lorelse
- | TacFail (g,n,l) ->
- let arg =
- match n with
- | ArgArg 0 -> mt ()
- | _ -> pr_arg (pr_or_var int) n
- in
- let name =
- match g with
- | TacGlobal -> keyword "gfail"
- | TacLocal -> keyword "fail"
- in
- hov 1 (
- name ++ arg
- ++ prlist (pr_arg (pr_message_token pr.pr_name)) l),
- latom
- | TacFirst tl ->
- keyword "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
- | TacSolve tl ->
- keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
- | TacComplete t ->
- pr_tac (lcomplete,E) t, lcomplete
- | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom
- | TacId l ->
- keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom
- | TacAtom (loc,t) ->
- pr_with_comments loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom
- | TacArg(_,Tacexp e) ->
- pr.pr_tactic (latom,E) e, latom
- | TacArg(_,ConstrMayEval (ConstrTerm c)) ->
- keyword "constr:" ++ pr.pr_constr c, latom
- | TacArg(_,ConstrMayEval c) ->
- pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval
- | TacArg(_,TacFreshId l) ->
- primitive "fresh" ++ pr_fresh_ids l, latom
- | TacArg(_,TacGeneric arg) ->
- pr.pr_generic arg, latom
- | TacArg(_,TacCall(loc,f,[])) ->
- pr.pr_reference f, latom
- | TacArg(_,TacCall(loc,f,l)) ->
- pr_with_comments loc (hov 1 (
- pr.pr_reference f ++ spc ()
- ++ prlist_with_sep spc pr_tacarg l)),
- lcall
- | TacArg (_,a) ->
- pr_tacarg a, latom
- | TacML (loc,s,l) ->
- pr_with_comments loc (pr.pr_extend 1 s l), lcall
- | TacAlias (loc,kn,l) ->
- pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom
- )
- in
- if prec_less prec inherited then strm
- else str"(" ++ strm ++ str")"
-
- and pr_tacarg = function
- | Reference r ->
- pr.pr_reference r
- | ConstrMayEval c ->
- pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c
- | TacFreshId l ->
- keyword "fresh" ++ pr_fresh_ids l
- | TacPretype c ->
- keyword "type_term" ++ pr.pr_constr c
- | TacNumgoals ->
- keyword "numgoals"
- | (TacCall _|Tacexp _ | TacGeneric _) as a ->
- hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a))))
-
- in pr_tac
-
- let strip_prod_binders_glob_constr n (ty,_) =
- let rec strip_ty acc n ty =
- if Int.equal n 0 then (List.rev acc, (ty,None)) else
- match ty with
- Glob_term.GProd(loc,na,Explicit,a,b) ->
- strip_ty (([Loc.ghost,na],(a,None))::acc) (n-1) b
- | _ -> error "Cannot translate fix tactic: not enough products" in
- strip_ty [] n ty
-
- let raw_printers =
- (strip_prod_binders_expr)
-
- let rec pr_raw_tactic_level n (t:raw_tactic_expr) =
- let pr = {
- pr_tactic = pr_raw_tactic_level;
- pr_constr = pr_constr_expr;
- pr_dconstr = pr_constr_expr;
- pr_lconstr = pr_lconstr_expr;
- pr_pattern = pr_constr_pattern_expr;
- pr_lpattern = pr_lconstr_pattern_expr;
- pr_constant = pr_or_by_notation pr_reference;
- pr_reference = pr_reference;
- pr_name = pr_lident;
- pr_generic = pr_raw_generic_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference;
- pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr;
- pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr;
- } in
- make_pr_tac
- pr raw_printers
- tag_raw_atomic_tactic_expr tag_raw_tactic_expr
- n t
-
- let pr_raw_tactic = pr_raw_tactic_level ltop
-
- let pr_and_constr_expr pr (c,_) = pr c
-
- let pr_pat_and_constr_expr pr (_,(c,_),_) = pr c
-
- let pr_glob_tactic_level env n t =
- let glob_printers =
- (strip_prod_binders_glob_constr)
- in
- let rec prtac n (t:glob_tactic_expr) =
- let pr = {
- pr_tactic = prtac;
- pr_constr = pr_and_constr_expr (pr_glob_constr_env env);
- pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env);
- pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env);
- pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env);
- pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env);
- pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env));
- pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant);
- pr_name = pr_lident;
- pr_generic = pr_glb_generic_rec
- (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
- prtac (pr_pat_and_constr_expr (pr_glob_constr_env env));
- pr_extend = pr_glob_extend_rec
- (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
- prtac (pr_pat_and_constr_expr (pr_glob_constr_env env));
- pr_alias = pr_glob_alias
- (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
- prtac (pr_pat_and_constr_expr (pr_glob_constr_env env));
- } in
- make_pr_tac
- pr glob_printers
- tag_glob_atomic_tactic_expr tag_glob_tactic_expr
- n t
- in
- prtac n t
-
- let pr_glob_tactic env = pr_glob_tactic_level env ltop
-
- let strip_prod_binders_constr n ty =
- let rec strip_ty acc n ty =
- if n=0 then (List.rev acc, ty) else
- match Term.kind_of_term ty with
- Term.Prod(na,a,b) ->
- strip_ty (([Loc.ghost,na],a)::acc) (n-1) b
- | _ -> error "Cannot translate fix tactic: not enough products" in
- strip_ty [] n ty
-
- let pr_atomic_tactic_level env n t =
- let prtac n (t:atomic_tactic_expr) =
- let pr = {
- pr_tactic = (fun _ _ -> str "<tactic>");
- pr_constr = pr_constr_env env Evd.empty;
- pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env);
- pr_lconstr = pr_lconstr_env env Evd.empty;
- pr_pattern = pr_constr_pattern_env env Evd.empty;
- pr_lpattern = pr_lconstr_pattern_env env Evd.empty;
- pr_constant = pr_evaluable_reference_env env;
- pr_reference = pr_located pr_ltac_constant;
- pr_name = pr_id;
- (** Those are not used by the atomic printer *)
- pr_generic = (fun _ -> assert false);
- pr_extend = (fun _ _ _ -> assert false);
- pr_alias = (fun _ _ _ -> assert false);
- }
- in
- pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t
- in
- prtac n t
-
- let pr_raw_generic env = pr_raw_generic_rec
- pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference
-
- let pr_glb_generic env = pr_glb_generic_rec
- (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
- (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env))
-
- let pr_raw_extend env = pr_raw_extend_rec
- pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr
-
- let pr_glob_extend env = pr_glob_extend_rec
- (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
- (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env))
-
- let pr_alias pr lev key args =
- pr_alias_gen (fun _ arg -> pr arg) lev key args
-
- let pr_extend pr lev ml args =
- pr_extend_gen pr lev ml args
-
- let pr_atomic_tactic env = pr_atomic_tactic_level env ltop
-
-end
-
-module Tag =
-struct
- let keyword =
- let style = Terminal.make ~bold:true () in
- Ppstyle.make ~style ["tactic"; "keyword"]
-
- let primitive =
- let style = Terminal.make ~fg_color:`LIGHT_GREEN () in
- Ppstyle.make ~style ["tactic"; "primitive"]
-
- let string =
- let style = Terminal.make ~fg_color:`LIGHT_RED () in
- Ppstyle.make ~style ["tactic"; "string"]
-
-end
-
-include Make (Ppconstr) (struct
- let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s
- let do_not_tag _ x = x
- let tag_keyword = tag Tag.keyword
- let tag_primitive = tag Tag.primitive
- let tag_string = tag Tag.string
- let tag_glob_tactic_expr = do_not_tag
- let tag_glob_atomic_tactic_expr = do_not_tag
- let tag_raw_tactic_expr = do_not_tag
- let tag_raw_atomic_tactic_expr = do_not_tag
- let tag_atomic_tactic_expr = do_not_tag
-end)
-
-(** Registering *)
-
-let run_delayed c =
- Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma }
-
-let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *)
- | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g))
- | clear_flag,ElimOnAnonHyp n as x -> x
- | clear_flag,ElimOnIdent id as x -> x
-
-let () =
- let pr_bool b = if b then str "true" else str "false" in
- let pr_unit _ = str "()" in
- let pr_string s = str "\"" ++ str s ++ str "\"" in
- Genprint.register_print0 Constrarg.wit_int_or_var
- (pr_or_var int) (pr_or_var int) int;
- Genprint.register_print0 Constrarg.wit_ref
- pr_reference (pr_or_var (pr_located pr_global)) pr_global;
- Genprint.register_print0 Constrarg.wit_ident
- pr_id pr_id pr_id;
- Genprint.register_print0 Constrarg.wit_var
- (pr_located pr_id) (pr_located pr_id) pr_id;
- Genprint.register_print0
- Constrarg.wit_intro_pattern
- (Miscprint.pr_intro_pattern pr_constr_expr)
- (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c))
- (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c))));
- Genprint.register_print0
- Constrarg.wit_clause_dft_concl
- (pr_clauses (Some true) pr_lident)
- (pr_clauses (Some true) pr_lident)
- (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id)))
- ;
- Genprint.register_print0
- Constrarg.wit_constr
- Ppconstr.pr_constr_expr
- (fun (c, _) -> Printer.pr_glob_constr c)
- Printer.pr_constr
- ;
- Genprint.register_print0
- Constrarg.wit_uconstr
- Ppconstr.pr_constr_expr
- (fun (c,_) -> Printer.pr_glob_constr c)
- Printer.pr_closed_glob
- ;
- Genprint.register_print0
- Constrarg.wit_open_constr
- Ppconstr.pr_constr_expr
- (fun (c, _) -> Printer.pr_glob_constr c)
- Printer.pr_constr
- ;
- Genprint.register_print0 Constrarg.wit_red_expr
- (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))
- (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr))
- (pr_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern));
- Genprint.register_print0 Constrarg.wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis;
- Genprint.register_print0 Constrarg.wit_bindings
- (pr_bindings_no_with pr_constr_expr pr_lconstr_expr)
- (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
- (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it)));
- Genprint.register_print0 Constrarg.wit_constr_with_bindings
- (pr_with_bindings pr_constr_expr pr_lconstr_expr)
- (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
- (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it)));
- Genprint.register_print0 Constrarg.wit_destruction_arg
- (pr_destruction_arg pr_constr_expr pr_lconstr_expr)
- (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
- (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg it));
- Genprint.register_print0 Stdarg.wit_int int int int;
- Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool;
- Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit;
- Genprint.register_print0 Stdarg.wit_pre_ident str str str;
- Genprint.register_print0 Stdarg.wit_string pr_string pr_string pr_string
-
-let () =
- let printer _ _ prtac = prtac (0, E) in
- declare_extra_genarg_pprule wit_tactic printer printer printer
-
-let () =
- let pr_unit _ _ _ () = str "()" in
- let printer _ _ prtac = prtac (0, E) in
- declare_extra_genarg_pprule wit_ltac printer printer pr_unit
-
-module Richpp = struct
-
- include Make (Ppconstr.Richpp) (struct
- open Ppannotation
- let do_not_tag _ x = x
- let tag e s = Pp.tag (Pp.Tag.inj e tag) s
- let tag_keyword = tag AKeyword
- let tag_primitive = tag AKeyword
- let tag_string = do_not_tag ()
- let tag_glob_tactic_expr e = tag (AGlobTacticExpr e)
- let tag_glob_atomic_tactic_expr a = tag (AGlobAtomicTacticExpr a)
- let tag_raw_tactic_expr e = tag (ARawTacticExpr e)
- let tag_raw_atomic_tactic_expr a = tag (ARawAtomicTacticExpr a)
- let tag_atomic_tactic_expr a = tag (AAtomicTacticExpr a)
- end)
-
-end
diff --git a/printing/pptactic.mli b/printing/pptactic.mli
deleted file mode 100644
index 86e3ea54..00000000
--- a/printing/pptactic.mli
+++ /dev/null
@@ -1,67 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** This module implements pretty-printers for tactic_expr syntactic
- objects and their subcomponents. *)
-
-open Pp
-open Genarg
-open Geninterp
-open Names
-open Constrexpr
-open Tacexpr
-open Ppextend
-
-type 'a grammar_tactic_prod_item_expr =
-| TacTerm of string
-| TacNonTerm of Loc.t * 'a * Names.Id.t
-
-type 'a raw_extra_genarg_printer =
- (constr_expr -> std_ppcmds) ->
- (constr_expr -> std_ppcmds) ->
- (tolerability -> raw_tactic_expr -> std_ppcmds) ->
- 'a -> std_ppcmds
-
-type 'a glob_extra_genarg_printer =
- (glob_constr_and_expr -> std_ppcmds) ->
- (glob_constr_and_expr -> std_ppcmds) ->
- (tolerability -> glob_tactic_expr -> std_ppcmds) ->
- 'a -> std_ppcmds
-
-type 'a extra_genarg_printer =
- (Term.constr -> std_ppcmds) ->
- (Term.constr -> std_ppcmds) ->
- (tolerability -> Val.t -> std_ppcmds) ->
- 'a -> std_ppcmds
-
-val declare_extra_genarg_pprule :
- ('a, 'b, 'c) genarg_type ->
- 'a raw_extra_genarg_printer ->
- 'b glob_extra_genarg_printer ->
- 'c extra_genarg_printer -> unit
-
-type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
-
-type pp_tactic = {
- pptac_level : int;
- pptac_prods : grammar_terminals;
-}
-
-val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit
-
-(** The default pretty-printers produce {!Pp.std_ppcmds} that are
- interpreted as raw strings. *)
-include Pptacticsig.Pp
-
-(** The rich pretty-printers produce {!Pp.std_ppcmds} that are
- interpreted as annotated strings. The annotations can be
- retrieved using {!RichPp.rich_pp}. Their definitions are
- located in {!Ppannotation.t}. *)
-module Richpp : Pptacticsig.Pp
-
-val ltop : tolerability
diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli
deleted file mode 100644
index 665e055f..00000000
--- a/printing/pptacticsig.mli
+++ /dev/null
@@ -1,83 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Genarg
-open Geninterp
-open Tacexpr
-open Ppextend
-open Environ
-open Misctypes
-
-module type Pp = sig
-
- val pr_with_occurrences :
- ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds
- val pr_red_expr :
- ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) ->
- ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds
- val pr_may_eval :
- ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
- ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds
-
- val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
- val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
- val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds
-
- val pr_in_clause :
- ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
-
- val pr_clauses : bool option ->
- ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
-
- val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds
-
- val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds
-
- val pr_raw_extend: env -> int ->
- ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds
-
- val pr_glob_extend: env -> int ->
- ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds
-
- val pr_extend :
- (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds
-
- val pr_alias_key : Names.KerName.t -> std_ppcmds
-
- val pr_alias : (Val.t -> std_ppcmds) ->
- int -> Names.KerName.t -> Val.t list -> std_ppcmds
-
- val pr_alias_key : Names.KerName.t -> std_ppcmds
-
- val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
-
- val pr_raw_tactic : raw_tactic_expr -> std_ppcmds
-
- val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds
-
- val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
-
- val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds
-
- val pr_hintbases : string list option -> std_ppcmds
-
- val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds
-
- val pr_bindings :
- ('constr -> std_ppcmds) ->
- ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds
-
- val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds
-
- val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
- ('b, 'a) match_rule -> std_ppcmds
-
- val pr_value : tolerability -> Val.t -> std_ppcmds
-
-end
diff --git a/printing/pputils.ml b/printing/pputils.ml
index 50ce56fb..c14aa318 100644
--- a/printing/pputils.ml
+++ b/printing/pputils.ml
@@ -1,19 +1,177 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
+open Util
open Pp
+open Genarg
+open Misctypes
+open Locus
+open Genredexpr
+
+let beautify_comments = ref []
+
+let rec split_comments comacc acc pos = function
+ | [] -> beautify_comments := List.rev acc; comacc
+ | ((b,e),c as com)::coms ->
+ (* Take all comments that terminates before pos, or begin exactly
+ at pos (used to print comments attached after an expression) *)
+ if e<=pos || pos=b then split_comments (c::comacc) acc pos coms
+ else split_comments comacc (com::acc) pos coms
+
+let extract_comments pos = split_comments [] [] pos !beautify_comments
let pr_located pr (loc, x) =
- if !Flags.beautify && loc <> Loc.ghost then
+ match loc with
+ | Some loc when !Flags.beautify ->
let (b, e) = Loc.unloc loc in
(* Side-effect: order matters *)
- let before = Pp.comment (CLexer.extract_comments b) in
+ let before = Pp.comment (extract_comments b) in
let x = pr x in
- let after = Pp.comment (CLexer.extract_comments e) in
+ let after = Pp.comment (extract_comments e) in
before ++ x ++ after
- else pr x
+ | _ -> pr x
+
+let pr_ast pr { CAst.loc; v } = pr_located pr (loc, v)
+
+let pr_or_var pr = function
+ | ArgArg x -> pr x
+ | ArgVar {CAst.v=s} -> Names.Id.print s
+
+let pr_with_occurrences pr keyword (occs,c) =
+ match occs with
+ | AllOccurrences ->
+ pr c
+ | NoOccurrences ->
+ failwith "pr_with_occurrences: no occurrences"
+ | OnlyOccurrences nl ->
+ hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++
+ hov 0 (prlist_with_sep spc (pr_or_var int) nl))
+ | AllOccurrencesBut nl ->
+ hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++
+ hov 0 (prlist_with_sep spc (pr_or_var int) nl))
+
+exception ComplexRedFlag
+
+let pr_short_red_flag pr r =
+ if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then
+ raise ComplexRedFlag
+ else if List.is_empty r.rConst then
+ if r.rDelta then mt () else raise ComplexRedFlag
+ else (if r.rDelta then str "-" else mt ()) ++
+ hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")
+
+let pr_red_flag pr r =
+ try pr_short_red_flag pr r
+ with complexRedFlags ->
+ (if r.rBeta then pr_arg str "beta" else mt ()) ++
+ (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else
+ (if r.rMatch then pr_arg str "match" else mt ()) ++
+ (if r.rFix then pr_arg str "fix" else mt ()) ++
+ (if r.rCofix then pr_arg str "cofix" else mt ())) ++
+ (if r.rZeta then pr_arg str "zeta" else mt ()) ++
+ (if List.is_empty r.rConst then
+ if r.rDelta then pr_arg str "delta"
+ else mt ()
+ else
+ pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++
+ hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]"))
+
+let pr_union pr1 pr2 = function
+ | Inl a -> pr1 a
+ | Inr b -> pr2 b
+
+let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function
+ | Red false -> keyword "red"
+ | Hnf -> keyword "hnf"
+ | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f)
+ ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o
+ | Cbv f ->
+ if f.rBeta && f.rMatch && f.rFix && f.rCofix &&
+ f.rZeta && f.rDelta && List.is_empty f.rConst then
+ keyword "compute"
+ else
+ hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f)
+ | Lazy f ->
+ hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f)
+ | Cbn f ->
+ hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f)
+ | Unfold l ->
+ hov 1 (keyword "unfold" ++ spc() ++
+ prlist_with_sep pr_comma (pr_with_occurrences pr_ref keyword) l)
+ | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l)
+ | Pattern l ->
+ hov 1 (keyword "pattern" ++
+ pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr keyword)) l)
+
+ | Red true ->
+ CErrors.user_err Pp.(str "Shouldn't be accessible from user.")
+ | ExtraRedExpr s ->
+ str s
+ | CbvVm o ->
+ keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o
+ | CbvNative o ->
+ keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o
+
+let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) =
+ pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma)
+
+let pr_or_by_notation f = function
+ | {CAst.loc; v=AN v} -> f v
+ | {CAst.loc; v=ByNotation (s,sc)} -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
+
+let hov_if_not_empty n p = if Pp.ismt p then p else hov n p
+
+let rec pr_raw_generic env (GenArg (Rawwit wit, x)) =
+ match wit with
+ | ListArg wit ->
+ let map x = pr_raw_generic env (in_gen (rawwit wit) x) in
+ let ans = pr_sequence map x in
+ hov_if_not_empty 0 ans
+ | OptArg wit ->
+ let ans = match x with
+ | None -> mt ()
+ | Some x -> pr_raw_generic env (in_gen (rawwit wit) x)
+ in
+ hov_if_not_empty 0 ans
+ | PairArg (wit1, wit2) ->
+ let p, q = x in
+ let p = in_gen (rawwit wit1) p in
+ let q = in_gen (rawwit wit2) q in
+ hov_if_not_empty 0 (pr_sequence (pr_raw_generic env) [p; q])
+ | ExtraArg s ->
+ let open Genprint in
+ match generic_raw_print (in_gen (rawwit wit) x) with
+ | PrinterBasic pp -> pp ()
+ | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded
+
+
+let rec pr_glb_generic env (GenArg (Glbwit wit, x)) =
+ match wit with
+ | ListArg wit ->
+ let map x = pr_glb_generic env (in_gen (glbwit wit) x) in
+ let ans = pr_sequence map x in
+ hov_if_not_empty 0 ans
+ | OptArg wit ->
+ let ans = match x with
+ | None -> mt ()
+ | Some x -> pr_glb_generic env (in_gen (glbwit wit) x)
+ in
+ hov_if_not_empty 0 ans
+ | PairArg (wit1, wit2) ->
+ let p, q = x in
+ let p = in_gen (glbwit wit1) p in
+ let q = in_gen (glbwit wit2) q in
+ let ans = pr_sequence (pr_glb_generic env) [p; q] in
+ hov_if_not_empty 0 ans
+ | ExtraArg s ->
+ let open Genprint in
+ match generic_glb_print (in_gen (glbwit wit) x) with
+ | PrinterBasic pp -> pp ()
+ | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded
diff --git a/printing/pputils.mli b/printing/pputils.mli
index a0f2c772..6039168f 100644
--- a/printing/pputils.mli
+++ b/printing/pputils.mli
@@ -1,13 +1,47 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
-open Pp
+open Genarg
+open Misctypes
+open Locus
+open Genredexpr
-val pr_located : ('a -> std_ppcmds) -> 'a Loc.located -> std_ppcmds
+val pr_located : ('a -> Pp.t) -> 'a Loc.located -> Pp.t
+val pr_ast : ('a -> Pp.t) -> 'a CAst.t -> Pp.t
(** Prints an object surrounded by its commented location *)
+val pr_or_var : ('a -> Pp.t) -> 'a or_var -> Pp.t
+val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t
+val pr_with_occurrences :
+ ('a -> Pp.t) -> (string -> Pp.t) -> 'a with_occurrences -> Pp.t
+
+val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t
+val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t
+
+val pr_red_expr :
+ ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) ->
+ (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t
+
+val pr_red_expr_env : Environ.env -> Evd.evar_map ->
+ (Environ.env -> Evd.evar_map -> 'a -> Pp.t) *
+ (Environ.env -> Evd.evar_map -> 'a -> Pp.t) *
+ ('b -> Pp.t) *
+ (Environ.env -> Evd.evar_map -> 'c -> Pp.t) ->
+ (string -> Pp.t) ->
+ ('a,'b,'c) red_expr_gen -> Pp.t
+
+val pr_raw_generic : Environ.env -> rlevel generic_argument -> Pp.t
+val pr_glb_generic : Environ.env -> glevel generic_argument -> Pp.t
+
+(* The comments interface is imperative due to the printer not
+ threading it, this could be solved using a better data
+ structure. *)
+val beautify_comments : ((int * int) * string) list ref
+val extract_comments : int -> string list
diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml
index 5d6d36d5..5c5b7206 100644
--- a/printing/ppvernac.ml
+++ b/printing/ppvernac.ml
@@ -1,9 +1,11 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
open Pp
@@ -11,6 +13,8 @@ open Names
open CErrors
open Util
+open CAst
+
open Extend
open Vernacexpr
open Pputils
@@ -19,18 +23,11 @@ open Constrexpr
open Constrexpr_ops
open Decl_kinds
-module Make
- (Ppconstr : Ppconstrsig.Pp)
- (Pptactic : Pptacticsig.Pp)
- (Taggers : sig
- val tag_keyword : std_ppcmds -> std_ppcmds
- val tag_vernac : vernac_expr -> std_ppcmds -> std_ppcmds
- end)
-= struct
-
- open Taggers
open Ppconstr
- open Pptactic
+
+ let do_not_tag _ x = x
+ let tag_keyword = do_not_tag ()
+ let tag_vernac = do_not_tag
let keyword s = tag_keyword (str s)
@@ -38,36 +35,50 @@ module Make
let pr_lconstr = pr_lconstr_expr
let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr
- let pr_lident (loc,id) =
- if Loc.is_ghost loc then
- let (b,_) = Loc.unloc loc in
- pr_located pr_id (Loc.make_loc (b,b + String.length(Id.to_string id)),id)
- else
- pr_id id
-
- let pr_plident (lid, l) =
- pr_lident lid ++
- (match l with
- | Some l -> prlist_with_sep spc pr_lident l
- | None -> mt())
-
+ let pr_uconstraint (l, d, r) =
+ pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++
+ pr_glob_level r
+
+ let pr_univ_name_list = function
+ | None -> mt ()
+ | Some l ->
+ str "@{" ++ prlist_with_sep spc pr_lname l ++ str"}"
+
+ let pr_univdecl_instance l extensible =
+ prlist_with_sep spc pr_lident l ++
+ (if extensible then str"+" else mt ())
+
+ let pr_univdecl_constraints l extensible =
+ if List.is_empty l && extensible then mt ()
+ else str"|" ++ spc () ++ prlist_with_sep (fun () -> str",") pr_uconstraint l ++
+ (if extensible then str"+" else mt())
+
+ let pr_universe_decl l =
+ let open Misctypes in
+ match l with
+ | None -> mt ()
+ | Some l ->
+ str"@{" ++ pr_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++
+ pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}"
+
+ let pr_ident_decl (lid, l) =
+ pr_lident lid ++ pr_universe_decl l
+
let string_of_fqid fqid =
String.concat "." (List.map Id.to_string fqid)
let pr_fqid fqid = str (string_of_fqid fqid)
- let pr_lfqid (loc,fqid) =
- if Loc.is_ghost loc then
- let (b,_) = Loc.unloc loc in
- pr_located pr_fqid (Loc.make_loc (b,b + String.length(string_of_fqid fqid)),fqid)
- else
- pr_fqid fqid
+ let pr_lfqid {CAst.loc;v=fqid} =
+ match loc with
+ | None -> pr_fqid fqid
+ | Some loc -> let (b,_) = Loc.unloc loc in
+ pr_located pr_fqid @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (string_of_fqid fqid))) fqid
- let pr_lname = function
- | (loc,Name id) -> pr_lident (loc,id)
- | lna -> pr_located pr_name lna
+ let pr_lname_decl (n, u) =
+ pr_lname n ++ pr_universe_decl u
- let pr_smart_global = pr_or_by_notation pr_reference
+ let pr_smart_global = Pputils.pr_or_by_notation pr_reference
let pr_ltac_ref = Libnames.pr_reference
@@ -77,25 +88,44 @@ module Make
let sep_end = function
| VernacBullet _
- | VernacSubproof None
+ | VernacSubproof _
| VernacEndSubproof -> str""
| _ -> str"."
- let pr_gen t = pr_raw_generic (Global.env ()) t
+ let pr_gen t = Pputils.pr_raw_generic (Global.env ()) t
let sep = fun _ -> spc()
let sep_v2 = fun _ -> str"," ++ spc()
- let pr_set_entry_type = function
+ let pr_at_level = function
+ | NumLevel n -> keyword "at" ++ spc () ++ keyword "level" ++ spc () ++ int n
+ | NextLevel -> keyword "at" ++ spc () ++ keyword "next" ++ spc () ++ keyword "level"
+
+ let pr_constr_as_binder_kind = function
+ | AsIdent -> keyword "as ident"
+ | AsIdentOrPattern -> keyword "as pattern"
+ | AsStrictPattern -> keyword "as strict pattern"
+
+ let pr_strict b = if b then str "strict " else mt ()
+
+ let pr_set_entry_type pr = function
| ETName -> str"ident"
| ETReference -> str"global"
- | ETPattern -> str"pattern"
- | ETConstr _ -> str"constr"
+ | ETPattern (b,None) -> pr_strict b ++ str"pattern"
+ | ETPattern (b,Some n) -> pr_strict b ++ str"pattern" ++ spc () ++ pr_at_level (NumLevel n)
+ | ETConstr lev -> str"constr" ++ pr lev
| ETOther (_,e) -> str e
+ | ETConstrAsBinder (bk,lev) -> pr lev ++ spc () ++ pr_constr_as_binder_kind bk
| ETBigint -> str "bigint"
| ETBinder true -> str "binder"
| ETBinder false -> str "closed binder"
- | ETBinderList _ | ETConstrList _ -> failwith "Internal entry type"
+
+ let pr_at_level_opt = function
+ | None -> mt ()
+ | Some n -> spc () ++ pr_at_level n
+
+ let pr_set_simple_entry_type =
+ pr_set_entry_type pr_at_level_opt
let pr_comment pr_c = function
| CommentConstr c -> pr_c c
@@ -114,7 +144,7 @@ module Make
| SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
let pr_search a gopt b pr_p =
- pr_opt (fun g -> int g ++ str ":"++ spc()) gopt
+ pr_opt (fun g -> Proof_bullet.pr_goal_selector g ++ str ":"++ spc()) gopt
++
match a with
| SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b
@@ -127,7 +157,7 @@ module Make
let pr_explanation (e,b,f) =
let a = match e with
- | ExplByPos (n,_) -> anomaly (Pp.str "No more supported")
+ | ExplByPos (n,_) -> anomaly (Pp.str "No more supported.")
| ExplByName id -> pr_id id in
let a = if f then str"!" ++ a else a in
if b then str "[" ++ a ++ str "]" else a
@@ -198,31 +228,31 @@ module Make
| HintsExtern (n,c,tac) ->
let pat = match c with None -> mt () | Some pat -> pr_pat pat in
keyword "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++
- spc() ++ pr_raw_tactic tac
+ spc() ++ Pputils.pr_raw_generic (Global.env ()) tac
in
hov 2 (keyword "Hint "++ pph ++ opth)
let pr_with_declaration pr_c = function
- | CWith_Definition (id,c) ->
+ | CWith_Definition (id,udecl,c) ->
let p = pr_c c in
- keyword "Definition" ++ spc() ++ pr_lfqid id ++ str" := " ++ p
+ keyword "Definition" ++ spc() ++ pr_lfqid id ++ pr_universe_decl udecl ++ str" := " ++ p
| CWith_Module (id,qid) ->
keyword "Module" ++ spc() ++ pr_lfqid id ++ str" := " ++
- pr_located pr_qualid qid
+ pr_ast pr_qualid qid
let rec pr_module_ast leading_space pr_c = function
- | CMident qid ->
+ | { loc ; v = CMident qid } ->
if leading_space then
- spc () ++ pr_located pr_qualid qid
+ spc () ++ pr_located pr_qualid (loc, qid)
else
- pr_located pr_qualid qid
- | CMwith (_,mty,decl) ->
+ pr_located pr_qualid (loc,qid)
+ | { v = CMwith (mty,decl) } ->
let m = pr_module_ast leading_space pr_c mty in
let p = pr_with_declaration pr_c decl in
m ++ spc() ++ keyword "with" ++ spc() ++ p
- | CMapply (_,me1,(CMident _ as me2)) ->
+ | { v = CMapply (me1, ( { v = CMident _ } as me2 ) ) } ->
pr_module_ast leading_space pr_c me1 ++ spc() ++ pr_module_ast false pr_c me2
- | CMapply (_,me1,me2) ->
+ | { v = CMapply (me1,me2) } ->
pr_module_ast leading_space pr_c me1 ++ spc() ++
hov 1 (str"(" ++ pr_module_ast false pr_c me2 ++ str")")
@@ -261,10 +291,10 @@ module Make
prlist_strict (pr_module_vardecls pr_c) l
let pr_type_option pr_c = function
- | CHole (loc, k, Misctypes.IntroAnonymous, _) -> mt()
+ | { v = CHole (k, Misctypes.IntroAnonymous, _) } -> mt()
| _ as c -> brk(0,2) ++ str" :" ++ pr_c c
- let pr_decl_notation prc ((loc,ntn),c,scopt) =
+ let pr_decl_notation prc ({loc; v=ntn},c,scopt) =
fnl () ++ keyword "where " ++ qs ntn ++ str " := "
++ Flags.without_option Flags.beautify prc c ++
pr_opt (fun sc -> str ": " ++ str sc) scopt
@@ -284,7 +314,7 @@ module Make
) ++
hov 0 ((if dep then keyword "Induction for" else keyword "Minimality for")
++ spc() ++ pr_smart_global ind) ++ spc() ++
- hov 0 (keyword "Sort" ++ spc() ++ pr_glob_sort s)
+ hov 0 (keyword "Sort" ++ spc() ++ Termops.pr_sort_family s)
| CaseScheme (dep,ind,s) ->
(match idop with
| Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
@@ -292,7 +322,7 @@ module Make
) ++
hov 0 ((if dep then keyword "Elimination for" else keyword "Case for")
++ spc() ++ pr_smart_global ind) ++ spc() ++
- hov 0 (keyword "Sort" ++ spc() ++ pr_glob_sort s)
+ hov 0 (keyword "Sort" ++ spc() ++ Termops.pr_sort_family s)
| EqualityScheme ind ->
(match idop with
| Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
@@ -303,31 +333,26 @@ module Make
let begin_of_inductive = function
| [] -> 0
- | (_,((loc,_),_))::_ -> fst (Loc.unloc loc)
+ | (_,({loc},_))::_ -> Option.cata (fun loc -> fst (Loc.unloc loc)) 0 loc
let pr_class_rawexpr = function
| FunClass -> keyword "Funclass"
| SortClass -> keyword "Sortclass"
| RefClass qid -> pr_smart_global qid
- let pr_assumption_token many (l,a) =
- let l = match l with Some x -> x | None -> Decl_kinds.Global in
- match l, a with
- | (Discharge,Logical) ->
- keyword (if many then "Hypotheses" else "Hypothesis")
- | (Discharge,Definitional) ->
- keyword (if many then "Variables" else "Variable")
- | (Global,Logical) ->
+ let pr_assumption_token many discharge kind =
+ match discharge, kind with
+ | (NoDischarge,Logical) ->
keyword (if many then "Axioms" else "Axiom")
- | (Global,Definitional) ->
+ | (NoDischarge,Definitional) ->
keyword (if many then "Parameters" else "Parameter")
- | (Local, Logical) ->
- keyword (if many then "Local Axioms" else "Local Axiom")
- | (Local,Definitional) ->
- keyword (if many then "Local Parameters" else "Local Parameter")
- | (Global,Conjectural) -> str"Conjecture"
- | ((Discharge | Local),Conjectural) ->
- anomaly (Pp.str "Don't know how to beautify a local conjecture")
+ | (NoDischarge,Conjectural) -> str"Conjecture"
+ | (DoDischarge,Logical) ->
+ keyword (if many then "Hypotheses" else "Hypothesis")
+ | (DoDischarge,Definitional) ->
+ keyword (if many then "Variables" else "Variable")
+ | (DoDischarge,Conjectural) ->
+ anomaly (Pp.str "Don't know how to beautify a local conjecture.")
let pr_params pr_c (xl,(c,t)) =
hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++
@@ -358,54 +383,41 @@ module Make
let pr_thm_token k = keyword (Kindops.string_of_theorem_kind k)
let pr_syntax_modifier = function
- | SetItemLevel (l,NextLevel) ->
- prlist_with_sep sep_v2 str l ++
- spc() ++ keyword "at next level"
- | SetItemLevel (l,NumLevel n) ->
+ | SetItemLevel (l,n) ->
+ prlist_with_sep sep_v2 str l ++ spc () ++ pr_at_level n
+ | SetItemLevelAsBinder (l,bk,n) ->
prlist_with_sep sep_v2 str l ++
- spc() ++ keyword "at level" ++ spc() ++ int n
- | SetLevel n -> keyword "at level" ++ spc() ++ int n
+ spc() ++ pr_at_level_opt n ++ spc() ++ pr_constr_as_binder_kind bk
+ | SetLevel n -> pr_at_level (NumLevel n)
| SetAssoc LeftA -> keyword "left associativity"
| SetAssoc RightA -> keyword "right associativity"
| SetAssoc NonA -> keyword "no associativity"
- | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ
+ | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_simple_entry_type typ
| SetOnlyPrinting -> keyword "only printing"
| SetOnlyParsing -> keyword "only parsing"
| SetCompatVersion v -> keyword("compat \"" ^ Flags.pr_version v ^ "\"")
- | SetFormat("text",s) -> keyword "format " ++ pr_located qs s
- | SetFormat(k,s) -> keyword "format " ++ qs k ++ spc() ++ pr_located qs s
+ | SetFormat("text",s) -> keyword "format " ++ pr_ast qs s
+ | SetFormat(k,s) -> keyword "format " ++ qs k ++ spc() ++ pr_ast qs s
let pr_syntax_modifiers = function
| [] -> mt()
| l -> spc() ++
hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")")
- let pr_univs pl =
- match pl with
- | None -> mt ()
- | Some pl -> str"@{" ++ prlist_with_sep spc pr_lident pl ++ str"}"
-
- let pr_rec_definition ((((loc,id),pl),ro,bl,type_,def),ntn) =
+ let pr_rec_definition ((iddecl,ro,bl,type_,def),ntn) =
let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in
let annot = pr_guard_annot pr_lconstr_expr bl ro in
- pr_id id ++ pr_univs pl ++ pr_binders_arg bl ++ annot
+ pr_ident_decl iddecl ++ pr_binders_arg bl ++ annot
++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr def) def
++ prlist (pr_decl_notation pr_constr) ntn
- let pr_statement head (idpl,(bl,c,guard)) =
- assert (not (Option.is_empty idpl));
- let id, pl = Option.get idpl in
+ let pr_statement head (idpl,(bl,c)) =
hov 2
- (head ++ spc() ++ pr_lident id ++ pr_univs pl ++ spc() ++
+ (head ++ spc() ++ pr_ident_decl idpl ++ spc() ++
(match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++
- pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++
str":" ++ pr_spc_lconstr c)
- let pr_priority = function
- | None -> mt ()
- | Some i -> spc () ++ str "|" ++ spc () ++ int i
-
(**************************************)
(* Pretty printer for vernac commands *)
(**************************************)
@@ -448,7 +460,7 @@ module Make
| PrintGrammar ent ->
keyword "Print Grammar" ++ spc() ++ str ent
| PrintLoadPath dir ->
- keyword "Print LoadPath" ++ pr_opt pr_dirpath dir
+ keyword "Print LoadPath" ++ pr_opt DirPath.print dir
| PrintModules ->
keyword "Print Modules"
| PrintMLLoadPath ->
@@ -489,8 +501,8 @@ module Make
else "Print Universes"
in
keyword cmd ++ pr_opt str fopt
- | PrintName qid ->
- keyword "Print" ++ spc() ++ pr_smart_global qid
+ | PrintName (qid,udecl) ->
+ keyword "Print" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list udecl
| PrintModuleType qid ->
keyword "Print Module Type" ++ spc() ++ pr_reference qid
| PrintModule qid ->
@@ -503,9 +515,9 @@ module Make
keyword "Print Scope" ++ spc() ++ str s
| PrintVisibility s ->
keyword "Print Visibility" ++ pr_opt str s
- | PrintAbout (qid,gopt) ->
- pr_opt (fun g -> int g ++ str ":"++ spc()) gopt
- ++ keyword "About" ++ spc() ++ pr_smart_global qid
+ | PrintAbout (qid,l,gopt) ->
+ pr_opt (fun g -> Proof_bullet.pr_goal_selector g ++ str ":"++ spc()) gopt
+ ++ keyword "About" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list l
| PrintImplicit qid ->
keyword "Print Implicit" ++ spc() ++ pr_smart_global qid
(* spiwack: command printing all the axioms and section variables used in a
@@ -519,40 +531,50 @@ module Make
in
keyword cmd ++ spc() ++ pr_smart_global qid
| PrintNamespace dp ->
- keyword "Print Namespace" ++ pr_dirpath dp
+ keyword "Print Namespace" ++ DirPath.print dp
| PrintStrategy None ->
keyword "Print Strategies"
| PrintStrategy (Some qid) ->
keyword "Print Strategy" ++ pr_smart_global qid
- let pr_using e = str (Proof_using.to_string e)
+ let pr_using e =
+ let rec aux = function
+ | SsEmpty -> "()"
+ | SsType -> "(Type)"
+ | SsSingl { v=id } -> "("^Id.to_string id^")"
+ | SsCompl e -> "-" ^ aux e^""
+ | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")"
+ | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")"
+ | SsFwdClose e -> "("^aux e^")*"
+ in Pp.str (aux e)
+
+ let pr_extend s cl =
+ let pr_arg a =
+ try pr_gen a
+ with Failure _ -> str "<error in " ++ str (fst s) ++ str ">" in
+ try
+ let rl = Egramml.get_extend_vernac_rule s in
+ let rec aux rl cl =
+ match rl, cl with
+ | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl
+ | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl
+ | [], [] -> []
+ | _ -> assert false in
+ hov 1 (pr_sequence identity (aux rl cl))
+ with Not_found ->
+ hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")")
- let rec pr_vernac_body v =
- let return = Taggers.tag_vernac v in
+ let pr_vernac_expr v =
+ let return = tag_vernac v in
match v with
- | VernacPolymorphic (poly, v) ->
- let s = if poly then keyword "Polymorphic" else keyword "Monomorphic" in
- return (s ++ spc () ++ pr_vernac_body v)
- | VernacProgram v ->
- return (keyword "Program" ++ spc() ++ pr_vernac_body v)
- | VernacLocal (local, v) ->
- return (pr_locality local ++ spc() ++ pr_vernac_body v)
-
- (* Stm *)
- | VernacStm JoinDocument ->
- return (keyword "Stm JoinDocument")
- | VernacStm PrintDag ->
- return (keyword "Stm PrintDag")
- | VernacStm Finish ->
- return (keyword "Stm Finish")
- | VernacStm Wait ->
- return (keyword "Stm Wait")
- | VernacStm (Observe id) ->
- return (keyword "Stm Observe " ++ str(Stateid.to_string id))
- | VernacStm (Command v) ->
- return (keyword "Stm Command " ++ pr_vernac_body v)
- | VernacStm (PGLast v) ->
- return (keyword "Stm PGLast " ++ pr_vernac_body v)
+ | VernacLoad (f,s) ->
+ return (
+ keyword "Load"
+ ++ if f then
+ (spc() ++ keyword "Verbose" ++ spc())
+ else
+ spc() ++ qs s
+ )
(* Proof management *)
| VernacAbortAll ->
@@ -563,8 +585,6 @@ module Make
return (keyword "Unfocus")
| VernacUnfocused ->
return (keyword "Unfocused")
- | VernacGoal c ->
- return (keyword "Goal" ++ pr_lconstrarg c)
| VernacAbort id ->
return (keyword "Abort" ++ pr_opt pr_lident id)
| VernacUndo i ->
@@ -582,20 +602,16 @@ module Make
| OpenSubgoals -> mt ()
| NthGoal n -> spc () ++ int n
| GoalId id -> spc () ++ pr_id id
- | GoalUid n -> spc () ++ str n in
+ in
let pr_showable = function
| ShowGoal n -> keyword "Show" ++ pr_goal_reference n
- | ShowGoalImplicitly n -> keyword "Show Implicit Arguments" ++ pr_opt int n
| ShowProof -> keyword "Show Proof"
- | ShowNode -> keyword "Show Node"
| ShowScript -> keyword "Show Script"
| ShowExistentials -> keyword "Show Existentials"
| ShowUniverses -> keyword "Show Universes"
- | ShowTree -> keyword "Show Tree"
| ShowProofNames -> keyword "Show Conjectures"
| ShowIntros b -> keyword "Show " ++ (if b then keyword "Intros" else keyword "Intro")
| ShowMatch id -> keyword "Show Match " ++ pr_reference id
- | ShowThesis -> keyword "Show Thesis"
in
return (pr_showable s)
| VernacCheckGuard ->
@@ -619,28 +635,8 @@ module Make
| VernacRestoreState s ->
return (keyword "Restore State" ++ spc() ++ qs s)
- (* Control *)
- | VernacLoad (f,s) ->
- return (
- keyword "Load"
- ++ if f then
- (spc() ++ keyword "Verbose" ++ spc())
- else
- spc() ++ qs s
- )
- | VernacTime (_,v) ->
- return (keyword "Time" ++ spc() ++ pr_vernac_body v)
- | VernacRedirect (s, (_,v)) ->
- return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_body v)
- | VernacTimeout(n,v) ->
- return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_body v)
- | VernacFail v ->
- return (keyword "Fail" ++ spc() ++ pr_vernac_body v)
- | VernacError _ ->
- return (keyword "No-parsing-rule for VernacError")
-
(* Syntax *)
- | VernacOpenCloseScope (_,(opening,sc)) ->
+ | VernacOpenCloseScope (opening,sc) ->
return (
keyword (if opening then "Open " else "Close ") ++
keyword "Scope" ++ spc() ++ str sc
@@ -669,7 +665,7 @@ module Make
++ spc() ++ pr_smart_global q
++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]"
)
- | VernacInfix (_,((_,s),mv),q,sn) -> (* A Verifier *)
+ | VernacInfix (({v=s},mv),q,sn) -> (* A Verifier *)
return (
hov 0 (hov 0 (keyword "Infix "
++ qs s ++ str " :=" ++ pr_constrarg q) ++
@@ -678,7 +674,7 @@ module Make
| None -> mt()
| Some sc -> spc() ++ str":" ++ spc() ++ str sc))
)
- | VernacNotation (_,c,((_,s),l),opt) ->
+ | VernacNotation (c,({v=s},l),opt) ->
return (
hov 2 (keyword "Notation" ++ spc() ++ qs s ++
str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++
@@ -686,9 +682,9 @@ module Make
| None -> mt()
| Some sc -> str" :" ++ spc() ++ str sc))
)
- | VernacSyntaxExtension (_,(s,l)) ->
+ | VernacSyntaxExtension (_, (s, l)) ->
return (
- keyword "Reserved Notation" ++ spc() ++ pr_located qs s ++
+ keyword "Reserved Notation" ++ spc() ++ pr_ast qs s ++
pr_syntax_modifiers l
)
| VernacNotationAddFormat(s,k,v) ->
@@ -697,16 +693,18 @@ module Make
)
(* Gallina *)
- | VernacDefinition (d,id,b) -> (* A verifier... *)
- let pr_def_token (l,dk) =
- let l = match l with Some x -> x | None -> Decl_kinds.Global in
- keyword (Kindops.string_of_definition_kind (l,false,dk))
+ | VernacDefinition ((discharge,kind),id,b) -> (* A verifier... *)
+ let pr_def_token dk =
+ keyword (
+ if Name.is_anonymous (fst id).v
+ then "Goal"
+ else Kindops.string_of_definition_object_kind dk)
in
let pr_reduce = function
| None -> mt()
| Some r ->
keyword "Eval" ++ spc() ++
- pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++
+ pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++
keyword " in" ++ spc()
in
let pr_def_body = function
@@ -717,18 +715,19 @@ module Make
in
(pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body))
| ProveBody (bl,t) ->
- (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in
+ let typ u = if (fst id).v = Anonymous then (assert (bl = []); u) else (str" :" ++ u) in
+ (pr_binders_arg bl, typ (pr_spc_lconstr t), None) in
let (binds,typ,c) = pr_def_body b in
return (
hov 2 (
- pr_def_token d ++ spc()
- ++ pr_plident id ++ binds ++ typ
+ pr_def_token kind ++ spc()
+ ++ pr_lname_decl id ++ binds ++ typ
++ (match c with
| None -> mt()
| Some cc -> str" :=" ++ spc() ++ cc))
)
- | VernacStartTheoremProof (ki,l,_) ->
+ | VernacStartTheoremProof (ki,l) ->
return (
hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++
prlist (pr_statement (spc () ++ keyword "with")) (List.tl l))
@@ -741,25 +740,20 @@ module Make
match o with
| None -> (match opac with
| Transparent -> keyword "Defined"
- | Opaque None -> keyword "Qed"
- | Opaque (Some l) ->
- keyword "Qed" ++ spc() ++ str"export" ++
- prlist_with_sep (fun () -> str", ") pr_lident l)
- | Some (id,th) -> (match th with
- | None -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id
- | Some tok -> keyword "Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)
+ | Opaque -> keyword "Qed")
+ | Some id -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id
)
| VernacExactProof c ->
return (hov 2 (keyword "Proof" ++ pr_lconstrarg c))
- | VernacAssumption (stre,t,l) ->
+ | VernacAssumption ((discharge,kind),t,l) ->
let n = List.length (List.flatten (List.map fst (List.map snd l))) in
let pr_params (c, (xl, t)) =
- hov 2 (prlist_with_sep sep pr_plident xl ++ spc() ++
+ hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++
(if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in
let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in
- return (hov 2 (pr_assumption_token (n > 1) stre ++
+ return (hov 2 (pr_assumption_token (n > 1) discharge kind ++
pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions))
- | VernacInductive (p,f,l) ->
+ | VernacInductive (cum, p,f,l) ->
let pr_constructor (coe,(id,c)) =
hov 2 (pr_lident id ++ str" " ++
(if coe then str":>" else str":") ++
@@ -775,10 +769,10 @@ module Make
| RecordDecl (c,fs) ->
pr_record_decl b c fs
in
- let pr_oneind key (((coe,(id,pl)),indpar,s,k,lc),ntn) =
+ let pr_oneind key (((coe,iddecl),indpar,s,k,lc),ntn) =
hov 0 (
str key ++ spc() ++
- (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++
+ (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++
pr_and_type_binders_arg indpar ++
pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++
str" :=") ++ pr_constructor_list k lc ++
@@ -786,20 +780,29 @@ module Make
in
let key =
let (_,_,_,k,_),_ = List.hd l in
- match k with Record -> "Record" | Structure -> "Structure"
- | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
- | Class _ -> "Class" | Variant -> "Variant"
+ let kind =
+ match k with Record -> "Record" | Structure -> "Structure"
+ | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
+ | Class _ -> "Class" | Variant -> "Variant"
+ in
+ if p then
+ let cm =
+ match cum with
+ | GlobalCumulativity | LocalCumulativity -> "Cumulative"
+ | GlobalNonCumulativity | LocalNonCumulativity -> "NonCumulative"
+ in
+ cm ^ " " ^ kind
+ else kind
in
return (
hov 1 (pr_oneind key (List.hd l)) ++
- (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
+ (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
)
| VernacFixpoint (local, recs) ->
let local = match local with
- | Some Discharge -> "Let "
- | Some Local -> "Local "
- | None | Some Global -> ""
+ | DoDischarge -> "Let "
+ | NoDischarge -> ""
in
return (
hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++
@@ -809,12 +812,11 @@ module Make
| VernacCoFixpoint (local, corecs) ->
let local = match local with
- | Some Discharge -> keyword "Let" ++ spc ()
- | Some Local -> keyword "Local" ++ spc ()
- | None | Some Global -> str ""
+ | DoDischarge -> keyword "Let" ++ spc ()
+ | NoDischarge -> str ""
in
- let pr_onecorec ((((loc,id),pl),bl,c,def),ntn) =
- pr_id id ++ pr_univs pl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
+ let pr_onecorec ((iddecl,bl,c,def),ntn) =
+ pr_ident_decl iddecl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
spc() ++ pr_lconstr_expr c ++
pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++
prlist (pr_decl_notation pr_constr) ntn
@@ -840,10 +842,6 @@ module Make
prlist_with_sep (fun _ -> str",") pr_lident v)
)
| VernacConstraint v ->
- let pr_uconstraint (l, d, r) =
- pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++
- pr_glob_level r
- in
return (
hov 2 (keyword "Constraint" ++ spc () ++
prlist_with_sep (fun _ -> str",") pr_uconstraint v)
@@ -876,14 +874,14 @@ module Make
return (
keyword "Canonical Structure" ++ spc() ++ pr_smart_global q
)
- | VernacCoercion (_,id,c1,c2) ->
+ | VernacCoercion (id,c1,c2) ->
return (
hov 1 (
keyword "Coercion" ++ spc() ++
pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2)
)
- | VernacIdentityCoercion (_,id,c1,c2) ->
+ | VernacIdentityCoercion (id,c1,c2) ->
return (
hov 1 (
keyword "Identity Coercion" ++ spc() ++ pr_lident id ++
@@ -895,16 +893,16 @@ module Make
return (
hov 1 (
(if abst then keyword "Declare" ++ spc () else mt ()) ++
- keyword "Instance" ++
- (match instid with
- | (loc, Name id), l -> spc () ++ pr_plident ((loc, id),l) ++ spc ()
- | (_, Anonymous), _ -> mt ()) ++
- pr_and_type_binders_arg sup ++
+ keyword "Instance" ++
+ (match instid with
+ | {loc; v = Name id}, l -> spc () ++ pr_ident_decl (CAst.(make ?loc id),l) ++ spc ()
+ | { v = Anonymous }, _ -> mt ()) ++
+ pr_and_type_binders_arg sup ++
str":" ++ spc () ++
(match bk with Implicit -> str "! " | Explicit -> mt ()) ++
pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info ++
(match props with
- | Some (true,CRecord (_,l)) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}"
+ | Some (true, { v = CRecord l}) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}"
| Some (true,_) -> assert false
| Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr p
| None -> mt()))
@@ -977,7 +975,7 @@ module Make
keyword "LoadPath" ++ spc() ++ qs s ++
(match d with
| None -> mt()
- | Some dir -> spc() ++ keyword "as" ++ spc() ++ pr_dirpath dir))
+ | Some dir -> spc() ++ keyword "as" ++ spc() ++ DirPath.print dir))
)
| VernacRemoveLoadPath s ->
return (keyword "Remove LoadPath" ++ qs s)
@@ -1007,9 +1005,9 @@ module Make
prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++
pr_opt_hintbases dbnames)
)
- | VernacHints (_, dbnames,h) ->
+ | VernacHints (dbnames,h) ->
return (pr_hints dbnames h pr_constr pr_constr_pattern_expr)
- | VernacSyntacticDefinition (id,(ids,c),_,compat) ->
+ | VernacSyntacticDefinition (id,(ids,c),compat) ->
return (
hov 2
(keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++
@@ -1037,7 +1035,7 @@ module Make
hov 2 (
keyword "Arguments" ++ spc() ++
pr_smart_global q ++
- let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in
+ let pr_s = function None -> str"" | Some {v=s} -> str "%" ++ str s in
let pr_if b x = if b then x else str "" in
let pr_br imp x = match imp with
| Vernacexpr.Implicit -> str "[" ++ x ++ str "]"
@@ -1050,13 +1048,13 @@ module Make
| n, { name = id; recarg_like = k;
notation_scope = s;
implicit_status = imp } :: tl ->
- spc() ++ pr_br imp (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++
+ spc() ++ pr_br imp (pr_if k (str"!") ++ Name.print id ++ pr_s s) ++
print_arguments (Option.map pred n) tl
in
let rec print_implicits = function
| [] -> mt ()
| (name, impl) :: rest ->
- spc() ++ pr_br impl (pr_name name) ++ print_implicits rest
+ spc() ++ pr_br impl (Name.print name) ++ print_implicits rest
in
print_arguments nargs args ++
if not (List.is_empty more_implicits) then
@@ -1103,7 +1101,7 @@ module Make
)
| VernacSetOpacity _ ->
return (
- CErrors.anomaly (keyword "VernacSetOpacity used to set something else")
+ CErrors.anomaly (keyword "VernacSetOpacity used to set something else.")
)
| VernacSetStrategy l ->
let pr_lev = function
@@ -1120,18 +1118,15 @@ module Make
hov 1 (keyword "Strategy" ++ spc() ++
hv 0 (prlist_with_sep sep pr_line l))
)
- | VernacUnsetOption (na) ->
+ | VernacUnsetOption (export, na) ->
+ let export = if export then keyword "Export" ++ spc () else mt () in
return (
- hov 1 (keyword "Unset" ++ spc() ++ pr_printoption na None)
+ hov 1 (export ++ keyword "Unset" ++ spc() ++ pr_printoption na None)
)
- | VernacSetOption (na,v) ->
+ | VernacSetOption (export, na,v) ->
+ let export = if export then keyword "Export" ++ spc () else mt () in
return (
- hov 2 (keyword "Set" ++ spc() ++ pr_set_option na v)
- )
- | VernacSetAppendOption (na,v) ->
- return (
- hov 2 (keyword "Set" ++ spc() ++ pr_printoption na None ++
- spc() ++ keyword "Append" ++ spc() ++ qs v)
+ hov 2 (export ++ keyword "Set" ++ spc() ++ pr_set_option na v)
)
| VernacAddOption (na,l) ->
return (
@@ -1153,18 +1148,19 @@ module Make
let pr_mayeval r c = match r with
| Some r0 ->
hov 2 (keyword "Eval" ++ spc() ++
- pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++
+ pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++
spc() ++ keyword "in" ++ spc () ++ pr_lconstr c)
| None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c)
in
- let pr_i = match io with None -> mt () | Some i -> int i ++ str ": " in
+ let pr_i = match io with None -> mt ()
+ | Some i -> Proof_bullet.pr_goal_selector i ++ str ": " in
return (pr_i ++ pr_mayeval r c)
| VernacGlobalCheck c ->
return (hov 2 (keyword "Type" ++ pr_constrarg c))
| VernacDeclareReduction (s,r) ->
return (
keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++
- pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r
+ pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r
)
| VernacPrint p ->
return (pr_printable p)
@@ -1177,7 +1173,7 @@ module Make
| LocateFile f -> keyword "File" ++ spc() ++ qs f
| LocateLibrary qid -> keyword "Library" ++ spc () ++ pr_module qid
| LocateModule qid -> keyword "Module" ++ spc () ++ pr_module qid
- | LocateTactic qid -> keyword "Ltac" ++ spc () ++ pr_ltac_ref qid
+ | LocateOther (s, qid) -> keyword s ++ spc () ++ pr_ltac_ref qid
in
return (keyword "Locate" ++ spc() ++ pr_locate loc)
| VernacRegister (id, RegisterInline) ->
@@ -1205,12 +1201,12 @@ module Make
return (keyword "Proof " ++ spc () ++
keyword "using" ++ spc() ++ pr_using e)
| VernacProof (Some te, None) ->
- return (keyword "Proof with" ++ spc() ++ pr_raw_tactic te)
+ return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te)
| VernacProof (Some te, Some e) ->
return (
keyword "Proof" ++ spc () ++
keyword "using" ++ spc() ++ pr_using e ++ spc() ++
- keyword "with" ++ spc() ++pr_raw_tactic te
+ keyword "with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te
)
| VernacProofMode s ->
return (keyword "Proof Mode" ++ str s)
@@ -1223,47 +1219,34 @@ module Make
| VernacSubproof None ->
return (str "{")
| VernacSubproof (Some i) ->
- return (keyword "BeginSubproof" ++ spc () ++ int i)
+ return (Proof_bullet.pr_goal_selector i ++ str ":" ++ spc () ++ str "{")
| VernacEndSubproof ->
return (str "}")
- and pr_extend s cl =
- let pr_arg a =
- try pr_gen a
- with Failure _ -> str "<error in " ++ str (fst s) ++ str ">" in
- try
- let rl = Egramml.get_extend_vernac_rule s in
- let rec aux rl cl =
- match rl, cl with
- | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl
- | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl
- | [], [] -> []
- | _ -> assert false in
- hov 1 (pr_sequence (fun x -> x) (aux rl cl))
- with Not_found ->
- hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")")
-
- let pr_vernac v =
- try pr_vernac_body v ++ sep_end v
- with e -> CErrors.print e
-
-end
-
-include Make (Ppconstr) (Pptactic) (struct
- let do_not_tag _ x = x
- let tag_keyword = do_not_tag ()
- let tag_vernac = do_not_tag
-end)
-
-module Richpp = struct
+let pr_vernac_flag =
+ function
+ | VernacPolymorphic true -> keyword "Polymorphic"
+ | VernacPolymorphic false -> keyword "Monomorphic"
+ | VernacProgram -> keyword "Program"
+ | VernacLocal local -> pr_locality local
- include Make
- (Ppconstr.Richpp)
- (Pptactic.Richpp)
- (struct
- open Ppannotation
- let tag_keyword s = Pp.tag (Pp.Tag.inj AKeyword tag) s
- let tag_vernac v s = Pp.tag (Pp.Tag.inj (AVernac v) tag) s
- end)
-
-end
+ let rec pr_vernac_control v =
+ let return = tag_vernac v in
+ match v with
+ | VernacExpr (f, v') ->
+ List.fold_right
+ (fun f a -> pr_vernac_flag f ++ spc() ++ a)
+ f
+ (pr_vernac_expr v' ++ sep_end v')
+ | VernacTime (_,{v}) ->
+ return (keyword "Time" ++ spc() ++ pr_vernac_control v)
+ | VernacRedirect (s, {v}) ->
+ return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_control v)
+ | VernacTimeout(n,v) ->
+ return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_control v)
+ | VernacFail v ->
+ return (keyword "Fail" ++ spc() ++ pr_vernac_control v)
+
+ let pr_vernac v =
+ try pr_vernac_control v
+ with e -> CErrors.print e
diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli
index d3d4a5ce..4aa24bf5 100644
--- a/printing/ppvernac.mli
+++ b/printing/ppvernac.mli
@@ -1,20 +1,26 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
(** This module implements pretty-printers for vernac_expr syntactic
objects and their subcomponents. *)
-(** The default pretty-printers produce {!Pp.std_ppcmds} that are
- interpreted as raw strings. *)
-include Ppvernacsig.Pp
+val pr_set_entry_type : ('a -> Pp.t) -> 'a Extend.constr_entry_key_gen -> Pp.t
-(** The rich pretty-printers produce {!Pp.std_ppcmds} that are
- interpreted as annotated strings. The annotations can be
- retrieved using {!RichPp.rich_pp}. Their definitions are
- located in {!Ppannotation.t}. *)
-module Richpp : Ppvernacsig.Pp
+(** Prints a fixpoint body *)
+val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.t
+
+(** Prints a vernac expression without dot *)
+val pr_vernac_expr : Vernacexpr.vernac_expr -> Pp.t
+
+(** Prints a "proof using X" clause. *)
+val pr_using : Vernacexpr.section_subset_expr -> Pp.t
+
+(** Prints a vernac expression and closes it with a dot. *)
+val pr_vernac : Vernacexpr.vernac_control -> Pp.t
diff --git a/printing/ppvernacsig.mli b/printing/ppvernacsig.mli
deleted file mode 100644
index 5e5e4bcf..00000000
--- a/printing/ppvernacsig.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-module type Pp = sig
-
- (** Prints a fixpoint body *)
- val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds
-
- (** Prints a vernac expression *)
- val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds
-
- (** Prints a vernac expression and closes it with a dot. *)
- val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds
-
-end
diff --git a/printing/prettyp.ml b/printing/prettyp.ml
index e117f1dc..1f17d844 100644
--- a/printing/prettyp.ml
+++ b/printing/prettyp.ml
@@ -1,9 +1,11 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
(* Changed by (and thus parts copyright ©) by Lionel Elie Mamane <lionel@mamane.lu>
@@ -13,9 +15,9 @@
open Pp
open CErrors
open Util
+open CAst
open Names
open Nameops
-open Term
open Termops
open Declarations
open Environ
@@ -27,19 +29,23 @@ open Recordops
open Misctypes
open Printer
open Printmod
+open Context.Rel.Declaration
+
+(* module RelDecl = Context.Rel.Declaration *)
+module NamedDecl = Context.Named.Declaration
type object_pr = {
- print_inductive : mutual_inductive -> std_ppcmds;
- print_constant_with_infos : constant -> std_ppcmds;
- print_section_variable : variable -> std_ppcmds;
- print_syntactic_def : kernel_name -> std_ppcmds;
- print_module : bool -> Names.module_path -> std_ppcmds;
- print_modtype : module_path -> std_ppcmds;
- print_named_decl : Context.Named.Declaration.t -> std_ppcmds;
- print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option;
- print_context : bool -> int option -> Lib.library_segment -> std_ppcmds;
- print_typed_value_in_env : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds;
- print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> unsafe_judgment -> std_ppcmds;
+ print_inductive : MutInd.t -> Universes.univ_name_list option -> Pp.t;
+ print_constant_with_infos : Constant.t -> Universes.univ_name_list option -> Pp.t;
+ print_section_variable : env -> Evd.evar_map -> variable -> Pp.t;
+ print_syntactic_def : env -> KerName.t -> Pp.t;
+ print_module : bool -> ModPath.t -> Pp.t;
+ print_modtype : ModPath.t -> Pp.t;
+ print_named_decl : env -> Evd.evar_map -> Context.Named.Declaration.t -> Pp.t;
+ print_library_entry : env -> Evd.evar_map -> bool -> (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;
}
let gallina_print_module = print_module
@@ -65,28 +71,42 @@ 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 =
- let typ = Global.type_of_global_unsafe ref in
+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 = EConstr.of_constr typ in
let typ =
if reduce then
let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ
- in it_mkProd_or_LetIn ccl ctx
+ 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,_),_) ->
+ let mind = Environ.lookup_mind ind (Global.env ()) in
+ begin match mind.Declarations.mind_universes with
+ | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> None
+ | 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 = Universes.universe_binders_of_global ref in
- let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in
+ let bl = Universes.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 univs
else mt ()
in
- hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_ltype_env env sigma typ ++
- Printer.pr_universe_ctx sigma univs)
+ hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++
+ Printer.pr_universe_ctx sigma ?variance univs)
(********************************)
(** Printing implicit arguments *)
-let pr_impl_name imp = pr_id (name_of_implicit imp)
+let pr_impl_name imp = Id.print (name_of_implicit imp)
let print_impargs_by_name max = function
| [] -> []
@@ -127,12 +147,11 @@ let print_impargs_list prefix l =
let print_renames_list prefix l =
if List.is_empty l then [] else
[add_colon prefix ++ str "Arguments are renamed to " ++
- hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map pr_name 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_unsafe ref in
- let ctx = prod_assum typ in
- let open Context.Rel.Declaration in
+ let typ, _ = Global.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 &&
let _,lastimpl = List.chop nprods impl in
@@ -144,7 +163,7 @@ let print_impargs ref =
let has_impl = not (List.is_empty impl) in
(* Need to reduce since implicits are computed with products flattened *)
pr_infos_list
- ([ print_ref (need_expansion (select_impargs_size 0 impl) ref) ref;
+ ([ print_ref (need_expansion (select_impargs_size 0 impl) ref) ref None;
blankline ] @
(if has_impl then print_impargs_list (mt()) impl
else [str "No implicit arguments"]))
@@ -170,9 +189,8 @@ type opacity =
| TransparentMaybeOpacified of Conv_oracle.level
let opacity env =
- let open Context.Named.Declaration in
function
- | VarRef v when is_local_def (Environ.lookup_named v env) ->
+ | VarRef v when NamedDecl.is_local_def (Environ.lookup_named v env) ->
Some(TransparentMaybeOpacified
(Conv_oracle.get_strategy (Environ.oracle env) (VarKey v)))
| ConstRef cst ->
@@ -202,6 +220,11 @@ let print_opacity ref =
str "transparent (with minimal expansion weight)"]
(*******************)
+
+let print_if_is_coercion ref =
+ if Classops.coercion_exists ref then [pr_global ref ++ str " is a coercion"] else []
+
+(*******************)
(* *)
let print_polymorphism ref =
@@ -224,10 +247,10 @@ let print_type_in_type ref =
let print_primitive_record recflag mipv = function
| Some (Some (_, ps,_)) ->
let eta = match recflag with
- | Decl_kinds.CoFinite | Decl_kinds.Finite -> str" without eta conversion"
- | Decl_kinds.BiFinite -> str " with eta conversion"
+ | CoFinite | Finite -> str" without eta conversion"
+ | BiFinite -> str " with eta conversion"
in
- [pr_id mipv.(0).mind_typename ++ str" has primitive projections" ++ eta ++ str"."]
+ [Id.print mipv.(0).mind_typename ++ str" has primitive projections" ++ eta ++ str"."]
| _ -> []
let print_primitive ref =
@@ -246,7 +269,7 @@ let print_name_infos ref =
if need_expansion (select_impargs_size 0 impls) ref then
(* Need to reduce since implicits are computed with products flattened *)
[str "Expanded type for implicit arguments";
- print_ref true ref; blankline]
+ print_ref true ref None; blankline]
else
[] in
print_polymorphism ref @
@@ -255,11 +278,12 @@ let print_name_infos ref =
type_info_for_implicit @
print_renames_list (mt()) renames @
print_impargs_list (mt()) impls @
- print_argument_scopes (mt()) scopes
+ print_argument_scopes (mt()) scopes @
+ print_if_is_coercion ref
let print_id_args_data test pr id l =
if List.exists test l then
- pr (str "For " ++ pr_id id) l
+ pr (str "For " ++ Id.print id) l
else
[]
@@ -292,16 +316,35 @@ let print_inductive_argument_scopes =
(*********************)
(* "Locate" commands *)
+type 'a locatable_info = {
+ locate : qualid -> 'a option;
+ locate_all : qualid -> 'a list;
+ shortest_qualid : 'a -> qualid;
+ name : 'a -> Pp.t;
+ print : 'a -> Pp.t;
+ about : 'a -> Pp.t;
+}
+
+type locatable = Locatable : 'a locatable_info -> locatable
+
type logical_name =
| Term of global_reference
| Dir of global_dir_reference
- | Syntactic of kernel_name
- | ModuleType of module_path
- | Tactic of Nametab.ltac_constant
+ | Syntactic of KerName.t
+ | ModuleType of ModPath.t
+ | Other : 'a * 'a locatable_info -> logical_name
| Undefined of qualid
+(** Generic table for objects that are accessible through a name. *)
+let locatable_map : locatable String.Map.t ref = ref String.Map.empty
+
+let register_locatable name f =
+ locatable_map := String.Map.add name (Locatable f) !locatable_map
+
+exception ObjFound of logical_name
+
let locate_any_name ref =
- let (loc,qid) = qualid_of_reference ref in
+ let {v=qid} = qualid_of_reference ref in
try Term (Nametab.locate qid)
with Not_found ->
try Syntactic (Nametab.locate_syndef qid)
@@ -309,7 +352,13 @@ let locate_any_name ref =
try Dir (Nametab.locate_dir qid)
with Not_found ->
try ModuleType (Nametab.locate_modtype qid)
- with Not_found -> Undefined qid
+ with Not_found ->
+ let iter _ (Locatable info) = match info.locate qid with
+ | None -> ()
+ | Some ans -> raise (ObjFound (Other (ans, info)))
+ in
+ try String.Map.iter iter !locatable_map; Undefined qid
+ with ObjFound obj -> obj
let pr_located_qualid = function
| Term ref ->
@@ -323,17 +372,16 @@ let pr_located_qualid = function
str "Notation" ++ spc () ++ pr_path (Nametab.path_of_syndef kn)
| Dir dir ->
let s,dir = match dir with
- | DirOpenModule (dir,_) -> "Open Module", dir
- | DirOpenModtype (dir,_) -> "Open Module Type", dir
- | DirOpenSection (dir,_) -> "Open Section", dir
- | DirModule (dir,_) -> "Module", dir
+ | DirOpenModule { obj_dir ; _ } -> "Open Module", obj_dir
+ | DirOpenModtype { obj_dir ; _ } -> "Open Module Type", obj_dir
+ | DirOpenSection { obj_dir ; _ } -> "Open Section", obj_dir
+ | DirModule { obj_dir ; _ } -> "Module", obj_dir
| DirClosedSection dir -> "Closed Section", dir
in
- str s ++ spc () ++ pr_dirpath dir
+ str s ++ spc () ++ DirPath.print dir
| ModuleType mp ->
str "Module Type" ++ spc () ++ pr_path (Nametab.path_of_modtype mp)
- | Tactic kn ->
- str "Ltac" ++ spc () ++ pr_path (Nametab.path_of_tactic kn)
+ | Other (obj, info) -> info.name obj
| Undefined qid ->
pr_qualid qid ++ spc () ++ str "not a defined object."
@@ -371,14 +419,10 @@ let locate_term qid =
in
List.map expand (Nametab.locate_extended_all qid)
-let locate_tactic qid =
- let all = Nametab.locate_extended_all_tactic qid in
- List.map (fun kn -> (Tactic kn, Nametab.shortest_qualid_of_tactic kn)) all
-
let locate_module qid =
let all = Nametab.locate_extended_all_dir qid in
let map dir = match dir with
- | DirModule (_, (mp, _)) -> Some (Dir dir, Nametab.shortest_qualid_of_module mp)
+ | DirModule { obj_mp ; _ } -> Some (Dir dir, Nametab.shortest_qualid_of_module obj_mp)
| DirOpenModule _ -> Some (Dir dir, qid)
| _ -> None
in
@@ -396,18 +440,35 @@ let locate_modtype qid =
in
modtypes @ List.map_filter map all
+let locate_other s qid =
+ let Locatable info = String.Map.find s !locatable_map in
+ let ans = info.locate_all qid in
+ let map obj = (Other (obj, info), info.shortest_qualid obj) in
+ List.map map ans
+
+type locatable_kind =
+| LocTerm
+| LocModule
+| LocOther of string
+| LocAny
+
let print_located_qualid name flags ref =
- let (loc,qid) = qualid_of_reference ref in
- let located = [] in
- let located = if List.mem `LTAC flags then locate_tactic qid @ located else located in
- let located = if List.mem `MODTYPE flags then locate_modtype qid @ located else located in
- let located = if List.mem `MODULE flags then locate_module qid @ located else located in
- let located = if List.mem `TERM flags then locate_term qid @ located else located in
+ let {v=qid} = qualid_of_reference ref in
+ let located = match flags with
+ | LocTerm -> locate_term qid
+ | LocModule -> locate_modtype qid @ locate_module qid
+ | LocOther s -> locate_other s qid
+ | LocAny ->
+ locate_term qid @
+ locate_modtype qid @
+ locate_module qid @
+ String.Map.fold (fun s _ accu -> locate_other s qid @ accu) !locatable_map []
+ in
match located with
| [] ->
let (dir,id) = repr_qualid qid in
if DirPath.is_empty dir then
- str "No " ++ str name ++ str " of basename" ++ spc () ++ pr_id id
+ str "No " ++ str name ++ str " of basename" ++ spc () ++ Id.print id
else
str "No " ++ str name ++ str " of suffix" ++ spc () ++ pr_qualid qid
| l ->
@@ -420,43 +481,43 @@ let print_located_qualid name flags ref =
else mt ()) ++
display_alias o)) l
-let print_located_term ref = print_located_qualid "term" [`TERM] ref
-let print_located_tactic ref = print_located_qualid "tactic" [`LTAC] ref
-let print_located_module ref = print_located_qualid "module" [`MODULE; `MODTYPE] ref
-let print_located_qualid ref = print_located_qualid "object" [`TERM; `LTAC; `MODULE; `MODTYPE] ref
+let print_located_term ref = print_located_qualid "term" LocTerm ref
+let print_located_other s ref = print_located_qualid s (LocOther s) ref
+let print_located_module ref = print_located_qualid "module" LocModule ref
+let print_located_qualid ref = print_located_qualid "object" LocAny ref
(******************************************)
(**** Printing declarations and judgments *)
(**** Gallina layer *****)
let gallina_print_typed_value_in_env env sigma (trm,typ) =
- (pr_lconstr_env env sigma trm ++ fnl () ++
- str " : " ++ pr_ltype_env env sigma typ)
+ (pr_leconstr_env env sigma trm ++ fnl () ++
+ str " : " ++ pr_letype_env env sigma typ)
(* To be improved; the type should be used to provide the types in the
abstractions. This should be done recursively inside pr_lconstr, so that
the pretty-print of a proposition (P:(nat->nat)->Prop)(P [u]u)
synthesizes the type nat of the abstraction on u *)
-let print_named_def name body typ =
- let pbody = pr_lconstr body in
- let ptyp = pr_ltype typ in
- let pbody = if isCast body then surround pbody else pbody in
+let print_named_def env sigma name body typ =
+ let pbody = pr_lconstr_env env sigma body in
+ let ptyp = pr_ltype_env env sigma typ in
+ let pbody = if Constr.isCast body then surround pbody else pbody in
(str "*** [" ++ str name ++ str " " ++
hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++
str ":" ++ brk (1,2) ++ ptyp) ++
str "]")
-let print_named_assum name typ =
- str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]"
+let print_named_assum env sigma name typ =
+ str "*** [" ++ str name ++ str " : " ++ pr_ltype_env env sigma typ ++ str "]"
-let gallina_print_named_decl =
+let gallina_print_named_decl env sigma =
let open Context.Named.Declaration in
function
| LocalAssum (id, typ) ->
- print_named_assum (Id.to_string id) typ
+ print_named_assum env sigma (Id.to_string id) typ
| LocalDef (id, body, typ) ->
- print_named_def (Id.to_string id) body typ
+ print_named_def env sigma (Id.to_string id) body typ
let assumptions_for_print lna =
List.fold_right (fun na env -> add_name na env) lna empty_names_context
@@ -464,22 +525,22 @@ let assumptions_for_print lna =
(*********************)
(* *)
-let gallina_print_inductive sp =
+let gallina_print_inductive sp udecl =
let env = Global.env() in
let mib = Environ.lookup_mind sp env in
let mipv = mib.mind_packets in
- pr_mutual_inductive_body env sp mib ++
+ pr_mutual_inductive_body env sp mib udecl ++
with_line_skip
(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)
-let print_named_decl id =
- gallina_print_named_decl (Global.lookup_named id) ++ fnl ()
+let print_named_decl env sigma id =
+ gallina_print_named_decl env sigma (Global.lookup_named id) ++ fnl ()
-let gallina_print_section_variable id =
- print_named_decl id ++
+let gallina_print_section_variable env sigma id =
+ print_named_decl env sigma id ++
with_line_skip (print_name_infos (VarRef id))
let print_body env evd = function
@@ -489,102 +550,128 @@ let print_body env evd = function
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
+ if Declareops.constant_is_polymorphic cb then
+ let univs = Declareops.constant_polymorphic_context cb in
+ let inst = Univ.AUContext.instance univs in
+ let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in
+ pr_universe_instance sigma univs
else mt()
-let print_constant with_values sep sp =
+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 = Declareops.type_of_constant cb in
- let typ = ungeneralized_type_of_constant_type typ in
- let univs = Univ.instantiate_univ_context
- (Global.universes_of_constant_body cb)
+ 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 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
+ | 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), []
+ | 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)
in
let ctx =
- Evd.evar_universe_context_of_binders
- (Universes.universe_binders_of_global (ConstRef sp))
+ UState.of_binders
+ (Universes.universe_binders_with_opt_names (ConstRef sp) ulist udecl)
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 ++
+ hov 0 (pr_polymorphic (Declareops.constant_is_polymorphic cb) ++
match val_0 with
| None ->
str"*** [ " ++
print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++
str" ]" ++
- Printer.pr_universe_ctx sigma univs
- | _ ->
+ 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 (val_0,typ) else pr_ltype typ)++
- Printer.pr_universe_ctx sigma univs)
+ (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++
+ Printer.pr_constant_universes sigma univs)
-let gallina_print_constant_with_infos sp =
- print_constant true " = " sp ++
+let gallina_print_constant_with_infos sp udecl =
+ print_constant true " = " sp udecl ++
with_line_skip (print_name_infos (ConstRef sp))
-let gallina_print_syntactic_def kn =
+let gallina_print_syntactic_def env kn =
let qid = Nametab.shortest_qualid_of_syndef Id.Set.empty kn
and (vars,a) = Syntax_def.search_syntactic_definition kn in
- let c = Notation_ops.glob_constr_of_notation_constr Loc.ghost a in
+ let c = Notation_ops.glob_constr_of_notation_constr a in
hov 2
(hov 4
(str "Notation " ++ pr_qualid qid ++
- prlist (fun id -> spc () ++ pr_id id) (List.map fst vars) ++
+ prlist (fun id -> spc () ++ Id.print id) (List.map fst vars) ++
spc () ++ str ":=") ++
spc () ++
Constrextern.without_specific_symbols
- [Notation.SynDefRule kn] pr_glob_constr c)
+ [Notation.SynDefRule kn] (pr_glob_constr_env env) c)
-let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) =
+let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) =
let sep = if with_values then " = " else " : "
and tag = object_tag lobj in
match (oname,tag) with
| (_,"VARIABLE") ->
(* Outside sections, VARIABLES still exist but only with universes
constraints *)
- (try Some(print_named_decl (basename sp)) with Not_found -> None)
+ (try Some(print_named_decl env sigma (basename sp)) with Not_found -> None)
| (_,"CONSTANT") ->
- Some (print_constant with_values sep (constant_of_kn kn))
+ Some (print_constant with_values sep (Constant.make1 kn) None)
| (_,"INDUCTIVE") ->
- Some (gallina_print_inductive (mind_of_kn kn))
+ Some (gallina_print_inductive (MutInd.make1 kn) None)
| (_,"MODULE") ->
- let (mp,_,l) = repr_kn kn in
+ let (mp,_,l) = KerName.repr kn in
Some (print_module with_values (MPdot (mp,l)))
| (_,"MODULE TYPE") ->
- let (mp,_,l) = repr_kn 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
(* To deal with forgotten cases... *)
| (_,s) -> None
-let gallina_print_library_entry with_values ent =
- let pr_name (sp,_) = pr_id (basename sp) in
+let gallina_print_library_entry env sigma with_values ent =
+ let pr_name (sp,_) = Id.print (basename sp) in
match ent with
| (oname,Lib.Leaf lobj) ->
- gallina_print_leaf_entry with_values (oname,lobj)
+ gallina_print_leaf_entry env sigma with_values (oname,lobj)
| (oname,Lib.OpenedSection (dir,_)) ->
Some (str " >>>>>>> Section " ++ pr_name oname)
| (oname,Lib.ClosedSection _) ->
Some (str " >>>>>>> Closed Section " ++ pr_name oname)
- | (_,Lib.CompilingLibrary (dir,_)) ->
- Some (str " >>>>>>> Library " ++ pr_dirpath dir)
+ | (_,Lib.CompilingLibrary { obj_dir; _ }) ->
+ Some (str " >>>>>>> Library " ++ DirPath.print obj_dir)
| (oname,Lib.OpenedModule _) ->
Some (str " >>>>>>> Module " ++ pr_name oname)
| (oname,Lib.ClosedModule _) ->
Some (str " >>>>>>> Closed Module " ++ pr_name oname)
- | (_,Lib.FrozenState _) ->
- None
-let gallina_print_context with_values =
+let gallina_print_context env sigma with_values =
let rec prec n = function
| h::rest when Option.is_empty n || Option.get n > 0 ->
- (match gallina_print_library_entry with_values h with
+ (match gallina_print_library_entry env sigma with_values h with
| None -> prec n rest
| Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ())
| _ -> mt ()
@@ -639,49 +726,51 @@ let print_judgment env sigma {uj_val=trm;uj_type=typ} =
let print_safe_judgment env sigma j =
let trm = Safe_typing.j_val j in
let typ = Safe_typing.j_type j in
+ let trm = EConstr.of_constr trm in
+ let typ = EConstr.of_constr typ in
print_typed_value_in_env env sigma (trm, typ)
(*********************)
(* *)
-let print_full_context () = print_context true None (Lib.contents ())
-let print_full_context_typ () = print_context false None (Lib.contents ())
+let print_full_context env sigma = print_context env sigma true None (Lib.contents ())
+let print_full_context_typ env sigma = print_context env sigma false None (Lib.contents ())
-let print_full_pure_context () =
+let print_full_pure_context env sigma =
let rec prec = function
| ((_,kn),Lib.Leaf lobj)::rest ->
let pp = match object_tag lobj with
| "CONSTANT" ->
let con = Global.constant_of_delta_kn kn in
let cb = Global.lookup_constant con in
- let typ = ungeneralized_type_of_constant_type cb.const_type in
+ let typ = cb.const_type in
hov 0 (
match cb.const_body with
| Undef _ ->
str "Parameter " ++
- print_basename con ++ str " : " ++ cut () ++ pr_ltype typ
+ print_basename con ++ str " : " ++ cut () ++ pr_ltype_env env sigma typ
| OpaqueDef lc ->
str "Theorem " ++ print_basename con ++ cut () ++
- str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++
- str "Proof " ++ pr_lconstr (Opaqueproof.force_proof (Global.opaque_tables ()) lc)
+ str " : " ++ pr_ltype_env env sigma typ ++ str "." ++ fnl () ++
+ str "Proof " ++ pr_lconstr_env env sigma (Opaqueproof.force_proof (Global.opaque_tables ()) lc)
| Def c ->
str "Definition " ++ print_basename con ++ cut () ++
- str " : " ++ pr_ltype typ ++ cut () ++ str " := " ++
- pr_lconstr (Mod_subst.force_constr c))
+ str " : " ++ pr_ltype_env env sigma typ ++ cut () ++ str " := " ++
+ pr_lconstr_env env sigma (Mod_subst.force_constr c))
++ str "." ++ fnl () ++ fnl ()
| "INDUCTIVE" ->
let mind = Global.mind_of_delta_kn kn in
let mib = Global.lookup_mind mind in
- pr_mutual_inductive_body (Global.env()) mind mib ++
+ pr_mutual_inductive_body (Global.env()) mind mib None ++
str "." ++ fnl () ++ fnl ()
| "MODULE" ->
(* TODO: make it reparsable *)
- let (mp,_,l) = repr_kn 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) = repr_kn kn in
+ let (mp,_,l) = KerName.repr kn in
print_modtype (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl ()
| _ -> mt () in
prec rest ++ pp
@@ -696,16 +785,16 @@ let print_full_pure_context () =
(* This is designed to print the contents of an opened section *)
let read_sec_context r =
- let loc,qid = qualid_of_reference r in
+ let qid = qualid_of_reference r in
let dir =
- try Nametab.locate_section qid
+ try Nametab.locate_section qid.v
with Not_found ->
- user_err_loc (loc,"read_sec_context", str "Unknown section.") in
+ user_err ?loc:qid.loc ~hdr:"read_sec_context" (str "Unknown section.") in
let rec get_cxt in_cxt = function
- | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest ->
- if DirPath.equal dir dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest
+ | (_,Lib.OpenedSection ({obj_dir;_},_) as hd)::rest ->
+ if DirPath.equal dir obj_dir then (hd::in_cxt) else get_cxt (hd::in_cxt) rest
| (_,Lib.ClosedSection _)::rest ->
- error "Cannot print the contents of a closed section."
+ user_err Pp.(str "Cannot print the contents of a closed section.")
(* LEM: Actually, we could if we wanted to. *)
| [] -> []
| hd::rest -> get_cxt (hd::in_cxt) rest
@@ -713,90 +802,106 @@ let read_sec_context r =
let cxt = Lib.contents () in
List.rev (get_cxt [] cxt)
-let print_sec_context sec =
- print_context true None (read_sec_context sec)
-
-let print_sec_context_typ sec =
- print_context false None (read_sec_context sec)
-
-let print_any_name = function
- | Term (ConstRef sp) -> print_constant_with_infos sp
- | Term (IndRef (sp,_)) -> print_inductive sp
- | Term (ConstructRef ((sp,_),_)) -> print_inductive sp
- | Term (VarRef sp) -> print_section_variable sp
- | Syntactic kn -> print_syntactic_def kn
- | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp
+let print_sec_context env sigma sec =
+ print_context env sigma true None (read_sec_context sec)
+
+let print_sec_context_typ env sigma sec =
+ print_context env sigma false None (read_sec_context sec)
+
+let maybe_error_reject_univ_decl na udecl =
+ match na, udecl with
+ | _, None | Term (ConstRef _ | IndRef _ | ConstructRef _), Some _ -> ()
+ | (Term (VarRef _) | Syntactic _ | Dir _ | ModuleType _ | Other _ | Undefined _), Some udecl ->
+ (* TODO Print na somehow *)
+ user_err ~hdr:"reject_univ_decl" (str "This object does not support universe names.")
+
+let print_any_name env sigma na udecl =
+ maybe_error_reject_univ_decl na udecl;
+ match na with
+ | Term (ConstRef sp) -> print_constant_with_infos sp udecl
+ | Term (IndRef (sp,_)) -> print_inductive sp udecl
+ | Term (ConstructRef ((sp,_),_)) -> print_inductive sp udecl
+ | Term (VarRef sp) -> print_section_variable env sigma sp
+ | Syntactic kn -> print_syntactic_def env kn
+ | Dir (DirModule { obj_dir; obj_mp; _ } ) -> print_module (printable_body obj_dir) obj_mp
| Dir _ -> mt ()
| ModuleType mp -> print_modtype mp
- | Tactic kn -> mt () (** TODO *)
+ | Other (obj, info) -> info.print obj
| Undefined qid ->
try (* Var locale de but, pas var de section... donc pas d'implicits *)
let dir,str = repr_qualid qid in
if not (DirPath.is_empty dir) then raise Not_found;
- let open Context.Named.Declaration in
- str |> Global.lookup_named |> set_id str |> print_named_decl
- with Not_found ->
- errorlabstrm
- "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.")
+ str |> Global.lookup_named |> print_named_decl env sigma
-let print_name = function
- | ByNotation (loc,ntn,sc) ->
- print_any_name
- (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true)
+ with Not_found ->
+ user_err
+ ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.")
+
+let print_name env sigma na udecl =
+ match na with
+ | {loc; v=ByNotation (ntn,sc)} ->
+ print_any_name env sigma
+ (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true)
ntn sc))
- | AN ref ->
- print_any_name (locate_any_name ref)
+ udecl
+ | {loc; v=AN ref} ->
+ print_any_name env sigma (locate_any_name ref) udecl
-let print_opaque_name qid =
- let env = Global.env () in
+let print_opaque_name env sigma qid =
match Nametab.global qid with
| ConstRef cst ->
let cb = Global.lookup_constant cst in
if Declareops.constant_has_body cb then
- print_constant_with_infos cst
+ print_constant_with_infos cst None
else
- error "Not a defined constant."
+ user_err Pp.(str "Not a defined constant.")
| IndRef (sp,_) ->
- print_inductive sp
+ print_inductive sp None
| ConstructRef cstr as gr ->
- let ty = Universes.unsafe_type_of_global gr in
+ 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 = EConstr.of_constr ty in
+ let open EConstr in
print_typed_value (mkConstruct cstr, ty)
| VarRef id ->
- let open Context.Named.Declaration in
- lookup_named id env |> set_id id |> print_named_decl
+ env |> lookup_named id |> print_named_decl env sigma
-let print_about_any loc k =
+let print_about_any ?loc env sigma k udecl =
+ maybe_error_reject_univ_decl k udecl;
match k with
| Term ref ->
let rb = Reductionops.ReductionBehaviour.print ref in
- Dumpglob.add_glob loc ref;
+ Dumpglob.add_glob ?loc ref;
pr_infos_list
- (print_ref false ref :: blankline ::
+ (print_ref false ref udecl :: blankline ::
print_name_infos ref @
(if Pp.ismt rb then [] else [rb]) @
print_opacity ref @
[hov 0 (str "Expands to: " ++ pr_located_qualid k)])
| Syntactic kn ->
let () = match Syntax_def.search_syntactic_definition kn with
- | [],Notation_term.NRef ref -> Dumpglob.add_glob loc ref
+ | [],Notation_term.NRef ref -> Dumpglob.add_glob ?loc ref
| _ -> () in
v 0 (
- print_syntactic_def kn ++ fnl () ++
+ print_syntactic_def env kn ++ fnl () ++
hov 0 (str "Expands to: " ++ pr_located_qualid k))
- | Dir _ | ModuleType _ | Tactic _ | Undefined _ ->
+ | Dir _ | ModuleType _ | Undefined _ ->
hov 0 (pr_located_qualid k)
+ | Other (obj, info) -> hov 0 (info.about obj)
-let print_about = function
- | ByNotation (loc,ntn,sc) ->
- print_about_any loc
- (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true)
- ntn sc))
- | AN ref ->
- print_about_any (loc_of_reference ref) (locate_any_name ref)
+let print_about env sigma na udecl =
+ match na with
+ | {loc;v=ByNotation (ntn,sc)} ->
+ print_about_any ?loc env sigma
+ (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true)
+ ntn sc)) udecl
+ | {loc;v=AN ref} ->
+ print_about_any ?loc env sigma (locate_any_name ref) udecl
(* for debug *)
-let inspect depth =
- print_context false (Some depth) (Lib.contents ())
+let inspect env sigma depth =
+ print_context env sigma false (Some depth) (Lib.contents ())
(*************************************************************************)
@@ -804,54 +909,54 @@ let inspect depth =
open Classops
-let print_coercion_value v = pr_lconstr (get_coercion_value v)
+let print_coercion_value env sigma v = pr_lconstr_env env sigma (get_coercion_value v)
let print_class i =
let cl,_ = class_info_from_index i in
pr_class cl
-let print_path ((i,j),p) =
+let print_path env sigma ((i,j),p) =
hov 2 (
- str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++
+ str"[" ++ hov 0 (prlist_with_sep pr_semicolon (print_coercion_value env sigma) p) ++
str"] : ") ++
print_class i ++ str" >-> " ++ print_class j
let _ = Classops.install_path_printer print_path
-let print_graph () =
- prlist_with_sep fnl print_path (inheritance_graph())
+let print_graph env sigma =
+ prlist_with_sep fnl (print_path env sigma) (inheritance_graph())
let print_classes () =
pr_sequence pr_class (classes())
-let print_coercions () =
- pr_sequence print_coercion_value (coercions())
+let print_coercions env sigma =
+ pr_sequence (print_coercion_value env sigma) (coercions())
let index_of_class cl =
try
fst (class_info cl)
with Not_found ->
- errorlabstrm "index_of_class"
+ user_err ~hdr:"index_of_class"
(pr_class cl ++ spc() ++ str "not a defined class.")
-let print_path_between cls clt =
+let print_path_between env sigma cls clt =
let i = index_of_class cls in
let j = index_of_class clt in
let p =
try
lookup_path_between_class (i,j)
with Not_found ->
- errorlabstrm "index_cl_of_id"
+ user_err ~hdr:"index_cl_of_id"
(str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt
++ str ".")
in
- print_path ((i,j),p)
+ print_path env sigma ((i,j),p)
-let print_canonical_projections () =
+let print_canonical_projections env sigma =
prlist_with_sep fnl
(fun ((r1,r2),o) -> pr_cs_pattern r2 ++
str " <- " ++
- pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )")
+ pr_global r1 ++ str " ( " ++ pr_lconstr_env env sigma o.o_DEF ++ str " )")
(canonical_projections ())
(*************************************************************************)
@@ -862,7 +967,7 @@ let print_canonical_projections () =
open Typeclasses
let pr_typeclass env t =
- print_ref false t.cl_impl
+ print_ref false t.cl_impl None
let print_typeclasses () =
let env = Global.env () in
@@ -871,7 +976,7 @@ let print_typeclasses () =
let pr_instance env i =
(* gallina_print_constant_with_infos i.is_impl *)
(* lighter *)
- print_ref false (instance_impl i) ++
+ print_ref false (instance_impl i) None ++
begin match hint_priority i with
| None -> mt ()
| Some i -> spc () ++ str "|" ++ spc () ++ int i
diff --git a/printing/prettyp.mli b/printing/prettyp.mli
index 0eab1557..213f0aee 100644
--- a/printing/prettyp.mli
+++ b/printing/prettyp.mli
@@ -1,76 +1,101 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
-open Pp
open Names
-open Term
open Environ
open Reductionops
open Libnames
open Globnames
open Misctypes
+open Evd
(** A Pretty-Printer for the Calculus of Inductive Constructions. *)
val assumptions_for_print : Name.t list -> Termops.names_context
val print_closed_sections : bool ref
-val print_context : bool -> int option -> Lib.library_segment -> std_ppcmds
-val print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option
-val print_full_context : unit -> std_ppcmds
-val print_full_context_typ : unit -> std_ppcmds
-val print_full_pure_context : unit -> std_ppcmds
-val print_sec_context : reference -> std_ppcmds
-val print_sec_context_typ : reference -> std_ppcmds
-val print_judgment : env -> Evd.evar_map -> unsafe_judgment -> std_ppcmds
-val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> std_ppcmds
+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_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
+val print_sec_context : env -> Evd.evar_map -> reference -> Pp.t
+val print_sec_context_typ : env -> Evd.evar_map -> reference -> Pp.t
+val print_judgment : env -> Evd.evar_map -> EConstr.unsafe_judgment -> Pp.t
+val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> Pp.t
val print_eval :
reduction_function -> env -> Evd.evar_map ->
- Constrexpr.constr_expr -> unsafe_judgment -> std_ppcmds
+ Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t
-val print_name : reference or_by_notation -> std_ppcmds
-val print_opaque_name : reference -> std_ppcmds
-val print_about : reference or_by_notation -> std_ppcmds
-val print_impargs : reference or_by_notation -> std_ppcmds
+val print_name : env -> Evd.evar_map -> reference or_by_notation ->
+ Universes.univ_name_list option -> Pp.t
+val print_opaque_name : env -> Evd.evar_map -> reference -> Pp.t
+val print_about : env -> Evd.evar_map -> reference or_by_notation ->
+ Universes.univ_name_list option -> Pp.t
+val print_impargs : reference or_by_notation -> Pp.t
(** Pretty-printing functions for classes and coercions *)
-val print_graph : unit -> std_ppcmds
-val print_classes : unit -> std_ppcmds
-val print_coercions : unit -> std_ppcmds
-val print_path_between : Classops.cl_typ -> Classops.cl_typ -> std_ppcmds
-val print_canonical_projections : unit -> std_ppcmds
+val print_graph : env -> evar_map -> Pp.t
+val print_classes : unit -> Pp.t
+val print_coercions : env -> Evd.evar_map -> Pp.t
+val print_path_between : env -> evar_map -> Classops.cl_typ -> Classops.cl_typ -> Pp.t
+val print_canonical_projections : env -> Evd.evar_map -> Pp.t
(** Pretty-printing functions for type classes and instances *)
-val print_typeclasses : unit -> std_ppcmds
-val print_instances : global_reference -> std_ppcmds
-val print_all_instances : unit -> std_ppcmds
+val print_typeclasses : unit -> Pp.t
+val print_instances : global_reference -> Pp.t
+val print_all_instances : unit -> Pp.t
-val inspect : int -> std_ppcmds
+val inspect : env -> Evd.evar_map -> int -> Pp.t
-(** Locate *)
+(** {5 Locate} *)
-val print_located_qualid : reference -> std_ppcmds
-val print_located_term : reference -> std_ppcmds
-val print_located_tactic : reference -> std_ppcmds
-val print_located_module : reference -> std_ppcmds
+type 'a locatable_info = {
+ locate : qualid -> 'a option;
+ (** Locate the most precise object with the provided name if any. *)
+ locate_all : qualid -> 'a list;
+ (** Locate all objects whose name is a suffix of the provided name *)
+ shortest_qualid : 'a -> qualid;
+ (** Return the shortest name in the current context *)
+ name : 'a -> Pp.t;
+ (** Data as printed by the Locate command *)
+ print : 'a -> Pp.t;
+ (** Data as printed by the Print command *)
+ about : 'a -> Pp.t;
+ (** Data as printed by the About command *)
+}
+(** Generic data structure representing locatable objects. *)
+
+val register_locatable : string -> 'a locatable_info -> unit
+(** Define a new type of locatable objects that can be reached via the
+ corresponding generic vernacular commands. The string should be a unique
+ name describing the kind of objects considered and that is added as a
+ grammar command prefix for vernacular commands Locate. *)
+
+val print_located_qualid : reference -> Pp.t
+val print_located_term : reference -> Pp.t
+val print_located_module : reference -> Pp.t
+val print_located_other : string -> reference -> Pp.t
type object_pr = {
- print_inductive : mutual_inductive -> std_ppcmds;
- print_constant_with_infos : constant -> std_ppcmds;
- print_section_variable : variable -> std_ppcmds;
- print_syntactic_def : kernel_name -> std_ppcmds;
- print_module : bool -> Names.module_path -> std_ppcmds;
- print_modtype : module_path -> std_ppcmds;
- print_named_decl : Context.Named.Declaration.t -> std_ppcmds;
- print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option;
- print_context : bool -> int option -> Lib.library_segment -> std_ppcmds;
- print_typed_value_in_env : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds;
- print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> unsafe_judgment -> std_ppcmds
+ print_inductive : MutInd.t -> Universes.univ_name_list option -> Pp.t;
+ print_constant_with_infos : Constant.t -> Universes.univ_name_list option -> Pp.t;
+ print_section_variable : env -> Evd.evar_map -> variable -> Pp.t;
+ print_syntactic_def : env -> KerName.t -> Pp.t;
+ print_module : bool -> ModPath.t -> Pp.t;
+ print_modtype : ModPath.t -> Pp.t;
+ print_named_decl : env -> Evd.evar_map -> Context.Named.Declaration.t -> Pp.t;
+ print_library_entry : env -> Evd.evar_map -> bool -> (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;
}
val set_object_pr : object_pr -> unit
diff --git a/printing/printer.ml b/printing/printer.ml
index 04337f6b..199aa79c 100644
--- a/printing/printer.ml
+++ b/printing/printer.ml
@@ -1,34 +1,71 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
open Pp
open CErrors
open Util
open Names
-open Term
+open Constr
open Environ
open Globnames
open Nametab
open Evd
open Proof_type
open Refiner
-open Pfedit
open Constrextern
open Ppconstr
open Declarations
-let emacs_str s =
- if !Flags.print_emacs then s else ""
-let delayed_emacs_cmd s =
- if !Flags.print_emacs then s () else str ""
+module RelDecl = Context.Rel.Declaration
+module NamedDecl = Context.Named.Declaration
+module CompactedDecl = Context.Compacted.Declaration
+
+let enable_unfocused_goal_printing = ref false
+let enable_goal_tags_printing = ref false
+let enable_goal_names_printing = ref false
+
+let should_tag() = !enable_goal_tags_printing
+let should_unfoc() = !enable_unfocused_goal_printing
+let should_gname() = !enable_goal_names_printing
+
+
+let _ =
+ let open Goptions in
+ declare_bool_option
+ { optdepr = false;
+ optname = "printing of unfocused goal";
+ optkey = ["Printing";"Unfocused"];
+ optread = (fun () -> !enable_unfocused_goal_printing);
+ optwrite = (fun b -> enable_unfocused_goal_printing:=b) }
+
+(* This is set on by proofgeneral proof-tree mode. But may be used for
+ other purposes *)
+let _ =
+ let open Goptions in
+ declare_bool_option
+ { optdepr = false;
+ optname = "printing of goal tags";
+ optkey = ["Printing";"Goal";"Tags"];
+ optread = (fun () -> !enable_goal_tags_printing);
+ optwrite = (fun b -> enable_goal_tags_printing:=b) }
+
+
+let _ =
+ let open Goptions in
+ declare_bool_option
+ { optdepr = false;
+ optname = "printing of goal names";
+ optkey = ["Printing";"Goal";"Names"];
+ optread = (fun () -> !enable_goal_names_printing);
+ optwrite = (fun b -> enable_goal_names_printing:=b) }
-let get_current_context () =
- Pfedit.get_current_context ()
(**********************************************************************)
(** Terms *)
@@ -41,32 +78,42 @@ let get_current_context () =
and only names of goal/section variables and rel names that do
_not_ occur in the scope of the binder to be printed are avoided. *)
-let pr_constr_core goal_concl_style env sigma t =
+let pr_econstr_n_core goal_concl_style env sigma n t =
+ pr_constr_expr_n n (extern_constr goal_concl_style env sigma t)
+let pr_econstr_core goal_concl_style env sigma t =
pr_constr_expr (extern_constr goal_concl_style env sigma t)
-let pr_lconstr_core goal_concl_style env sigma t =
+let pr_leconstr_core goal_concl_style env sigma t =
pr_lconstr_expr (extern_constr goal_concl_style env sigma t)
-let pr_lconstr_env env = pr_lconstr_core false env
-let pr_constr_env env = pr_constr_core false env
+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 env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c)
+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 = pr_lconstr_core true env
-let pr_constr_goal_style_env env = pr_constr_core true 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)
let pr_open_lconstr_env env sigma (_,c) = pr_lconstr_env env sigma c
let pr_open_constr_env env sigma (_,c) = pr_constr_env env sigma c
- (* NB do not remove the eta-redexes! Global.env() has side-effects... *)
+let pr_econstr_n_env env sigma c = pr_econstr_n_core false env sigma c
+let pr_leconstr_env env sigma c = pr_leconstr_core false env sigma c
+let pr_econstr_env env sigma c = pr_econstr_core false env sigma c
+
+(* NB do not remove the eta-redexes! Global.env() has side-effects... *)
let pr_lconstr t =
- let (sigma, env) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
pr_lconstr_env env sigma t
let pr_constr t =
- let (sigma, env) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
pr_constr_env env sigma t
let pr_open_lconstr (_,c) = pr_lconstr c
let pr_open_constr (_,c) = pr_constr c
+let pr_leconstr c = pr_lconstr (EConstr.Unsafe.to_constr c)
+let pr_econstr c = pr_constr (EConstr.Unsafe.to_constr 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 *)
@@ -74,37 +121,40 @@ let pr_constr_under_binders_env_gen pr env sigma (ids,c) =
let assums = List.map (fun id -> (Name id,(* dummy *) mkProp)) ids in
pr (Termops.push_rels_assum assums env) sigma c
-let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_constr_env
-let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_lconstr_env
+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) = get_current_context () in
+ 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) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
pr_lconstr_under_binders_env env sigma c
-let pr_type_core goal_concl_style env sigma t =
+let pr_etype_core goal_concl_style env sigma t =
pr_constr_expr (extern_type goal_concl_style env sigma t)
-let pr_ltype_core goal_concl_style env sigma t =
+let pr_letype_core goal_concl_style env sigma t =
pr_lconstr_expr (extern_type goal_concl_style env sigma t)
-let pr_goal_concl_style_env env = pr_ltype_core true env
-let pr_ltype_env env = pr_ltype_core false env
-let pr_type_env env = pr_type_core false env
+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) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
pr_ltype_env env sigma t
let pr_type t =
- let (sigma, env) = get_current_context () in
+ 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
+
let pr_ljudge_env env sigma j =
- (pr_lconstr_env env sigma j.uj_val, pr_lconstr_env env sigma j.uj_type)
+ (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type)
let pr_ljudge j =
- let (sigma, env) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
pr_ljudge_env env sigma j
let pr_lglob_constr_env env c =
@@ -113,16 +163,18 @@ 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) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
pr_lglob_constr_env env c
let pr_glob_constr c =
- let (sigma, env) = get_current_context () in
+ 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) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
pr_closed_glob_env env sigma c
let pr_lconstr_pattern_env env sigma c =
@@ -134,16 +186,16 @@ 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) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
pr_lconstr_pattern_env env sigma t
let pr_constr_pattern t =
- let (sigma, env) = get_current_context () in
+ 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
- (fun env t -> pr_lconstr_expr (extern_constr ~lax:true false env Evd.empty t))
+ (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 " *)"
@@ -182,10 +234,10 @@ let qualid_of_global env r =
let safe_gen f env sigma c =
let orig_extern_ref = Constrextern.get_extern_reference () in
- let extern_ref loc vars r =
- try orig_extern_ref loc vars r
+ let extern_ref ?loc vars r =
+ try orig_extern_ref vars r
with e when CErrors.noncritical e ->
- Libnames.Qualid (loc, qualid_of_global env r)
+ CAst.make ?loc @@ Libnames.Qualid (qualid_of_global env r)
in
Constrextern.set_extern_reference extern_ref;
try
@@ -199,17 +251,36 @@ 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) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
safe_pr_lconstr_env env sigma t
let safe_pr_constr t =
- let (sigma, env) = get_current_context () in
+ let (sigma, env) = Pfedit.get_current_context () in
safe_pr_constr_env env sigma t
-let pr_universe_ctx sigma c =
+let pr_universe_ctx_set sigma c =
+ if !Detyping.print_universes && not (Univ.ContextSet.is_empty c) then
+ fnl()++pr_in_comment (fun c -> v 0
+ (Univ.pr_universe_context_set (Termops.pr_evd_level sigma) c)) c
+ else
+ mt()
+
+let pr_universe_ctx sigma ?variance c =
if !Detyping.print_universes && not (Univ.UContext.is_empty c) then
fnl()++pr_in_comment (fun c -> v 0
- (Univ.pr_universe_context (Evd.pr_evd_level sigma) c)) c
+ (Univ.pr_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
+
+let pr_cumulativity_info sigma cumi =
+ if !Detyping.print_universes
+ && not (Univ.UContext.is_empty (Univ.CumulativityInfo.univ_context cumi)) then
+ fnl()++pr_in_comment (fun uii -> v 0
+ (Univ.pr_cumulativity_info (Termops.pr_evd_level sigma) uii)) cumi
else
mt()
@@ -226,7 +297,7 @@ let pr_puniverses f env (c,u) =
else mt ())
let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst)
-let pr_existential_key = Evd.pr_existential_key
+let pr_existential_key = Termops.pr_existential_key
let pr_existential env sigma ev = pr_lconstr_env env sigma (mkEvar ev)
let pr_inductive env ind = pr_lconstr_env env Evd.empty (mkInd ind)
let pr_constructor env cstr = pr_lconstr_env env Evd.empty (mkConstruct cstr)
@@ -248,31 +319,37 @@ let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t*)
(**********************************************************************)
(* Contexts and declarations *)
-let pr_var_decl_skel pr_id env sigma (id,c,typ) =
- let pbody = match c with
- | None -> (mt ())
- | Some c ->
- (* Force evaluation *)
- let pb = pr_lconstr_env env sigma c in
- let pb = if isCast c then surround pb else pb in
- (str" := " ++ pb ++ cut () ) in
+
+(* Flag for compact display of goals *)
+
+let get_compact_context,set_compact_context =
+ let compact_context = ref false in
+ (fun () -> !compact_context),(fun b -> compact_context := b)
+
+let pr_compacted_decl env sigma decl =
+ let ids, pbody, typ = match decl with
+ | CompactedDecl.LocalAssum (ids, typ) ->
+ ids, mt (), typ
+ | CompactedDecl.LocalDef (ids,c,typ) ->
+ (* Force evaluation *)
+ let pb = pr_lconstr_env env sigma c in
+ let pb = if isCast c then surround pb else pb in
+ ids, (str" := " ++ pb ++ cut ()), typ
+ in
+ let pids = prlist_with_sep pr_comma pr_id ids in
let pt = pr_ltype_env env sigma typ in
let ptyp = (str" : " ++ pt) in
- (pr_id id ++ hov 0 (pbody ++ ptyp))
+ hov 0 (pids ++ pbody ++ ptyp)
-let pr_var_decl env sigma d =
- pr_var_decl_skel pr_id env sigma (Context.Named.Declaration.to_tuple d)
-
-let pr_var_list_decl env sigma (l,c,typ) =
- hov 0 (pr_var_decl_skel (fun ids -> prlist_with_sep pr_comma pr_id ids) env sigma (l,c,typ))
+let pr_named_decl env sigma decl =
+ decl |> CompactedDecl.of_named_decl |> pr_compacted_decl env sigma
let pr_rel_decl env sigma decl =
- let open Context.Rel.Declaration in
- let na = get_name decl in
- let typ = get_type decl in
+ let na = RelDecl.get_name decl in
+ let typ = RelDecl.get_type decl in
let pbody = match decl with
- | LocalAssum _ -> mt ()
- | LocalDef (_,c,_) ->
+ | RelDecl.LocalAssum _ -> mt ()
+ | RelDecl.LocalDef (_,c,_) ->
(* Force evaluation *)
let pb = pr_lconstr_env env sigma c in
let pb = if isCast c then surround pb else pb in
@@ -289,16 +366,20 @@ let pr_rel_decl env sigma decl =
(* Prints a signature, all declarations on the same line if possible *)
let pr_named_context_of env sigma =
- let make_decl_list env d pps = pr_var_decl env sigma d :: pps in
+ let make_decl_list env d pps = pr_named_decl env sigma d :: pps in
let psl = List.rev (fold_named_context make_decl_list env ~init:[]) in
hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl)
+let pr_var_list_decl env sigma decl =
+ hov 0 (pr_compacted_decl env sigma decl)
+
let pr_named_context env sigma ne_context =
hv 0 (Context.Named.fold_outside
- (fun d pps -> pps ++ ws 2 ++ pr_var_decl env sigma d)
+ (fun d pps -> pps ++ ws 2 ++ pr_named_decl env sigma d)
ne_context ~init:(mt ()))
let pr_rel_context env sigma rel_context =
+ let rel_context = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) rel_context in
pr_binders (extern_rel_context None env sigma rel_context)
let pr_rel_context_of env sigma =
@@ -307,9 +388,9 @@ let pr_rel_context_of env sigma =
(* Prints an env (variables and de Bruijn). Separator: newline *)
let pr_context_unlimited env sigma =
let sign_env =
- Context.NamedList.fold
+ Context.Compacted.fold
(fun d pps ->
- let pidt = pr_var_list_decl env sigma d in
+ let pidt = pr_compacted_decl env sigma d in
(pps ++ fnl () ++ pidt))
(Termops.compact_named_context (named_context env)) ~init:(mt ())
in
@@ -326,39 +407,74 @@ let pr_ne_context_of header env sigma =
List.is_empty (Environ.named_context env) then (mt ())
else let penv = pr_context_unlimited env sigma in (header ++ penv ++ fnl ())
-let pr_context_limit n env sigma =
- let named_context = Environ.named_context env in
- let lgsign = List.length named_context in
- if n >= lgsign then
- pr_context_unlimited env sigma
- else
- let k = lgsign-n in
- let _,sign_env =
- Context.NamedList.fold
- (fun d (i,pps) ->
- if i < k then
- (i+1, (pps ++str "."))
- else
- let pidt = pr_var_list_decl env sigma d in
- (i+1, (pps ++ fnl () ++
- str (emacs_str "") ++
- pidt)))
- (Termops.compact_named_context (Environ.named_context env)) ~init:(0,(mt ()))
- in
- let db_env =
- fold_rel_context
- (fun env d pps ->
- let pnat = pr_rel_decl env sigma d in
- (pps ++ fnl () ++
- str (emacs_str "") ++
- pnat))
- env ~init:(mt ())
- in
- (sign_env ++ db_env)
+(* Heuristic for horizontalizing hypothesis that the user probably
+ considers as "variables": An hypothesis H:T where T:S and S<>Prop. *)
+let should_compact env sigma typ =
+ get_compact_context() &&
+ let type_of_typ = Retyping.get_type_of env sigma (EConstr.of_constr typ) in
+ not (is_Prop (EConstr.to_constr sigma type_of_typ))
+
+
+(* If option Compact Contexts is set, we pack "simple" hypothesis in a
+ hov box (with three sapaces as a separator), the global box being a
+ v box *)
+let rec bld_sign_env env sigma ctxt pps =
+ match ctxt with
+ | [] -> pps
+ | CompactedDecl.LocalAssum (ids,typ)::ctxt' when should_compact env sigma typ ->
+ let pps',ctxt' = bld_sign_env_id env sigma ctxt (mt ()) true in
+ (* putting simple hyps in a more horizontal flavor *)
+ bld_sign_env env sigma ctxt' (pps ++ brk (0,0) ++ hov 0 pps')
+ | d:: ctxt' ->
+ let pidt = pr_var_list_decl env sigma d in
+ let pps' = pps ++ brk (0,0) ++ pidt in
+ bld_sign_env env sigma ctxt' pps'
+and bld_sign_env_id env sigma ctxt pps is_start =
+ match ctxt with
+ | [] -> pps,ctxt
+ | CompactedDecl.LocalAssum(ids,typ) as d :: ctxt' when should_compact env sigma typ ->
+ let pidt = pr_var_list_decl env sigma d in
+ let pps' = pps ++ (if not is_start then brk (3,0) else (mt ())) ++ pidt in
+ bld_sign_env_id env sigma ctxt' pps' false
+ | _ -> pps,ctxt
+
+
+(* compact printing an env (variables and de Bruijn). Separator: three
+ spaces between simple hyps, and newline otherwise *)
+let pr_context_limit_compact ?n env sigma =
+ let ctxt = Termops.compact_named_context (named_context env) in
+ let lgth = List.length ctxt in
+ let n_capped =
+ match n with
+ | None -> lgth
+ | Some n when n > lgth -> lgth
+ | Some n -> n in
+ let ctxt_chopped,ctxt_hidden = Util.List.chop n_capped ctxt in
+ (* a dot line hinting the number of hidden hyps. *)
+ let hidden_dots = String.make (List.length ctxt_hidden) '.' in
+ let sign_env = v 0 (str hidden_dots ++ (mt ())
+ ++ bld_sign_env env sigma (List.rev ctxt_chopped) (mt ())) in
+ let db_env =
+ fold_rel_context (fun env d pps -> pps ++ fnl () ++ pr_rel_decl env sigma d)
+ env ~init:(mt ()) in
+ sign_env ++ db_env
+
+(* The number of printed hypothesis in a goal *)
+(* If [None], no limit *)
+let print_hyps_limit = ref (None : int option)
+
+let _ =
+ let open Goptions in
+ declare_int_option
+ { optdepr = false;
+ optname = "the hypotheses limit";
+ optkey = ["Hyps";"Limit"];
+ optread = (fun () -> !print_hyps_limit);
+ optwrite = (fun x -> print_hyps_limit := x) }
-let pr_context_of env sigma = match Flags.print_hyps_limit () with
- | None -> hv 0 (pr_context_unlimited env sigma)
- | Some n -> hv 0 (pr_context_limit n env sigma)
+let pr_context_of env sigma = match !print_hyps_limit with
+ | None -> hv 0 (pr_context_limit_compact env sigma)
+ | Some n -> hv 0 (pr_context_limit_compact ~n env sigma)
(* display goal parts (Proof mode) *)
@@ -371,7 +487,7 @@ let pr_predicate pr_elt (b, elts) =
if List.is_empty elts then str"none" else pr_elts
let pr_cpred p = pr_predicate (pr_constant (Global.env())) (Cpred.elements p)
-let pr_idpred p = pr_predicate Nameops.pr_id (Id.Pred.elements p)
+let pr_idpred p = pr_predicate Id.print (Id.Pred.elements p)
let pr_transparent_state (ids, csts) =
hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++
@@ -379,7 +495,8 @@ let pr_transparent_state (ids, csts) =
(* display complete goal *)
let default_pr_goal gs =
- let (g,sigma) = Goal.V82.nf_evar (project gs) (sig_it gs) in
+ let g = sig_it gs in
+ let sigma = project gs in
let env = Goal.V82.env sigma g in
let concl = Goal.V82.concl sigma g in
let goal =
@@ -391,23 +508,25 @@ let default_pr_goal gs =
(* display a goal tag *)
let pr_goal_tag g =
let s = " (ID " ^ Goal.uid g ^ ")" in
- str (emacs_str s)
-
-let display_name = false
+ str s
(* display a goal name *)
let pr_goal_name sigma g =
- if display_name then str " " ++ Pp.surround (pr_existential_key sigma g)
+ if should_gname() then str " " ++ Pp.surround (pr_existential_key sigma g)
else mt ()
+let pr_goal_header nme sigma g =
+ let (g,sigma) = Goal.V82.nf_evar sigma g in
+ str "subgoal " ++ nme ++ (if should_tag() then pr_goal_tag g else str"")
+ ++ (if should_gname() then str " " ++ Pp.surround (pr_existential_key sigma g) else mt ())
+
(* display the conclusion of a goal *)
let pr_concl n sigma g =
let (g,sigma) = Goal.V82.nf_evar sigma g in
let env = Goal.V82.env sigma g in
let pc = pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g) in
- str (emacs_str "") ++
- str "subgoal " ++ int n ++ pr_goal_tag g ++ pr_goal_name sigma g ++
- str " is:" ++ cut () ++ str" " ++ pc
+ let header = pr_goal_header (int n) sigma g in
+ header ++ str " is:" ++ cut () ++ str" " ++ pc
(* display evar type: a context and a type *)
let pr_evgl_sign sigma evi =
@@ -417,11 +536,10 @@ let pr_evgl_sign sigma evi =
| None -> [], []
| Some f -> List.filter2 (fun b c -> not b) f (evar_context evi)
in
- let open Context.Named.Declaration in
- let ids = List.rev_map get_id l in
+ let ids = List.rev_map NamedDecl.get_id l in
let warn =
if List.is_empty ids then mt () else
- (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)")
+ (str " (" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)")
in
let pc = pr_lconstr_env env sigma evi.evar_concl in
let candidates =
@@ -433,7 +551,7 @@ let pr_evgl_sign sigma evi =
mt ()
in
hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]" ++
- candidates ++ spc () ++ warn)
+ candidates ++ warn)
(* Print an existential variable *)
@@ -442,15 +560,25 @@ let pr_evar sigma (evk, evi) =
hov 0 (pr_existential_key sigma evk ++ str " : " ++ pegl)
(* Print an enumerated list of existential variables *)
-let rec pr_evars_int_hd head sigma i = function
+let rec pr_evars_int_hd pr sigma i = function
| [] -> mt ()
| (evk,evi)::rest ->
- (hov 0 (head i ++ pr_evar sigma (evk,evi))) ++
- (match rest with [] -> mt () | _ -> fnl () ++ pr_evars_int_hd head sigma (i+1) rest)
-
-let pr_evars_int sigma i evs = pr_evars_int_hd (fun i -> str "Existential " ++ int i ++ str " =" ++ spc ()) sigma i (Evar.Map.bindings evs)
-
-let pr_evars sigma evs = pr_evars_int_hd (fun i -> mt ()) sigma 1 (Evar.Map.bindings evs)
+ (hov 0 (pr i evk evi)) ++
+ (match rest with [] -> mt () | _ -> fnl () ++ pr_evars_int_hd pr sigma (i+1) rest)
+
+let pr_evars_int sigma ~shelf ~givenup i evs =
+ let pr_status i =
+ if List.mem i shelf then str " (shelved)"
+ else if List.mem i givenup then str " (given up)"
+ else mt () in
+ pr_evars_int_hd
+ (fun i evk evi ->
+ str "Existential " ++ int i ++ str " =" ++
+ spc () ++ pr_evar sigma (evk,evi) ++ pr_status evk)
+ sigma i (Evar.Map.bindings evs)
+
+let pr_evars sigma evs =
+ pr_evars_int_hd (fun i evk evi -> pr_evar sigma (evk,evi)) sigma 1 (Evar.Map.bindings evs)
(* Display a list of evars given by their name, with a prefix *)
let pr_ne_evar_set hd tl sigma l =
@@ -464,12 +592,12 @@ let pr_ne_evar_set hd tl sigma l =
let pr_selected_subgoal name sigma g =
let pg = default_pr_goal { sigma=sigma ; it=g; } in
- v 0 (str "subgoal " ++ name ++ pr_goal_tag g ++ pr_goal_name sigma g
- ++ str " is:" ++ cut () ++ pg)
+ let header = pr_goal_header name sigma g in
+ v 0 (header ++ str " is:" ++ cut () ++ pg)
let default_pr_subgoal n sigma =
let rec prrec p = function
- | [] -> error "No such goal."
+ | [] -> user_err Pp.(str "No such goal.")
| g::rest ->
if Int.equal p 1 then
pr_selected_subgoal (int n) sigma g
@@ -478,7 +606,7 @@ let default_pr_subgoal n sigma =
in
prrec n
-let pr_internal_existential_key ev = str (string_of_existential ev)
+let pr_internal_existential_key ev = Evar.print ev
let print_evar_constraints gl sigma =
let pr_env =
@@ -487,15 +615,15 @@ let print_evar_constraints gl sigma =
| Some g ->
let env = Goal.V82.env sigma g in fun e' ->
begin
- if Context.Named.equal (named_context env) (named_context e') then
- if Context.Rel.equal (rel_context env) (rel_context e') then mt ()
+ if Context.Named.equal Constr.equal (named_context env) (named_context e') then
+ if Context.Rel.equal Constr.equal (rel_context env) (rel_context e') then mt ()
else pr_rel_context_of e' sigma ++ str " |-" ++ spc ()
else pr_context_of e' sigma ++ str " |-" ++ spc ()
end
in
let pr_evconstr (pbty,env,t1,t2) =
- let t1 = Evarutil.nf_evar sigma t1
- and t2 = Evarutil.nf_evar sigma t2 in
+ let t1 = Evarutil.nf_evar sigma (EConstr.of_constr t1)
+ and t2 = Evarutil.nf_evar sigma (EConstr.of_constr t2) in
let env =
(** We currently allow evar instances to refer to anonymous de Bruijn
indices, so we protect the error printing code in this case by giving
@@ -503,13 +631,13 @@ let print_evar_constraints gl sigma =
problem. MS: we should rather stop depending on anonymous variables, they
can be used to indicate independency. Also, this depends on a strategy for
naming/renaming *)
- Namegen.make_all_name_different env in
+ Namegen.make_all_name_different env sigma in
str" " ++
- hov 2 (pr_env env ++ pr_lconstr_env env sigma t1 ++ spc () ++
+ hov 2 (pr_env env ++ pr_leconstr_env env sigma t1 ++ spc () ++
str (match pbty with
| Reduction.CONV -> "=="
| Reduction.CUMUL -> "<=") ++
- spc () ++ pr_lconstr_env env sigma t2)
+ spc () ++ pr_leconstr_env env sigma t2)
in
let pr_candidate ev evi (candidates,acc) =
if Option.has_some evi.evar_candidates then
@@ -534,8 +662,7 @@ let should_print_dependent_evars = ref false
let _ =
let open Goptions in
declare_bool_option
- { optsync = true;
- optdepr = false;
+ { optdepr = false;
optname = "Printing Dependent Evars Line";
optkey = ["Printing";"Dependent";"Evars";"Line"];
optread = (fun () -> !should_print_dependent_evars);
@@ -558,27 +685,24 @@ let print_dependent_evars gl sigma seeds =
end i (str ",")
end evars (str "")
in
- fnl () ++
- str "(dependent evars:" ++ evars ++ str ")" ++ fnl ()
- else
- fnl () ++
- str "(dependent evars: (printing disabled) )" ++ fnl ()
+ cut () ++ cut () ++
+ str "(dependent evars:" ++ evars ++ str ")"
+ else mt ()
in
- constraints ++ delayed_emacs_cmd evars
+ constraints ++ evars ()
(* Print open subgoals. Checks for uninstantiated existential variables *)
(* spiwack: [seeds] is for printing dependent evars in emacs mode. *)
(* spiwack: [pr_first] is true when the first goal must be singled out
and printed in its entirety. *)
-(* courtieu: in emacs mode, even less cases where the first goal is printed
- in its entirety *)
-let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals =
+let default_pr_subgoals ?(pr_first=true)
+ close_cmd sigma ~seeds ~shelf ~stack ~unfocused ~goals =
(** Printing functions for the extra informations. *)
let rec print_stack a = function
| [] -> Pp.int a
| b::l -> Pp.int a ++ str"-" ++ print_stack b l
in
- let print_unfocused l =
+ let print_unfocused_nums l =
match l with
| [] -> None
| a::l -> Some (str"unfocused: " ++ print_stack a l)
@@ -598,7 +722,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
| [] -> Pp.mt ()
| a::l -> Pp.spc () ++ str"(" ++ print_comma_separated_list a l ++ str")"
in
- let extra = Option.List.flatten [ print_unfocused stack ; print_shelf shelf ] in
+ let extra = Option.List.flatten [ print_unfocused_nums stack ; print_shelf shelf ] in
let print_extra = print_extra_list extra in
let focused_if_needed =
let needed = not (CList.is_empty extra) && pr_first in
@@ -615,8 +739,9 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
in
let print_multiple_goals g l =
if pr_first then
- default_pr_goal { it = g ; sigma = sigma; } ++ fnl () ++
- pr_rec 2 l
+ default_pr_goal { it = g ; sigma = sigma; }
+ ++ (if l=[] then mt () else cut ())
+ ++ pr_rec 2 l
else
pr_rec 1 (g::l)
in
@@ -629,34 +754,29 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
match goals with
| [] ->
begin
- let exl = Evarutil.non_instantiated sigma in
+ let exl = Evd.undefined_map sigma in
if Evar.Map.is_empty exl then
- (str"No more subgoals."
- ++ print_dependent_evars None sigma seeds)
+ (str"No more subgoals." ++ print_dependent_evars None sigma seeds)
else
- let pei = pr_evars_int sigma 1 exl in
- (str "No more subgoals, but there are non-instantiated existential variables:"
- ++ fnl () ++ (hov 0 pei)
- ++ print_dependent_evars None sigma seeds ++ fnl () ++
- str "You can use Grab Existential Variables.")
+ let pei = pr_evars_int sigma ~shelf ~givenup:[] 1 exl in
+ v 0 ((str "No more subgoals,"
+ ++ str " but there are non-instantiated existential variables:"
+ ++ cut () ++ (hov 0 pei)
+ ++ print_dependent_evars None sigma seeds
+ ++ cut () ++ str "You can use Grab Existential Variables."))
end
- | [g] when not !Flags.print_emacs && pr_first ->
- let pg = default_pr_goal { it = g ; sigma = sigma; } in
- v 0 (
- str "1" ++ focused_if_needed ++ str"subgoal" ++ print_extra
- ++ pr_goal_tag g ++ pr_goal_name sigma g ++ cut () ++ pg
- ++ print_dependent_evars (Some g) sigma seeds
- )
| g1::rest ->
let goals = print_multiple_goals g1 rest in
let ngoals = List.length rest+1 in
v 0 (
- int ngoals ++ focused_if_needed ++ str(String.plural ngoals "subgoal") ++
- print_extra ++
- str ((if display_name then (fun x -> x) else emacs_str) ", subgoal 1")
- ++ pr_goal_tag g1
- ++ pr_goal_name sigma g1 ++ cut ()
- ++ goals
+ int ngoals ++ focused_if_needed ++ str(String.plural ngoals "subgoal")
+ ++ print_extra
+ ++ str (if (should_gname()) then ", subgoal 1" else "")
+ ++ (if should_tag() then pr_goal_tag g1 else str"")
+ ++ pr_goal_name sigma g1 ++ cut () ++ goals
+ ++ (if unfocused=[] then str ""
+ else (cut() ++ cut() ++ str "*** Unfocused goals:" ++ cut()
+ ++ pr_rec (List.length rest + 2) unfocused))
++ print_dependent_evars (Some g1) sigma seeds
)
@@ -665,9 +785,9 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
type printer_pr = {
- pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds;
- pr_subgoal : int -> evar_map -> goal list -> std_ppcmds;
- pr_goal : goal sigma -> std_ppcmds;
+ pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> seeds:goal list -> shelf:goal list -> stack:int list -> unfocused:goal list -> goals:goal list -> Pp.t;
+ pr_subgoal : int -> evar_map -> goal list -> Pp.t;
+ pr_goal : goal sigma -> Pp.t;
}
let default_printer_pr = {
@@ -687,7 +807,7 @@ let pr_goal x = !printer_pr.pr_goal x
(* End abstraction layer *)
(**********************************************************************)
-let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () =
+let pr_open_subgoals ~proof =
(* spiwack: it shouldn't be the job of the printer to look up stuff
in the [evar_map], I did stuff that way because it was more
straightforward, but seriously, [Proof.proof] should return
@@ -699,66 +819,49 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () =
begin match goals with
| [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in
begin match bgoals,shelf,given_up with
- | [] , [] , [] -> pr_subgoals None sigma seeds shelf stack goals
+ | [] , [] , [] -> pr_subgoals None sigma ~seeds ~shelf ~stack ~unfocused:[] ~goals
| [] , [] , _ ->
Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:");
fnl ()
- ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] given_up
+ ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:given_up
++ fnl () ++ str "You need to go back and solve them."
| [] , _ , _ ->
Feedback.msg_info (str "All the remaining goals are on the shelf.");
fnl ()
- ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] shelf
+ ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:shelf
| _ , _, _ ->
let end_cmd =
str "This subproof is complete, but there are some unfocused goals." ++
- (let s = Proof_global.Bullet.suggest p in
- if Pp.is_empty s then s else fnl () ++ s) ++
+ (let s = Proof_bullet.suggest p in
+ if Pp.ismt s then s else fnl () ++ s) ++
fnl ()
in
- pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals
+ pr_subgoals ~pr_first:false (Some end_cmd) bsigma ~seeds ~shelf ~stack:[] ~unfocused:[] ~goals:bgoals
end
- | _ -> pr_subgoals None sigma seeds shelf stack goals
+ | _ ->
+ let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in
+ let bgoals_focused, bgoals_unfocused = List.partition (fun x -> List.mem x goals) bgoals in
+ let unfocused_if_needed = if should_unfoc() then bgoals_unfocused else [] in
+ pr_subgoals ~pr_first:true None bsigma ~seeds ~shelf ~stack:[] ~unfocused:unfocused_if_needed ~goals:bgoals_focused
end
-let pr_nth_open_subgoal n =
- let pf = get_pftreestate () in
- let { it=gls ; sigma=sigma } = Proof.V82.subgoals pf in
+let pr_nth_open_subgoal ~proof n =
+ let gls,_,_,_,sigma = Proof.proof proof in
pr_subgoal n sigma gls
-let pr_goal_by_id id =
- let p = Proof_global.give_me_the_proof () in
+let pr_goal_by_id ~proof id =
try
- Proof.in_proof p (fun sigma ->
+ Proof.in_proof proof (fun sigma ->
let g = Evd.evar_key id sigma in
pr_selected_subgoal (pr_id id) sigma g)
- with Not_found -> error "No such goal."
-
-let pr_goal_by_uid uid =
- let p = Proof_global.give_me_the_proof () in
- let g = Goal.get_by_uid uid in
- let pr gs =
- v 0 (str "goal / evar " ++ str uid ++ str " is:" ++ cut ()
- ++ pr_goal gs)
- in
- try
- Proof.in_proof p (fun sigma -> pr {it=g;sigma=sigma;})
- with Not_found -> error "Invalid goal identifier."
+ with Not_found -> user_err Pp.(str "No such goal.")
(* Elementary tactics *)
let pr_prim_rule = function
- | Cut (b,replace,id,t) ->
- if b then
- (* TODO: express "replace" *)
- (str"assert " ++ str"(" ++ pr_id id ++ str":" ++ pr_lconstr t ++ str")")
- else
- let cl = if replace then str"clear " ++ pr_id id ++ str"; " else mt() in
- (str"cut " ++ pr_constr t ++
- str ";[" ++ cl ++ str"intro " ++ pr_id id ++ str"|idtac]")
-
| Refine c ->
- str(if Termops.occur_meta c then "refine " else "exact ") ++
+ (** 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 *)
@@ -770,15 +873,15 @@ let prterm = pr_lconstr
It is used primarily by the Print Assumptions command. *)
type axiom =
- | Constant of constant (* An axiom or a constant. *)
+ | Constant of Constant.t (* An axiom or a constant. *)
| Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *)
- | Guarded of constant (* a constant whose (co)fixpoints have been assumed to be guarded *)
+ | Guarded of Constant.t (* a constant whose (co)fixpoints have been assumed to be guarded *)
type context_object =
| Variable of Id.t (* A section variable or a Let definition *)
| Axiom of axiom * (Label.t * Context.Rel.t * types) list
- | Opaque of constant (* An opaque constant. *)
- | Transparent of constant
+ | Opaque of Constant.t (* An opaque constant. *)
+ | Transparent of Constant.t
(* Defines a set of [assumption] *)
module OrderedContextObject =
@@ -788,11 +891,11 @@ struct
let compare_axiom x y =
match x,y with
| Constant k1 , Constant k2 ->
- con_ord k1 k2
+ Constant.CanOrd.compare k1 k2
| Positive m1 , Positive m2 ->
MutInd.CanOrd.compare m1 m2
| Guarded k1 , Guarded k2 ->
- con_ord k1 k2
+ Constant.CanOrd.compare k1 k2
| _ , Constant _ -> 1
| _ , Positive _ -> 1
| _ -> -1
@@ -805,16 +908,16 @@ struct
| Axiom (k1,_) , Axiom (k2, _) -> compare_axiom k1 k2
| Axiom _ , _ -> -1
| _ , Axiom _ -> 1
- | Opaque k1 , Opaque k2 -> con_ord k1 k2
+ | Opaque k1 , Opaque k2 -> Constant.CanOrd.compare k1 k2
| Opaque _ , _ -> -1
| _ , Opaque _ -> 1
- | Transparent k1 , Transparent k2 -> con_ord k1 k2
+ | Transparent k1 , Transparent k2 -> Constant.CanOrd.compare k1 k2
end
module ContextObjectSet = Set.Make (OrderedContextObject)
module ContextObjectMap = Map.Make (OrderedContextObject)
-let pr_assumptionset env s =
+let pr_assumptionset env sigma s =
if ContextObjectMap.is_empty s &&
engagement env = PredicativeSet then
str "Closed under the global context"
@@ -822,15 +925,14 @@ let pr_assumptionset env s =
let safe_pr_constant env kn =
try pr_constant env kn
with Not_found ->
- let mp,_,lab = repr_con kn in
- str (string_of_mp mp) ++ str "." ++ pr_label lab
+ let mp,_,lab = Constant.repr3 kn in
+ str (ModPath.to_string mp) ++ str "." ++ Label.print lab
in
let safe_pr_ltype typ =
try str " : " ++ pr_ltype typ
with e when CErrors.noncritical e -> mt ()
in
let safe_pr_ltype_relctx (rctx, typ) =
- let sigma, env = get_current_context () in
let env = Environ.push_rel_context rctx env in
try str " " ++ pr_ltype_env env sigma typ
with e when CErrors.noncritical e -> mt ()
@@ -857,7 +959,7 @@ let pr_assumptionset env s =
let ax = pr_axiom env axiom typ ++
cut() ++
prlist_with_sep cut (fun (lbl, ctx, ty) ->
- str " used in " ++ pr_label lbl ++
+ str " used in " ++ Label.print lbl ++
str " to prove:" ++ safe_pr_ltype_relctx (ctx,ty))
l in
(v, ax :: a, o, tr)
@@ -901,6 +1003,11 @@ let pr_assumptionset env s =
let xor a b =
(a && not b) || (not a && b)
+let pr_cumulative poly cum =
+ if poly then
+ if cum then str "Cumulative " else str "NonCumulative "
+ else mt ()
+
let pr_polymorphic b =
let print = xor (Flags.is_universe_polymorphism ()) b in
if print then
@@ -909,4 +1016,4 @@ let pr_polymorphic b =
let pr_universe_instance evd ctx =
let inst = Univ.UContext.instance ctx in
- str"@{" ++ Univ.Instance.pr (Evd.pr_evd_level evd) inst ++ str"}"
+ str"@{" ++ Univ.Instance.pr (Termops.pr_evd_level evd) inst ++ str"}"
diff --git a/printing/printer.mli b/printing/printer.mli
index 695ab33b..41843680 100644
--- a/printing/printer.mli
+++ b/printing/printer.mli
@@ -1,192 +1,234 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
-open Pp
open Names
open Globnames
-open Term
+open Constr
open Environ
open Pattern
open Evd
open Proof_type
open Glob_term
+open Ltac_pretype
(** These are the entry points for printing terms, context, tac, ... *)
+
+val enable_unfocused_goal_printing: bool ref
+val enable_goal_tags_printing : bool ref
+val enable_goal_names_printing : bool ref
+
(** Terms *)
-val pr_lconstr_env : env -> evar_map -> constr -> std_ppcmds
-val pr_lconstr : constr -> std_ppcmds
-val pr_lconstr_goal_style_env : env -> evar_map -> constr -> std_ppcmds
+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_env : env -> evar_map -> constr -> std_ppcmds
-val pr_constr : constr -> std_ppcmds
-val pr_constr_goal_style_env : env -> evar_map -> constr -> std_ppcmds
+val pr_constr_n_env : env -> evar_map -> Notation_term.tolerability -> constr -> Pp.t
(** Same, but resilient to [Nametab] errors. Prints fully-qualified
names when [shortest_qualid_of_global] has failed. Prints "??"
in case of remaining issues (such as reference not in env). *)
-val safe_pr_lconstr_env : env -> evar_map -> constr -> std_ppcmds
-val safe_pr_lconstr : constr -> std_ppcmds
+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 -> std_ppcmds
-val safe_pr_constr : constr -> std_ppcmds
+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_open_constr_env : env -> evar_map -> open_constr -> std_ppcmds
-val pr_open_constr : open_constr -> std_ppcmds
+val pr_econstr_n_env : env -> evar_map -> Notation_term.tolerability -> EConstr.t -> Pp.t
-val pr_open_lconstr_env : env -> evar_map -> open_constr -> std_ppcmds
-val pr_open_lconstr : open_constr -> std_ppcmds
+val pr_etype_env : env -> evar_map -> EConstr.types -> Pp.t
+val pr_letype_env : env -> evar_map -> EConstr.types -> Pp.t
-val pr_constr_under_binders_env : env -> evar_map -> constr_under_binders -> std_ppcmds
-val pr_constr_under_binders : constr_under_binders -> std_ppcmds
+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_lconstr_under_binders_env : env -> evar_map -> constr_under_binders -> std_ppcmds
-val pr_lconstr_under_binders : constr_under_binders -> std_ppcmds
+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_goal_concl_style_env : env -> evar_map -> types -> std_ppcmds
-val pr_ltype_env : env -> evar_map -> types -> std_ppcmds
-val pr_ltype : types -> std_ppcmds
+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_type_env : env -> evar_map -> types -> std_ppcmds
-val pr_type : types -> std_ppcmds
+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_closed_glob_env : env -> evar_map -> closed_glob_constr -> std_ppcmds
-val pr_closed_glob : closed_glob_constr -> std_ppcmds
+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_ljudge_env : env -> evar_map -> unsafe_judgment -> std_ppcmds * std_ppcmds
-val pr_ljudge : unsafe_judgment -> std_ppcmds * std_ppcmds
+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_lglob_constr_env : env -> glob_constr -> std_ppcmds
-val pr_lglob_constr : glob_constr -> std_ppcmds
+val pr_closed_glob_n_env : env -> evar_map -> Notation_term.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_glob_constr_env : env -> glob_constr -> std_ppcmds
-val pr_glob_constr : glob_constr -> std_ppcmds
+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_lconstr_pattern_env : env -> evar_map -> constr_pattern -> std_ppcmds
-val pr_lconstr_pattern : constr_pattern -> std_ppcmds
+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_constr_pattern_env : env -> evar_map -> constr_pattern -> std_ppcmds
-val pr_constr_pattern : constr_pattern -> std_ppcmds
+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_cases_pattern : cases_pattern -> std_ppcmds
+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_sort : evar_map -> sorts -> std_ppcmds
+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
+
+val pr_sort : evar_map -> Sorts.t -> Pp.t
(** Universe constraints *)
-val pr_polymorphic : bool -> std_ppcmds
-val pr_universe_instance : evar_map -> Univ.universe_context -> std_ppcmds
-val pr_universe_ctx : evar_map -> Univ.universe_context -> std_ppcmds
+val pr_polymorphic : bool -> Pp.t
+val pr_cumulative : bool -> bool -> Pp.t
+val pr_universe_instance : evar_map -> Univ.UContext.t -> Pp.t
+val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array ->
+ Univ.UContext.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_cumulativity_info : evar_map -> Univ.CumulativityInfo.t -> Pp.t
(** Printing global references using names as short as possible *)
-val pr_global_env : Id.Set.t -> global_reference -> std_ppcmds
-val pr_global : global_reference -> std_ppcmds
+val pr_global_env : Id.Set.t -> global_reference -> Pp.t
+val pr_global : global_reference -> Pp.t
-val pr_constant : env -> constant -> std_ppcmds
-val pr_existential_key : evar_map -> existential_key -> std_ppcmds
-val pr_existential : env -> evar_map -> existential -> std_ppcmds
-val pr_constructor : env -> constructor -> std_ppcmds
-val pr_inductive : env -> inductive -> std_ppcmds
-val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds
+val pr_constant : env -> Constant.t -> Pp.t
+val pr_existential_key : evar_map -> Evar.t -> Pp.t
+val pr_existential : env -> evar_map -> existential -> Pp.t
+val pr_constructor : env -> constructor -> Pp.t
+val pr_inductive : env -> inductive -> Pp.t
+val pr_evaluable_reference : evaluable_global_reference -> Pp.t
-val pr_pconstant : env -> pconstant -> std_ppcmds
-val pr_pinductive : env -> pinductive -> std_ppcmds
-val pr_pconstructor : env -> pconstructor -> std_ppcmds
+val pr_pconstant : env -> pconstant -> Pp.t
+val pr_pinductive : env -> pinductive -> Pp.t
+val pr_pconstructor : env -> pconstructor -> Pp.t
(** Contexts *)
+(** Display compact contexts of goals (simple hyps on the same line) *)
+val set_compact_context : bool -> unit
+val get_compact_context : unit -> bool
-val pr_context_unlimited : env -> evar_map -> std_ppcmds
-val pr_ne_context_of : std_ppcmds -> env -> evar_map -> std_ppcmds
+val pr_context_unlimited : env -> evar_map -> Pp.t
+val pr_ne_context_of : Pp.t -> env -> evar_map -> Pp.t
-val pr_var_decl : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds
-val pr_var_list_decl : env -> evar_map -> Context.NamedList.Declaration.t -> std_ppcmds
-val pr_rel_decl : env -> evar_map -> Context.Rel.Declaration.t -> std_ppcmds
+val pr_named_decl : env -> evar_map -> Context.Named.Declaration.t -> Pp.t
+val pr_compacted_decl : env -> evar_map -> Context.Compacted.Declaration.t -> Pp.t
+val pr_rel_decl : env -> evar_map -> Context.Rel.Declaration.t -> Pp.t
-val pr_named_context : env -> evar_map -> Context.Named.t -> std_ppcmds
-val pr_named_context_of : env -> evar_map -> std_ppcmds
-val pr_rel_context : env -> evar_map -> Context.Rel.t -> std_ppcmds
-val pr_rel_context_of : env -> evar_map -> std_ppcmds
-val pr_context_of : env -> evar_map -> std_ppcmds
+val pr_named_context : env -> evar_map -> Context.Named.t -> Pp.t
+val pr_named_context_of : env -> evar_map -> Pp.t
+val pr_rel_context : env -> evar_map -> Context.Rel.t -> Pp.t
+val pr_rel_context_of : env -> evar_map -> Pp.t
+val pr_context_of : env -> evar_map -> Pp.t
(** Predicates *)
-val pr_predicate : ('a -> std_ppcmds) -> (bool * 'a list) -> std_ppcmds
-val pr_cpred : Cpred.t -> std_ppcmds
-val pr_idpred : Id.Pred.t -> std_ppcmds
-val pr_transparent_state : transparent_state -> std_ppcmds
-
-(** Proofs *)
-
-val pr_goal : goal sigma -> std_ppcmds
-val pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds
-val pr_subgoal : int -> evar_map -> goal list -> std_ppcmds
-val pr_concl : int -> evar_map -> goal -> std_ppcmds
-
-val pr_open_subgoals : ?proof:Proof.proof -> unit -> std_ppcmds
-val pr_nth_open_subgoal : int -> std_ppcmds
-val pr_evar : evar_map -> (evar * evar_info) -> std_ppcmds
-val pr_evars_int : evar_map -> int -> evar_info Evar.Map.t -> std_ppcmds
-val pr_evars : evar_map -> evar_info Evar.Map.t -> std_ppcmds
-val pr_ne_evar_set : std_ppcmds -> std_ppcmds -> evar_map ->
- Evar.Set.t -> std_ppcmds
-
-val pr_prim_rule : prim_rule -> std_ppcmds
-
-(** Emacs/proof general support
- (emacs_str s) outputs
- - s if emacs mode,
- - nothing otherwise.
- This function was previously used to insert special chars like
- [(String.make 1 (Char.chr 253))] to parenthesize sub-parts of the
- proof context for proof by pointing. This part of the code is
- removed for now because it interacted badly with utf8. We may put
- it back some day using some xml-like tags instead of special
- chars. See for example the <prompt> tag in the prompt when in
- emacs mode. *)
-val emacs_str : string -> string
+val pr_predicate : ('a -> Pp.t) -> (bool * 'a list) -> Pp.t
+val pr_cpred : Cpred.t -> Pp.t
+val pr_idpred : Id.Pred.t -> Pp.t
+val pr_transparent_state : transparent_state -> Pp.t
+
+(** Proofs, these functions obey [Hyps Limit] and [Compact contexts]. *)
+
+val pr_goal : goal sigma -> Pp.t
+
+(** [pr_subgoals ~pr_first pp sigma seeds shelf focus_stack unfocused goals]
+ prints the goals of the list [goals] followed by the goals in
+ [unfocused], in a short way (typically only the conclusion) except
+ for the first goal if [pr_first] is true. This function can be
+ replaced by another one by calling [set_printer_pr] (see below),
+ typically by plugin writers. The default printer prints only the
+ focused goals unless the conrresponding option
+ [enable_unfocused_goal_printing] is set. [seeds] is for printing
+ dependent evars (mainly for emacs proof tree mode). *)
+val pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> seeds:goal list -> shelf:goal list -> stack:int list -> unfocused:goal list -> goals:goal list -> Pp.t
+
+val pr_subgoal : int -> evar_map -> goal list -> Pp.t
+val pr_concl : int -> evar_map -> goal -> Pp.t
+
+val pr_open_subgoals : proof:Proof.t -> Pp.t
+val pr_nth_open_subgoal : proof:Proof.t -> int -> Pp.t
+val pr_evar : evar_map -> (Evar.t * evar_info) -> Pp.t
+val pr_evars_int : evar_map -> shelf:goal list -> givenup:goal list -> int -> evar_info Evar.Map.t -> Pp.t
+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
(** Backwards compatibility *)
-val prterm : constr -> std_ppcmds (** = pr_lconstr *)
+val prterm : constr -> Pp.t (** = pr_lconstr *)
(** Declarations for the "Print Assumption" command *)
type axiom =
- | Constant of constant (* An axiom or a constant. *)
+ | Constant of Constant.t (* An axiom or a constant. *)
| Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *)
- | Guarded of constant (* a constant whose (co)fixpoints have been assumed to be guarded *)
+ | Guarded of Constant.t (* a constant whose (co)fixpoints have been assumed to be guarded *)
type context_object =
| Variable of Id.t (* A section variable or a Let definition *)
| Axiom of axiom * (Label.t * Context.Rel.t * types) list
- | Opaque of constant (* An opaque constant. *)
- | Transparent of constant
+ | Opaque of Constant.t (* An opaque constant. *)
+ | Transparent of Constant.t
module ContextObjectSet : Set.S with type elt = context_object
module ContextObjectMap : CMap.ExtS
with type key = context_object and module Set := ContextObjectSet
-val pr_assumptionset :
- env -> Term.types ContextObjectMap.t -> std_ppcmds
+val pr_assumptionset : env -> evar_map -> types ContextObjectMap.t -> Pp.t
-val pr_goal_by_id : Id.t -> std_ppcmds
-val pr_goal_by_uid : string -> std_ppcmds
+val pr_goal_by_id : proof:Proof.t -> Id.t -> Pp.t
type printer_pr = {
- pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds;
- pr_subgoal : int -> evar_map -> goal list -> std_ppcmds;
- pr_goal : goal sigma -> std_ppcmds;
-};;
+ pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> seeds:goal list -> shelf:goal list -> stack:int list -> unfocused:goal list -> goals:goal list -> Pp.t;
+
+ pr_subgoal : int -> evar_map -> goal list -> Pp.t;
+ pr_goal : goal sigma -> Pp.t;
+}
val set_printer_pr : printer_pr -> unit
diff --git a/printing/printing.mllib b/printing/printing.mllib
index bc8f0750..86b68d8f 100644
--- a/printing/printing.mllib
+++ b/printing/printing.mllib
@@ -1,9 +1,7 @@
Genprint
Pputils
-Ppannotation
Ppconstr
Printer
-Pptactic
Printmod
Prettyp
Ppvernac
diff --git a/printing/printmod.ml b/printing/printmod.ml
index dfa66d43..e076c10f 100644
--- a/printing/printmod.ml
+++ b/printing/printmod.ml
@@ -1,18 +1,19 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
open Util
-open Term
+open Constr
open Pp
open Names
open Environ
open Declarations
-open Nameops
open Globnames
open Libnames
open Goptions
@@ -26,12 +27,23 @@ open Goptions
the "short" mode or (Some env) in the "rich" one.
*)
+module Tag =
+struct
+
+ let definition = "module.definition"
+ let keyword = "module.keyword"
+
+end
+
+let tag t s = Pp.tag t s
+let tag_definition s = tag Tag.definition s
+let tag_keyword s = tag Tag.keyword s
+
let short = ref false
let _ =
declare_bool_option
- { optsync = true;
- optdepr = false;
+ { optdepr = false;
optname = "short module printing";
optkey = ["Short";"Module";"Printing"];
optread = (fun () -> !short) ;
@@ -44,14 +56,8 @@ let mk_fake_top =
let r = ref 0 in
fun () -> incr r; Id.of_string ("FAKETOP"^(string_of_int !r))
-module Make (Taggers : sig
- val tag_definition : std_ppcmds -> std_ppcmds
- val tag_keyword : std_ppcmds -> std_ppcmds
-end) =
-struct
-
-let def s = Taggers.tag_definition (str s)
-let keyword s = Taggers.tag_keyword (str s)
+let def s = tag_definition (str s)
+let keyword s = tag_keyword (str s)
let get_new_id locals id =
let rec get_id l id =
@@ -59,9 +65,10 @@ let get_new_id locals id =
if not (Nametab.exists_module dir) then
id
else
- get_id (id::l) (Namegen.next_ident_away id l)
+ get_id (Id.Set.add id l) (Namegen.next_ident_away id l)
in
- get_id (List.map snd locals) id
+ let avoid = List.fold_left (fun accu (_, id) -> Id.Set.add id accu) Id.Set.empty locals in
+ get_id avoid id
(** Inductive declarations *)
@@ -74,7 +81,7 @@ let print_params env sigma params =
let print_constructors envpar sigma names types =
let pc =
prlist_with_sep (fun () -> brk(1,0) ++ str "| ")
- (fun (id,c) -> pr_id id ++ str " : " ++ Printer.pr_lconstr_env envpar sigma c)
+ (fun (id,c) -> Id.print id ++ str " : " ++ Printer.pr_lconstr_env envpar sigma c)
(Array.to_list (Array.map2 (fun n t -> (n,t)) names types))
in
hv 0 (str " " ++ pc)
@@ -83,47 +90,74 @@ 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 mib.mind_polymorphic then
- Univ.UContext.instance mib.mind_universes
+ let u = if Declareops.inductive_is_polymorphic mib then
+ Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib)
else Univ.Instance.empty in
let mip = mib.mind_packets.(i) in
let params = Inductive.inductive_paramdecls (mib,u) in
- let args = Context.Rel.to_extended_list 0 params in
- let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in
+ let nparamdecls = Context.Rel.length params in
+ let args = Context.Rel.to_extended_list mkRel 0 params in
+ let arity = hnf_prod_applist_assum env nparamdecls (build_ind_type env ((mib,mip),u)) args in
let cstrtypes = Inductive.type_of_constructors (ind,u) (mib,mip) in
- let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in
+ let cstrtypes = Array.map (fun c -> hnf_prod_applist_assum env nparamdecls c args) cstrtypes in
let envpar = push_rel_context params env in
let inst =
- if mib.mind_polymorphic then
- Printer.pr_universe_instance sigma mib.mind_universes
+ if Declareops.inductive_is_polymorphic mib then
+ let ctx = Declareops.inductive_polymorphic_context mib in
+ let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u ctx) in
+ Printer.pr_universe_instance sigma ctx
else mt ()
in
hov 0 (
- pr_id mip.mind_typename ++ inst ++ brk(1,4) ++ print_params env sigma params ++
+ Id.print mip.mind_typename ++ inst ++ brk(1,4) ++ print_params env sigma params ++
str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ str " :=") ++
brk(0,2) ++ print_constructors envpar sigma mip.mind_consnames cstrtypes
-let print_mutual_inductive env mind mib =
+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
let keyword =
- let open Decl_kinds in
+ let open Declarations in
match mib.mind_finite with
| Finite -> "Inductive"
| BiFinite -> "Variant"
| CoFinite -> "CoInductive"
in
- let bl = Universes.universe_binders_of_global (IndRef (mind, 0)) in
- let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in
- hov 0 (Printer.pr_polymorphic mib.mind_polymorphic ++
- def keyword ++ spc () ++
- prlist_with_sep (fun () -> fnl () ++ str" with ")
- (print_one_inductive env sigma mib) inds ++
- Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context mib.mind_universes))
+ 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 = Universes.universe_binders_with_opt_names (IndRef (mind, 0)) univs 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
+ (Declareops.inductive_is_polymorphic mib)
+ (Declareops.inductive_is_cumulative mib) ++
+ def keyword ++ spc () ++
+ prlist_with_sep (fun () -> fnl () ++ str" with ")
+ (print_one_inductive env sigma mib) inds ++
+ match mib.mind_universes with
+ | Monomorphic_ind _ | Polymorphic_ind _ -> str ""
+ | Cumulative_ind cumi ->
+ Printer.pr_cumulativity_info
+ sigma (instantiate_cumulativity_info cumi))
let get_fields =
let rec prodec_rec l subst c =
- match kind_of_term c with
+ match kind c with
| Prod (na,t,c) ->
let id = match na with Name id -> id | Anonymous -> Id.of_string "_" in
prodec_rec ((id,true,Vars.substl subst t)::l) (mkVar id::subst) c
@@ -134,24 +168,26 @@ let get_fields =
in
prodec_rec [] []
-let print_record env mind mib =
+let print_record env mind mib udecl =
let u =
- if mib.mind_polymorphic then
- Univ.UContext.instance mib.mind_universes
+ if Declareops.inductive_is_polymorphic mib then
+ Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib)
else Univ.Instance.empty
in
let mip = mib.mind_packets.(0) in
let params = Inductive.inductive_paramdecls (mib,u) in
- let args = Context.Rel.to_extended_list 0 params in
- let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in
+ let nparamdecls = Context.Rel.length params in
+ let args = Context.Rel.to_extended_list mkRel 0 params in
+ let arity = hnf_prod_applist_assum env nparamdecls (build_ind_type env ((mib,mip),u)) args in
let cstrtypes = Inductive.type_of_constructors ((mind,0),u) (mib,mip) in
- let cstrtype = hnf_prod_applist env cstrtypes.(0) args in
+ 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 = Universes.universe_binders_of_global (IndRef (mind,0)) in
- let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in
+ let bl = Universes.universe_binders_with_opt_names (IndRef (mind,0))
+ (Array.to_list (Univ.Instance.to_array u)) udecl in
+ let sigma = Evd.from_ctx (UState.of_binders bl) in
let keyword =
- let open Decl_kinds in
+ let open Declarations in
match mib.mind_finite with
| BiFinite -> "Record"
| Finite -> "Inductive"
@@ -159,31 +195,39 @@ let print_record env mind mib =
in
hov 0 (
hov 0 (
- Printer.pr_polymorphic mib.mind_polymorphic ++
- def keyword ++ spc () ++ pr_id mip.mind_typename ++ brk(1,4) ++
+ Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++
+ Printer.pr_cumulative
+ (Declareops.inductive_is_polymorphic mib)
+ (Declareops.inductive_is_cumulative mib) ++
+ def keyword ++ spc () ++ Id.print mip.mind_typename ++ brk(1,4) ++
print_params env sigma params ++
str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ brk(1,2) ++
- str ":= " ++ pr_id mip.mind_consnames.(0)) ++
+ str ":= " ++ Id.print mip.mind_consnames.(0)) ++
brk(1,2) ++
hv 2 (str "{ " ++
prlist_with_sep (fun () -> str ";" ++ brk(2,0))
(fun (id,b,c) ->
- pr_id id ++ str (if b then " : " else " := ") ++
+ Id.print id ++ str (if b then " : " else " := ") ++
Printer.pr_lconstr_env envpar sigma c) fields) ++ str" }" ++
- Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context mib.mind_universes))
-
-let pr_mutual_inductive_body env mind mib =
+ match mib.mind_universes with
+ | Monomorphic_ind _ | Polymorphic_ind _ -> str ""
+ | Cumulative_ind cumi ->
+ Printer.pr_cumulativity_info
+ sigma (instantiate_cumulativity_info cumi)
+ )
+
+let pr_mutual_inductive_body env mind mib udecl =
if mib.mind_record <> None && not !Flags.raw_print then
- print_record env mind mib
+ print_record env mind mib udecl
else
- print_mutual_inductive env mind mib
+ print_mutual_inductive env mind mib udecl
(** Modpaths *)
let rec print_local_modpath locals = function
- | MPbound mbid -> pr_id (Util.List.assoc_f MBId.equal mbid locals)
+ | MPbound mbid -> Id.print (Util.List.assoc_f MBId.equal mbid locals)
| MPdot(mp,l) ->
- print_local_modpath locals mp ++ str "." ++ pr_lab l
+ print_local_modpath locals mp ++ str "." ++ Label.print l
| MPfile _ -> raise Not_found
let print_modpath locals mp =
@@ -204,10 +248,10 @@ let print_kn locals kn =
with
Not_found -> print_modpath locals kn
-let nametab_register_dir mp =
+let nametab_register_dir obj_mp =
let id = mk_fake_top () in
- let dir = DirPath.make [id] in
- Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,DirPath.empty)))
+ let obj_dir = DirPath.make [id] in
+ Nametab.push_dir (Nametab.Until 1) obj_dir (DirModule { obj_dir; obj_mp; obj_sec = DirPath.empty })
(** Nota: the [global_reference] we register in the nametab below
might differ from internal ones, since we cannot recreate here
@@ -267,15 +311,18 @@ let nametab_register_modparam mbid mtb =
id
let print_body is_impl env mp (l,body) =
- let name = pr_label l in
+ 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 cb.const_polymorphic then Univ.UContext.instance cb.const_universes
+ 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
let sigma = Evd.empty in
(match cb.const_body with
| Def _ -> def "Definition" ++ spc ()
@@ -287,7 +334,7 @@ let print_body is_impl env mp (l,body) =
str " :" ++ spc () ++
hov 0 (Printer.pr_ltype_env env sigma
(Vars.subst_instance_constr u
- (Typeops.type_of_constant_type env cb.const_type))) ++
+ cb.const_type)) ++
(match cb.const_body with
| Def l when is_impl ->
spc () ++
@@ -295,14 +342,14 @@ let print_body is_impl env mp (l,body) =
Printer.pr_lconstr_env env sigma
(Vars.subst_instance_constr u (Mod_subst.force_constr l)))
| _ -> mt ()) ++ str "." ++
- Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context cb.const_universes))
+ Printer.pr_universe_ctx sigma ctx)
| SFBmind mib ->
try
let env = Option.get env in
- pr_mutual_inductive_body env (MutInd.make2 mp l) mib
+ pr_mutual_inductive_body env (MutInd.make2 mp l) mib None
with e when CErrors.noncritical e ->
let keyword =
- let open Decl_kinds in
+ let open Declarations in
match mib.mind_finite with
| Finite -> def "Inductive"
| BiFinite -> def "Variant"
@@ -338,9 +385,12 @@ let rec print_typ_expr env mp locals mty =
| 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.empty 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 c)
+ ++ Printer.pr_lconstr_env env sigma c)
| 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() ++
@@ -366,7 +416,7 @@ let rec print_functor fty fatom is_type env mp locals = function
let kwd = if is_type then "Funsig" else "Functor" in
hov 2
(keyword kwd ++ spc () ++
- str "(" ++ pr_id id ++ str ":" ++ pr_mtb1 ++ str ")" ++
+ str "(" ++ Id.print id ++ str ":" ++ pr_mtb1 ++ str ")" ++
spc() ++ print_functor fty fatom is_type env' mp locals' me2)
let rec print_expression x =
@@ -397,11 +447,11 @@ let rec printable_body dir =
let print_expression' is_type env mp me =
States.with_state_protection
- (fun e -> eval_ppcmds (print_expression is_type env mp [] e)) me
+ (fun e -> print_expression is_type env mp [] e) me
let print_signature' is_type env mp me =
States.with_state_protection
- (fun e -> eval_ppcmds (print_signature is_type env mp [] e)) me
+ (fun e -> print_signature is_type env mp [] e) me
let unsafe_print_module env mp with_body mb =
let name = print_modpath [] mp in
@@ -441,20 +491,4 @@ let print_modtype kn =
with e when CErrors.noncritical e ->
print_signature' true None kn mtb.mod_type))
-end
-
-module Tag =
-struct
- let definition =
- let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in
- Ppstyle.make ~style ["module"; "definition"]
- let keyword =
- let style = Terminal.make ~bold:true () in
- Ppstyle.make ~style ["module"; "keyword"]
-end
-include Make(struct
- let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s
- let tag_definition s = tag Tag.definition s
- let tag_keyword s = tag Tag.keyword s
-end)
diff --git a/printing/printmod.mli b/printing/printmod.mli
index 7f7d3439..b0b0b0a3 100644
--- a/printing/printmod.mli
+++ b/printing/printmod.mli
@@ -1,9 +1,11 @@
(************************************************************************)
-(* 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) *)
(************************************************************************)
open Names
@@ -11,4 +13,8 @@ open Names
(** false iff the module is an element of an open module type *)
val printable_body : DirPath.t -> bool
-include Printmodsig.Pp
+val pr_mutual_inductive_body : Environ.env ->
+ MutInd.t -> Declarations.mutual_inductive_body ->
+ Universes.univ_name_list option -> Pp.t
+val print_module : bool -> ModPath.t -> Pp.t
+val print_modtype : ModPath.t -> Pp.t
diff --git a/printing/printmodsig.mli b/printing/printmodsig.mli
deleted file mode 100644
index f71fffdc..00000000
--- a/printing/printmodsig.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Names
-
-module type Pp =
-sig
- val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds
- val print_module : bool -> module_path -> std_ppcmds
- val print_modtype : module_path -> std_ppcmds
-end
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-06 20:55:16 +0000