From 7cfc4e5146be5666419451bdd516f1f3f264d24a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 25 Jan 2015 14:42:51 +0100 Subject: Imported Upstream version 8.5~beta1+dfsg --- parsing/argextend.ml4 | 340 -------------- parsing/compat.ml4 | 325 ++++++++++++++ parsing/egramcoq.ml | 385 ++++++++++++++++ parsing/egramcoq.mli | 69 +++ parsing/egrammar.ml | 368 --------------- parsing/egrammar.mli | 75 ---- parsing/egramml.ml | 63 +++ parsing/egramml.mli | 29 ++ parsing/extend.ml | 46 -- parsing/extend.mli | 45 -- parsing/extrawit.ml | 60 --- parsing/extrawit.mli | 49 -- parsing/g_constr.ml4 | 253 ++++++----- parsing/g_ltac.ml4 | 131 +++--- parsing/g_prim.ml4 | 59 ++- parsing/g_proofs.ml4 | 66 ++- parsing/g_tactic.ml4 | 509 ++++++++++----------- parsing/g_vernac.ml4 | 512 ++++++++++++--------- parsing/g_xml.ml4 | 160 +++---- parsing/grammar.mllib | 88 ---- parsing/highparsing.mllib | 1 + parsing/lexer.ml4 | 249 +++++----- parsing/lexer.mli | 10 +- parsing/parsing.mllib | 15 +- parsing/pcoq.ml4 | 343 ++++++++------ parsing/pcoq.mli | 69 +-- parsing/ppconstr.ml | 654 --------------------------- parsing/ppconstr.mli | 102 ----- parsing/pptactic.ml | 1072 -------------------------------------------- parsing/pptactic.mli | 100 ----- parsing/ppvernac.ml | 979 ---------------------------------------- parsing/ppvernac.mli | 24 - parsing/prettyp.ml | 794 -------------------------------- parsing/prettyp.mli | 74 --- parsing/printer.ml | 790 -------------------------------- parsing/printer.mli | 169 ------- parsing/printmod.ml | 279 ------------ parsing/printmod.mli | 17 - parsing/q_constr.ml4 | 126 ------ parsing/q_coqast.ml4 | 568 ----------------------- parsing/q_util.ml4 | 69 --- parsing/q_util.mli | 33 -- parsing/tacextend.ml4 | 238 ---------- parsing/tactic_printer.ml | 172 ------- parsing/tactic_printer.mli | 23 - parsing/tok.ml | 27 +- parsing/tok.mli | 4 +- parsing/vernacextend.ml4 | 105 ----- 48 files changed, 2223 insertions(+), 8515 deletions(-) delete mode 100644 parsing/argextend.ml4 create mode 100644 parsing/compat.ml4 create mode 100644 parsing/egramcoq.ml create mode 100644 parsing/egramcoq.mli delete mode 100644 parsing/egrammar.ml delete mode 100644 parsing/egrammar.mli create mode 100644 parsing/egramml.ml create mode 100644 parsing/egramml.mli delete mode 100644 parsing/extend.ml delete mode 100644 parsing/extend.mli delete mode 100644 parsing/extrawit.ml delete mode 100644 parsing/extrawit.mli delete mode 100644 parsing/grammar.mllib delete mode 100644 parsing/ppconstr.ml delete mode 100644 parsing/ppconstr.mli delete mode 100644 parsing/pptactic.ml delete mode 100644 parsing/pptactic.mli delete mode 100644 parsing/ppvernac.ml delete mode 100644 parsing/ppvernac.mli delete mode 100644 parsing/prettyp.ml delete mode 100644 parsing/prettyp.mli delete mode 100644 parsing/printer.ml delete mode 100644 parsing/printer.mli delete mode 100644 parsing/printmod.ml delete mode 100644 parsing/printmod.mli delete mode 100644 parsing/q_constr.ml4 delete mode 100644 parsing/q_coqast.ml4 delete mode 100644 parsing/q_util.ml4 delete mode 100644 parsing/q_util.mli delete mode 100644 parsing/tacextend.ml4 delete mode 100644 parsing/tactic_printer.ml delete mode 100644 parsing/tactic_printer.mli delete mode 100644 parsing/vernacextend.ml4 (limited to 'parsing') diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 deleted file mode 100644 index 1fc429c6..00000000 --- a/parsing/argextend.ml4 +++ /dev/null @@ -1,340 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* > - -let rec make_rawwit loc = function - | BoolArgType -> <:expr< Genarg.rawwit_bool >> - | IntArgType -> <:expr< Genarg.rawwit_int >> - | IntOrVarArgType -> <:expr< Genarg.rawwit_int_or_var >> - | StringArgType -> <:expr< Genarg.rawwit_string >> - | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >> - | IntroPatternArgType -> <:expr< Genarg.rawwit_intro_pattern >> - | IdentArgType b -> <:expr< Genarg.rawwit_ident_gen $mlexpr_of_bool b$ >> - | VarArgType -> <:expr< Genarg.rawwit_var >> - | RefArgType -> <:expr< Genarg.rawwit_ref >> - | SortArgType -> <:expr< Genarg.rawwit_sort >> - | ConstrArgType -> <:expr< Genarg.rawwit_constr >> - | ConstrMayEvalArgType -> <:expr< Genarg.rawwit_constr_may_eval >> - | QuantHypArgType -> <:expr< Genarg.rawwit_quant_hyp >> - | RedExprArgType -> <:expr< Genarg.rawwit_red_expr >> - | OpenConstrArgType (b1,b2) -> <:expr< Genarg.rawwit_open_constr_gen ($mlexpr_of_bool b1$,$mlexpr_of_bool b2$) >> - | ConstrWithBindingsArgType -> <:expr< Genarg.rawwit_constr_with_bindings >> - | BindingsArgType -> <:expr< Genarg.rawwit_bindings >> - | List0ArgType t -> <:expr< Genarg.wit_list0 $make_rawwit loc t$ >> - | List1ArgType t -> <:expr< Genarg.wit_list1 $make_rawwit loc t$ >> - | OptArgType t -> <:expr< Genarg.wit_opt $make_rawwit loc t$ >> - | PairArgType (t1,t2) -> - <:expr< Genarg.wit_pair $make_rawwit loc t1$ $make_rawwit loc t2$ >> - | ExtraArgType s -> - <:expr< - let module WIT = struct - open Extrawit; - value wit = $lid:"rawwit_"^s$; - end in WIT.wit >> - -let rec make_globwit loc = function - | BoolArgType -> <:expr< Genarg.globwit_bool >> - | IntArgType -> <:expr< Genarg.globwit_int >> - | IntOrVarArgType -> <:expr< Genarg.globwit_int_or_var >> - | StringArgType -> <:expr< Genarg.globwit_string >> - | PreIdentArgType -> <:expr< Genarg.globwit_pre_ident >> - | IntroPatternArgType -> <:expr< Genarg.globwit_intro_pattern >> - | IdentArgType b -> <:expr< Genarg.globwit_ident_gen $mlexpr_of_bool b$ >> - | VarArgType -> <:expr< Genarg.globwit_var >> - | RefArgType -> <:expr< Genarg.globwit_ref >> - | QuantHypArgType -> <:expr< Genarg.globwit_quant_hyp >> - | SortArgType -> <:expr< Genarg.globwit_sort >> - | ConstrArgType -> <:expr< Genarg.globwit_constr >> - | ConstrMayEvalArgType -> <:expr< Genarg.globwit_constr_may_eval >> - | RedExprArgType -> <:expr< Genarg.globwit_red_expr >> - | OpenConstrArgType (b1,b2) -> <:expr< Genarg.globwit_open_constr_gen ($mlexpr_of_bool b1$,$mlexpr_of_bool b2$) >> - | ConstrWithBindingsArgType -> <:expr< Genarg.globwit_constr_with_bindings >> - | BindingsArgType -> <:expr< Genarg.globwit_bindings >> - | List0ArgType t -> <:expr< Genarg.wit_list0 $make_globwit loc t$ >> - | List1ArgType t -> <:expr< Genarg.wit_list1 $make_globwit loc t$ >> - | OptArgType t -> <:expr< Genarg.wit_opt $make_globwit loc t$ >> - | PairArgType (t1,t2) -> - <:expr< Genarg.wit_pair $make_globwit loc t1$ $make_globwit loc t2$ >> - | ExtraArgType s -> - <:expr< - let module WIT = struct - open Extrawit; - value wit = $lid:"globwit_"^s$; - end in WIT.wit >> - -let rec make_wit loc = function - | BoolArgType -> <:expr< Genarg.wit_bool >> - | IntArgType -> <:expr< Genarg.wit_int >> - | IntOrVarArgType -> <:expr< Genarg.wit_int_or_var >> - | StringArgType -> <:expr< Genarg.wit_string >> - | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >> - | IntroPatternArgType -> <:expr< Genarg.wit_intro_pattern >> - | IdentArgType b -> <:expr< Genarg.wit_ident_gen $mlexpr_of_bool b$ >> - | VarArgType -> <:expr< Genarg.wit_var >> - | RefArgType -> <:expr< Genarg.wit_ref >> - | QuantHypArgType -> <:expr< Genarg.wit_quant_hyp >> - | SortArgType -> <:expr< Genarg.wit_sort >> - | ConstrArgType -> <:expr< Genarg.wit_constr >> - | ConstrMayEvalArgType -> <:expr< Genarg.wit_constr_may_eval >> - | RedExprArgType -> <:expr< Genarg.wit_red_expr >> - | OpenConstrArgType (b1,b2) -> <:expr< Genarg.wit_open_constr_gen ($mlexpr_of_bool b1$,$mlexpr_of_bool b2$) >> - | ConstrWithBindingsArgType -> <:expr< Genarg.wit_constr_with_bindings >> - | BindingsArgType -> <:expr< Genarg.wit_bindings >> - | List0ArgType t -> <:expr< Genarg.wit_list0 $make_wit loc t$ >> - | List1ArgType t -> <:expr< Genarg.wit_list1 $make_wit loc t$ >> - | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> - | PairArgType (t1,t2) -> - <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >> - | ExtraArgType s -> - <:expr< - let module WIT = struct - open Extrawit; - value wit = $lid:"wit_"^s$; - end in WIT.wit >> - -let has_extraarg = - List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false) - -let statically_known_possibly_empty s (prods,_) = - List.for_all (function - | GramNonTerminal(_,ExtraArgType s',_,_) -> - (* For ExtraArg we don't know (we'll have to test dynamically) *) - (* unless it is a recursive call *) - s <> s' - | GramNonTerminal(_,(OptArgType _|List0ArgType _),_,_) -> - (* Opt and List0 parses the empty string *) - true - | _ -> - (* This consumes a token for sure *) false) - prods - -let possibly_empty_subentries loc (prods,act) = - let bind_name p v e = match p with - | None -> e - | Some id -> - let s = Names.string_of_id id in <:expr< let $lid:s$ = $v$ in $e$ >> in - let rec aux = function - | [] -> <:expr< let loc = $default_loc$ in let _ = loc = loc in $act$ >> - | GramNonTerminal(_,OptArgType _,_,p) :: tl -> - bind_name p <:expr< None >> (aux tl) - | GramNonTerminal(_,List0ArgType _,_,p) :: tl -> - bind_name p <:expr< [] >> (aux tl) - | GramNonTerminal(_,(ExtraArgType _ as t),_,p) :: tl -> - (* We check at runtime if extraarg s parses "epsilon" *) - let s = match p with None -> "_" | Some id -> Names.string_of_id id in - <:expr< let $lid:s$ = match Genarg.default_empty_value $make_rawwit loc t$ with - [ None -> raise Exit - | Some v -> v ] in $aux tl$ >> - | _ -> assert false (* already filtered out *) in - if has_extraarg prods then - (* Needs a dynamic check; catch all exceptions if ever some rhs raises *) - (* an exception rather than returning a value; *) - (* declares loc because some code can refer to it; *) - (* ensures loc is used to avoid "unused variable" warning *) - (true, <:expr< try Some $aux prods$ with [ e when Errors.noncritical e -> None ] >>) - else - (* Static optimisation *) - (false, aux prods) - -let make_possibly_empty_subentries loc s cl = - let cl = List.filter (statically_known_possibly_empty s) cl in - if cl = [] then - <:expr< None >> - else - let rec aux = function - | (true, e) :: l -> - <:expr< match $e$ with [ Some v -> Some v | None -> $aux l$ ] >> - | (false, e) :: _ -> - <:expr< Some $e$ >> - | [] -> - <:expr< None >> in - aux (List.map (possibly_empty_subentries loc) cl) - -let make_act loc act pil = - let rec make = function - | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >> - | GramNonTerminal (_,t,_,Some p) :: tl -> - let p = Names.string_of_id p in - <:expr< - Pcoq.Gram.action - (fun $lid:p$ -> - let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) - >> - | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl -> - <:expr< Pcoq.Gram.action (fun _ -> $make tl$) >> in - make (List.rev pil) - -let make_prod_item = function - | GramTerminal s -> <:expr< Pcoq.gram_token_of_string $str:s$ >> - | GramNonTerminal (_,_,g,_) -> - <:expr< Pcoq.symbol_of_prod_entry_key $mlexpr_of_prod_entry_key g$ >> - -let make_rule loc (prods,act) = - <:expr< ($mlexpr_of_list make_prod_item prods$,$make_act loc act prods$) >> - -let declare_tactic_argument loc s (typ, pr, f, g, h) cl = - let rawtyp, rawpr, globtyp, globpr = match typ with - | `Uniform typ -> typ, pr, typ, pr - | `Specialized (a, b, c, d) -> a, b, c, d - in - let glob = match g with - | None -> - <:expr< fun e x -> - out_gen $make_globwit loc rawtyp$ - (Tacinterp.intern_genarg e - (Genarg.in_gen $make_rawwit loc rawtyp$ x)) >> - | Some f -> <:expr< $lid:f$>> in - let interp = match f with - | None -> - <:expr< fun ist gl x -> - let (sigma,a_interp) = - Tacinterp.interp_genarg ist gl - (Genarg.in_gen $make_globwit loc globtyp$ x) - in - (sigma , out_gen $make_wit loc globtyp$ a_interp)>> - | Some f -> <:expr< $lid:f$>> in - let substitute = match h with - | None -> - <:expr< fun s x -> - out_gen $make_globwit loc globtyp$ - (Tacinterp.subst_genarg s - (Genarg.in_gen $make_globwit loc globtyp$ x)) >> - | Some f -> <:expr< $lid:f$>> in - let se = mlexpr_of_string s in - let wit = <:expr< $lid:"wit_"^s$ >> in - let rawwit = <:expr< $lid:"rawwit_"^s$ >> in - let globwit = <:expr< $lid:"globwit_"^s$ >> in - let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in - let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in - declare_str_items loc - [ <:str_item< - value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) = - Genarg.create_arg $default_value$ $se$>>; - <:str_item< - value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; - <:str_item< do { - Tacinterp.add_interp_genarg $se$ - ((fun e x -> - (Genarg.in_gen $globwit$ ($glob$ e (out_gen $rawwit$ x)))), - (fun ist gl x -> - let (sigma,a_interp) = $interp$ ist gl (out_gen $globwit$ x) in - (sigma , Genarg.in_gen $wit$ a_interp)), - (fun subst x -> - (Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x))))); - Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a)) - (None, [(None, None, $rules$)]); - Pptactic.declare_extra_genarg_pprule - ($rawwit$, $lid:rawpr$) - ($globwit$, $lid:globpr$) - ($wit$, $lid:pr$) } - >> ] - -let declare_vernac_argument loc s pr cl = - let se = mlexpr_of_string s in - let wit = <:expr< $lid:"wit_"^s$ >> in - let rawwit = <:expr< $lid:"rawwit_"^s$ >> in - let globwit = <:expr< $lid:"globwit_"^s$ >> in - let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in - let pr_rules = match pr with - | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >> - | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in - declare_str_items loc - [ <:str_item< - value (($lid:"wit_"^s$:Genarg.abstract_argument_type unit Genarg.tlevel), - ($lid:"globwit_"^s$:Genarg.abstract_argument_type unit Genarg.glevel), - $lid:"rawwit_"^s$) = Genarg.create_arg None $se$ >>; - <:str_item< - value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; - <:str_item< do { - Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a)) - (None, [(None, None, $rules$)]); - Pptactic.declare_extra_genarg_pprule - ($rawwit$, $pr_rules$) - ($globwit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not globwit printer") - ($wit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not wit printer") } - >> ] - -open Vernacexpr -open Pcoq -open Pcaml -open PcamlSig - -EXTEND - GLOBAL: str_item; - str_item: - [ [ "ARGUMENT"; "EXTEND"; s = entry_name; - header = argextend_header; - OPT "|"; l = LIST1 argrule SEP "|"; - "END" -> - declare_tactic_argument loc s header l - | "VERNAC"; "ARGUMENT"; "EXTEND"; s = entry_name; - pr = OPT ["PRINTED"; "BY"; pr = LIDENT -> pr]; - OPT "|"; l = LIST1 argrule SEP "|"; - "END" -> - declare_vernac_argument loc s pr l ] ] - ; - argextend_header: - [ [ "TYPED"; "AS"; typ = argtype; - "PRINTED"; "BY"; pr = LIDENT; - f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; - g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; - h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ] -> - (`Uniform typ, pr, f, g, h) - | "PRINTED"; "BY"; pr = LIDENT; - f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; - g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; - h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; - "RAW_TYPED"; "AS"; rawtyp = argtype; - "RAW_PRINTED"; "BY"; rawpr = LIDENT; - "GLOB_TYPED"; "AS"; globtyp = argtype; - "GLOB_PRINTED"; "BY"; globpr = LIDENT -> - (`Specialized (rawtyp, rawpr, globtyp, globpr), pr, f, g, h) ] ] - ; - argtype: - [ "2" - [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ] - | "1" - [ e = argtype; LIDENT "list" -> List0ArgType e - | e = argtype; LIDENT "option" -> OptArgType e ] - | "0" - [ e = LIDENT -> fst (interp_entry_name false None e "") - | "("; e = argtype; ")" -> e ] ] - ; - argrule: - [ [ "["; l = LIST0 genarg; "]"; "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ] - ; - genarg: - [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name false None e "" in - GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) - | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let t, g = interp_entry_name false None e sep in - GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) - | s = STRING -> - if String.length s > 0 && Util.is_letter s.[0] then - Lexer.add_keyword s; - GramTerminal s - ] ] - ; - entry_name: - [ [ s = LIDENT -> s - | UIDENT -> failwith "Argument entry names must be lowercase" - ] ] - ; - END - diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 new file mode 100644 index 00000000..eba1d2b8 --- /dev/null +++ b/parsing/compat.ml4 @@ -0,0 +1,325 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Extend.RightA +| Gramext.LeftA -> Extend.LeftA +| Gramext.NonA -> Extend.NonA + +let of_coq_assoc = function +| Extend.RightA -> Gramext.RightA +| Extend.LeftA -> Gramext.LeftA +| Extend.NonA -> Gramext.NonA + +let of_coq_position = function +| Extend.First -> Gramext.First +| Extend.Last -> Gramext.Last +| Extend.Before s -> Gramext.Before s +| Extend.After s -> Gramext.After s +| Extend.Level s -> Gramext.Level s + +let to_coq_position = function +| Gramext.First -> Extend.First +| Gramext.Last -> Extend.Last +| Gramext.Before s -> Extend.Before s +| Gramext.After s -> Extend.After s +| Gramext.Level s -> Extend.Level s +| Gramext.Like _ -> assert false (** dont use it, not in camlp4 *) + +ELSE + +let to_coq_assoc = function +| PcamlSig.Grammar.RightA -> Extend.RightA +| PcamlSig.Grammar.LeftA -> Extend.LeftA +| PcamlSig.Grammar.NonA -> Extend.NonA + +let of_coq_assoc = function +| Extend.RightA -> PcamlSig.Grammar.RightA +| Extend.LeftA -> PcamlSig.Grammar.LeftA +| Extend.NonA -> PcamlSig.Grammar.NonA + +let of_coq_position = function +| Extend.First -> PcamlSig.Grammar.First +| Extend.Last -> PcamlSig.Grammar.Last +| Extend.Before s -> PcamlSig.Grammar.Before s +| Extend.After s -> PcamlSig.Grammar.After s +| Extend.Level s -> PcamlSig.Grammar.Level s + +let to_coq_position = function +| PcamlSig.Grammar.First -> Extend.First +| PcamlSig.Grammar.Last -> Extend.Last +| PcamlSig.Grammar.Before s -> Extend.Before s +| PcamlSig.Grammar.After s -> Extend.After s +| PcamlSig.Grammar.Level s -> Extend.Level s + +END + + +(** Signature of Lexer *) + +IFDEF CAMLP5 THEN + +module type LexerSig = sig + include Grammar.GLexerType with type te = Tok.t + module Error : sig + type t + exception E of t + val to_string : t -> string + end +end + +ELSE + +module type LexerSig = + Camlp4.Sig.Lexer with module Loc = CompatLoc and type Token.t = Tok.t + +END + +(** Signature and implementation of grammars *) + +IFDEF CAMLP5 THEN + +module type GrammarSig = sig + include Grammar.S with type te = Tok.t + type 'a entry = 'a Entry.e + type internal_entry = Tok.t Gramext.g_entry + type symbol = Tok.t Gramext.g_symbol + type action = Gramext.g_action + type production_rule = symbol list * action + type single_extend_statment = + string option * Gramext.g_assoc option * production_rule list + type extend_statment = + Gramext.position option * single_extend_statment list + val action : 'a -> action + val entry_create : string -> 'a entry + val entry_parse : 'a entry -> parsable -> 'a + val entry_print : Format.formatter -> 'a entry -> unit + val srules' : production_rule list -> symbol + val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a +end + +module GrammarMake (L:LexerSig) : GrammarSig = struct + include Grammar.GMake (L) + type 'a entry = 'a Entry.e + type internal_entry = Tok.t Gramext.g_entry + type symbol = Tok.t Gramext.g_symbol + type action = Gramext.g_action + type production_rule = symbol list * action + type single_extend_statment = + string option * Gramext.g_assoc option * production_rule list + type extend_statment = + Gramext.position option * single_extend_statment list + let action = Gramext.action + let entry_create = Entry.create + let entry_parse e p = + try Entry.parse e p + with Exc_located (loc,e) -> Loc.raise (to_coqloc loc) e +IFDEF CAMLP5_6_02_1 THEN + let entry_print ft x = Entry.print ft x +ELSE + let entry_print _ x = Entry.print x +END + let srules' = Gramext.srules + let parse_tokens_after_filter = Entry.parse_token +end + +ELSE + +module type GrammarSig = sig + include Camlp4.Sig.Grammar.Static + with module Loc = CompatLoc and type Token.t = Tok.t + type 'a entry = 'a Entry.t + type action = Action.t + type parsable + val parsable : char Stream.t -> parsable + val action : 'a -> action + val entry_create : string -> 'a entry + val entry_parse : 'a entry -> parsable -> 'a + val entry_print : Format.formatter -> 'a entry -> unit + val srules' : production_rule list -> symbol +end + +module GrammarMake (L:LexerSig) : GrammarSig = struct + (* We need to refer to Coq's module Loc before it is hidden by include *) + let raise_coq_loc loc e = Loc.raise (to_coqloc loc) e + include Camlp4.Struct.Grammar.Static.Make (L) + type 'a entry = 'a Entry.t + type action = Action.t + type parsable = char Stream.t + let parsable s = s + let action = Action.mk + let entry_create = Entry.mk + let entry_parse e s = + try parse e (*FIXME*)CompatLoc.ghost s + with Exc_located (loc,e) -> raise_coq_loc loc e + let entry_print ft x = Entry.print ft x + let srules' = srules (entry_create "dummy") +end + +END + + +(** Misc functional adjustments *) + +(** - The lexer produces streams made of pairs in camlp4 *) + +let get_tok = IFDEF CAMLP5 THEN fun x -> x ELSE fst END + +(** - Gram.extend is more currified in camlp5 than in camlp4 *) + +IFDEF CAMLP5 THEN +let maybe_curry f x y = f (x,y) +let maybe_uncurry f (x,y) = f x y +ELSE +let maybe_curry f = f +let maybe_uncurry f = f +END + +(** Compatibility with camlp5 strict mode *) +IFDEF CAMLP5 THEN + IFDEF STRICT THEN + let vala x = Ploc.VaVal x + ELSE + let vala x = x + END +ELSE + let vala x = x +END + +(** Fix a quotation difference in [str_item] *) + +let declare_str_items loc l = +IFDEF CAMLP5 THEN + MLast.StDcl (loc, vala l) (* correspond to <:str_item< declare $list:l'$ end >> *) +ELSE + Ast.stSem_of_list l +END + +(** Quotation difference for match clauses *) + +let default_patt loc = + (<:patt< _ >>, vala None, <:expr< failwith "Extension: cannot occur" >>) + +IFDEF CAMLP5 THEN + +let make_fun loc cl = + let l = cl @ [default_patt loc] in + MLast.ExFun (loc, vala l) (* correspond to <:expr< fun [ $list:l$ ] >> *) + +ELSE + +let make_fun loc cl = + let mk_when = function + | Some w -> w + | None -> Ast.ExNil loc + in + let mk_clause (patt,optwhen,expr) = + (* correspond to <:match_case< ... when ... -> ... >> *) + Ast.McArr (loc, patt, mk_when optwhen, expr) in + let init = mk_clause (default_patt loc) in + let add_clause x acc = Ast.McOr (loc, mk_clause x, acc) in + let l = List.fold_right add_clause cl init in + Ast.ExFun (loc,l) (* correspond to <:expr< fun [ $l$ ] >> *) + +END + +(** Explicit antiquotation $anti:... $ *) + +IFDEF CAMLP5 THEN +let expl_anti loc e = <:expr< $anti:e$ >> +ELSE +let expl_anti _loc e = e (* FIXME: understand someday if we can do better *) +END + +(** Qualified names in OCaml *) + +IFDEF CAMLP5 THEN +let qualified_name loc path name = + let fold dir accu = <:expr< $uid:dir$.$accu$ >> in + List.fold_right fold path <:expr< $lid:name$ >> +ELSE +let qualified_name loc path name = + let fold dir accu = Ast.IdAcc (loc, Ast.IdUid (loc, dir), accu) in + let path = List.fold_right fold path (Ast.IdLid (loc, name)) in + Ast.ExId (loc, path) +END diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml new file mode 100644 index 00000000..01194c60 --- /dev/null +++ b/parsing/egramcoq.ml @@ -0,0 +1,385 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* act(x1..xi) + * is written (with camlp4 conventions): + * (fun vi -> .... (fun v1 -> act(v1 .. vi) )..) + * where v1..vi are the values generated by non-terminals nt1..nti. + * Since the actions are executed by substituting an environment, + * the make_*_action family build the following closure: + * + * ((fun env -> + * (fun vi -> + * (fun env -> ... + * + * (fun v1 -> + * (fun env -> gram_action .. env act) + * ((x1,v1)::env)) + * ...) + * ((xi,vi)::env))) + * []) + *) + +(**********************************************************************) +(** Declare Notations grammar rules *) + +let constr_expr_of_name (loc,na) = match na with + | Anonymous -> CHole (loc,None,Misctypes.IntroAnonymous,None) + | Name id -> CRef (Ident (loc,id), None) + +let cases_pattern_expr_of_name (loc,na) = match na with + | Anonymous -> CPatAtom (loc,None) + | Name id -> CPatAtom (loc,Some (Ident (loc,id))) + +type grammar_constr_prod_item = + | GramConstrTerminal of Tok.t + | GramConstrNonTerminal of constr_prod_entry_key * Id.t option + | GramConstrListMark of int * bool + (* tells action rule to make a list of the n previous parsed items; + concat with last parsed list if true *) + +let make_constr_action + (f : Loc.t -> constr_notation_substitution -> constr_expr) pil = + let rec make (constrs,constrlists,binders as fullsubst) = function + | [] -> + Gram.action (fun (loc:CompatLoc.t) -> f (!@loc) fullsubst) + | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl -> + (* parse a non-binding item *) + Gram.action (fun _ -> make fullsubst tl) + | GramConstrNonTerminal (typ, Some _) :: tl -> + (* parse a binding non-terminal *) + (match typ with + | (ETConstr _| ETOther _) -> + Gram.action (fun (v:constr_expr) -> + make (v :: constrs, constrlists, binders) tl) + | ETReference -> + Gram.action (fun (v:reference) -> + make (CRef (v,None) :: constrs, constrlists, binders) tl) + | ETName -> + Gram.action (fun (na:Loc.t * Name.t) -> + make (constr_expr_of_name na :: constrs, constrlists, binders) tl) + | ETBigint -> + Gram.action (fun (v:Bigint.bigint) -> + make (CPrim(Loc.ghost,Numeral v) :: constrs, constrlists, binders) tl) + | ETConstrList (_,n) -> + Gram.action (fun (v:constr_expr list) -> + make (constrs, v::constrlists, binders) tl) + | ETBinder _ | ETBinderList (true,_) -> + Gram.action (fun (v:local_binder list) -> + make (constrs, constrlists, v::binders) tl) + | ETBinderList (false,_) -> + Gram.action (fun (v:local_binder list list) -> + make (constrs, constrlists, List.flatten v::binders) tl) + | ETPattern -> + failwith "Unexpected entry of type cases pattern") + | GramConstrListMark (n,b) :: tl -> + (* Rebuild expansions of ConstrList *) + let heads,constrs = List.chop n constrs in + let constrlists = + if b then (heads@List.hd constrlists)::List.tl constrlists + else heads::constrlists + in make (constrs, constrlists, binders) tl + in + make ([],[],[]) (List.rev pil) + +let check_cases_pattern_env loc (env,envlist,hasbinders) = + if hasbinders then Topconstr.error_invalid_pattern_notation loc + else (env,envlist) + +let make_cases_pattern_action + (f : Loc.t -> cases_pattern_notation_substitution -> cases_pattern_expr) pil = + let rec make (env,envlist,hasbinders as fullenv) = function + | [] -> + Gram.action + (fun (loc:CompatLoc.t) -> + let loc = !@loc in + f loc (check_cases_pattern_env loc fullenv)) + | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl -> + (* parse a non-binding item *) + Gram.action (fun _ -> make fullenv tl) + | GramConstrNonTerminal (typ, Some _) :: tl -> + (* parse a binding non-terminal *) + (match typ with + | ETConstr _ -> (* pattern non-terminal *) + Gram.action (fun (v:cases_pattern_expr) -> + make (v::env, envlist, hasbinders) tl) + | ETReference -> + Gram.action (fun (v:reference) -> + make (CPatAtom (Loc.ghost,Some v) :: env, envlist, hasbinders) tl) + | ETName -> + Gram.action (fun (na:Loc.t * Name.t) -> + make (cases_pattern_expr_of_name na :: env, envlist, hasbinders) tl) + | ETBigint -> + Gram.action (fun (v:Bigint.bigint) -> + make (CPatPrim (Loc.ghost,Numeral v) :: env, envlist, hasbinders) tl) + | ETConstrList (_,_) -> + Gram.action (fun (vl:cases_pattern_expr list) -> + make (env, vl :: envlist, hasbinders) tl) + | ETBinder _ | ETBinderList (true,_) -> + Gram.action (fun (v:local_binder list) -> + make (env, envlist, hasbinders) tl) + | ETBinderList (false,_) -> + Gram.action (fun (v:local_binder list list) -> + make (env, envlist, true) tl) + | (ETPattern | ETOther _) -> + anomaly (Pp.str "Unexpected entry of type cases pattern or other")) + | GramConstrListMark (n,b) :: tl -> + (* Rebuild expansions of ConstrList *) + let heads,env = List.chop n env in + if b then + make (env,(heads@List.hd envlist)::List.tl envlist,hasbinders) tl + else + make (env,heads::envlist,hasbinders) tl + in + make ([],[],false) (List.rev pil) + +let rec make_constr_prod_item assoc from forpat = function + | GramConstrTerminal tok :: l -> + gram_token_of_token tok :: make_constr_prod_item assoc from forpat l + | GramConstrNonTerminal (nt, ovar) :: l -> + symbol_of_constr_prod_entry_key assoc from forpat nt + :: make_constr_prod_item assoc from forpat l + | GramConstrListMark _ :: l -> + make_constr_prod_item assoc from forpat l + | [] -> + [] + +let prepare_empty_levels forpat (pos,p4assoc,name,reinit) = + let entry = + if forpat then weaken_entry Constr.pattern + else weaken_entry Constr.operconstr in + grammar_extend entry reinit (pos,[(name, p4assoc, [])]) + +let pure_sublevels level symbs = + let filter s = + try + let i = level_of_snterml s in + begin match level with + | Some j when Int.equal i j -> None + | _ -> Some i + end + with Failure _ -> None + in + List.map_filter filter symbs + +let extend_constr (entry,level) (n,assoc) mkact forpat rules = + List.fold_left (fun nb pt -> + let symbs = make_constr_prod_item assoc n forpat pt in + let pure_sublevels = pure_sublevels level symbs in + let needed_levels = register_empty_levels forpat pure_sublevels in + let map_level (pos, ass1, name, ass2) = + (Option.map of_coq_position pos, Option.map of_coq_assoc ass1, name, ass2) in + let needed_levels = List.map map_level needed_levels in + let pos,p4assoc,name,reinit = find_position forpat assoc level in + let nb_decls = List.length needed_levels + 1 in + List.iter (prepare_empty_levels forpat) needed_levels; + grammar_extend entry reinit (Option.map of_coq_position pos, + [(name, Option.map of_coq_assoc p4assoc, [symbs, mkact pt])]); + nb_decls) 0 rules + +type notation_grammar = { + notgram_level : int; + notgram_assoc : gram_assoc option; + notgram_notation : notation; + notgram_prods : grammar_constr_prod_item list list; + notgram_typs : notation_var_internalization_type list; +} + +let extend_constr_constr_notation ng = + let level = ng.notgram_level in + let mkact loc env = CNotation (loc, ng.notgram_notation, env) in + let e = interp_constr_entry_key false (ETConstr (level, ())) in + let ext = (ETConstr (level, ()), ng.notgram_assoc) in + extend_constr e ext (make_constr_action mkact) false ng.notgram_prods + +let extend_constr_pat_notation ng = + let level = ng.notgram_level in + let mkact loc env = CPatNotation (loc, ng.notgram_notation, env, []) in + let e = interp_constr_entry_key true (ETConstr (level, ())) in + let ext = ETConstr (level, ()), ng.notgram_assoc in + extend_constr e ext (make_cases_pattern_action mkact) true ng.notgram_prods + +let extend_constr_notation ng = + (* Add the notation in constr *) + let nb = extend_constr_constr_notation ng in + (* Add the notation in cases_pattern *) + let nb' = extend_constr_pat_notation ng in + nb + nb' + +(**********************************************************************) +(** Grammar declaration for Tactic Notation (Coq level) *) + +let get_tactic_entry n = + if Int.equal n 0 then + weaken_entry Tactic.simple_tactic, None + else if Int.equal n 5 then + weaken_entry Tactic.binder_tactic, None + else if 1<=n && n<5 then + weaken_entry Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) + else + error ("Invalid Tactic Notation level: "^(string_of_int n)^".") + +(**********************************************************************) +(** State of the grammar extensions *) + +type tactic_grammar = { + tacgram_level : int; + tacgram_prods : grammar_prod_item list; +} + +type all_grammar_command = + | Notation of Notation.level * notation_grammar + | TacticGrammar of KerName.t * tactic_grammar + | MLTacticGrammar of ml_tactic_name * grammar_prod_item list list + +(** ML Tactic grammar extensions *) + +let add_ml_tactic_entry name prods = + let entry = weaken_entry Tactic.simple_tactic in + let mkact loc l : raw_tactic_expr = Tacexpr.TacML (loc, name, List.map snd l) in + let rules = List.map (make_rule mkact) prods in + synchronize_level_positions (); + grammar_extend entry None (None ,[(None, None, List.rev rules)]); + 1 + +(* Declaration of the tactic grammar rule *) + +let head_is_ident tg = match tg.tacgram_prods with +| GramTerminal _::_ -> true +| _ -> false + +(** Tactic grammar extensions *) + +let add_tactic_entry kn tg = + let entry, pos = get_tactic_entry tg.tacgram_level in + let mkact loc l = (TacAlias (loc,kn,l):raw_tactic_expr) in + let () = + if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then + error "Notation for simple tactic must start with an identifier." + in + let rules = make_rule mkact tg.tacgram_prods in + synchronize_level_positions (); + grammar_extend entry None (Option.map of_coq_position pos,[(None, None, List.rev [rules])]); + 1 + +let (grammar_state : (int * all_grammar_command) list ref) = ref [] + +let extend_grammar gram = + let nb = match gram with + | Notation (_,a) -> extend_constr_notation a + | TacticGrammar (kn, g) -> add_tactic_entry kn g + | MLTacticGrammar (name, pr) -> add_ml_tactic_entry name pr + in + grammar_state := (nb,gram) :: !grammar_state + +let extend_constr_grammar pr ntn = + extend_grammar (Notation (pr, ntn)) + +let extend_tactic_grammar kn ntn = + extend_grammar (TacticGrammar (kn, ntn)) + +let extend_ml_tactic_grammar name ntn = + extend_grammar (MLTacticGrammar (name, ntn)) + +let recover_constr_grammar ntn prec = + let filter = function + | _, Notation (prec', ng) when + Notation.level_eq prec prec' && + String.equal ntn ng.notgram_notation -> Some ng + | _ -> None + in + match List.map_filter filter !grammar_state with + | [x] -> x + | _ -> assert false + +(* Summary functions: the state of the lexer is included in that of the parser. + Because the grammar affects the set of keywords when adding or removing + grammar rules. *) +type frozen_t = (int * all_grammar_command) list * Lexer.frozen_t + +let freeze _ : frozen_t = (!grammar_state, Lexer.freeze ()) + +(* We compare the current state of the grammar and the state to unfreeze, + by computing the longest common suffixes *) +let factorize_grams l1 l2 = + if l1 == l2 then ([], [], l1) else List.share_tails l1 l2 + +let number_of_entries gcl = + List.fold_left (fun n (p,_) -> n + p) 0 gcl + +let unfreeze (grams, lex) = + let (undo, redo, common) = factorize_grams !grammar_state grams in + let n = number_of_entries undo in + remove_grammars n; + remove_levels n; + grammar_state := common; + Lexer.unfreeze lex; + List.iter extend_grammar (List.rev_map snd redo) + +(** No need to provide an init function : the grammar state is + statically available, and already empty initially, while + the lexer state should not be resetted, since it contains + keywords declared in g_*.ml4 *) + +let _ = + Summary.declare_summary "GRAMMAR_LEXER" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = Summary.nop } + +let with_grammar_rule_protection f x = + let fs = freeze false in + try let a = f x in unfreeze fs; a + with reraise -> + let reraise = Errors.push reraise in + let () = unfreeze fs in + iraise reraise + +(**********************************************************************) +(** Ltac quotations *) + +let ltac_quotations = ref String.Set.empty + +let create_ltac_quotation name cast wit e = + let () = + if String.Set.mem name !ltac_quotations then + failwith ("Ltac quotation " ^ name ^ " already registered") + in + let () = ltac_quotations := String.Set.add name !ltac_quotations in +(* let level = Some "1" in *) + let level = None in + let assoc = Some (of_coq_assoc Extend.RightA) in + let rule = [ + gram_token_of_string name; + gram_token_of_string ":"; + symbol_of_prod_entry_key (Agram (Gram.Entry.name e)); + ] in + let action v _ _ loc = + let loc = !@loc in + let arg = TacGeneric (Genarg.in_gen (Genarg.rawwit wit) (cast (loc, v))) in + TacArg (loc, arg) + in + let gram = (level, assoc, [rule, Gram.action action]) in + maybe_uncurry (Gram.extend Tactic.tactic_expr) (None, [gram]) diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli new file mode 100644 index 00000000..2b0f7da8 --- /dev/null +++ b/parsing/egramcoq.mli @@ -0,0 +1,69 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* notation_grammar -> unit +(** Add a term notation rule to the parsing system. *) + +val extend_tactic_grammar : KerName.t -> tactic_grammar -> unit +(** Add a tactic notation rule to the parsing system. This produces a TacAlias + tactic with the provided kernel name. *) + +val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> grammar_prod_item list list -> unit +(** Add a ML tactic notation rule to the parsing system. This produces a + TacML tactic with the provided string as name. *) + +val recover_constr_grammar : notation -> Notation.level -> notation_grammar +(** For a declared grammar, returns the rule + the ordered entry types + of variables in the rule (for use in the interpretation) *) + +val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b + +(** {5 Adding tactic quotations} *) + +val create_ltac_quotation : string -> ('grm Loc.located -> 'raw) -> + ('raw, 'glb, 'top) genarg_type -> 'grm Gram.entry -> unit +(** [create_ltac_quotation name f wit e] adds a quotation rule to Ltac, that is, + Ltac grammar now accepts arguments of the form ["name" ":" ], and + generates a generic argument using [f] on the entry parsed by [e]. *) diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml deleted file mode 100644 index 6deb7622..00000000 --- a/parsing/egrammar.ml +++ /dev/null @@ -1,368 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* act(x1..xi) - * is written (with camlp4 conventions): - * (fun vi -> .... (fun v1 -> act(v1 .. vi) )..) - * where v1..vi are the values generated by non-terminals nt1..nti. - * Since the actions are executed by substituting an environment, - * the make_*_action family build the following closure: - * - * ((fun env -> - * (fun vi -> - * (fun env -> ... - * - * (fun v1 -> - * (fun env -> gram_action .. env act) - * ((x1,v1)::env)) - * ...) - * ((xi,vi)::env))) - * []) - *) - -(**********************************************************************) -(** Declare Notations grammar rules *) - -let constr_expr_of_name (loc,na) = match na with - | Anonymous -> CHole (loc,None) - | Name id -> CRef (Ident (loc,id)) - -let cases_pattern_expr_of_name (loc,na) = match na with - | Anonymous -> CPatAtom (loc,None) - | Name id -> CPatAtom (loc,Some (Ident (loc,id))) - -type grammar_constr_prod_item = - | GramConstrTerminal of Tok.t - | GramConstrNonTerminal of constr_prod_entry_key * identifier option - | GramConstrListMark of int * bool - (* tells action rule to make a list of the n previous parsed items; - concat with last parsed list if true *) - -let make_constr_action - (f : loc -> constr_notation_substitution -> constr_expr) pil = - let rec make (constrs,constrlists,binders as fullsubst) = function - | [] -> - Gram.action (fun loc -> f loc fullsubst) - | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl -> - (* parse a non-binding item *) - Gram.action (fun _ -> make fullsubst tl) - | GramConstrNonTerminal (typ, Some _) :: tl -> - (* parse a binding non-terminal *) - (match typ with - | (ETConstr _| ETOther _) -> - Gram.action (fun (v:constr_expr) -> - make (v :: constrs, constrlists, binders) tl) - | ETReference -> - Gram.action (fun (v:reference) -> - make (CRef v :: constrs, constrlists, binders) tl) - | ETName -> - Gram.action (fun (na:name located) -> - make (constr_expr_of_name na :: constrs, constrlists, binders) tl) - | ETBigint -> - Gram.action (fun (v:Bigint.bigint) -> - make (CPrim(dummy_loc,Numeral v) :: constrs, constrlists, binders) tl) - | ETConstrList (_,n) -> - Gram.action (fun (v:constr_expr list) -> - make (constrs, v::constrlists, binders) tl) - | ETBinder _ | ETBinderList (true,_) -> - Gram.action (fun (v:local_binder list) -> - make (constrs, constrlists, v::binders) tl) - | ETBinderList (false,_) -> - Gram.action (fun (v:local_binder list list) -> - make (constrs, constrlists, List.flatten v::binders) tl) - | ETPattern -> - failwith "Unexpected entry of type cases pattern") - | GramConstrListMark (n,b) :: tl -> - (* Rebuild expansions of ConstrList *) - let heads,constrs = list_chop n constrs in - let constrlists = - if b then (heads@List.hd constrlists)::List.tl constrlists - else heads::constrlists - in make (constrs, constrlists, binders) tl - in - make ([],[],[]) (List.rev pil) - -let check_cases_pattern_env loc (env,envlist,hasbinders) = - if hasbinders then error_invalid_pattern_notation loc else (env,envlist) - -let make_cases_pattern_action - (f : loc -> cases_pattern_notation_substitution -> cases_pattern_expr) pil = - let rec make (env,envlist,hasbinders as fullenv) = function - | [] -> - Gram.action (fun loc -> f loc (check_cases_pattern_env loc fullenv)) - | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl -> - (* parse a non-binding item *) - Gram.action (fun _ -> make fullenv tl) - | GramConstrNonTerminal (typ, Some _) :: tl -> - (* parse a binding non-terminal *) - (match typ with - | ETConstr _ -> (* pattern non-terminal *) - Gram.action (fun (v:cases_pattern_expr) -> - make (v::env, envlist, hasbinders) tl) - | ETReference -> - Gram.action (fun (v:reference) -> - make (CPatAtom (dummy_loc,Some v) :: env, envlist, hasbinders) tl) - | ETName -> - Gram.action (fun (na:name located) -> - make (cases_pattern_expr_of_name na :: env, envlist, hasbinders) tl) - | ETBigint -> - Gram.action (fun (v:Bigint.bigint) -> - make (CPatPrim (dummy_loc,Numeral v) :: env, envlist, hasbinders) tl) - | ETConstrList (_,_) -> - Gram.action (fun (vl:cases_pattern_expr list) -> - make (env, vl :: envlist, hasbinders) tl) - | ETBinder _ | ETBinderList (true,_) -> - Gram.action (fun (v:local_binder list) -> - make (env, envlist, hasbinders) tl) - | ETBinderList (false,_) -> - Gram.action (fun (v:local_binder list list) -> - make (env, envlist, true) tl) - | (ETPattern | ETOther _) -> - anomaly "Unexpected entry of type cases pattern or other") - | GramConstrListMark (n,b) :: tl -> - (* Rebuild expansions of ConstrList *) - let heads,env = list_chop n env in - if b then - make (env,(heads@List.hd envlist)::List.tl envlist,hasbinders) tl - else - make (env,heads::envlist,hasbinders) tl - in - make ([],[],false) (List.rev pil) - -let rec make_constr_prod_item assoc from forpat = function - | GramConstrTerminal tok :: l -> - gram_token_of_token tok :: make_constr_prod_item assoc from forpat l - | GramConstrNonTerminal (nt, ovar) :: l -> - symbol_of_constr_prod_entry_key assoc from forpat nt - :: make_constr_prod_item assoc from forpat l - | GramConstrListMark _ :: l -> - make_constr_prod_item assoc from forpat l - | [] -> - [] - -let prepare_empty_levels forpat (pos,p4assoc,name,reinit) = - let entry = - if forpat then weaken_entry Constr.pattern - else weaken_entry Constr.operconstr in - grammar_extend entry reinit (pos,[(name, p4assoc, [])]) - -let pure_sublevels level symbs = - map_succeed - (function s -> - let i = level_of_snterml s in - if level = Some i then failwith ""; - i) - symbs - -let extend_constr (entry,level) (n,assoc) mkact forpat rules = - List.fold_left (fun nb pt -> - let symbs = make_constr_prod_item assoc n forpat pt in - let pure_sublevels = pure_sublevels level symbs in - let needed_levels = register_empty_levels forpat pure_sublevels in - let pos,p4assoc,name,reinit = find_position forpat assoc level in - let nb_decls = List.length needed_levels + 1 in - List.iter (prepare_empty_levels forpat) needed_levels; - grammar_extend entry reinit (pos,[(name, p4assoc, [symbs, mkact pt])]); - nb_decls) 0 rules - -let extend_constr_notation (n,assoc,ntn,rules) = - (* Add the notation in constr *) - let mkact loc env = CNotation (loc,ntn,env) in - let e = interp_constr_entry_key false (ETConstr (n,())) in - let nb = extend_constr e (ETConstr(n,()),assoc) (make_constr_action mkact) false rules in - (* Add the notation in cases_pattern *) - let mkact loc env = CPatNotation (loc,ntn,env) in - let e = interp_constr_entry_key true (ETConstr (n,())) in - let nb' = extend_constr e (ETConstr (n,()),assoc) (make_cases_pattern_action mkact) - true rules in - nb+nb' - -(**********************************************************************) -(** Making generic actions in type generic_argument *) - -let make_generic_action - (f:loc -> ('b * raw_generic_argument) list -> 'a) pil = - let rec make env = function - | [] -> - Gram.action (fun loc -> f loc env) - | None :: tl -> (* parse a non-binding item *) - Gram.action (fun _ -> make env tl) - | Some (p, t) :: tl -> (* non-terminal *) - Gram.action (fun v -> make ((p,in_generic t v) :: env) tl) in - make [] (List.rev pil) - -let make_rule univ f g pt = - let (symbs,ntl) = List.split (List.map g pt) in - let act = make_generic_action f ntl in - (symbs, act) - -(**********************************************************************) -(** Grammar extensions declared at ML level *) - -type grammar_prod_item = - | GramTerminal of string - | GramNonTerminal of - loc * argument_type * prod_entry_key * identifier option - -let make_prod_item = function - | GramTerminal s -> (gram_token_of_string s, None) - | GramNonTerminal (_,t,e,po) -> - (symbol_of_prod_entry_key e, Option.map (fun p -> (p,t)) po) - -(* Tactic grammar extensions *) - -let extend_tactic_grammar s gl = - let univ = get_univ "tactic" in - let mkact loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in - let rules = List.map (make_rule univ mkact make_prod_item) gl in - maybe_uncurry (Gram.extend Tactic.simple_tactic) - (None,[(None, None, List.rev rules)]) - -(* Vernac grammar extensions *) - -let vernac_exts = ref [] -let get_extend_vernac_grammars () = !vernac_exts - -let extend_vernac_command_grammar s nt gl = - let nt = Option.default Vernac_.command nt in - vernac_exts := (s,gl) :: !vernac_exts; - let univ = get_univ "vernac" in - let mkact loc l = VernacExtend (s,List.map snd l) in - let rules = List.map (make_rule univ mkact make_prod_item) gl in - maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)]) - -(**********************************************************************) -(** Grammar declaration for Tactic Notation (Coq level) *) - -let get_tactic_entry n = - if n = 0 then - weaken_entry Tactic.simple_tactic, None - else if n = 5 then - weaken_entry Tactic.binder_tactic, None - else if 1<=n && n<5 then - weaken_entry Tactic.tactic_expr, Some (Compat.Level (string_of_int n)) - else - error ("Invalid Tactic Notation level: "^(string_of_int n)^".") - -(* Declaration of the tactic grammar rule *) - -let head_is_ident = function GramTerminal _::_ -> true | _ -> false - -let add_tactic_entry (key,lev,prods,tac) = - let univ = get_univ "tactic" in - let entry, pos = get_tactic_entry lev in - let rules = - if lev = 0 then begin - if not (head_is_ident prods) then - error "Notation for simple tactic must start with an identifier."; - let mkact s tac loc l = - (TacAlias(loc,s,l,tac):raw_atomic_tactic_expr) in - make_rule univ (mkact key tac) make_prod_item prods - end - else - let mkact s tac loc l = - (TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) in - make_rule univ (mkact key tac) make_prod_item prods in - synchronize_level_positions (); - grammar_extend entry None (pos,[(None, None, List.rev [rules])]); - 1 - -(**********************************************************************) -(** State of the grammar extensions *) - -type notation_grammar = - int * gram_assoc option * notation * grammar_constr_prod_item list list - -type all_grammar_command = - | Notation of - (precedence * tolerability list) * - notation_var_internalization_type list * - notation_grammar - | TacticGrammar of - (string * int * grammar_prod_item list * - (dir_path * Tacexpr.glob_tactic_expr)) - -let (grammar_state : (int * all_grammar_command) list ref) = ref [] - -let extend_grammar gram = - let nb = match gram with - | Notation (_,_,a) -> extend_constr_notation a - | TacticGrammar g -> add_tactic_entry g in - grammar_state := (nb,gram) :: !grammar_state - -let recover_notation_grammar ntn prec = - let l = map_succeed (function - | _, Notation (prec',vars,(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' -> - vars, x - | _ -> - failwith "") !grammar_state in - assert (List.length l = 1); - List.hd l - -(* Summary functions: the state of the lexer is included in that of the parser. - Because the grammar affects the set of keywords when adding or removing - grammar rules. *) -type frozen_t = all_grammar_command list * Lexer.frozen_t - -let freeze () = (!grammar_state, Lexer.freeze ()) - -(* We compare the current state of the grammar and the state to unfreeze, - by computing the longest common suffixes *) -let factorize_grams l1 l2 = - if l1 == l2 then ([], [], l1) else list_share_tails l1 l2 - -let number_of_entries gcl = - List.fold_left (fun n (p,_) -> n + p) 0 gcl - -let unfreeze (grams, lex) = - let (undo, redo, common) = factorize_grams !grammar_state grams in - let n = number_of_entries undo in - remove_grammars n; - remove_levels n; - grammar_state := common; - Lexer.unfreeze lex; - List.iter extend_grammar (List.rev (List.map snd redo)) - -let init_grammar () = - remove_grammars (number_of_entries !grammar_state); - grammar_state := [] - -let init () = - init_grammar () - -open Summary - -let _ = - declare_summary "GRAMMAR_LEXER" - { freeze_function = freeze; - unfreeze_function = unfreeze; - init_function = init } - -let with_grammar_rule_protection f x = - let fs = freeze () in - try let a = f x in unfreeze fs; a - with reraise -> unfreeze fs; raise reraise diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli deleted file mode 100644 index 094b4203..00000000 --- a/parsing/egrammar.mli +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit - -val extend_tactic_grammar : - string -> grammar_prod_item list list -> unit - -val extend_vernac_command_grammar : - string -> vernac_expr Gram.entry option -> grammar_prod_item list list -> unit - -val get_extend_vernac_grammars : - unit -> (string * grammar_prod_item list list) list - -(** For a declared grammar, returns the rule + the ordered entry types - of variables in the rule (for use in the interpretation) *) -val recover_notation_grammar : - notation -> (precedence * tolerability list) -> - notation_var_internalization_type list * notation_grammar - -val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b diff --git a/parsing/egramml.ml b/parsing/egramml.ml new file mode 100644 index 00000000..8fe03b36 --- /dev/null +++ b/parsing/egramml.ml @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ('b * raw_generic_argument) list -> 'a) pil = + let rec make env = function + | [] -> + Gram.action (fun loc -> f (to_coqloc loc) env) + | None :: tl -> (* parse a non-binding item *) + Gram.action (fun _ -> make env tl) + | Some (p, t) :: tl -> (* non-terminal *) + Gram.action (fun v -> make ((p, Unsafe.inj t v) :: env) tl) in + make [] (List.rev pil) + +(** Grammar extensions declared at ML level *) + +type grammar_prod_item = + | GramTerminal of string + | GramNonTerminal of + Loc.t * argument_type * prod_entry_key * Id.t option + +let make_prod_item = function + | GramTerminal s -> (gram_token_of_string s, None) + | GramNonTerminal (_,t,e,po) -> + (symbol_of_prod_entry_key e, Option.map (fun p -> (p,t)) po) + +let make_rule mkact pt = + let (symbs,ntl) = List.split (List.map make_prod_item pt) in + let act = make_generic_action mkact ntl in + (symbs, act) + +(** Vernac grammar extensions *) + +let vernac_exts = ref [] + +let get_extend_vernac_rule (s, i) = + try + let find ((name, j), _) = String.equal name s && Int.equal i j in + let (_, rules) = List.find find !vernac_exts in + rules + with + | Failure _ -> raise Not_found + +let extend_vernac_command_grammar s nt gl = + let nt = Option.default Vernac_.command nt in + vernac_exts := (s,gl) :: !vernac_exts; + let mkact loc l = VernacExtend (s,List.map snd l) in + let rules = [make_rule mkact gl] in + maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)]) diff --git a/parsing/egramml.mli b/parsing/egramml.mli new file mode 100644 index 00000000..9ebb5b83 --- /dev/null +++ b/parsing/egramml.mli @@ -0,0 +1,29 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Vernacexpr.vernac_expr Pcoq.Gram.entry option -> + grammar_prod_item list -> unit + +val get_extend_vernac_rule : Vernacexpr.extend_name -> grammar_prod_item list + +(** Utility function reused in Egramcoq : *) + +val make_rule : + (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'b) -> + grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action diff --git a/parsing/extend.ml b/parsing/extend.ml deleted file mode 100644 index 620e2ac2..00000000 --- a/parsing/extend.ml +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* wit_tactic0 - | 1 -> wit_tactic1 - | 2 -> wit_tactic2 - | 3 -> wit_tactic3 - | 4 -> wit_tactic4 - | 5 -> wit_tactic5 - | n -> anomaly ("Unavailable tactic level: "^string_of_int n) - -let globwit_tactic = function - | 0 -> globwit_tactic0 - | 1 -> globwit_tactic1 - | 2 -> globwit_tactic2 - | 3 -> globwit_tactic3 - | 4 -> globwit_tactic4 - | 5 -> globwit_tactic5 - | n -> anomaly ("Unavailable tactic level: "^string_of_int n) - -let rawwit_tactic = function - | 0 -> rawwit_tactic0 - | 1 -> rawwit_tactic1 - | 2 -> rawwit_tactic2 - | 3 -> rawwit_tactic3 - | 4 -> rawwit_tactic4 - | 5 -> rawwit_tactic5 - | n -> anomaly ("Unavailable tactic level: "^string_of_int n) - -let tactic_genarg_level s = - if String.length s = 7 && String.sub s 0 6 = "tactic" then - let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48) - else None - else None - -let is_tactic_genarg = function -| ExtraArgType s -> tactic_genarg_level s <> None -| _ -> false diff --git a/parsing/extrawit.mli b/parsing/extrawit.mli deleted file mode 100644 index d8f36928..00000000 --- a/parsing/extrawit.mli +++ /dev/null @@ -1,49 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (raw_tactic_expr,rlevel) abstract_argument_type -val globwit_tactic : int -> (glob_tactic_expr,glevel) abstract_argument_type -val wit_tactic : int -> (glob_tactic_expr,tlevel) abstract_argument_type - -val rawwit_tactic0 : (raw_tactic_expr,rlevel) abstract_argument_type -val globwit_tactic0 : (glob_tactic_expr,glevel) abstract_argument_type -val wit_tactic0 : (glob_tactic_expr,tlevel) abstract_argument_type - -val rawwit_tactic1 : (raw_tactic_expr,rlevel) abstract_argument_type -val globwit_tactic1 : (glob_tactic_expr,glevel) abstract_argument_type -val wit_tactic1 : (glob_tactic_expr,tlevel) abstract_argument_type - -val rawwit_tactic2 : (raw_tactic_expr,rlevel) abstract_argument_type -val globwit_tactic2 : (glob_tactic_expr,glevel) abstract_argument_type -val wit_tactic2 : (glob_tactic_expr,tlevel) abstract_argument_type - -val rawwit_tactic3 : (raw_tactic_expr,rlevel) abstract_argument_type -val globwit_tactic3 : (glob_tactic_expr,glevel) abstract_argument_type -val wit_tactic3 : (glob_tactic_expr,tlevel) abstract_argument_type - -val rawwit_tactic4 : (raw_tactic_expr,rlevel) abstract_argument_type -val globwit_tactic4 : (glob_tactic_expr,glevel) abstract_argument_type -val wit_tactic4 : (glob_tactic_expr,tlevel) abstract_argument_type - -val rawwit_tactic5 : (raw_tactic_expr,rlevel) abstract_argument_type -val globwit_tactic5 : (glob_tactic_expr,glevel) abstract_argument_type -val wit_tactic5 : (glob_tactic_expr,tlevel) abstract_argument_type - -val is_tactic_genarg : argument_type -> bool - -val tactic_genarg_level : string -> int option diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 325c1cec..8246df28 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -1,23 +1,27 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* c - | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty)) + | (c,(_,Some ty)) -> + let loc = Loc.merge (constr_loc c) (constr_loc ty) + in CCast(loc, c, CastConv ty) + +let binder_of_name expl (loc,na) = + LocalRawAssum ([loc, na], Default expl, + CHole (loc, Some (Evar_kinds.BinderType na), IntroAnonymous, None)) let binders_of_names l = - List.map (fun (loc, na) -> - LocalRawAssum ([loc, na], Default Explicit, - CHole (loc, Some (Evd.BinderType na)))) l + List.map (binder_of_name Explicit) l let binders_of_lidents l = - List.map (fun (loc, id) -> - LocalRawAssum ([loc, Name id], Default Glob_term.Explicit, - CHole (loc, Some (Evd.BinderType (Name id))))) l + List.map (fun (loc, id) -> binder_of_name Explicit (loc, Name id)) l let mk_fixb (id,bl,ann,body,(loc,tyc)) = let ty = match tyc with Some ty -> ty - | None -> CHole (loc, None) in + | None -> CHole (loc, None, IntroAnonymous, None) in (id,ann,bl,ty,body) let mk_cofixb (id,bl,ann,body,(loc,tyc)) = let _ = Option.map (fun (aloc,_) -> - Util.user_err_loc + Errors.user_err_loc (aloc,"Constr:mk_cofixb", Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in let ty = match tyc with Some ty -> ty - | None -> CHole (loc, None) in + | None -> CHole (loc, None, IntroAnonymous, None) in (id,bl,ty,body) let mk_fix(loc,kw,id,dcls) = @@ -82,7 +88,7 @@ let lpar_id_coloneq = (match get_tok (stream_nth 2 strm) with | KEYWORD ":=" -> stream_njunk 3 strm; - Names.id_of_string s + Names.Id.of_string s | _ -> err ()) | _ -> err ()) | _ -> err ()) @@ -96,7 +102,7 @@ let impl_ident_head = | IDENT ("wf"|"struct"|"measure") -> err () | IDENT s -> stream_njunk 2 strm; - Names.id_of_string s + Names.Id.of_string s | _ -> err ()) | _ -> err ()) @@ -108,7 +114,7 @@ let name_colon = (match get_tok (stream_nth 1 strm) with | KEYWORD ":" -> stream_njunk 2 strm; - Name (Names.id_of_string s) + Name (Names.Id.of_string s) | _ -> err ()) | KEYWORD "_" -> (match get_tok (stream_nth 1 strm) with @@ -129,10 +135,10 @@ GEXTEND Gram [ [ id = Prim.ident -> id (* This is used in quotations and Syntax *) - | id = METAIDENT -> id_of_string id ] ] + | id = METAIDENT -> Id.of_string id ] ] ; Prim.name: - [ [ "_" -> (loc, Anonymous) ] ] + [ [ "_" -> (!@loc, Anonymous) ] ] ; global: [ [ r = Prim.reference -> r ] ] @@ -144,65 +150,77 @@ GEXTEND Gram [ [ c = lconstr -> c ] ] ; sort: - [ [ "Set" -> GProp Pos - | "Prop" -> GProp Null - | "Type" -> GType None ] ] + [ [ "Set" -> GSet + | "Prop" -> GProp + | "Type" -> GType [] + | "Type"; "@{"; u = universe; "}" -> GType (List.map Id.to_string u) + ] ] + ; + universe: + [ [ "max("; ids = LIST1 ident SEP ","; ")" -> ids + | id = ident -> [id] + ] ] ; lconstr: [ [ c = operconstr LEVEL "200" -> c ] ] ; constr: [ [ c = operconstr LEVEL "8" -> c - | "@"; f=global -> CAppExpl(loc,(None,f),[]) ] ] + | "@"; f=global; i = instance -> CAppExpl(!@loc,(None,f,i),[]) ] ] ; operconstr: [ "200" RIGHTA [ c = binder_constr -> c ] | "100" RIGHTA [ c1 = operconstr; "<:"; c2 = binder_constr -> - CCast(loc,c1, CastConv (VMcast,c2)) + CCast(!@loc,c1, CastVM c2) | c1 = operconstr; "<:"; c2 = SELF -> - CCast(loc,c1, CastConv (VMcast,c2)) + CCast(!@loc,c1, CastVM c2) + | c1 = operconstr; "<<:"; c2 = binder_constr -> + CCast(!@loc,c1, CastNative c2) + | c1 = operconstr; "<<:"; c2 = SELF -> + CCast(!@loc,c1, CastNative c2) | c1 = operconstr; ":";c2 = binder_constr -> - CCast(loc,c1, CastConv (DEFAULTcast,c2)) + CCast(!@loc,c1, CastConv c2) | c1 = operconstr; ":"; c2 = SELF -> - CCast(loc,c1, CastConv (DEFAULTcast,c2)) + CCast(!@loc,c1, CastConv c2) | c1 = operconstr; ":>" -> - CCast(loc,c1, CastCoerce) ] + CCast(!@loc,c1, CastCoerce) ] | "99" RIGHTA [ ] - | "90" RIGHTA - [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2) - | c1 = operconstr; "->"; c2 = SELF -> CArrow(loc,c1,c2)] + | "90" RIGHTA [ ] | "10" LEFTA - [ f=operconstr; args=LIST1 appl_arg -> CApp(loc,(None,f),args) - | "@"; f=global; args=LIST0 NEXT -> CAppExpl(loc,(None,f),args) + [ f=operconstr; args=LIST1 appl_arg -> CApp(!@loc,(None,f),args) + | "@"; f=global; i = instance; args=LIST0 NEXT -> CAppExpl(!@loc,(None,f,i),args) | "@"; (locid,id) = pattern_identref; args=LIST1 identref -> - let args = List.map (fun x -> CRef (Ident x), None) args in - CApp(loc,(None,CPatVar(locid,(true,id))),args) ] + let args = List.map (fun x -> CRef (Ident x,None), None) args in + CApp(!@loc,(None,CPatVar(locid,id)),args) ] | "9" [ ".."; c = operconstr LEVEL "0"; ".." -> - CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ] + CAppExpl (!@loc,(None,Ident (!@loc,ldots_var),None),[c]) ] | "8" [ ] | "1" LEFTA [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" -> - CApp(loc,(Some (List.length args+1),CRef f),args@[c,None]) + CApp(!@loc,(Some (List.length args+1),CRef (f,None)),args@[c,None]) | c=operconstr; ".("; "@"; f=global; args=LIST0 (operconstr LEVEL "9"); ")" -> - CAppExpl(loc,(Some (List.length args+1),f),args@[c]) - | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ] + CAppExpl(!@loc,(Some (List.length args+1),f,None),args@[c]) + | c=operconstr; "%"; key=IDENT -> CDelimiters (!@loc,key,c) ] | "0" [ c=atomic_constr -> c | c=match_constr -> c | "("; c = operconstr LEVEL "200"; ")" -> (match c with CPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> - CNotation(loc,"( _ )",([c],[],[])) + CNotation(!@loc,"( _ )",([c],[],[])) | _ -> c) | "{|"; c = record_declaration; "|}" -> c | "`{"; c = operconstr LEVEL "200"; "}" -> - CGeneralization (loc, Implicit, None, c) + CGeneralization (!@loc, Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> - CGeneralization (loc, Explicit, None, c) + CGeneralization (!@loc, Explicit, None, c) + | "$("; tac = Tactic.tactic; ")$" -> + let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in + CHole (!@loc, None, IntroAnonymous, Some arg) ] ] ; forall: @@ -212,74 +230,96 @@ GEXTEND Gram [ [ "fun" -> () ] ] ; record_declaration: - [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (loc, None, fs) + [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (!@loc, None, fs) (* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) -(* CRecord (loc, Some c, fs) *) +(* CRecord (!@loc, Some c, fs) *) ] ] ; record_field_declaration: [ [ id = global; params = LIST0 identref; ":="; c = lconstr -> - (id, Topconstr.abstract_constr_expr c (binders_of_lidents params)) ] ] + (id, abstract_constr_expr c (binders_of_lidents params)) ] ] ; binder_constr: [ [ forall; bl = open_binders; ","; c = operconstr LEVEL "200" -> - mkCProdN loc bl c + mkCProdN (!@loc) bl c | lambda; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> - mkCLambdaN loc bl c + mkCLambdaN (!@loc) bl c | "let"; id=name; bl = binders; ty = type_cstr; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - let loc1 = join_loc (local_binders_loc bl) (constr_loc c1) in - CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2) + let loc1 = + Loc.merge (local_binders_loc bl) (constr_loc c1) + in + CLetIn(!@loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2) | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" -> let fixp = mk_single_fix fx in let (li,id) = match fixp with CFix(_,id,_) -> id | CCoFix(_,id,_) -> id | _ -> assert false in - CLetIn(loc,(li,Name id),fixp,c) + CLetIn(!@loc,(li,Name id),fixp,c) | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []]; po = return_type; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - CLetTuple (loc,lb,po,c1,c2) + CLetTuple (!@loc,lb,po,c1,c2) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - CCases (loc, LetPatternStyle, None, [(c1,(None,None))], [(loc, [(loc,[p])], c2)]) + CCases (!@loc, LetPatternStyle, None, [(c1,(None,None))], [(!@loc, [(!@loc,[p])], c2)]) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(loc, [(loc, [p])], c2)]) - | "let"; "'"; p=pattern; "in"; t = operconstr LEVEL "200"; + CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(!@loc, [(!@loc, [p])], c2)]) + | "let"; "'"; p=pattern; "in"; t = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, Some t))], [(loc, [(loc, [p])], c2)]) + CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, Some t))], [(!@loc, [(!@loc, [p])], c2)]) | "if"; c=operconstr LEVEL "200"; po = return_type; "then"; b1=operconstr LEVEL "200"; "else"; b2=operconstr LEVEL "200" -> - CIf (loc, c, po, b1, b2) + CIf (!@loc, c, po, b1, b2) | c=fix_constr -> c ] ] ; appl_arg: [ [ id = lpar_id_coloneq; c=lconstr; ")" -> - (c,Some (loc,ExplByName id)) + (c,Some (!@loc,ExplByName id)) | c=operconstr LEVEL "9" -> (c,None) ] ] ; atomic_constr: - [ [ g=global -> CRef g - | s=sort -> CSort (loc,s) - | n=INT -> CPrim (loc, Numeral (Bigint.of_string n)) - | s=string -> CPrim (loc, String s) - | "_" -> CHole (loc, None) - | id=pattern_ident -> CPatVar(loc,(false,id)) ] ] + [ [ g=global; i=instance -> CRef (g,i) + | s=sort -> CSort (!@loc,s) + | n=INT -> CPrim (!@loc, Numeral (Bigint.of_string n)) + | s=string -> CPrim (!@loc, String s) + | "_" -> CHole (!@loc, None, IntroAnonymous, None) + | "?"; "["; id=ident; "]" -> CHole (!@loc, None, IntroIdentifier id, None) + | "?"; "["; id=pattern_ident; "]" -> CHole (!@loc, None, IntroFresh id, None) + | id=pattern_ident; inst = evar_instance -> CEvar(!@loc,id,inst) ] ] + ; + inst: + [ [ id = ident; ":="; c = lconstr -> (id,c) ] ] + ; + evar_instance: + [ [ "@{"; l = LIST1 inst SEP ";"; "}" -> l + | -> [] ] ] + ; + instance: + [ [ "@{"; l = LIST1 level; "}" -> Some l + | -> None ] ] + ; + level: + [ [ "Set" -> GSet + | "Prop" -> GProp + | "Type" -> GType None + | id = ident -> GType (Some (Id.to_string id)) + ] ] ; fix_constr: [ [ fx1=single_fix -> mk_single_fix fx1 | (_,kw,dcl1)=single_fix; "with"; dcls=LIST1 fix_decl SEP "with"; "for"; id=identref -> - mk_fix(loc,kw,id,dcl1::dcls) + mk_fix(!@loc,kw,id,dcl1::dcls) ] ] ; single_fix: - [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ] + [ [ kw=fix_kw; dcl=fix_decl -> (!@loc,kw,dcl) ] ] ; fix_kw: [ [ "fix" -> true @@ -292,14 +332,14 @@ GEXTEND Gram ; match_constr: [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with"; - br=branches; "end" -> CCases(loc,RegularStyle,ty,ci,br) ] ] + br=branches; "end" -> CCases(!@loc,RegularStyle,ty,ci,br) ] ] ; case_item: [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] ; pred_pattern: [ [ ona = OPT ["as"; id=name -> id]; - ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ] + ty = OPT ["in"; t=pattern -> t] -> (ona,ty) ] ] ; case_type: [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ] @@ -316,11 +356,11 @@ GEXTEND Gram [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ] ; mult_pattern: - [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> (loc,pl) ] ] + [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> (!@loc,pl) ] ] ; eqn: [ [ pll = LIST1 mult_pattern SEP "|"; - "=>"; rhs = lconstr -> (loc,pll,rhs) ] ] + "=>"; rhs = lconstr -> (!@loc,pll,rhs) ] ] ; recordpattern: [ [ id = global; ":="; pat = pattern -> (id, pat) ] ] @@ -328,42 +368,44 @@ GEXTEND Gram pattern: [ "200" RIGHTA [ ] | "100" RIGHTA - [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ] + [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (!@loc,p::pl) ] | "99" RIGHTA [ ] | "10" LEFTA [ p = pattern; "as"; id = ident -> - CPatAlias (loc, p, id) ] + CPatAlias (!@loc, p, id) ] | "9" RIGHTA [ p = pattern; lp = LIST1 NEXT -> (match p with - | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) - | _ -> Util.user_err_loc + | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, [], lp) + | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) + | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) + | _ -> Errors.user_err_loc (cases_pattern_expr_loc p, "compound_pattern", - Pp.str "Constructor expected.")) + Pp.str "Such pattern cannot have arguments.")) |"@"; r = Prim.reference; lp = LIST1 NEXT -> - CPatCstrExpl (loc, r, lp) ] + CPatCstr (!@loc, r, lp, []) ] | "1" LEFTA - [ c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ] + [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ] | "0" - [ r = Prim.reference -> CPatAtom (loc,Some r) - | "{|"; pat = LIST0 recordpattern SEP ";" ; "|}" -> CPatRecord (loc, pat) - | "_" -> CPatAtom (loc,None) + [ r = Prim.reference -> CPatAtom (!@loc,Some r) + | "{|"; pat = LIST0 recordpattern SEP ";" ; "|}" -> CPatRecord (!@loc, pat) + | "_" -> CPatAtom (!@loc,None) | "("; p = pattern LEVEL "200"; ")" -> (match p with CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> - CPatNotation(loc,"( _ )",([p],[])) + CPatNotation(!@loc,"( _ )",([p],[]),[]) | _ -> p) - | n = INT -> CPatPrim (loc, Numeral (Bigint.of_string n)) - | s = string -> CPatPrim (loc, String s) ] ] + | n = INT -> CPatPrim (!@loc, Numeral (Bigint.of_string n)) + | s = string -> CPatPrim (!@loc, String s) ] ] ; impl_ident_tail: - [ [ "}" -> fun id -> LocalRawAssum([id], Default Implicit, CHole(loc, None)) - | idl=LIST1 name; ":"; c=lconstr; "}" -> - (fun id -> LocalRawAssum (id::idl,Default Implicit,c)) - | idl=LIST1 name; "}" -> - (fun id -> LocalRawAssum (id::idl,Default Implicit,CHole (loc, None))) + [ [ "}" -> binder_of_name Implicit + | nal=LIST1 name; ":"; c=lconstr; "}" -> + (fun na -> LocalRawAssum (na::nal,Default Implicit,c)) + | nal=LIST1 name; "}" -> + (fun na -> LocalRawAssum (na::nal,Default Implicit,CHole (Loc.join_loc (fst na) !@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None))) | ":"; c=lconstr; "}" -> - (fun id -> LocalRawAssum ([id],Default Implicit,c)) + (fun na -> LocalRawAssum ([na],Default Implicit,c)) ] ] ; fixannot: @@ -373,9 +415,12 @@ GEXTEND Gram rel=OPT constr; "}" -> (id, CMeasureRec (m,rel)) ] ] ; + impl_name_head: + [ [ id = impl_ident_head -> (!@loc,Name id) ] ] + ; binders_fixannot: - [ [ id = impl_ident_head; assum = impl_ident_tail; bl = binders_fixannot -> - (assum (loc, Name id) :: fst bl), snd bl + [ [ na = impl_name_head; assum = impl_ident_tail; bl = binders_fixannot -> + (assum na :: fst bl), snd bl | f = fixannot -> [], f | b = binder; bl = binders_fixannot -> b @ fst bl, snd bl | -> [], (None, CStructRec) @@ -391,8 +436,8 @@ GEXTEND Gram | id = name; idl = LIST0 name; bl = binders -> binders_of_names (id::idl) @ bl | id1 = name; ".."; id2 = name -> - [LocalRawAssum ([id1;(loc,Name ldots_var);id2], - Default Explicit,CHole (loc,None))] + [LocalRawAssum ([id1;(!@loc,Name ldots_var);id2], + Default Explicit,CHole (!@loc, None, IntroAnonymous, None))] | bl = closed_binder; bl' = binders -> bl@bl' ] ] @@ -401,7 +446,7 @@ GEXTEND Gram [ [ l = LIST0 binder -> List.flatten l ] ] ; binder: - [ [ id = name -> [LocalRawAssum ([id],Default Explicit,CHole (loc, None))] + [ [ id = name -> [LocalRawAssum ([id],Default Explicit,CHole (!@loc, None, IntroAnonymous, None))] | bl = closed_binder -> bl ] ] ; closed_binder: @@ -412,15 +457,15 @@ GEXTEND Gram | "("; id=name; ":="; c=lconstr; ")" -> [LocalRawDef (id,c)] | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> - [LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t)))] + [LocalRawDef (id,CCast (Loc.merge (constr_loc t) (!@loc),c, CastConv t))] | "{"; id=name; "}" -> - [LocalRawAssum ([id],Default Implicit,CHole (loc, None))] + [LocalRawAssum ([id],Default Implicit,CHole (!@loc, None, IntroAnonymous, None))] | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" -> [LocalRawAssum (id::idl,Default Implicit,c)] | "{"; id=name; ":"; c=lconstr; "}" -> [LocalRawAssum ([id],Default Implicit,c)] | "{"; id=name; idl=LIST1 name; "}" -> - List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl) + List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (!@loc, None, IntroAnonymous, None))) (id::idl) | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" -> @@ -428,17 +473,17 @@ GEXTEND Gram ] ] ; typeclass_constraint: - [ [ "!" ; c = operconstr LEVEL "200" -> (loc, Anonymous), true, c + [ [ "!" ; c = operconstr LEVEL "200" -> (!@loc, Anonymous), true, c | "{"; id = name; "}"; ":" ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> id, expl, c | iid=name_colon ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> - (loc, iid), expl, c + (!@loc, iid), expl, c | c = operconstr LEVEL "200" -> - (loc, Anonymous), false, c + (!@loc, Anonymous), false, c ] ] ; type_cstr: - [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ] + [ [ c=OPT [":"; c=lconstr -> c] -> (!@loc,c) ] ] ; END;; diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 34615ad1..b4d96e5c 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -1,21 +1,23 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* a | e -> Tacexp (e:raw_tactic_expr) +let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () +let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n +let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat + (* Tactics grammar rules *) GEXTEND Gram - GLOBAL: tactic Vernac_.command tactic_expr binder_tactic tactic_arg + GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg constr_may_eval; tactic_then_last: @@ -44,29 +50,44 @@ GEXTEND Gram | -> ([TacId []], None) ] ] ; + tactic_then_locality: (* [true] for the local variant [TacThens] and [false] + for [TacExtend] *) + [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] + ; tactic_expr: [ "5" RIGHTA [ te = binder_tactic -> te ] | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, [||], ta1, [||]) - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, [||], ta1, [||]) - | ta0 = tactic_expr; ";"; "["; (first,tail) = tactic_then_gen; "]" -> - match tail with - | Some (t,last) -> TacThen (ta0, Array.of_list first, t, last) - | None -> TacThens (ta0,first) ] + [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) + | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) + | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> + match l , tail with + | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) + | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) + | false , None -> TacThen (ta0,TacDispatch first) + | true , None -> TacThens (ta0,first) ] | "3" RIGHTA [ IDENT "try"; ta = tactic_expr -> TacTry ta | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) + | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta | IDENT "progress"; ta = tactic_expr -> TacProgress ta + | IDENT "once"; ta = tactic_expr -> TacOnce ta + | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta + | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta (*To do: put Abstract in Refiner*) | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) | IDENT "abstract"; tc = NEXT; "using"; s = ident -> TacAbstract (tc,Some s) ] (*End of To do*) | "2" RIGHTA - [ ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) + [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) + | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) + | IDENT "tryif" ; ta = tactic_expr ; + "then" ; tat = tactic_expr ; + "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) + | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] | "1" RIGHTA [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> @@ -81,23 +102,25 @@ GEXTEND Gram | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> TacSolve l | IDENT "idtac"; l = LIST0 message_token -> TacId l - | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ]; - l = LIST0 message_token -> TacFail (n,l) - | IDENT "external"; com = STRING; req = STRING; la = LIST1 tactic_arg -> - TacArg (loc,TacExternal (loc,com,req,la)) - | st = simple_tactic -> TacAtom (loc,st) - | a = may_eval_arg -> TacArg(loc,a) - | IDENT "constr"; ":"; id = METAIDENT -> - TacArg(loc,MetaIdArg (loc,false,id)) + | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; + l = LIST0 message_token -> TacFail (g,n,l) + | st = simple_tactic -> st | IDENT "constr"; ":"; c = Constr.constr -> - TacArg(loc,ConstrMayEval(ConstrTerm c)) - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> - TacArg(loc,IntroPattern ipat) + TacArg(!@loc,ConstrMayEval(ConstrTerm c)) + | a = tactic_top_or_arg -> TacArg(!@loc,a) | r = reference; la = LIST0 tactic_arg -> - TacArg(loc,TacCall (loc,r,la)) ] + TacArg(!@loc,TacCall (!@loc,r,la)) ] | "0" [ "("; a = tactic_expr; ")" -> a - | a = tactic_atom -> TacArg (loc,a) ] ] + | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> + begin match tail with + | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) + | None -> TacDispatch tf + end + | a = tactic_atom -> TacArg (!@loc,a) ] ] + ; + failkw: + [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] ; (* binder_tactic: level 5 of tactic_expr *) binder_tactic: @@ -112,21 +135,26 @@ GEXTEND Gram (* Tactic arguments *) tactic_arg: [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a - | IDENT "ltac"; ":"; n = natural -> Integer n - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat - | a = may_eval_arg -> a + | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n) + | a = tactic_top_or_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) (* Unambigous entries: tolerated w/o "ltac:" modifier *) - | id = METAIDENT -> MetaIdArg (loc,true,id) - | "()" -> TacVoid ] ] + | id = METAIDENT -> MetaIdArg (!@loc,true,id) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; - may_eval_arg: - [ [ c = constr_eval -> ConstrMayEval c - | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l ] ] + (* Can be used as argument and at toplevel in tactic expressions. *) + tactic_top_or_arg: + [ [ IDENT "uconstr"; ":" ; c = uconstr -> UConstr c + | IDENT "ipattern"; ":"; ipat = simple_intropattern -> + TacGeneric (genarg_of_ipattern ipat) + | c = constr_eval -> ConstrMayEval c + | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l + | IDENT "type_term"; c=uconstr -> TacPretype c + | IDENT "numgoals" -> TacNumgoals ] ] ; fresh_id: - [ [ s = STRING -> ArgArg s | id = ident -> ArgVar (loc,id) ] ] + [ [ s = STRING -> ArgArg s | id = ident -> ArgVar (!@loc,id) ] ] ; constr_eval: [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> @@ -141,13 +169,15 @@ GEXTEND Gram | c = Constr.constr -> ConstrTerm c ] ] ; tactic_atom: - [ [ id = METAIDENT -> MetaIdArg (loc,true,id) - | n = integer -> Integer n - | r = reference -> TacCall (loc,r,[]) - | "()" -> TacVoid ] ] + [ [ id = METAIDENT -> MetaIdArg (!@loc,true,id) + | n = integer -> TacGeneric (genarg_of_int n) + | r = reference -> TacCall (!@loc,r,[]) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; match_key: - [ [ "match" -> false | "lazymatch" -> true ] ] + [ [ "match" -> Once + | "lazymatch" -> Select + | "multimatch" -> General ] ] ; input_fun: [ [ "_" -> None @@ -162,9 +192,11 @@ GEXTEND Gram match_pattern: [ [ IDENT "context"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> - Subterm (false,oid, pc) + let mode = not (!Flags.tactic_context_compat) in + Subterm (mode, oid, pc) | IDENT "appcontext"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> + msg_warning (strbrk "appcontext is deprecated"); Subterm (true,oid, pc) | pc = Constr.lconstr_pattern -> Term pc ] ] ; @@ -175,10 +207,10 @@ GEXTEND Gram let t, ty = match mpv with | Term t -> (match t with - | CCast (loc, t, CastConv (_, ty)) -> Term t, Some (Term ty) + | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) | _ -> mpv, None) | _ -> mpv, None - in Def (na, t, Option.default (Term (CHole (dummy_loc, None))) ty) + in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) ] ] ; match_context_rule: @@ -201,7 +233,7 @@ GEXTEND Gram | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] ; message_token: - [ [ id = identref -> MsgIdent (AI id) + [ [ id = identref -> MsgIdent id | s = STRING -> MsgString s | n = integer -> MsgInt n ] ] ; @@ -221,9 +253,4 @@ GEXTEND Gram tactic: [ [ tac = tactic_expr -> tac ] ] ; - Vernac_.command: - [ [ IDENT "Ltac"; - l = LIST1 tacdef_body SEP "with" -> - VernacDeclareTacticDefinition (use_module_locality (), true, l) ] ] - ; END diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index e0aae9a6..84da9c42 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -1,25 +1,24 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 1024 * 2048 then raise Exit; n with Failure _ | Exit -> - Util.user_err_loc (loc,"",Pp.str "Cannot support a so large number.") + Errors.user_err_loc (loc,"",Pp.str "Cannot support a so large number.") GEXTEND Gram GLOBAL: @@ -40,22 +39,22 @@ GEXTEND Gram [ [ s = IDENT -> s ] ] ; ident: - [ [ s = IDENT -> id_of_string s ] ] + [ [ s = IDENT -> Id.of_string s ] ] ; pattern_ident: [ [ LEFTQMARK; id = ident -> id ] ] ; pattern_identref: - [ [ id = pattern_ident -> (loc, id) ] ] + [ [ id = pattern_ident -> (!@loc, id) ] ] ; var: (* as identref, but interpret as a term identifier in ltac *) - [ [ id = ident -> (loc,id) ] ] + [ [ id = ident -> (!@loc, id) ] ] ; identref: - [ [ id = ident -> (loc,id) ] ] + [ [ id = ident -> (!@loc, id) ] ] ; field: - [ [ s = FIELD -> id_of_string s ] ] + [ [ s = FIELD -> Id.of_string s ] ] ; fields: [ [ id = field; (l,id') = fields -> (l@[id],id') @@ -63,8 +62,8 @@ GEXTEND Gram ] ] ; fullyqualid: - [ [ id = ident; (l,id')=fields -> loc,id::List.rev (id'::l) - | id = ident -> loc,[id] + [ [ id = ident; (l,id')=fields -> !@loc,id::List.rev (id'::l) + | id = ident -> !@loc,[id] ] ] ; basequalid: @@ -73,46 +72,46 @@ GEXTEND Gram ] ] ; name: - [ [ IDENT "_" -> (loc, Anonymous) - | id = ident -> (loc, Name id) ] ] + [ [ IDENT "_" -> (!@loc, Anonymous) + | id = ident -> (!@loc, Name id) ] ] ; reference: [ [ id = ident; (l,id') = fields -> - Qualid (loc, local_make_qualid (l@[id]) id') - | id = ident -> Ident (loc,id) + Qualid (!@loc, local_make_qualid (l@[id]) id') + | id = ident -> Ident (!@loc,id) ] ] ; by_notation: - [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> (loc,s,sc) ] ] + [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> (!@loc, s, sc) ] ] ; smart_global: - [ [ c = reference -> Genarg.AN c - | ntn = by_notation -> Genarg.ByNotation ntn ] ] + [ [ c = reference -> Misctypes.AN c + | ntn = by_notation -> Misctypes.ByNotation ntn ] ] ; qualid: - [ [ qid = basequalid -> loc, qid ] ] + [ [ qid = basequalid -> !@loc, qid ] ] ; ne_string: [ [ s = STRING -> - if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string."); s + if s="" then Errors.user_err_loc(!@loc, "", Pp.str"Empty string."); s ] ] ; ne_lstring: - [ [ s = ne_string -> (loc,s) ] ] + [ [ s = ne_string -> (!@loc, s) ] ] ; dirpath: [ [ id = ident; l = LIST0 field -> - make_dirpath (l@[id]) ] ] + DirPath.make (List.rev (id::l)) ] ] ; string: [ [ s = STRING -> s ] ] ; integer: - [ [ i = INT -> my_int_of_string loc i - | "-"; i = INT -> - my_int_of_string loc i ] ] + [ [ i = INT -> my_int_of_string (!@loc) i + | "-"; i = INT -> - my_int_of_string (!@loc) i ] ] ; natural: - [ [ i = INT -> my_int_of_string loc i ] ] + [ [ i = INT -> my_int_of_string (!@loc) i ] ] ; bigint: (* Negative numbers are dealt with specially *) [ [ i = INT -> (Bigint.of_string i) ] ] diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 557972ce..27f14c79 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -1,24 +1,31 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* x + | None -> match Proof_using.get_default_proof_using () with + | None -> None + | Some s -> Some (Gram.entry_parse e (Gram.parsable (Stream.of_string s))) + (* Proof commands *) GEXTEND Gram GLOBAL: command; @@ -29,12 +36,13 @@ GEXTEND Gram ; command: [ [ IDENT "Goal"; c = lconstr -> VernacGoal c - | IDENT "Proof" -> VernacProof (None,None) + | IDENT "Proof" -> + VernacProof (None,hint_proof_using G_vernac.section_subset_descr None) | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn | IDENT "Proof"; "with"; ta = tactic; - l = OPT [ "using"; l = LIST0 identref -> l ] -> - VernacProof (Some ta, l) - | IDENT "Proof"; "using"; l = LIST0 identref; + l = OPT [ "using"; l = G_vernac.section_subset_descr -> l ] -> + VernacProof (Some ta,hint_proof_using G_vernac.section_subset_descr l) + | IDENT "Proof"; "using"; l = G_vernac.section_subset_descr; ta = OPT [ "with"; ta = tactic -> ta ] -> VernacProof (ta,Some l) | IDENT "Proof"; c = lconstr -> VernacExactProof c @@ -70,6 +78,7 @@ GEXTEND Gram | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials + | IDENT "Show"; IDENT "Universes" -> VernacShow ShowUniverses | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof @@ -81,29 +90,35 @@ GEXTEND Gram (* Hints for Auto and EAuto *) | IDENT "Create"; IDENT "HintDb" ; id = IDENT ; b = [ "discriminated" -> true | -> false ] -> - VernacCreateHintDb (use_module_locality (), id, b) + VernacCreateHintDb (id, b) | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> - VernacRemoveHints (use_module_locality (), dbnames, ids) + VernacRemoveHints (dbnames, ids) | IDENT "Hint"; local = obsolete_locality; h = hint; dbnames = opt_hintbases -> - VernacHints (enforce_module_locality local,dbnames, h) + VernacHints (local,dbnames, h) (* Declare "Resolve" explicitly so as to be able to later extend with "Resolve ->" and "Resolve <-" *) - | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 constr; n = OPT natural; + | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 reference_or_constr; + pri = OPT [ "|"; i = natural -> i ]; dbnames = opt_hintbases -> - VernacHints (use_module_locality (),dbnames, - HintsResolve (List.map (fun x -> (n, true, x)) lc)) + VernacHints (false,dbnames, + HintsResolve (List.map (fun x -> (pri, true, x)) lc)) ] ]; - obsolete_locality: [ [ IDENT "Local" -> true | -> false ] ] ; + reference_or_constr: + [ [ r = global -> HintsReference r + | c = constr -> HintsConstr c ] ] + ; hint: - [ [ IDENT "Resolve"; lc = LIST1 constr; n = OPT natural -> - HintsResolve (List.map (fun x -> (n, true, x)) lc) - | IDENT "Immediate"; lc = LIST1 constr -> HintsImmediate lc + [ [ IDENT "Resolve"; lc = LIST1 reference_or_constr; + pri = OPT [ "|"; i = natural -> i ] -> + HintsResolve (List.map (fun x -> (pri, true, x)) lc) + | IDENT "Immediate"; lc = LIST1 reference_or_constr -> HintsImmediate lc | IDENT "Transparent"; lc = LIST1 global -> HintsTransparency (lc, true) | IDENT "Opaque"; lc = LIST1 global -> HintsTransparency (lc, false) + | IDENT "Mode"; l = global; m = mode -> HintsMode (l, m) | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>"; @@ -112,6 +127,9 @@ GEXTEND Gram ; constr_body: [ [ ":="; c = lconstr -> c - | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Glob_term.CastConv (Term.DEFAULTcast,t)) ] ] + | ":"; t = lconstr; ":="; c = lconstr -> CCast(!@loc,c,CastConv t) ] ] + ; + mode: + [ [ l = LIST1 ["+" -> true | "-" -> false] -> l ] ] ; END diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 820a1f16..b42b2c6d 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -1,24 +1,28 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "; "<-" ; "by" ] let _ = List.iter Lexer.add_keyword tactic_kw @@ -73,18 +77,18 @@ let check_for_coloneq = Gram.Entry.of_parser "lpar_id_colon" (fun strm -> let rec skip_to_rpar p n = - match get_tok (list_last (Stream.npeek n strm)) with + match get_tok (List.last (Stream.npeek n strm)) with | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) - | KEYWORD ")" -> if p=0 then n+1 else skip_to_rpar (p-1) (n+1) + | KEYWORD ")" -> if Int.equal p 0 then n+1 else skip_to_rpar (p-1) (n+1) | KEYWORD "." -> err () | _ -> skip_to_rpar p (n+1) in let rec skip_names n = - match get_tok (list_last (Stream.npeek n strm)) with + match get_tok (List.last (Stream.npeek n strm)) with | IDENT _ | KEYWORD "_" -> skip_names (n+1) | KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *) | _ -> err () in let rec skip_binders n = - match get_tok (list_last (Stream.npeek n strm)) with + match get_tok (List.last (Stream.npeek n strm)) with | KEYWORD "(" -> skip_binders (skip_names (n+1)) | IDENT _ | KEYWORD "_" -> skip_binders (n+1) | KEYWORD ":=" -> () @@ -110,39 +114,41 @@ let mk_fix_tac (loc,id,bl,ann,ty) = [([_],_,_)], None -> 1 | _, Some x -> let ids = List.map snd (List.flatten (List.map pi1 bl)) in - (try list_index (snd x) ids + (try List.index Names.Name.equal (snd x) ids with Not_found -> error "No such fix variable.") | _ -> error "Cannot guess decreasing argument of fix." in (id,n,CProdN(loc,bl,ty)) let mk_cofix_tac (loc,id,bl,ann,ty) = let _ = Option.map (fun (aloc,_) -> - Util.user_err_loc + user_err_loc (aloc,"Constr:mk_cofix_tac", Pp.str"Annotation forbidden in cofix expression.")) ann in (id,CProdN(loc,bl,ty)) (* Functions overloaded by quotifier *) -let induction_arg_of_constr (c,lbind as clbind) = - if lbind = NoBindings then - try ElimOnIdent (constr_loc c,snd(coerce_to_id c)) - with e when Errors.noncritical e -> ElimOnConstr clbind - else ElimOnConstr clbind +let induction_arg_of_constr (c,lbind as clbind) = match lbind with + | NoBindings -> + begin + try ElimOnIdent (Constrexpr_ops.constr_loc c,snd(Constrexpr_ops.coerce_to_id c)) + with e when Errors.noncritical e -> ElimOnConstr clbind + end + | _ -> ElimOnConstr clbind let mkTacCase with_evar = function - | [ElimOnConstr cl,(None,None)],None,None -> - TacCase (with_evar,cl) + | [(clear,ElimOnConstr cl),(None,None),None],None -> + TacCase (with_evar,(clear,cl)) (* Reinterpret numbers as a notation for terms *) - | [ElimOnAnonHyp n,(None,None)],None,None -> + | [(clear,ElimOnAnonHyp n),(None,None),None],None -> TacCase (with_evar, - (CPrim (dummy_loc, Numeral (Bigint.of_int n)), - NoBindings)) + (clear,(CPrim (Loc.ghost, Numeral (Bigint.of_int n)), + NoBindings))) (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) - | [ElimOnIdent id,(None,None)],None,None -> - TacCase (with_evar,(CRef (Ident id),NoBindings)) + | [(clear,ElimOnIdent id),(None,None),None],None -> + TacCase (with_evar,(clear,(CRef (Ident id,None),NoBindings))) | ic -> - if List.exists (function (ElimOnAnonHyp _,_) -> true | _ -> false) (pi1 ic) + if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) then error "Use of numbers as direct arguments of 'case' is not supported."; TacInductionDestruct (false,with_evar,ic) @@ -150,146 +156,156 @@ let mkTacCase with_evar = function let rec mkCLambdaN_simple_loc loc bll c = match bll with | ((loc1,_)::_ as idl,bk,t) :: bll -> - CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (join_loc loc1 loc) bll c) + CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (Loc.merge loc1 loc) bll c) | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c | [] -> c -let mkCLambdaN_simple bl c = - if bl=[] then c - else - let loc = join_loc (fst (List.hd (pi1 (List.hd bl)))) (constr_loc c) in +let mkCLambdaN_simple bl c = match bl with + | [] -> c + | h :: _ -> + let loc = Loc.merge (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in mkCLambdaN_simple_loc loc bl c -let loc_of_ne_list l = join_loc (fst (List.hd l)) (fst (list_last l)) +let loc_of_ne_list l = Loc.merge (fst (List.hd l)) (fst (List.last l)) let map_int_or_var f = function - | Glob_term.ArgArg x -> Glob_term.ArgArg (f x) - | Glob_term.ArgVar _ as y -> y - -let all_concl_occs_clause = { onhyps=Some[]; concl_occs=all_occurrences_expr } + | ArgArg x -> ArgArg (f x) + | ArgVar _ as y -> y -let has_no_specified_occs cl = - (cl.onhyps = None || - List.for_all (fun ((occs,_),_) -> occs = all_occurrences_expr) - (Option.get cl.onhyps)) - && (cl.concl_occs = all_occurrences_expr - || cl.concl_occs = no_occurrences_expr) +let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences } let merge_occurrences loc cl = function | None -> - if has_no_specified_occs cl then (None, cl) + if Locusops.clause_with_generic_occurrences cl then (None, cl) else user_err_loc (loc,"",str "Found an \"at\" clause without \"with\" clause.") - | Some (occs,p) -> - (Some p, - if occs = all_occurrences_expr then cl - else if cl = all_concl_occs_clause then { onhyps=Some[]; concl_occs=occs } - else match cl.onhyps with - | Some [(occs',id),l] when - occs' = all_occurrences_expr && cl.concl_occs = no_occurrences_expr -> - { cl with onhyps=Some[(occs,id),l] } + | Some (occs, p) -> + let ans = match occs with + | AllOccurrences -> cl + | _ -> + begin match cl with + | { onhyps = Some []; concl_occs = AllOccurrences } -> + { onhyps = Some []; concl_occs = occs } + | { onhyps = Some [(AllOccurrences, id), l]; concl_occs = NoOccurrences } -> + { cl with onhyps = Some [(occs, id), l] } | _ -> - if has_no_specified_occs cl then - user_err_loc (loc,"",str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") - else - user_err_loc (loc,"",str "Cannot use clause \"at\" twice.")) + if Locusops.clause_with_generic_occurrences cl then + user_err_loc (loc,"",str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") + else + user_err_loc (loc,"",str "Cannot use clause \"at\" twice.") + end + in + (Some p, ans) (* Auxiliary grammar rules *) GEXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis - bindings red_expr int_or_var open_constr casted_open_constr open_constr_wTC - simple_intropattern; + bindings red_expr int_or_var open_constr uconstr + simple_intropattern clause_dft_concl; int_or_var: - [ [ n = integer -> Glob_term.ArgArg n - | id = identref -> Glob_term.ArgVar id ] ] + [ [ n = integer -> ArgArg n + | id = identref -> ArgVar id ] ] ; nat_or_var: - [ [ n = natural -> Glob_term.ArgArg n - | id = identref -> Glob_term.ArgVar id ] ] + [ [ n = natural -> ArgArg n + | id = identref -> ArgVar id ] ] ; (* An identifier or a quotation meta-variable *) id_or_meta: - [ [ id = identref -> AI id - - (* This is used in quotations *) - | id = METAIDENT -> MetaId (loc,id) ] ] + [ [ id = identref -> id ] ] ; open_constr: [ [ c = constr -> ((),c) ] ] ; - open_constr_wTC: - [ [ c = constr -> ((),c) ] ] - ; - casted_open_constr: - [ [ c = constr -> ((),c) ] ] + uconstr: + [ [ c = constr -> c ] ] ; induction_arg: - [ [ n = natural -> ElimOnAnonHyp n - | c = constr_with_bindings -> induction_arg_of_constr c + [ [ n = natural -> (None,ElimOnAnonHyp n) + | c = constr_with_bindings -> (None,induction_arg_of_constr c) + | "!"; c = constr_with_bindings -> (Some false,induction_arg_of_constr c) ] ] ; + constr_with_bindings_arg: + [ [ ">"; c = constr_with_bindings -> (Some true,c) + | c = constr_with_bindings -> (None,c) ] ] + ; quantified_hypothesis: [ [ id = ident -> NamedHyp id | n = natural -> AnonHyp n ] ] ; conversion: [ [ c = constr -> (None, c) - | c1 = constr; "with"; c2 = constr -> (Some (all_occurrences_expr,c1),c2) + | c1 = constr; "with"; c2 = constr -> (Some (AllOccurrences,c1),c2) | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> (Some (occs,c1), c2) ] ] ; occs_nums: - [ [ nl = LIST1 nat_or_var -> no_occurrences_expr_but nl + [ [ nl = LIST1 nat_or_var -> OnlyOccurrences nl | "-"; n = nat_or_var; nl = LIST0 int_or_var -> (* have used int_or_var instead of nat_or_var for compatibility *) - all_occurrences_expr_but (List.map (map_int_or_var abs) (n::nl)) ] ] + AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) ] ] ; occs: - [ [ "at"; occs = occs_nums -> occs | -> all_occurrences_expr ] ] + [ [ "at"; occs = occs_nums -> occs | -> AllOccurrences ] ] ; pattern_occ: [ [ c = constr; nl = occs -> (nl,c) ] ] ; + ref_or_pattern_occ: + (* If a string, it is interpreted as a ref + (anyway a Coq string does not reduce) *) + [ [ c = smart_global; nl = occs -> nl,Inl c + | c = constr; nl = occs -> nl,Inr c ] ] + ; unfold_occ: [ [ c = smart_global; nl = occs -> (nl,c) ] ] ; intropatterns: - [ [ l = LIST0 simple_intropattern -> l ]] + [ [ l = LIST0 nonsimple_intropattern -> l ]] ; - disjunctive_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> loc,IntroOrAndPattern tc - | "()" -> loc,IntroOrAndPattern [[]] - | "("; si = simple_intropattern; ")" -> loc,IntroOrAndPattern [[si]] + or_and_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> tc + | "()" -> [[]] + | "("; si = simple_intropattern; ")" -> [[si]] | "("; si = simple_intropattern; ","; - tc = LIST1 simple_intropattern SEP "," ; ")" -> - loc,IntroOrAndPattern [si::tc] + tc = LIST1 simple_intropattern SEP "," ; ")" -> [si::tc] | "("; si = simple_intropattern; "&"; tc = LIST1 simple_intropattern SEP "&" ; ")" -> (* (A & B & C) is translated into (A,(B,C)) *) let rec pairify = function - | ([]|[_]|[_;_]) as l -> IntroOrAndPattern [l] - | t::q -> IntroOrAndPattern [[t;(loc_of_ne_list q,pairify q)]] - in loc,pairify (si::tc) ] ] + | ([]|[_]|[_;_]) as l -> [l] + | t::q -> [[t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (pairify q)))]] + in pairify (si::tc) ] ] + ; + equality_intropattern: + [ [ "->" -> IntroRewrite true + | "<-" -> IntroRewrite false + | "[="; tc = intropatterns; "]" -> IntroInjection tc ] ] ; naming_intropattern: - [ [ prefix = pattern_ident -> loc, IntroFresh prefix - | "?" -> loc, IntroAnonymous - | id = ident -> loc, IntroIdentifier id - | "*" -> loc, IntroForthcoming true - | "**" -> loc, IntroForthcoming false ] ] + [ [ prefix = pattern_ident -> IntroFresh prefix + | "?" -> IntroAnonymous + | id = ident -> IntroIdentifier id ] ] + ; + nonsimple_intropattern: + [ [ l = simple_intropattern -> l + | "*" -> !@loc, IntroForthcoming true + | "**" -> !@loc, IntroForthcoming false ]] ; simple_intropattern: - [ [ pat = disjunctive_intropattern -> pat - | pat = naming_intropattern -> pat - | "_" -> loc, IntroWildcard - | "->" -> loc, IntroRewrite true - | "<-" -> loc, IntroRewrite false ] ] + [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat) + | pat = equality_intropattern -> !@loc, IntroAction pat + | "_" -> !@loc, IntroAction IntroWildcard + | pat = simple_intropattern; "/"; c = constr -> + !@loc, IntroAction (IntroApplyOn (c,pat)) + | pat = naming_intropattern -> !@loc, IntroNaming pat ] ] ; simple_binding: - [ [ "("; id = ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c) - | "("; n = natural; ":="; c = lconstr; ")" -> (loc, AnonHyp n, c) ] ] + [ [ "("; id = ident; ":="; c = lconstr; ")" -> (!@loc, NamedHyp id, c) + | "("; n = natural; ":="; c = lconstr; ")" -> (!@loc, AnonHyp n, c) ] ] ; bindings: [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> @@ -297,7 +313,7 @@ GEXTEND Gram | bl = LIST1 constr -> ImplicitBindings bl ] ] ; opt_bindings: - [ [ bl = bindings -> bl | -> NoBindings ] ] + [ [ bl = LIST1 bindings SEP "," -> bl | -> [NoBindings] ] ] ; constr_with_bindings: [ [ c = constr; l = with_bindings -> (c, l) ] ] @@ -319,18 +335,20 @@ GEXTEND Gram ] ] ; strategy_flag: - [ [ s = LIST1 red_flag -> make_red_flag s + [ [ s = LIST1 red_flag -> Redops.make_red_flag s | d = delta_flag -> all_with d ] ] ; red_tactic: [ [ IDENT "red" -> Red false | IDENT "hnf" -> Hnf - | IDENT "simpl"; po = OPT pattern_occ -> Simpl po + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po) | IDENT "cbv"; s = strategy_flag -> Cbv s + | IDENT "cbn"; s = strategy_flag -> Cbn s | IDENT "lazy"; s = strategy_flag -> Lazy s | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) - | IDENT "vm_compute" -> CbvVm + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po + | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul | IDENT "fold"; cl = LIST1 constr -> Fold cl | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl ] ] @@ -339,11 +357,13 @@ GEXTEND Gram red_expr: [ [ IDENT "red" -> Red false | IDENT "hnf" -> Hnf - | IDENT "simpl"; po = OPT pattern_occ -> Simpl po + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po) | IDENT "cbv"; s = strategy_flag -> Cbv s + | IDENT "cbn"; s = strategy_flag -> Cbn s | IDENT "lazy"; s = strategy_flag -> Lazy s | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) - | IDENT "vm_compute" -> CbvVm + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po + | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul | IDENT "fold"; cl = LIST1 constr -> Fold cl | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl @@ -369,7 +389,7 @@ GEXTEND Gram | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> {onhyps=Some hl; concl_occs=occs} | hl=LIST0 hypident_occ SEP"," -> - {onhyps=Some hl; concl_occs=no_occurrences_expr} ] ] + {onhyps=Some hl; concl_occs=NoOccurrences} ] ] ; clause_dft_concl: [ [ "in"; cl = in_clause -> cl @@ -378,21 +398,23 @@ GEXTEND Gram ; clause_dft_all: [ [ "in"; cl = in_clause -> cl - | -> {onhyps=None; concl_occs=all_occurrences_expr} ] ] + | -> {onhyps=None; concl_occs=AllOccurrences} ] ] ; opt_clause: - [ [ "in"; cl = in_clause -> Some cl | -> None ] ] + [ [ "in"; cl = in_clause -> Some cl + | "at"; occs = occs_nums -> Some {onhyps=Some[]; concl_occs=occs} + | -> None ] ] ; concl_occ: [ [ "*"; occs = occs -> occs - | -> no_occurrences_expr ] ] + | -> NoOccurrences ] ] ; in_hyp_list: [ [ "in"; idl = LIST1 id_or_meta -> idl | -> [] ] ] ; in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) + [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (None,id,ipat) | -> None ] ] ; orient: @@ -401,13 +423,13 @@ GEXTEND Gram | -> true ]] ; simple_binder: - [ [ na=name -> ([na],Default Explicit,CHole (loc, None)) + [ [ na=name -> ([na],Default Explicit,CHole (!@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None)) | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) ] ] ; fixdecl: [ [ "("; id = ident; bl=LIST0 simple_binder; ann=fixannot; - ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ] + ":"; ty=lconstr; ")" -> (!@loc, id, bl, ann, ty) ] ] ; fixannot: [ [ "{"; IDENT "struct"; id=name; "}" -> Some id @@ -415,7 +437,7 @@ GEXTEND Gram ; cofixdecl: [ [ "("; id = ident; bl=LIST0 simple_binder; ":"; ty=lconstr; ")" -> - (loc,id,bl,None,ty) ] ] + (!@loc, id, bl, None, ty) ] ] ; bindings_with_parameters: [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; @@ -430,6 +452,16 @@ GEXTEND Gram [ [ "using"; l = LIST1 constr SEP "," -> l | -> [] ] ] ; + trivial: + [ [ IDENT "trivial" -> Off + | IDENT "info_trivial" -> Info + | IDENT "debug"; IDENT "trivial" -> Debug ] ] + ; + auto: + [ [ IDENT "auto" -> Off + | IDENT "info_auto" -> Info + | IDENT "debug"; IDENT "auto" -> Debug ] ] + ; eliminator: [ [ "using"; el = constr_with_bindings -> el ] ] ; @@ -437,18 +469,22 @@ GEXTEND Gram [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ] ; - with_inversion_names: - [ [ "as"; ipat = simple_intropattern -> Some ipat + or_and_intropattern_loc: + [ [ ipat = or_and_intropattern -> ArgArg (!@loc,ipat) + | locid = identref -> ArgVar locid ] ] + ; + as_or_and_ipat: + [ [ "as"; ipat = or_and_intropattern_loc -> Some ipat | -> None ] ] ; eqn_ipat: - [ [ IDENT "eqn"; ":"; id = naming_intropattern -> Some id - | IDENT "_eqn"; ":"; id = naming_intropattern -> + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat) + | IDENT "_eqn"; ":"; pat = naming_intropattern -> let msg = "Obsolete syntax \"_eqn:H\" could be replaced by \"eqn:H\"" in - msg_warning (strbrk msg); Some id + msg_warning (strbrk msg); Some (!@loc, pat) | IDENT "_eqn" -> let msg = "Obsolete syntax \"_eqn\" could be replaced by \"eqn:?\"" in - msg_warning (strbrk msg); Some (loc, IntroAnonymous) + msg_warning (strbrk msg); Some (!@loc, IntroAnonymous) | -> None ] ] ; as_name: @@ -466,215 +502,186 @@ GEXTEND Gram [ [ id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> (id1,id2) ] ] ; rewriter : - [ [ "!"; c = constr_with_bindings -> (RepeatPlus,c) - | ["?"| LEFTQMARK]; c = constr_with_bindings -> (RepeatStar,c) - | n = natural; "!"; c = constr_with_bindings -> (Precisely n,c) - | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings -> (UpTo n,c) - | n = natural; c = constr_with_bindings -> (Precisely n,c) - | c = constr_with_bindings -> (Precisely 1, c) + [ [ "!"; c = constr_with_bindings -> (RepeatPlus,(None,c)) + | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c) + | n = natural; "!"; c = constr_with_bindings -> (Precisely n,(None,c)) + | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c) + | n = natural; c = constr_with_bindings_arg -> (Precisely n,c) + | c = constr_with_bindings -> (Precisely 1, (None,c)) ] ] ; oriented_rewriter : [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ] ; induction_clause: - [ [ c = induction_arg; pat = as_ipat; eq = eqn_ipat -> (c,(eq,pat)) ] ] + [ [ c = induction_arg; pat = as_or_and_ipat; eq = eqn_ipat; cl = opt_clause + -> (c,(eq,pat),cl) ] ] ; induction_clause_list: - [ [ ic = LIST1 induction_clause SEP ","; - el = OPT eliminator; cl = opt_clause -> (ic,el,cl) ] ] + [ [ ic = LIST1 induction_clause SEP ","; el = OPT eliminator; + cl_tolerance = opt_clause -> + (* Condition for accepting "in" at the end by compatibility *) + match ic,el,cl_tolerance with + | [c,pat,None],Some _,Some _ -> ([c,pat,cl_tolerance],el) + | _,_,Some _ -> err () + | _,_,None -> (ic,el) ]] ; move_location: [ [ IDENT "after"; id = id_or_meta -> MoveAfter id | IDENT "before"; id = id_or_meta -> MoveBefore id - | "at"; IDENT "bottom" -> MoveToEnd true - | "at"; IDENT "top" -> MoveToEnd false ] ] + | "at"; IDENT "top" -> MoveFirst + | "at"; IDENT "bottom" -> MoveLast ] ] ; simple_tactic: [ [ (* Basic tactics *) - IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> - TacIntrosUntil id - | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl + IDENT "intros"; pl = intropatterns -> TacAtom (!@loc, TacIntroPattern pl) | IDENT "intro"; id = ident; hto = move_location -> - TacIntroMove (Some id, hto) - | IDENT "intro"; hto = move_location -> TacIntroMove (None, hto) - | IDENT "intro"; id = ident -> TacIntroMove (Some id, no_move) - | IDENT "intro" -> TacIntroMove (None, no_move) - - | IDENT "assumption" -> TacAssumption - | IDENT "exact"; c = constr -> TacExact c - | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c - | IDENT "vm_cast_no_check"; c = constr -> TacVmCastNoCheck c - - | IDENT "apply"; cl = LIST1 constr_with_bindings SEP ","; - inhyp = in_hyp_as -> TacApply (true,false,cl,inhyp) - | IDENT "eapply"; cl = LIST1 constr_with_bindings SEP ","; - inhyp = in_hyp_as -> TacApply (true,true,cl,inhyp) - | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings SEP ","; - inhyp = in_hyp_as -> TacApply (false,false,cl,inhyp) - | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings SEP","; - inhyp = in_hyp_as -> TacApply (false,true,cl,inhyp) - | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator -> - TacElim (false,cl,el) - | IDENT "eelim"; cl = constr_with_bindings; el = OPT eliminator -> - TacElim (true,cl,el) - | IDENT "elimtype"; c = constr -> TacElimType c - | IDENT "case"; icl = induction_clause_list -> mkTacCase false icl - | IDENT "ecase"; icl = induction_clause_list -> mkTacCase true icl - | IDENT "casetype"; c = constr -> TacCaseType c - | "fix"; n = natural -> TacFix (None,n) - | "fix"; id = ident; n = natural -> TacFix (Some id,n) + TacAtom (!@loc, TacIntroMove (Some id, hto)) + | IDENT "intro"; hto = move_location -> TacAtom (!@loc, TacIntroMove (None, hto)) + | IDENT "intro"; id = ident -> TacAtom (!@loc, TacIntroMove (Some id, MoveLast)) + | IDENT "intro" -> TacAtom (!@loc, TacIntroMove (None, MoveLast)) + + | IDENT "exact"; c = constr -> TacAtom (!@loc, TacExact c) + + | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp)) + | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,true,cl,inhyp)) + | IDENT "simple"; IDENT "apply"; + cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,false,cl,inhyp)) + | IDENT "simple"; IDENT "eapply"; + cl = LIST1 constr_with_bindings_arg SEP","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,true,cl,inhyp)) + | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + TacAtom (!@loc, TacElim (false,cl,el)) + | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + TacAtom (!@loc, TacElim (true,cl,el)) + | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl) + | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) + | "fix"; n = natural -> TacAtom (!@loc, TacFix (None,n)) + | "fix"; id = ident; n = natural -> TacAtom (!@loc, TacFix (Some id,n)) | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - TacMutualFix (false,id,n,List.map mk_fix_tac fd) - | "cofix" -> TacCofix None - | "cofix"; id = ident -> TacCofix (Some id) + TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) + | "cofix" -> TacAtom (!@loc, TacCofix None) + | "cofix"; id = ident -> TacAtom (!@loc, TacCofix (Some id)) | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - TacMutualCofix (false,id,List.map mk_cofix_tac fd) + TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) | IDENT "pose"; (id,b) = bindings_with_parameters -> - TacLetTac (Names.Name id,b,nowhere,true,None) + TacAtom (!@loc, TacLetTac (Names.Name id,b,Locusops.nowhere,true,None)) | IDENT "pose"; b = constr; na = as_name -> - TacLetTac (na,b,nowhere,true,None) + TacAtom (!@loc, TacLetTac (na,b,Locusops.nowhere,true,None)) | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> - TacLetTac (Names.Name id,c,p,true,None) + TacAtom (!@loc, TacLetTac (Names.Name id,c,p,true,None)) | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - TacLetTac (na,c,p,true,None) + TacAtom (!@loc, TacLetTac (na,c,p,true,None)) | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - TacLetTac (na,c,p,false,e) + TacAtom (!@loc, TacLetTac (na,c,p,false,e)) - (* Begin compatibility *) + (* Alternative syntax for "pose proof c as id" *) | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; c = lconstr; ")" -> - TacAssert (None,Some (loc,IntroIdentifier id),c) + TacAtom (!@loc, TacAssert (true,None,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + (* Alternative syntax for "assert c as id by tac" *) | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - TacAssert (Some tac,Some (loc,IntroIdentifier id),c) - (* End compatibility *) + TacAtom (!@loc, TacAssert (true,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + (* Alternative syntax for "enough c as id by tac" *) + | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (!@loc, TacAssert (false,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAssert (Some tac,ipat,c) + TacAtom (!@loc, TacAssert (true,Some tac,ipat,c)) | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - TacAssert (None,ipat,c) + TacAtom (!@loc, TacAssert (true,None,ipat,c)) + | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (!@loc, TacAssert (false,Some tac,ipat,c)) - | IDENT "cut"; c = constr -> TacCut c | IDENT "generalize"; c = constr -> - TacGeneralize [((all_occurrences_expr,c),Names.Anonymous)] + TacAtom (!@loc, TacGeneralize [((AllOccurrences,c),Names.Anonymous)]) | IDENT "generalize"; c = constr; l = LIST1 constr -> - let gen_everywhere c = ((all_occurrences_expr,c),Names.Anonymous) in - TacGeneralize (List.map gen_everywhere (c::l)) + let gen_everywhere c = ((AllOccurrences,c),Names.Anonymous) in + TacAtom (!@loc, TacGeneralize (List.map gen_everywhere (c::l))) | IDENT "generalize"; c = constr; lookup_at_as_coma; nl = occs; na = as_name; l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> - TacGeneralize (((nl,c),na)::l) - | IDENT "generalize"; IDENT "dependent"; c = constr -> TacGeneralizeDep c - - | IDENT "specialize"; n = OPT natural; lcb = constr_with_bindings -> - TacSpecialize (n,lcb) - | IDENT "lapply"; c = constr -> TacLApply c + TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) + | IDENT "generalize"; IDENT "dependent"; c = constr -> TacAtom (!@loc, TacGeneralizeDep c) (* Derived basic tactics *) - | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis -> - TacSimpleInductionDestruct (true,h) | IDENT "induction"; ic = induction_clause_list -> - TacInductionDestruct (true,false,ic) + TacAtom (!@loc, TacInductionDestruct (true,false,ic)) | IDENT "einduction"; ic = induction_clause_list -> - TacInductionDestruct(true,true,ic) + TacAtom (!@loc, TacInductionDestruct(true,true,ic)) | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis; - h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2) - | IDENT "simple"; IDENT "destruct"; h = quantified_hypothesis -> - TacSimpleInductionDestruct (false,h) + h2 = quantified_hypothesis -> TacAtom (!@loc, TacDoubleInduction (h1,h2)) | IDENT "destruct"; icl = induction_clause_list -> - TacInductionDestruct(false,false,icl) + TacAtom (!@loc, TacInductionDestruct(false,false,icl)) | IDENT "edestruct"; icl = induction_clause_list -> - TacInductionDestruct(false,true,icl) - | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c - | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c - | IDENT "decompose"; "["; l = LIST1 smart_global; "]"; c = constr - -> TacDecompose (l,c) + TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Automation tactic *) - | IDENT "trivial"; lems = auto_using; db = hintbases -> - TacTrivial (Off,lems,db) - | IDENT "info_trivial"; lems = auto_using; db = hintbases -> - TacTrivial (Info,lems,db) - | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases -> - TacTrivial (Debug,lems,db) - - | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAuto (Off,n,lems,db) - | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using; - db = hintbases -> TacAuto (Info,n,lems,db) - | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using; - db = hintbases -> TacAuto (Debug,n,lems,db) + | d = trivial; lems = auto_using; db = hintbases -> TacAtom (!@loc, TacTrivial (d,lems,db)) + | d = auto; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (d,n,lems,db)) (* Context management *) - | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l) - | IDENT "clear"; l = LIST0 id_or_meta -> TacClear (l=[], l) - | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l + | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) + | IDENT "clear"; l = LIST0 id_or_meta -> + let is_empty = match l with [] -> true | _ -> false in + TacAtom (!@loc, TacClear (is_empty, l)) + | IDENT "clearbody"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClearBody l) | IDENT "move"; hfrom = id_or_meta; hto = move_location -> - TacMove (true,hfrom,hto) - | IDENT "rename"; l = LIST1 rename SEP "," -> TacRename l - | IDENT "revert"; l = LIST1 id_or_meta -> TacRevert l + TacAtom (!@loc, TacMove (hfrom,hto)) + | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l) (* Constructors *) - | IDENT "left"; bl = with_bindings -> TacLeft (false,bl) - | IDENT "eleft"; bl = with_bindings -> TacLeft (true,bl) - | IDENT "right"; bl = with_bindings -> TacRight (false,bl) - | IDENT "eright"; bl = with_bindings -> TacRight (true,bl) - | IDENT "split"; bl = with_bindings -> TacSplit (false,false,[bl]) - | IDENT "esplit"; bl = with_bindings -> TacSplit (true,false,[bl]) - | "exists"; bll = LIST1 opt_bindings SEP "," -> TacSplit (false,true,bll) - | IDENT "eexists"; bll = LIST1 opt_bindings SEP "," -> - TacSplit (true,true,bll) - | IDENT "constructor"; n = nat_or_var; l = with_bindings -> - TacConstructor (false,n,l) - | IDENT "econstructor"; n = nat_or_var; l = with_bindings -> - TacConstructor (true,n,l) - | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor (false,t) - | IDENT "econstructor"; t = OPT tactic -> TacAnyConstructor (true,t) - + | "exists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (false,bll)) + | IDENT "eexists"; bll = opt_bindings -> + TacAtom (!@loc, TacSplit (true,bll)) (* Equivalence relations *) - | IDENT "reflexivity" -> TacReflexivity - | IDENT "symmetry"; cl = clause_dft_concl -> TacSymmetry cl - | IDENT "transitivity"; c = constr -> TacTransitivity (Some c) - | IDENT "etransitivity" -> TacTransitivity None + | IDENT "symmetry"; "in"; cl = in_clause -> TacAtom (!@loc, TacSymmetry cl) (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=opt_by_tactic -> TacRewrite (false,l,cl,t) + cl = clause_dft_concl; t=opt_by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=opt_by_tactic -> TacRewrite (true,l,cl,t) + cl = clause_dft_concl; t=opt_by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t)) | IDENT "dependent"; k = [ IDENT "simple"; IDENT "inversion" -> SimpleInversion | IDENT "inversion" -> FullInversion | IDENT "inversion_clear" -> FullInversionClear ]; hyp = quantified_hypothesis; - ids = with_inversion_names; co = OPT ["with"; c = constr -> c] -> - TacInversion (DepInversion (k,co,ids),hyp) + ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] -> + TacAtom (!@loc, TacInversion (DepInversion (k,co,ids),hyp)) | IDENT "simple"; IDENT "inversion"; - hyp = quantified_hypothesis; ids = with_inversion_names; + hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp) + TacAtom (!@loc, TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) | IDENT "inversion"; - hyp = quantified_hypothesis; ids = with_inversion_names; + hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - TacInversion (NonDepInversion (FullInversion, cl, ids), hyp) + TacAtom (!@loc, TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) | IDENT "inversion_clear"; - hyp = quantified_hypothesis; ids = with_inversion_names; + hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp) + TacAtom (!@loc, TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) | IDENT "inversion"; hyp = quantified_hypothesis; "using"; c = constr; cl = in_hyp_list -> - TacInversion (InversionUsing (c,cl), hyp) + TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) (* Conversion *) - | r = red_tactic; cl = clause_dft_concl -> TacReduce (r, cl) + | r = red_tactic; cl = clause_dft_concl -> TacAtom (!@loc, TacReduce (r, cl)) (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl -> - let p,cl = merge_occurrences loc cl oc in - TacChange (p,c,cl) + let p,cl = merge_occurrences (!@loc) cl oc in + TacAtom (!@loc, TacChange (p,c,cl)) ] ] ; END;; diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 75cd7d67..70a8ec55 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ->"; ":<"; "<:"; "where"; "at" ] let _ = List.iter Lexer.add_keyword vernac_kw @@ -33,7 +32,7 @@ let _ = List.iter Lexer.add_keyword vernac_kw (* Rem: do not join the different GEXTEND into one, it breaks native *) (* compilation on PowerPC and Sun architectures *) -let check_command = Gram.entry_create "vernac:check_command" +let query_command = Gram.entry_create "vernac:query_command" let tactic_mode = Gram.entry_create "vernac:tactic_command" let noedit_mode = Gram.entry_create "vernac:noedit_command" @@ -47,6 +46,7 @@ let record_field = Gram.entry_create "vernac:record_field" let of_type_with_opt_coercion = Gram.entry_create "vernac:of_type_with_opt_coercion" let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" +let section_subset_descr = Gram.entry_create "vernac:section_subset_descr" let command_entry = ref noedit_mode let set_command_entry e = command_entry := e @@ -63,81 +63,118 @@ let _ = Proof_global.register_proof_mode {Proof_global. reset = set_noedit_mode } +let make_bullet s = + let n = String.length s in + match s.[0] with + | '-' -> Dash n + | '+' -> Plus n + | '*' -> Star n + | _ -> assert false + let default_command_entry = Gram.Entry.of_parser "command_entry" (fun strm -> Gram.parse_tokens_after_filter (get_command_entry ()) strm) -let no_hook _ _ = () GEXTEND Gram GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; vernac: FIRST - [ [ IDENT "Time"; v = vernac -> VernacTime v + [ [ IDENT "Time"; l = vernac_list -> VernacTime l | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) | IDENT "Fail"; v = vernac -> VernacFail v - | locality; v = vernac_aux -> v ] ] + + | IDENT "Local"; v = vernac_poly -> VernacLocal (true, v) + | IDENT "Global"; v = vernac_poly -> VernacLocal (false, v) + + (* Stm backdoor *) + | IDENT "Stm"; IDENT "JoinDocument"; "." -> VernacStm JoinDocument + | IDENT "Stm"; IDENT "Finish"; "." -> VernacStm Finish + | IDENT "Stm"; IDENT "Wait"; "." -> VernacStm Wait + | IDENT "Stm"; IDENT "PrintDag"; "." -> VernacStm PrintDag + | IDENT "Stm"; IDENT "Observe"; id = INT; "." -> + VernacStm (Observe (Stateid.of_int (int_of_string id))) + | IDENT "Stm"; IDENT "Command"; v = vernac_aux -> VernacStm (Command v) + | IDENT "Stm"; IDENT "PGLast"; v = vernac_aux -> VernacStm (PGLast v) + + | v = vernac_poly -> v ] + ] + ; + vernac_poly: + [ [ IDENT "Polymorphic"; v = vernac_aux -> VernacPolymorphic (true, v) + | IDENT "Monomorphic"; v = vernac_aux -> VernacPolymorphic (false, v) + | v = vernac_aux -> v ] + ] ; vernac_aux: (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *) (* "." is still in the stream and discard_to_dot works correctly *) - [ [ g = gallina; "." -> g + [ [ IDENT "Program"; g = gallina; "." -> VernacProgram g + | IDENT "Program"; g = gallina_ext; "." -> VernacProgram g + | g = gallina; "." -> g | g = gallina_ext; "." -> g | c = command; "." -> c | c = syntax; "." -> c - | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l | c = subprf -> c ] ] ; + vernac_list: + [ [ c = located_vernac -> [c] ] ] + ; vernac_aux: LAST [ [ prfcom = default_command_entry -> prfcom ] ] ; - locality: - [ [ IDENT "Local" -> locality_flag := Some (loc,true) - | IDENT "Global" -> locality_flag := Some (loc,false) - | -> locality_flag := None ] ] - ; noedit_mode: [ [ c = subgoal_command -> c None] ] ; + + selector: + [ [ n=natural; ":" -> SelectNth n + | "["; id = ident; "]"; ":" -> SelectId id + | IDENT "all" ; ":" -> SelectAll + | IDENT "par" ; ":" -> SelectAllParallel ] ] + ; + tactic_mode: - [ [ gln = OPT[n=natural; ":" -> n]; + [ [ gln = OPT selector; tac = subgoal_command -> tac gln ] ] ; subprf: - [ [ - "-" -> VernacBullet Dash - | "*" -> VernacBullet Star - | "+" -> VernacBullet Plus + [ [ s = BULLET -> VernacBullet (make_bullet s) | "{" -> VernacSubproof None | "}" -> VernacEndSubproof ] ] ; - - subgoal_command: - [ [ c = check_command; "." -> fun g -> c g - | tac = Tactic.tactic; + [ [ c = query_command; "." -> + begin function + | Some (SelectNth g) -> c (Some g) + | None -> c None + | _ -> + VernacError (UserError ("",str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) + end + | info = OPT [IDENT "Info";n=natural -> n]; + tac = Tactic.tactic; use_dft_tac = [ "." -> false | "..." -> true ] -> - (fun g -> - let g = Option.default 1 g in - VernacSolve(g,tac,use_dft_tac)) ] ] + (fun g -> + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + VernacSolve(g,info,tac,use_dft_tac)) ] ] ; located_vernac: - [ [ v = vernac -> loc, v ] ] + [ [ v = vernac -> !@loc, v ] ] ; END let test_plurial_form = function | [(_,([_],_))] -> Flags.if_verbose msg_warning - (str "Keywords Variables/Hypotheses/Parameters expect more than one assumption") + (strbrk "Keywords Variables/Hypotheses/Parameters expect more than one assumption") | _ -> () let test_plurial_form_types = function | [([_],_)] -> Flags.if_verbose msg_warning - (str "Keywords Implicit Types expect more than one type") + (strbrk "Keywords Implicit Types expect more than one type") | _ -> () (* Gallina declarations *) @@ -150,39 +187,42 @@ GEXTEND Gram [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr; l = LIST0 [ "with"; id = identref; bl = binders; ":"; c = lconstr -> - (Some id,(bl,c,None)) ] -> - VernacStartTheoremProof (thm,(Some id,(bl,c,None))::l, false, no_hook) + (Some id,(bl,c,None)) ] -> + VernacStartTheoremProof (thm, (Some id,(bl,c,None))::l, false) | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | stre = assumptions_token; nl = inline; bl = assum_list -> test_plurial_form bl; VernacAssumption (stre, nl, bl) - | (f,d) = def_token; id = identref; b = def_body -> - VernacDefinition (d, id, b, f) + | d = def_token; id = identref; b = def_body -> + VernacDefinition (d, id, b) + | IDENT "Let"; id = identref; b = def_body -> + VernacDefinition ((Some Discharge, Definition), id, b) (* Gallina inductive declarations *) - | f = finite_token; + | priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> let (k,f) = f in let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in - VernacInductive (f,false,indl) + VernacInductive (priv,f,indl) | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint recs + VernacFixpoint (None, recs) + | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + VernacFixpoint (Some Discharge, recs) | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint corecs + VernacCoFixpoint (None, corecs) + | IDENT "Let"; "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> + VernacCoFixpoint (Some Discharge, corecs) | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; - l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) ] ] - ; - gallina_ext: - [ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref; - ps = binders; - s = OPT [ ":"; s = lconstr -> s ]; - cfs = [ ":="; l = constructor_list_or_record_decl -> l - | -> RecordDecl (None, []) ] -> - let (recf,indf) = b in - VernacInductive (indf,infer,[((oc,name),ps,s,recf,cfs),[]]) + l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) + | IDENT "Register"; IDENT "Inline"; id = identref -> + VernacRegister(id, RegisterInline) + | IDENT "Universe"; l = LIST1 identref -> VernacUniverse l + | IDENT "Universes"; l = LIST1 identref -> VernacUniverse l + | IDENT "Constraint"; l = LIST1 univ_constraint SEP "," -> VernacConstraint l ] ] ; + thm_token: [ [ "Theorem" -> Theorem | IDENT "Lemma" -> Lemma @@ -193,50 +233,48 @@ GEXTEND Gram | IDENT "Property" -> Property ] ] ; def_token: - [ [ "Definition" -> - no_hook, (Global, Definition) - | IDENT "Let" -> - no_hook, (Local, Definition) - | IDENT "Example" -> - no_hook, (Global, Example) - | IDENT "SubClass" -> - Class.add_subclass_hook, (use_locality_exp (), SubClass) ] ] + [ [ "Definition" -> (None, Definition) + | IDENT "Example" -> (None, Example) + | IDENT "SubClass" -> (None, SubClass) ] ] ; assumption_token: - [ [ "Hypothesis" -> (Local, Logical) - | "Variable" -> (Local, Definitional) - | "Axiom" -> (Global, Logical) - | "Parameter" -> (Global, Definitional) - | IDENT "Conjecture" -> (Global, Conjectural) ] ] + [ [ "Hypothesis" -> (Some Discharge, Logical) + | "Variable" -> (Some Discharge, Definitional) + | "Axiom" -> (None, Logical) + | "Parameter" -> (None, Definitional) + | IDENT "Conjecture" -> (None, Conjectural) ] ] ; assumptions_token: - [ [ IDENT "Hypotheses" -> (Local, Logical) - | IDENT "Variables" -> (Local, Definitional) - | IDENT "Axioms" -> (Global, Logical) - | IDENT "Parameters" -> (Global, Definitional) ] ] + [ [ IDENT "Hypotheses" -> (Some Discharge, Logical) + | IDENT "Variables" -> (Some Discharge, Definitional) + | IDENT "Axioms" -> (None, Logical) + | IDENT "Parameters" -> (None, Definitional) ] ] ; inline: - [ [ IDENT "Inline"; "("; i = INT; ")" -> Some (int_of_string i) - | IDENT "Inline" -> Some (Flags.get_inline_level()) - | -> None] ] + [ [ IDENT "Inline"; "("; i = INT; ")" -> InlineAt (int_of_string i) + | IDENT "Inline" -> DefaultInline + | -> NoInline] ] + ; + univ_constraint: + [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; + r = identref -> (l, ord, r) ] ] ; finite_token: [ [ "Inductive" -> (Inductive_kw,Finite) - | "CoInductive" -> (CoInductive,CoFinite) ] ] - ; - infer_token: - [ [ IDENT "Infer" -> true | -> false ] ] - ; - record_token: - [ [ IDENT "Record" -> (Record,BiFinite) + | "CoInductive" -> (CoInductive,CoFinite) + | "Variant" -> (Variant,BiFinite) + | IDENT "Record" -> (Record,BiFinite) | IDENT "Structure" -> (Structure,BiFinite) | IDENT "Class" -> (Class true,BiFinite) ] ] ; + private_token: + [ [ IDENT "Private" -> true | -> false ] ] + ; (* Simple definitions *) def_body: [ [ bl = binders; ":="; red = reduce; c = lconstr -> (match c with - CCast(_,c, Glob_term.CastConv (Term.DEFAULTcast,t)) -> DefineBody (bl, red, c, Some t) + CCast(_,c, CastConv t) -> DefineBody (bl, red, c, Some t) | _ -> DefineBody (bl, red, c, None)) | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> DefineBody (bl, red, c, Some t) @@ -256,10 +294,14 @@ GEXTEND Gram | -> [] ] ] ; (* Inductives and records *) + opt_constructors_or_fields: + [ [ ":="; lc = constructor_list_or_record_decl -> lc + | -> RecordDecl (None, []) ] ] + ; inductive_definition: - [ [ id = identref; oc = opt_coercion; indpar = binders; + [ [ oc = opt_coercion; id = identref; indpar = binders; c = OPT [ ":"; c = lconstr -> c ]; - ":="; lc = constructor_list_or_record_decl; ntn = decl_notation -> + lc=opt_constructors_or_fields; ntn = decl_notation -> (((oc,id),indpar,c,lc),ntn) ] ] ; constructor_list_or_record_decl: @@ -296,7 +338,7 @@ GEXTEND Gram ; type_cstr: [ [ ":"; c=lconstr -> c - | -> CHole (loc, None) ] ] + | -> CHole (!@loc, None, Misctypes.IntroAnonymous, None) ] ] ; (* Inductive schemes *) scheme: @@ -333,19 +375,19 @@ GEXTEND Gram ; record_binder_body: [ [ l = binders; oc = of_type_with_opt_coercion; - t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN loc l t)) + t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN (!@loc) l t)) | l = binders; oc = of_type_with_opt_coercion; t = lconstr; ":="; b = lconstr -> fun id -> - (oc,DefExpr (id,mkCLambdaN loc l b,Some (mkCProdN loc l t))) + (oc,DefExpr (id,mkCLambdaN (!@loc) l b,Some (mkCProdN (!@loc) l t))) | l = binders; ":="; b = lconstr -> fun id -> match b with - | CCast(_,b, Glob_term.CastConv (_, t)) -> - (None,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t))) + | CCast(_,b, (CastConv t|CastVM t|CastNative t)) -> + (None,DefExpr(id,mkCLambdaN (!@loc) l b,Some (mkCProdN (!@loc) l t))) | _ -> - (None,DefExpr(id,mkCLambdaN loc l b,None)) ] ] + (None,DefExpr(id,mkCLambdaN (!@loc) l b,None)) ] ] ; record_binder: - [ [ id = name -> (None,AssumExpr(id,CHole (loc, None))) + [ [ id = name -> (None,AssumExpr(id,CHole (!@loc, None, Misctypes.IntroAnonymous, None))) | id = name; f = record_binder_body -> f id ] ] ; assum_list: @@ -356,15 +398,15 @@ GEXTEND Gram ; simple_assum_coe: [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> - (oc <> None,(idl,c)) ] ] + (not (Option.is_empty oc),(idl,c)) ] ] ; constructor_type: [[ l = binders; t= [ coe = of_type_with_opt_coercion; c = lconstr -> - fun l id -> (coe <> None,(id,mkCProdN loc l c)) + fun l id -> (not (Option.is_empty coe),(id,mkCProdN (!@loc) l c)) | -> - fun l id -> (false,(id,mkCProdN loc l (CHole (loc, None)))) ] + fun l id -> (false,(id,mkCProdN (!@loc) l (CHole (!@loc, None, Misctypes.IntroAnonymous, None)))) ] -> t l ]] ; @@ -382,10 +424,20 @@ GEXTEND Gram ; END +let only_identrefs = + Gram.Entry.of_parser "test_only_identrefs" + (fun strm -> + let rec aux n = + match get_tok (Util.stream_nth n strm) with + | KEYWORD "." -> () + | KEYWORD ")" -> () + | IDENT _ -> aux (n+1) + | _ -> raise Stream.Failure in + aux 0) (* Modules and Sections *) GEXTEND Gram - GLOBAL: gallina_ext module_expr module_type; + GLOBAL: gallina_ext module_expr module_type section_subset_descr; gallina_ext: [ [ (* Interactive module declaration *) @@ -407,18 +459,24 @@ GEXTEND Gram (* This end a Section a Module or a Module Type *) | IDENT "End"; id = identref -> VernacEndSegment id + (* Naming a set of section hyps *) + | IDENT "Collection"; id = identref; ":="; expr = section_subset_descr -> + VernacNameSectionHypSet (id, expr) + (* Requiring an already compiled module *) | IDENT "Require"; export = export_token; qidl = LIST1 global -> - VernacRequire (export, None, qidl) - | IDENT "Require"; export = export_token; filename = ne_string -> - VernacRequireFrom (export, None, filename) + VernacRequire (export, qidl) + | IDENT "From" ; ns = global ; IDENT "Require"; export = export_token + ; qidl = LIST1 global -> + let qidl = List.map (Libnames.join_reference ns) qidl in + VernacRequire (export, qidl) | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr -> VernacInclude(e::l) | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type -> Flags.if_verbose - msg_warning (str "Include Type is deprecated; use Include instead"); + msg_warning (strbrk "Include Type is deprecated; use Include instead"); VernacInclude(e::l) ] ] ; export_token: @@ -451,32 +509,19 @@ GEXTEND Gram | -> [] ] ] ; functor_app_annot: - [ [ IDENT "inline"; "at"; IDENT "level"; i = INT -> - [InlineAt (int_of_string i)], [] - | IDENT "no"; IDENT "inline" -> [NoInline], [] - | IDENT "scope"; sc1 = IDENT; IDENT "to"; sc2 = IDENT -> [], [sc1,sc2] - ] ] - ; - functor_app_annots: - [ [ "["; l = LIST1 functor_app_annot SEP ","; "]" -> - let inl,scs = List.split l in - let inl = match List.concat inl with - | [] -> DefaultInline - | [inl] -> inl - | _ -> error "Functor application with redundant inline annotations" - in { ann_inline = inl; ann_scope_subst = List.concat scs } - | -> { ann_inline = DefaultInline; ann_scope_subst = [] } + [ [ "["; IDENT "inline"; "at"; IDENT "level"; i = INT; "]" -> + InlineAt (int_of_string i) + | "["; IDENT "no"; IDENT "inline"; "]" -> NoInline + | -> DefaultInline ] ] ; module_expr_inl: - [ [ "!"; me = module_expr -> - (me, { ann_inline = NoInline; ann_scope_subst = []}) - | me = module_expr; a = functor_app_annots -> (me,a) ] ] + [ [ "!"; me = module_expr -> (me,NoInline) + | me = module_expr; a = functor_app_annot -> (me,a) ] ] ; module_type_inl: - [ [ "!"; me = module_type -> - (me, { ann_inline = NoInline; ann_scope_subst = []}) - | me = module_type; a = functor_app_annots -> (me,a) ] ] + [ [ "!"; me = module_type -> (me,NoInline) + | me = module_type; a = functor_app_annot -> (me,a) ] ] ; (* Module binder *) module_binder: @@ -486,7 +531,7 @@ GEXTEND Gram (* Module expressions *) module_expr: [ [ me = module_expr_atom -> me - | me1 = module_expr; me2 = module_expr_atom -> CMapply (loc,me1,me2) + | me1 = module_expr; me2 = module_expr_atom -> CMapply (!@loc,me1,me2) ] ] ; module_expr_atom: @@ -502,11 +547,28 @@ GEXTEND Gram module_type: [ [ qid = qualid -> CMident qid | "("; mt = module_type; ")" -> mt - | mty = module_type; me = module_expr_atom -> CMapply (loc,mty,me) + | mty = module_type; me = module_expr_atom -> CMapply (!@loc,mty,me) | mty = module_type; "with"; decl = with_declaration -> - CMwith (loc,mty,decl) + CMwith (!@loc,mty,decl) ] ] ; + section_subset_descr: + [ [ IDENT "All" -> SsAll + | "Type" -> SsType + | only_identrefs; l = LIST0 identref -> SsExpr (SsSet l) + | e = section_subset_expr -> SsExpr e ] ] + ; + section_subset_expr: + [ "35" + [ "-"; e = section_subset_expr -> SsCompl e ] + | "50" + [ e1 = section_subset_expr; "-"; e2 = section_subset_expr->SsSubstr(e1,e2) + | e1 = section_subset_expr; "+"; e2 = section_subset_expr->SsUnion(e1,e2)] + | "0" + [ i = identref -> SsSet [i] + | "("; only_identrefs; l = LIST0 identref; ")"-> SsSet l + | "("; e = section_subset_expr; ")"-> e ] ] + ; END (* Extensions: implicits, coercions, etc. *) @@ -516,12 +578,12 @@ GEXTEND Gram gallina_ext: [ [ (* Transparent and Opaque *) IDENT "Transparent"; l = LIST1 smart_global -> - VernacSetOpacity (use_non_locality (),[Conv_oracle.transparent,l]) + VernacSetOpacity (Conv_oracle.transparent, l) | IDENT "Opaque"; l = LIST1 smart_global -> - VernacSetOpacity (use_non_locality (),[Conv_oracle.Opaque, l]) + VernacSetOpacity (Conv_oracle.Opaque, l) | IDENT "Strategy"; l = - LIST1 [ lev=strategy_level; "["; q=LIST1 smart_global; "]" -> (lev,q)] -> - VernacSetOpacity (use_locality (),l) + LIST1 [ v=strategy_level; "["; q=LIST1 smart_global; "]" -> (v,q)] -> + VernacSetStrategy l (* Canonical structure *) | IDENT "Canonical"; IDENT "Structure"; qid = global -> VernacCanonical (AN qid) @@ -531,50 +593,50 @@ GEXTEND Gram d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition - ((Global,CanonicalStructure),(dummy_loc,s),d, - (fun _ -> Recordops.declare_canonical_structure)) + ((Some Global,CanonicalStructure),(Loc.ghost,s),d) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((use_locality_exp (),Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + VernacDefinition ((None,Coercion),(Loc.ghost,s),d) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((enforce_locality_exp true,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + VernacDefinition ((Some Decl_kinds.Local,Coercion),(Loc.ghost,s),d) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (enforce_locality_exp true, f, s, t) + VernacIdentityCoercion (true, f, s, t) | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (use_locality_exp (), f, s, t) + VernacIdentityCoercion (false, f, s, t) | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (enforce_locality_exp true, AN qid, s, t) + VernacCoercion (true, AN qid, s, t) | IDENT "Coercion"; IDENT "Local"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (enforce_locality_exp true, ByNotation ntn, s, t) + VernacCoercion (true, ByNotation ntn, s, t) | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (use_locality_exp (), AN qid, s, t) + VernacCoercion (false, AN qid, s, t) | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (use_locality_exp (), ByNotation ntn, s, t) + VernacCoercion (false, ByNotation ntn, s, t) | IDENT "Context"; c = binders -> VernacContext c | IDENT "Instance"; namesup = instance_name; ":"; - expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200"; + expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200"; pri = OPT [ "|"; i = natural -> i ] ; - props = [ ":="; "{"; r = record_declaration; "}" -> Some r | - ":="; c = lconstr -> Some c | -> None ] -> - VernacInstance (false, not (use_section_locality ()), - snd namesup, (fst namesup, expl, t), props, pri) + props = [ ":="; "{"; r = record_declaration; "}" -> Some (true,r) | + ":="; c = lconstr -> Some (false,c) | -> None ] -> + VernacInstance (false,snd namesup,(fst namesup,expl,t),props,pri) - | IDENT "Existing"; IDENT "Instance"; id = global -> - VernacDeclareInstances (not (use_section_locality ()), [id]) - | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global -> - VernacDeclareInstances (not (use_section_locality ()), ids) + | IDENT "Existing"; IDENT "Instance"; id = global; + pri = OPT [ "|"; i = natural -> i ] -> + VernacDeclareInstances ([id], pri) + | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global; + pri = OPT [ "|"; i = natural -> i ] -> + VernacDeclareInstances (ids, pri) | IDENT "Existing"; IDENT "Class"; is = global -> VernacDeclareClass is @@ -586,17 +648,17 @@ GEXTEND Gram | "/" -> [`Slash] | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> loc, y) x + | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x | Some _, Some _ -> error "scope declared twice" in List.map (fun (id,r,s) -> `Id(id,r,f s,false,false)) items | "["; items = LIST1 argument_spec; "]"; sc = OPT scope -> let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> loc, y) x + | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x | Some _, Some _ -> error "scope declared twice" in List.map (fun (id,r,s) -> `Id(id,r,f s,true,false)) items | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope -> let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> loc, y) x + | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x | Some _, Some _ -> error "scope declared twice" in List.map (fun (id,r,s) -> `Id(id,r,f s,true,true)) items ] -> l ] SEP ","; @@ -609,31 +671,30 @@ GEXTEND Gram | [] -> narg, impl in let nargs, impl = List.split (List.map (aux 0 (-1, [])) impl) in let nargs, rest = List.hd nargs, List.tl nargs in - if List.exists ((<>) nargs) rest then + if List.exists (fun arg -> not (Int.equal arg nargs)) rest then error "All arguments lists must have the same length"; let err_incompat x y = error ("Options \""^x^"\" and \""^y^"\" are incompatible") in - if nargs > 0 && List.mem `SimplNeverUnfold mods then + if nargs > 0 && List.mem `ReductionNeverUnfold mods then err_incompat "simpl never" "/"; - if List.mem `SimplNeverUnfold mods && - List.mem `SimplDontExposeCase mods then + if List.mem `ReductionNeverUnfold mods && + List.mem `ReductionDontExposeCase mods then err_incompat "simpl never" "simpl nomatch"; - VernacArguments (use_section_locality(), qid, impl, nargs, mods) + VernacArguments (qid, impl, nargs, mods) (* moved there so that camlp5 factors it with the previous rule *) | IDENT "Arguments"; IDENT "Scope"; qid = smart_global; "["; scl = LIST0 [ "_" -> None | sc = IDENT -> Some sc ]; "]" -> - Flags.if_verbose - msg_warning (str "Arguments Scope is deprecated; use Arguments instead"); - VernacArgumentsScope (use_section_locality (),qid,scl) + msg_warning (strbrk "Arguments Scope is deprecated; use Arguments instead"); + VernacArgumentsScope (qid,scl) (* Implicit *) | IDENT "Implicit"; IDENT "Arguments"; qid = smart_global; pos = LIST0 [ "["; l = LIST0 implicit_name; "]" -> List.map (fun (id,b,f) -> (ExplByName id,b,f)) l ] -> Flags.if_verbose - msg_warning (str "Implicit Arguments is deprecated; use Arguments instead"); - VernacDeclareImplicits (use_section_locality (),qid,pos) + msg_warning (strbrk "Implicit Arguments is deprecated; use Arguments instead"); + VernacDeclareImplicits (qid,pos) | IDENT "Implicit"; "Type"; bl = reserv_list -> VernacReserve bl @@ -647,15 +708,16 @@ GEXTEND Gram | IDENT "No"; IDENT "Variables" -> None | ["Variable" | IDENT "Variables"]; idl = LIST1 identref -> Some idl ] -> - VernacGeneralizable (use_non_locality (), gen) ] ] + VernacGeneralizable gen ] ] ; arguments_modifier: - [ [ IDENT "simpl"; IDENT "nomatch" -> [`SimplDontExposeCase] - | IDENT "simpl"; IDENT "never" -> [`SimplNeverUnfold] + [ [ IDENT "simpl"; IDENT "nomatch" -> [`ReductionDontExposeCase] + | IDENT "simpl"; IDENT "never" -> [`ReductionNeverUnfold] | IDENT "default"; IDENT "implicits" -> [`DefaultImplicits] | IDENT "clear"; IDENT "implicits" -> [`ClearImplicits] | IDENT "clear"; IDENT "scopes" -> [`ClearScopes] | IDENT "rename" -> [`Rename] + | IDENT "assert" -> [`Assert] | IDENT "extra"; IDENT "scopes" -> [`ExtraScopes] | IDENT "clear"; IDENT "scopes"; IDENT "and"; IDENT "implicits" -> [`ClearImplicits; `ClearScopes] @@ -674,7 +736,7 @@ GEXTEND Gram ; argument_spec: [ [ b = OPT "!"; id = name ; s = OPT scope -> - snd id, b <> None, Option.map (fun x -> loc, x) s + snd id, not (Option.is_empty b), Option.map (fun x -> !@loc, x) s ] ]; strategy_level: @@ -688,7 +750,7 @@ GEXTEND Gram [ [ name = identref; sup = OPT binders -> (let (loc,id) = name in (loc, Name id)), (Option.default [] sup) - | -> (loc, Anonymous), [] ] ] + | -> (!@loc, Anonymous), [] ] ] ; reserv_list: [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ] @@ -703,18 +765,20 @@ GEXTEND Gram END GEXTEND Gram - GLOBAL: command check_command class_rawexpr; + GLOBAL: command query_command class_rawexpr; command: - [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l + [ [ IDENT "Ltac"; + l = LIST1 tacdef_body SEP "with" -> + VernacDeclareTacticDefinition (true, l) + + | IDENT "Comments"; l = LIST0 comment -> VernacComments l (* Hack! Should be in grammar_ext, but camlp4 factorize badly *) | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; - expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200"; + expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200"; pri = OPT [ "|"; i = natural -> i ] -> - VernacInstance (true, not (use_section_locality ()), - snd namesup, (fst namesup, expl, t), - None, pri) + VernacInstance (true, snd namesup, (fst namesup, expl, t), None, pri) (* System directory *) | IDENT "Pwd" -> VernacChdir None @@ -729,7 +793,7 @@ GEXTEND Gram s = [ s = ne_string -> s | s = IDENT -> s ] -> VernacLoad (verbosely, s) | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string -> - VernacDeclareMLModule (use_locality (), l) + VernacDeclareMLModule l | IDENT "Locate"; l = locatable -> VernacLocate l @@ -759,44 +823,32 @@ GEXTEND Gram VernacPrint (PrintModuleType qid) | IDENT "Print"; IDENT "Module"; qid = global -> VernacPrint (PrintModule qid) + | IDENT "Print"; IDENT "Namespace" ; ns = dirpath -> + VernacPrint (PrintNamespace ns) | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) - | IDENT "About"; qid = smart_global -> VernacPrint (PrintAbout qid) - - (* Searching the environment *) - | IDENT "Search"; c = constr_pattern; l = in_or_out_modules -> - VernacSearch (SearchHead c, l) - | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules -> - VernacSearch (SearchPattern c, l) - | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules -> - VernacSearch (SearchRewrite c, l) - | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries -> - let (sl,m) = l in VernacSearch (SearchAbout (s::sl), m) - (* compatibility format of SearchAbout, with "[ ... ]" *) - | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]"; - l = in_or_out_modules -> VernacSearch (SearchAbout sl, l) | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string -> VernacAddMLPath (false, dir) | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string -> VernacAddMLPath (true, dir) - (* Pour intervenir sur les tables de paramètres *) + (* For acting on parameter tables *) | "Set"; table = option_table; v = option_value -> - VernacSetOption (use_locality_full(),table,v) + VernacSetOption (table,v) | "Set"; table = option_table -> - VernacSetOption (use_locality_full(),table,BoolValue true) + VernacSetOption (table,BoolValue true) | IDENT "Unset"; table = option_table -> - VernacUnsetOption (use_locality_full(),table) + VernacUnsetOption table | IDENT "Print"; IDENT "Table"; table = option_table -> VernacPrintOption table | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value -> VernacAddOption ([table;field], v) - (* Un value global ci-dessous va être caché par un field au dessus! *) - (* En fait, on donne priorité aux tables secondaires *) - (* Pas de syntaxe pour les tables tertiaires pour cause de conflit *) - (* (mais de toutes façons, pas utilisées) *) + (* A global value below will be hidden by a field above! *) + (* In fact, we give priority to secondary tables *) + (* No syntax for tertiary tables due to conflict *) + (* (but they are unused anyway) *) | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> VernacAddOption ([table], v) @@ -810,13 +862,31 @@ GEXTEND Gram | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> VernacRemoveOption ([table], v) ]] ; - check_command: (* TODO: rapprocher Eval et Check *) + query_command: (* TODO: rapprocher Eval et Check *) [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr -> fun g -> VernacCheckMayEval (Some r, g, c) | IDENT "Compute"; c = lconstr -> - fun g -> VernacCheckMayEval (Some Glob_term.CbvVm, g, c) + fun g -> VernacCheckMayEval (Some (Genredexpr.CbvVm None), g, c) | IDENT "Check"; c = lconstr -> - fun g -> VernacCheckMayEval (None, g, c) ] ] + fun g -> VernacCheckMayEval (None, g, c) + (* Searching the environment *) + | IDENT "About"; qid = smart_global -> + fun g -> VernacPrint (PrintAbout (qid,g)) + | IDENT "SearchHead"; c = constr_pattern; l = in_or_out_modules -> + fun g -> VernacSearch (SearchHead c,g, l) + | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules -> + fun g -> VernacSearch (SearchPattern c,g, l) + | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules -> + fun g -> VernacSearch (SearchRewrite c,g, l) + | IDENT "Search"; s = searchabout_query; l = searchabout_queries -> + let (sl,m) = l in fun g -> VernacSearch (SearchAbout (s::sl),g, m) + (* compatibility: SearchAbout *) + | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries -> + fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m) + (* compatibility: SearchAbout with "[ ... ]" *) + | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]"; + l = in_or_out_modules -> fun g -> VernacSearch (SearchAbout sl,g, l) + ] ] ; printable: [ [ IDENT "Term"; qid = smart_global -> PrintName qid @@ -832,6 +902,7 @@ GEXTEND Gram | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath | IDENT "ML"; IDENT "Modules" -> PrintMLModules + | IDENT "Debug"; IDENT "GC" -> PrintDebugGC | IDENT "Graph" -> PrintGraph | IDENT "Classes" -> PrintClasses | IDENT "TypeClasses" -> PrintTypeClasses @@ -854,8 +925,12 @@ GEXTEND Gram | IDENT "Implicit"; qid = smart_global -> PrintImplicit qid | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (false, fopt) | IDENT "Sorted"; IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (true, fopt) - | IDENT "Assumptions"; qid = smart_global -> PrintAssumptions (false, qid) - | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, qid) ] ] + | IDENT "Assumptions"; qid = smart_global -> PrintAssumptions (false, false, qid) + | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, false, qid) + | IDENT "Transparent"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (false, true, qid) + | IDENT "All"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, true, qid) + | IDENT "Strategy"; qid = smart_global -> PrintStrategy (Some qid) + | IDENT "Strategies" -> PrintStrategy None ] ] ; class_rawexpr: [ [ IDENT "Funclass" -> FunClass @@ -863,7 +938,8 @@ GEXTEND Gram | qid = smart_global -> RefClass qid ] ] ; locatable: - [ [ qid = smart_global -> LocateTerm qid + [ [ qid = smart_global -> LocateAny qid + | IDENT "Term"; qid = smart_global -> LocateTerm qid | IDENT "File"; f = ne_string -> LocateFile f | IDENT "Library"; qid = global -> LocateLibrary qid | IDENT "Module"; qid = global -> LocateModule qid @@ -938,16 +1014,16 @@ GEXTEND Gram (* Tactic Debugger *) | IDENT "Debug"; IDENT "On" -> - VernacSetOption (None,["Ltac";"Debug"], BoolValue true) + VernacSetOption (["Ltac";"Debug"], BoolValue true) | IDENT "Debug"; IDENT "Off" -> - VernacSetOption (None,["Ltac";"Debug"], BoolValue false) + VernacSetOption (["Ltac";"Debug"], BoolValue false) (* registration of a custom reduction *) | IDENT "Declare"; IDENT "Reduction"; s = IDENT; ":="; r = Tactic.red_expr -> - VernacDeclareReduction (use_locality(),s,r) + VernacDeclareReduction (s,r) ] ]; END @@ -960,31 +1036,33 @@ GEXTEND Gram syntax: [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (enforce_section_locality local,true,sc) + VernacOpenCloseScope (local,(true,sc)) | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (enforce_section_locality local,false,sc) + VernacOpenCloseScope (local,(false,sc)) | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> VernacDelimiters (sc,key) | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; - refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) + refl = LIST1 smart_global -> VernacBindScope (sc,refl) | IDENT "Infix"; local = obsolete_locality; op = ne_lstring; ":="; p = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacInfix (enforce_module_locality local,(op,modl),p,sc) + VernacInfix (local,(op,modl),p,sc) | IDENT "Notation"; local = obsolete_locality; id = identref; idl = LIST0 ident; ":="; c = constr; b = only_parsing -> VernacSyntacticDefinition - (id,(idl,c),enforce_module_locality local,b) + (id,(idl,c),local,b) | IDENT "Notation"; local = obsolete_locality; s = ne_lstring; ":="; c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacNotation (enforce_module_locality local,c,(s,modl),sc) + VernacNotation (local,c,(s,modl),sc) + | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> + VernacNotationAddFormat (n,s,fmt) | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; pil = LIST1 production_item; ":="; t = Tactic.tactic @@ -994,12 +1072,12 @@ GEXTEND Gram l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> Metasyntax.check_infix_modifiers l; let (loc,s) = s in - VernacSyntaxExtension (use_module_locality(),((loc,"x '"^s^"' y"),l)) + VernacSyntaxExtension (false,((loc,"x '"^s^"' y"),l)) | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] - -> VernacSyntaxExtension (enforce_module_locality local,(s,l)) + -> VernacSyntaxExtension (local,(s,l)) (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) @@ -1031,7 +1109,11 @@ GEXTEND Gram SetOnlyParsing Flags.Current | IDENT "compat"; s = STRING -> SetOnlyParsing (Coqinit.get_compat_version s) - | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s + | IDENT "format"; s1 = [s = STRING -> (!@loc,s)]; + s2 = OPT [s = STRING -> (!@loc,s)] -> + begin match s1, s2 with + | (_,k), Some s -> SetFormat(k,s) + | s, None -> SetFormat ("text",s) end | x = IDENT; ","; l = LIST1 [id = IDENT -> id ] SEP ","; "at"; lev = level -> SetItemLevel (x::l,lev) | x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) @@ -1049,6 +1131,6 @@ GEXTEND Gram [ [ s = ne_string -> TacTerm s | nt = IDENT; po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; - ")" -> (p,sep) ] -> TacNonTerm (loc,nt,po) ] ] + ")" -> (p,sep) ] -> TacNonTerm (!@loc,nt,po) ] ] ; END diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index 6f5e378a..84e4a573 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -1,32 +1,34 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ctag then + if not (String.equal otag ctag) then user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ str "does not match open xml tag " ++ str otag ++ str ".") @@ -41,27 +43,22 @@ GEXTEND Gram xml: [ [ "<"; otag = IDENT; attrs = LIST0 attr; ">"; l = LIST1 xml; "<"; "/"; ctag = IDENT; ">" -> - check_tags loc otag ctag; - XmlTag (loc,ctag,attrs,l) + check_tags (!@loc) otag ctag; + XmlTag (!@loc,ctag,attrs,l) | "<"; tag = IDENT; attrs = LIST0 attr; "/"; ">" -> - XmlTag (loc,tag,attrs,[]) + XmlTag (!@loc,tag,attrs,[]) ] ] ; attr: - [ [ name = IDENT; "="; data = STRING -> (name, (loc, data)) ] ] + [ [ name = IDENT; "="; data = STRING -> (name, (!@loc, data)) ] ] ; END (* Errors *) -let error_expect_two_arguments loc = - user_err_loc (loc,"",str "wrong number of arguments (expect two).") - -let error_expect_one_argument loc = - user_err_loc (loc,"",str "wrong number of arguments (expect one).") - -let error_expect_no_argument loc = - user_err_loc (loc,"",str "wrong number of arguments (expect none).") +let error_bad_arity loc n = + let s = match n with 0 -> "none" | 1 -> "one" | 2 -> "two" | _ -> "many" in + user_err_loc (loc,"",str ("wrong number of arguments (expect "^s^").")) (* Interpreting attributes *) @@ -70,33 +67,49 @@ let nmtoken (loc,a) = with Failure _ -> user_err_loc (loc,"",str "nmtoken expected.") let get_xml_attr s al = - try List.assoc s al + try String.List.assoc s al with Not_found -> error ("No attribute "^s) (* Interpreting specific attributes *) -let ident_of_cdata (loc,a) = id_of_string a +let ident_of_cdata (loc,a) = Id.of_string a let uri_of_data s = - let n = String.index s ':' in - let p = String.index s '.' in - let s = String.sub s (n+2) (p-n-2) in - for i=0 to String.length s - 1 do if s.[i]='/' then s.[i]<-'.' done; - qualid_of_string s - -let constant_of_cdata (loc,a) = Nametab.locate_constant (uri_of_data a) - -let global_of_cdata (loc,a) = Nametab.locate (uri_of_data a) + try + let n = String.index s ':' in + let p = String.index s '.' in + let s = String.sub s (n+2) (p-n-2) in + for i = 0 to String.length s - 1 do + match s.[i] with + | '/' -> s.[i] <- '.' + | _ -> () + done; + qualid_of_string s + with Not_found | Invalid_argument _ -> + error ("Malformed URI \""^s^"\"") + +let constant_of_cdata (loc,a) = + let q = uri_of_data a in + try Nametab.locate_constant q + with Not_found -> error ("No such constant "^string_of_qualid q) + +let global_of_cdata (loc,a) = + let q = uri_of_data a in + try Nametab.locate q + with Not_found -> error ("No such global "^string_of_qualid q) let inductive_of_cdata a = match global_of_cdata a with - | IndRef (kn,_) -> kn - | _ -> anomaly "XML parser: not an inductive" + | IndRef (kn,_) -> kn + | _ -> error (string_of_qualid (uri_of_data (snd a)) ^" is not an inductive") -let ltacref_of_cdata (loc,a) = (loc,locate_tactic (uri_of_data a)) +let ltacref_of_cdata (loc,a) = + let q = uri_of_data a in + try (loc,Nametab.locate_tactic q) + with Not_found -> error ("No such ltac "^string_of_qualid q) let sort_of_cdata (loc,a) = match a with - | "Prop" -> GProp Null - | "Set" -> GProp Pos + | "Prop" -> GProp + | "Set" -> GSet | "Type" -> GType None | _ -> user_err_loc (loc,"",str "sort expected.") @@ -105,7 +118,7 @@ let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al) let get_xml_inductive_kn al = inductive_of_cdata (* uriType apparent synonym of uri *) (try get_xml_attr "uri" al - with e when Errors.noncritical e -> get_xml_attr "uriType" al) + with UserError _ -> get_xml_attr "uriType" al) let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al) @@ -116,7 +129,7 @@ let get_xml_constructor al = (get_xml_inductive al, nmtoken (get_xml_attr "noConstr" al)) let get_xml_binder al = - try Name (ident_of_cdata (List.assoc "binder" al)) + try Name (ident_of_cdata (String.List.assoc "binder" al)) with Not_found -> Anonymous let get_xml_ident al = ident_of_cdata (get_xml_attr "binder" al) @@ -125,7 +138,7 @@ let get_xml_name al = ident_of_cdata (get_xml_attr "name" al) let get_xml_noFun al = nmtoken (get_xml_attr "noFun" al) -let get_xml_no al = nmtoken (get_xml_attr "no" al) +let get_xml_no al = Evar.unsafe_of_int (nmtoken (get_xml_attr "no" al)) (* A leak in the xml dtd: arities of constructor need to know global env *) @@ -133,8 +146,8 @@ let compute_branches_lengths ind = let (_,mip) = Inductive.lookup_mind_specif (Global.env()) ind in mip.Declarations.mind_consnrealdecls -let compute_inductive_nargs ind = - Inductiveops.inductive_nargs (Global.env()) ind +let compute_inductive_ndecls ind = + Inductiveops.inductive_nrealdecls ind (* Interpreting constr as a glob_constr *) @@ -144,17 +157,17 @@ let rec interp_xml_constr = function | XmlTag (loc,"VAR",al,[]) -> error "XML parser: unable to interp free variables" | XmlTag (loc,"LAMBDA",al,(_::_ as xl)) -> - let body,decls = list_sep_last xl in + let body,decls = List.sep_last xl in let ctx = List.map interp_xml_decl decls in List.fold_right (fun (na,t) b -> GLambda (loc, na, Explicit, t, b)) ctx (interp_xml_target body) | XmlTag (loc,"PROD",al,(_::_ as xl)) -> - let body,decls = list_sep_last xl in + let body,decls = List.sep_last xl in let ctx = List.map interp_xml_decl decls in List.fold_right (fun (na,t) b -> GProd (loc, na, Explicit, t, b)) ctx (interp_xml_target body) | XmlTag (loc,"LETIN",al,(_::_ as xl)) -> - let body,defs = list_sep_last xl in + let body,defs = List.sep_last xl in let ctx = List.map interp_xml_def defs in List.fold_right (fun (na,t) b -> GLetIn (loc, na, t, b)) ctx (interp_xml_target body) @@ -164,48 +177,48 @@ let rec interp_xml_constr = function (XmlTag (_,("CONST"|"MUTIND"|"MUTCONSTRUCT"),_,_) as x)::xl) -> GApp (loc, interp_xml_constr x, List.map interp_xml_arg xl) | XmlTag (loc,"META",al,xl) -> - GEvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl)) + GEvar (loc, get_xml_name al, Some (List.map interp_xml_substitution xl)) | XmlTag (loc,"CONST",al,[]) -> - GRef (loc, ConstRef (get_xml_constant al)) + GRef (loc, ConstRef (get_xml_constant al), None) | XmlTag (loc,"MUTCASE",al,x::y::yl) -> let ind = get_xml_inductive al in let p = interp_xml_patternsType x in let tm = interp_xml_inductiveTerm y in let vars = compute_branches_lengths ind in - let brs = list_map_i (fun i c -> (i,vars.(i),interp_xml_pattern c)) 0 yl + let brs = List.map_i (fun i c -> (i,vars.(i),interp_xml_pattern c)) 0 yl in let mat = simple_cases_matrix_of_branches ind brs in - let nparams,n = compute_inductive_nargs ind in - let nal,rtn = return_type_of_predicate ind nparams n p in + let n = compute_inductive_ndecls ind in + let nal,rtn = return_type_of_predicate ind n p in GCases (loc,RegularStyle,rtn,[tm,nal],mat) | XmlTag (loc,"MUTIND",al,[]) -> - GRef (loc, IndRef (get_xml_inductive al)) + GRef (loc, IndRef (get_xml_inductive al), None) | XmlTag (loc,"MUTCONSTRUCT",al,[]) -> - GRef (loc, ConstructRef (get_xml_constructor al)) + GRef (loc, ConstructRef (get_xml_constructor al), None) | XmlTag (loc,"FIX",al,xl) -> let li,lnct = List.split (List.map interp_xml_FixFunction xl) in - let ln,lc,lt = list_split3 lnct in + let ln,lc,lt = List.split3 lnct in let lctx = List.map (fun _ -> []) ln in GRec (loc, GFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, Array.of_list lctx, Array.of_list lc, Array.of_list lt) | XmlTag (loc,"COFIX",al,xl) -> - let ln,lc,lt = list_split3 (List.map interp_xml_CoFixFunction xl) in + let ln,lc,lt = List.split3 (List.map interp_xml_CoFixFunction xl) in GRec (loc, GCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt) | XmlTag (loc,"CAST",al,[x1;x2]) -> - GCast (loc, interp_xml_term x1, CastConv (DEFAULTcast, interp_xml_type x2)) + GCast (loc, interp_xml_term x1, CastConv (interp_xml_type x2)) | XmlTag (loc,"SORT",al,[]) -> GSort (loc, get_xml_sort al) | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s ++ str ".") and interp_xml_tag s = function - | XmlTag (loc,tag,al,xl) when tag=s -> (loc,al,xl) + | XmlTag (loc,tag,al,xl) when String.equal tag s -> (loc,al,xl) | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "", str "Expect tag " ++ str s ++ str " but find " ++ str s ++ str ".") and interp_xml_constr_alias s x = match interp_xml_tag s x with | (_,_,[x]) -> interp_xml_constr x - | (loc,_,_) -> error_expect_one_argument loc + | (loc,_,_) -> error_bad_arity loc 1 and interp_xml_term x = interp_xml_constr_alias "term" x and interp_xml_type x = interp_xml_constr_alias "type" x @@ -215,13 +228,16 @@ and interp_xml_pattern x = interp_xml_constr_alias "pattern" x and interp_xml_patternsType x = interp_xml_constr_alias "patternsType" x and interp_xml_inductiveTerm x = interp_xml_constr_alias "inductiveTerm" x and interp_xml_arg x = interp_xml_constr_alias "arg" x -and interp_xml_substitution x = interp_xml_constr_alias "substitution" x +and interp_xml_substitution x = + match interp_xml_tag "substitution" x with + _, al, [x] -> get_xml_name al, interp_xml_constr x + | loc, _, _ -> error_bad_arity loc 1 (* no support for empty substitution from official dtd *) and interp_xml_decl_alias s x = match interp_xml_tag s x with | (_,al,[x]) -> (get_xml_binder al, interp_xml_constr x) - | (loc,_,_) -> error_expect_one_argument loc + | (loc,_,_) -> error_bad_arity loc 1 and interp_xml_def x = interp_xml_decl_alias "def" x and interp_xml_decl x = interp_xml_decl_alias "decl" x @@ -229,20 +245,14 @@ and interp_xml_decl x = interp_xml_decl_alias "decl" x and interp_xml_recursionOrder x = let (loc, al, l) = interp_xml_tag "RecursionOrder" x in let (locs, s) = get_xml_attr "type" al in - match s with - "Structural" -> - (match l with [] -> GStructRec - | _ -> error_expect_no_argument loc) - | "WellFounded" -> - (match l with - [c] -> GWfRec (interp_xml_type c) - | _ -> error_expect_one_argument loc) - | "Measure" -> - (match l with - [m;r] -> GMeasureRec (interp_xml_type m, Some (interp_xml_type r)) - | _ -> error_expect_two_arguments loc) - | _ -> - user_err_loc (locs,"",str "Invalid recursion order.") + match s, l with + | "Structural", [] -> GStructRec + | "Structural", _ -> error_bad_arity loc 0 + | "WellFounded", [c] -> GWfRec (interp_xml_type c) + | "WellFounded", _ -> error_bad_arity loc 1 + | "Measure", [m;r] -> GMeasureRec (interp_xml_type m, Some (interp_xml_type r)) + | "Measure", _ -> error_bad_arity loc 2 + | _ -> user_err_loc (locs,"",str "Invalid recursion order.") and interp_xml_FixFunction x = match interp_xml_tag "FixFunction" x with @@ -254,14 +264,14 @@ and interp_xml_FixFunction x = ((Some (nmtoken (get_xml_attr "recIndex" al)), GStructRec), (get_xml_name al, interp_xml_type x1, interp_xml_body x2)) | (loc,_,_) -> - error_expect_one_argument loc + error_bad_arity loc 1 and interp_xml_CoFixFunction x = match interp_xml_tag "CoFixFunction" x with | (loc,al,[x1;x2]) -> (get_xml_name al, interp_xml_type x1, interp_xml_body x2) | (loc,_,_) -> - error_expect_one_argument loc + error_bad_arity loc 1 (* Interpreting tactic argument *) diff --git a/parsing/grammar.mllib b/parsing/grammar.mllib deleted file mode 100644 index ba393e63..00000000 --- a/parsing/grammar.mllib +++ /dev/null @@ -1,88 +0,0 @@ -Coq_config - -Profile -Pp_control -Pp -Compat -Flags -Segmenttree -Unicodetable -Util -Errors -Bigint -Dyn -Hashcons -Predicate -Rtree -Option -Store -Hashtbl_alt - -Names -Univ -Esubst -Term -Mod_subst -Sign -Cbytecodes -Copcodes -Cemitcodes -Declarations -Retroknowledge -Pre_env -Cbytegen -Environ -Conv_oracle -Closure -Reduction -Type_errors -Entries -Modops -Inductive -Typeops -Indtypes -Cooking -Term_typing -Subtyping -Mod_typing -Safe_typing - -Nameops -Libnames -Summary -Nametab -Libobject -Lib -Goptions -Decl_kinds -Global -Termops -Namegen -Evd -Reductionops -Inductiveops -Glob_term -Detyping -Pattern -Topconstr -Genarg -Ppextend -Tacexpr -Tok -Lexer -Extend -Vernacexpr -Extrawit -Pcoq -Q_util -Q_coqast - -Egrammar -Argextend -Tacextend -Vernacextend - -G_prim -G_tactic -G_ltac -G_constr diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index eed6caea..13ed8046 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -4,3 +4,4 @@ G_prim G_proofs G_tactic G_ltac +G_obligations diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 82ae2dc8..8e839296 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* char -> int = compare end +module CharMap = Map.Make (CharOrd) type ttree = { node : string option; @@ -86,27 +87,28 @@ module Error = struct let to_string x = "Syntax Error: Lexer: " ^ (match x with - | Illegal_character -> "Illegal character" - | Unterminated_comment -> "Unterminated comment" - | Unterminated_string -> "Unterminated string" - | Undefined_token -> "Undefined token" - | Bad_token tok -> Format.sprintf "Bad token %S" tok - | UnsupportedUnicode x -> - Printf.sprintf "Unsupported Unicode character (0x%x)" x) + | Illegal_character -> "Illegal character" + | Unterminated_comment -> "Unterminated comment" + | Unterminated_string -> "Unterminated string" + | Undefined_token -> "Undefined token" + | Bad_token tok -> Format.sprintf "Bad token %S" tok + | UnsupportedUnicode x -> + Printf.sprintf "Unsupported Unicode character (0x%x)" x) - let print ppf x = Format.fprintf ppf "%s@." (to_string x) + (* Require to fix the Camlp4 signature *) + let print ppf x = Pp.pp_with ppf (Pp.str (to_string x)) end open Error -let err loc str = Loc.raise (make_loc loc) (Error.E str) +let err loc str = Loc.raise (Loc.make_loc loc) (Error.E str) let bad_token str = raise (Error.E (Bad_token str)) (* Lexer conventions on tokens *) type token_kind = - | Utf8Token of (utf8_status * int) + | Utf8Token of (Unicode.status * int) | AsciiChar | EmptyStream @@ -130,38 +132,38 @@ let utf8_char_size cs = function let njunk n = Util.repeat n Stream.junk let check_utf8_trailing_byte cs c = - if Char.code c land 0xC0 <> 0x80 then error_utf8 cs + if not (Int.equal (Char.code c land 0xC0) 0x80) then error_utf8 cs (* Recognize utf8 blocks (of length less than 4 bytes) *) (* but don't certify full utf8 compliance (e.g. no emptyness check) *) let lookup_utf8_tail c cs = let c1 = Char.code c in - if c1 land 0x40 = 0 or c1 land 0x38 = 0x38 then error_utf8 cs + if Int.equal (c1 land 0x40) 0 || Int.equal (c1 land 0x38) 0x38 then error_utf8 cs else let n, unicode = - if c1 land 0x20 = 0 then + if Int.equal (c1 land 0x20) 0 then match Stream.npeek 2 cs with | [_;c2] -> - check_utf8_trailing_byte cs c2; - 2, (c1 land 0x1F) lsl 6 + (Char.code c2 land 0x3F) + check_utf8_trailing_byte cs c2; + 2, (c1 land 0x1F) lsl 6 + (Char.code c2 land 0x3F) | _ -> error_utf8 cs - else if c1 land 0x10 = 0 then + else if Int.equal (c1 land 0x10) 0 then match Stream.npeek 3 cs with | [_;c2;c3] -> - check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3; - 3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 + - (Char.code c3 land 0x3F) + check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3; + 3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 + + (Char.code c3 land 0x3F) | _ -> error_utf8 cs else match Stream.npeek 4 cs with | [_;c2;c3;c4] -> - check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3; - check_utf8_trailing_byte cs c4; - 4, (c1 land 0x07) lsl 18 + (Char.code c2 land 0x3F) lsl 12 + - (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F) + check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3; + check_utf8_trailing_byte cs c4; + 4, (c1 land 0x07) lsl 18 + (Char.code c2 land 0x3F) lsl 12 + + (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F) | _ -> error_utf8 cs in - try classify_unicode unicode, n - with UnsupportedUtf8 -> + try Unicode.classify unicode, n + with Unicode.Unsupported -> njunk n cs; error_unsupported_unicode_character n unicode cs let lookup_utf8 cs = @@ -170,17 +172,18 @@ let lookup_utf8 cs = | Some ('\x80'..'\xFF' as c) -> Utf8Token (lookup_utf8_tail c cs) | None -> EmptyStream -let unlocated f x = - try f x with Loc.Exc_located (_,exc) -> raise exc +let unlocated f x = f x + (** FIXME: should we still unloc the exception? *) +(* try f x with Loc.Exc_located (_, exc) -> raise exc *) let check_keyword str = let rec loop_symb = parser | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str | [< s >] -> - match unlocated lookup_utf8 s with - | Utf8Token (_,n) -> njunk n s; loop_symb s - | AsciiChar -> Stream.junk s; loop_symb s - | EmptyStream -> () + match unlocated lookup_utf8 s with + | Utf8Token (_,n) -> njunk n s; loop_symb s + | AsciiChar -> Stream.junk s; loop_symb s + | EmptyStream -> () in loop_symb (Stream.of_string str) @@ -188,7 +191,8 @@ let check_keyword_to_add s = try check_keyword s with Error.E (UnsupportedUnicode unicode) -> Flags.if_verbose msg_warning - (strbrk (Printf.sprintf "Token '%s' contains unicode character 0x%x which will not be parsable." s unicode)) + (strbrk (Printf.sprintf "Token '%s' contains unicode character 0x%x \ + which will not be parsable." s unicode)) let check_ident str = let rec loop_id intail = parser @@ -197,11 +201,13 @@ let check_ident str = | [< ' ('0'..'9' | ''') when intail; s >] -> loop_id true s | [< s >] -> - match unlocated lookup_utf8 s with - | Utf8Token (UnicodeLetter, n) -> njunk n s; loop_id true s - | Utf8Token (UnicodeIdentPart, n) when intail -> njunk n s; loop_id true s - | EmptyStream -> () - | Utf8Token _ | AsciiChar -> bad_token str + match unlocated lookup_utf8 s with + | Utf8Token (Unicode.Letter, n) -> njunk n s; loop_id true s + | Utf8Token (Unicode.IdentPart, n) when intail -> + njunk n s; + loop_id true s + | EmptyStream -> () + | Utf8Token _ | AsciiChar -> bad_token str in loop_id false (Stream.of_string str) @@ -229,14 +235,7 @@ let remove_keyword str = type frozen_t = ttree let freeze () = !token_tree - -let unfreeze tt = - token_tree := tt - -let init () = - unfreeze empty_ttree - -let _ = init() +let unfreeze tt = (token_tree := tt) (* The string buffering machinery *) @@ -260,8 +259,8 @@ let rec ident_tail len = parser ident_tail (store len c) s | [< s >] -> match lookup_utf8 s with - | Utf8Token ((UnicodeIdentPart | UnicodeLetter), n) -> - ident_tail (nstore n len s) s + | Utf8Token ((Unicode.IdentPart | Unicode.Letter), n) -> + ident_tail (nstore n len s) s | _ -> len let rec number len = parser @@ -274,28 +273,36 @@ let rec string in_comments bp len = parser | [< ''('; s >] -> (parser | [< ''*'; s >] -> - string (Option.map succ in_comments) bp (store (store len '(') '*') s + string + (Option.map succ in_comments) + bp (store (store len '(') '*') + s | [< >] -> - string in_comments bp (store len '(') s) s + string in_comments bp (store len '(') s) s | [< ''*'; s >] -> (parser | [< '')'; s >] -> - if in_comments = Some 0 then - msg_warning (str "Not interpreting \"*)\" as the end of current non-terminated comment because it occurs in a non-terminated string of the comment."); + let () = match in_comments with + | Some 0 -> + msg_warning + (strbrk + "Not interpreting \"*)\" as the end of current \ + non-terminated comment because it occurs in a \ + non-terminated string of the comment.") + | _ -> () + in let in_comments = Option.map pred in_comments in - string in_comments bp (store (store len '*') ')') s + string in_comments bp (store (store len '*') ')') s | [< >] -> - string in_comments bp (store len '*') s) s + string in_comments bp (store len '*') s) s | [< 'c; s >] -> string in_comments bp (store len c) s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string -(* Hook for exporting comment into xml theory files *) -let xml_output_comment = ref (fun _ -> ()) -let set_xml_output_comment f = xml_output_comment := f - (* Utilities for comments in beautify *) let comment_begin = ref None -let comm_loc bp = if !comment_begin=None then comment_begin := Some bp +let comm_loc bp = match !comment_begin with +| None -> comment_begin := Some bp +| _ -> () let current = Buffer.create 8192 let between_com = ref true @@ -318,9 +325,9 @@ let push_char c = if !between_com || List.mem c ['\n';'\r'] || (List.mem c [' ';'\t']&& - (Buffer.length current = 0 || + (Int.equal (Buffer.length current) 0 || not (let s = Buffer.contents current in - List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r']))) + List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r']))) then real_push_char c @@ -333,15 +340,14 @@ let null_comment s = let comment_stop ep = let current_s = Buffer.contents current in - if !Flags.xml_export && Buffer.length current > 0 && - (!between_com || not(null_comment current_s)) then - !xml_output_comment current_s; (if Flags.do_beautify() && Buffer.length current > 0 && (!between_com || not(null_comment current_s)) then let bp = match !comment_begin with Some bp -> bp | None -> - msgerrnl(str"No begin location for comment '"++str current_s ++str"' ending at "++int ep); + msgerrnl(str "No begin location for comment '" + ++ str current_s ++str"' ending at " + ++ int ep); ep-1 in Pp.comments := ((bp,ep),current_s) :: !Pp.comments); Buffer.clear current; @@ -353,8 +359,11 @@ let rec comm_string bp = parser | [< ''"' >] -> push_string "\"" | [< ''\\'; _ = (parser [< ' ('"' | '\\' as c) >] -> - if c='"' then real_push_char c; - real_push_char c + let () = match c with + | '"' -> real_push_char c + | _ -> () + in + real_push_char c | [< >] -> real_push_char '\\'); s >] -> comm_string bp s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string @@ -388,26 +397,26 @@ let rec progress_further last nj tt cs = and update_longest_valid_token last nj tt cs = match tt.node with | Some _ as last' -> - for i=1 to nj do Stream.junk cs done; - progress_further last' 0 tt cs + stream_njunk nj cs; + progress_further last' 0 tt cs | None -> - progress_further last nj tt cs + progress_further last nj tt cs (* nj is the number of char peeked since last valid token *) (* n the number of char in utf8 block *) and progress_utf8 last nj n c tt cs = try let tt = CharMap.find c tt.branch in - if n=1 then + if Int.equal n 1 then update_longest_valid_token last (nj+n) tt cs else - match Util.list_skipn (nj+1) (Stream.npeek (nj+n) cs) with - | l when List.length l = n-1 -> - List.iter (check_utf8_trailing_byte cs) l; - let tt = List.fold_left (fun tt c -> CharMap.find c tt.branch) tt l in - update_longest_valid_token last (nj+n) tt cs + match Util.List.skipn (nj+1) (Stream.npeek (nj+n) cs) with + | l when Int.equal (List.length l) (n - 1) -> + List.iter (check_utf8_trailing_byte cs) l; + let tt = List.fold_left (fun tt c -> CharMap.find c tt.branch) tt l in + update_longest_valid_token last (nj+n) tt cs | _ -> - error_utf8 cs + error_utf8 cs with Not_found -> last @@ -420,6 +429,14 @@ let find_keyword id s = | None -> raise Not_found | Some c -> KEYWORD c +let process_sequence bp c cs = + let rec aux n cs = + match Stream.peek cs with + | Some c' when c == c' -> Stream.junk cs; aux (n+1) cs + | _ -> BULLET (String.make n c), (bp, Stream.count cs) + in + aux 1 cs + (* Must be a special token *) let process_chars bp c cs = let t = progress_from_byte None (-1) !token_tree cs c in @@ -427,9 +444,9 @@ let process_chars bp c cs = match t with | Some t -> (KEYWORD t, (bp, ep)) | None -> - let ep' = bp + utf8_char_size cs c in - njunk (ep' - ep) cs; - err (bp, ep') Undefined_token + let ep' = bp + utf8_char_size cs c in + njunk (ep' - ep) cs; + err (bp, ep') Undefined_token let token_of_special c s = match c with | '$' -> METAIDENT s @@ -444,8 +461,8 @@ let parse_after_special c bp = token_of_special c (get_buff len) | [< s >] -> match lookup_utf8 s with - | Utf8Token (UnicodeLetter, n) -> - token_of_special c (get_buff (ident_tail (nstore n 0 s) s)) + | Utf8Token (Unicode.Letter, n) -> + token_of_special c (get_buff (ident_tail (nstore n 0 s) s)) | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp c s) (* Parse what follows a question mark *) @@ -455,9 +472,10 @@ let parse_after_qmark bp s = | Some ('a'..'z' | 'A'..'Z' | '_') -> LEFTQMARK | None -> KEYWORD "?" | _ -> - match lookup_utf8 s with - | Utf8Token (UnicodeLetter, _) -> LEFTQMARK - | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '?' s) + match lookup_utf8 s with + | Utf8Token (Unicode.Letter, _) -> LEFTQMARK + | AsciiChar | Utf8Token _ | EmptyStream -> + fst (process_chars bp '?' s) let blank_or_eof cs = match Stream.peek cs with @@ -476,11 +494,19 @@ let rec next_token = parser bp comment_stop bp; (* We enforce that "." should either be part of a larger keyword, for instance ".(", or followed by a blank or eof. *) - if t = KEYWORD "." then begin - if not (blank_or_eof s) then err (bp,ep+1) Undefined_token; - if Flags.do_beautify() then between_com := true; - end; + let () = match t with + | KEYWORD ("." | "...") -> + if not (blank_or_eof s) then err (bp,ep+1) Undefined_token; + between_com := true; + | _ -> () + in (t, (bp,ep)) + | [< ' ('-'|'+'|'*' as c); s >] -> + let t,new_between_com = + if !between_com then process_sequence bp c s,true + else process_chars bp c s,false + in + comment_stop bp; between_com := new_between_com; t | [< ''?'; s >] ep -> let t = parse_after_qmark bp s in comment_stop bp; (t, (ep, bp)) | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); @@ -499,23 +525,25 @@ let rec next_token = parser bp | [< ''*'; s >] -> comm_loc bp; push_string "(*"; - comment bp s; - next_token s + comment bp s; + next_token s | [< t = process_chars bp c >] -> comment_stop bp; t >] -> t | [< s >] -> match lookup_utf8 s with - | Utf8Token (UnicodeLetter, n) -> - let len = ident_tail (nstore n 0 s) s in - let id = get_buff len in - let ep = Stream.count s in - comment_stop bp; - (try find_keyword id s with Not_found -> IDENT id), (bp, ep) - | AsciiChar | Utf8Token ((UnicodeSymbol | UnicodeIdentPart), _) -> - let t = process_chars bp (Stream.next s) s in - comment_stop bp; t - | EmptyStream -> - comment_stop bp; (EOI, (bp, bp + 1)) + | Utf8Token (Unicode.Letter, n) -> + let len = ident_tail (nstore n 0 s) s in + let id = get_buff len in + let ep = Stream.count s in + comment_stop bp; + (try find_keyword id s with Not_found -> IDENT id), (bp, ep) + | AsciiChar | Utf8Token ((Unicode.Symbol | Unicode.IdentPart), _) -> + let t = process_chars bp (Stream.next s) s in + let new_between_com = match t with + (KEYWORD ("{"|"}"),_) -> !between_com | _ -> false in + comment_stop bp; between_com := new_between_com; t + | EmptyStream -> + comment_stop bp; (EOI, (bp, bp + 1)) (* (* Debug: uncomment this for tracing tokens seen by coq...*) let next_token s = @@ -537,10 +565,9 @@ let loct_add loct i loc = Hashtbl.add loct i loc let current_location_table = ref (loct_create ()) -type location_table = (int, loc) Hashtbl.t +type location_table = (int, CompatLoc.t) Hashtbl.t let location_table () = !current_location_table let restore_location_table t = current_location_table := t -let location_function n = loct_func !current_location_table n (** {6 The lexer of Coq} *) @@ -575,7 +602,7 @@ let func cs = Stream.from (fun i -> let (tok, loc) = next_token cs in - loct_add loct i (make_loc loc); Some tok) + loct_add loct i (make_loc loc); Some tok) in current_location_table := loct; (ts, loct_func loct) @@ -595,10 +622,10 @@ ELSE (* official camlp4 for ocaml >= 3.10 *) module M_ = Camlp4.ErrorHandler.Register (Error) -module Loc = Loc +module Loc = CompatLoc module Token = struct include Tok (* Cf. tok.ml *) - module Loc = Loc + module Loc = CompatLoc module Error = Camlp4.Struct.EmptyError module Filter = struct type token_filter = (Tok.t * Loc.t) Stream.t -> (Tok.t * Loc.t) Stream.t @@ -631,14 +658,14 @@ let is_ident_not_keyword s = let is_number s = let rec aux i = - String.length s = i or + Int.equal (String.length s) i || match s.[i] with '0'..'9' -> aux (i+1) | _ -> false in aux 0 let strip s = let len = let rec loop i len = - if i = String.length s then len + if Int.equal i (String.length s) then len else if s.[i] == ' ' then loop (i + 1) len else loop (i + 1) (len + 1) in @@ -656,7 +683,7 @@ let strip s = let terminal s = let s = strip s in - if s = "" then Util.error "empty token."; + let () = match s with "" -> Errors.error "empty token." | _ -> () in if is_ident_not_keyword s then IDENT s else if is_number s then INT s else KEYWORD s diff --git a/parsing/lexer.mli b/parsing/lexer.mli index cb6b694c..2b9bd37d 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -1,19 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val remove_keyword : string -> unit val is_keyword : string -> bool -val location_function : int -> loc +(* val location_function : int -> Loc.t *) (** for coqdoc *) type location_table @@ -27,14 +24,11 @@ val check_keyword : string -> unit type frozen_t val freeze : unit -> frozen_t val unfreeze : frozen_t -> unit -val init : unit -> unit type com_state val com_state: unit -> com_state val restore_com_state: com_state -> unit -val set_xml_output_comment : (string -> unit) -> unit - val terminal : string -> Tok.t (** The lexer of Coq: *) diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib index 84a08d54..a0cb8319 100644 --- a/parsing/parsing.mllib +++ b/parsing/parsing.mllib @@ -1,11 +1,6 @@ -Extend -Extrawit +Tok +Compat +Lexer Pcoq -Egrammar -G_xml -Ppconstr -Printer -Pptactic -Tactic_printer -Printmod -Prettyp +Egramml +Egramcoq diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 7949a77d..cf6435fe 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a G.entry -> typed_entry val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry end @@ -120,8 +116,8 @@ module Gramtypes : Gramtypes = struct let inGramObj rawwit = in_typed_entry (unquote rawwit) let outGramObj (a:'a raw_abstract_argument_type) o = - if type_of_typed_entry o <> unquote a - then anomaly "outGramObj: wrong type"; + if not (argument_type_eq (type_of_typed_entry o) (unquote a)) + then anomaly ~label:"outGramObj" (str "wrong type"); (* downcast from grammar_object *) Obj.magic (object_of_typed_entry o) end @@ -139,10 +135,13 @@ open Gramtypes In [single_extend_statement], first two parameters are name and assoc iff a level is created *) +(** Type of reinitialization data *) +type gram_reinit = gram_assoc * gram_position + type ext_kind = | ByGrammar of grammar_object G.entry - * gram_assoc option (** for reinitialization if ever needed *) + * gram_reinit option (** for reinitialization if ever needed *) * G.extend_statment | ByEXTEND of (unit -> unit) * (unit -> unit) @@ -150,28 +149,18 @@ type ext_kind = let camlp4_state = ref [] -(** Deletion - - Caveat: deletion is not the converse of extension: when an - empty level is extended, deletion removes the level instead - of keeping it empty. This has an effect on the empty levels 8, - 99 and 200. We didn't find a good solution to this problem - (e.g. using G.extend to know if the level exists results in a - printed error message as side effect). As a consequence an - extension at 99 or 8 (and for pattern 200 too) inside a section - corrupts the parser. *) +(** Deletion *) let grammar_delete e reinit (pos,rls) = List.iter (fun (n,ass,lev) -> List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) (List.rev rls); - if reinit <> None then + match reinit with + | Some (a,ext) -> let lev = match pos with Some (Level n) -> n | _ -> assert false in - let pos = - if lev = "200" then First - else After (string_of_int (int_of_string lev + 1)) in - maybe_uncurry (G.extend e) (Some pos, [Some lev,reinit,[]]) + maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]]) + | None -> () (** The apparent parser of Coq; encapsulate G to keep track of the extensions. *) @@ -213,9 +202,10 @@ let grammar_extend e reinit ext = let rec remove_grammars n = if n>0 then (match !camlp4_state with - | [] -> anomaly "Pcoq.remove_grammars: too many rules to remove" + | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove") | ByGrammar(g,reinit,ext)::t -> - grammar_delete g reinit ext; + let f (a,b) = (of_coq_assoc a, of_coq_position b) in + grammar_delete g (Option.map f reinit) ext; camlp4_state := t; remove_grammars (n-1) | ByEXTEND (undo,redo)::t -> @@ -270,7 +260,7 @@ let get_univ s = try Hashtbl.find univ_tab s with Not_found -> - anomaly ("Unknown grammar universe: "^s) + anomaly (Pp.str ("Unknown grammar universe: "^s)) let get_entry (u, utab) s = Hashtbl.find utab s @@ -283,14 +273,14 @@ let new_entry etyp (u, utab) s = let create_entry (u, utab) s etyp = try let e = Hashtbl.find utab s in - if type_of_typed_entry e <> etyp then + if not (argument_type_eq (type_of_typed_entry e) etyp) then failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); e with Not_found -> new_entry etyp (u, utab) s let create_constr_entry s = - outGramObj rawwit_constr (create_entry uconstr s ConstrArgType) + outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) let create_generic_entry s wit = outGramObj wit (create_entry utactic s (unquote wit)) @@ -310,22 +300,22 @@ module Prim = (* Entries that can be refered via the string -> Gram.entry table *) (* Typically for tactic or vernac extensions *) - let preident = gec_gen rawwit_pre_ident "preident" - let ident = gec_gen rawwit_ident "ident" - let natural = gec_gen rawwit_int "natural" - let integer = gec_gen rawwit_int "integer" + let preident = gec_gen (rawwit wit_pre_ident) "preident" + let ident = gec_gen (rawwit wit_ident) "ident" + let natural = gec_gen (rawwit wit_int) "natural" + let integer = gec_gen (rawwit wit_int) "integer" let bigint = Gram.entry_create "Prim.bigint" - let string = gec_gen rawwit_string "string" - let reference = make_gen_entry uprim rawwit_ref "reference" + let string = gec_gen (rawwit wit_string) "string" + let reference = make_gen_entry uprim (rawwit wit_ref) "reference" let by_notation = Gram.entry_create "by_notation" let smart_global = Gram.entry_create "smart_global" (* parsed like ident but interpreted as a term *) - let var = gec_gen rawwit_var "var" + let var = gec_gen (rawwit wit_var) "var" let name = Gram.entry_create "Prim.name" let identref = Gram.entry_create "Prim.identref" - let pattern_ident = gec_gen rawwit_pattern_ident "pattern_ident" + let pattern_ident = Gram.entry_create "pattern_ident" let pattern_identref = Gram.entry_create "pattern_identref" (* A synonym of ident - maybe ident will be located one day *) @@ -342,7 +332,7 @@ module Prim = module Constr = struct - let gec_constr = make_gen_entry uconstr rawwit_constr + let gec_constr = make_gen_entry uconstr (rawwit wit_constr) (* Entries that can be refered via the string -> Gram.entry table *) let constr = gec_constr "constr" @@ -350,9 +340,9 @@ module Constr = let constr_eoi = eoi_entry constr let lconstr = gec_constr "lconstr" let binder_constr = create_constr_entry "binder_constr" - let ident = make_gen_entry uconstr rawwit_ident "ident" - let global = make_gen_entry uconstr rawwit_ref "global" - let sort = make_gen_entry uconstr rawwit_sort "sort" + let ident = make_gen_entry uconstr (rawwit wit_ident) "ident" + let global = make_gen_entry uconstr (rawwit wit_ref) "global" + let sort = make_gen_entry uconstr (rawwit wit_sort) "sort" let pattern = Gram.entry_create "constr:pattern" let constr_pattern = gec_constr "constr_pattern" let lconstr_pattern = gec_constr "lconstr_pattern" @@ -380,33 +370,37 @@ module Tactic = (* Entries that can be refered via the string -> Gram.entry table *) (* Typically for tactic user extensions *) let open_constr = - make_gen_entry utactic (rawwit_open_constr_gen (false,false)) "open_constr" - let casted_open_constr = - make_gen_entry utactic (rawwit_open_constr_gen (true,false)) "casted_open_constr" - let open_constr_wTC = - make_gen_entry utactic (rawwit_open_constr_gen (false,true)) "open_constr_wTC" + make_gen_entry utactic (rawwit wit_open_constr) "open_constr" let constr_with_bindings = - make_gen_entry utactic rawwit_constr_with_bindings "constr_with_bindings" + make_gen_entry utactic (rawwit wit_constr_with_bindings) "constr_with_bindings" let bindings = - make_gen_entry utactic rawwit_bindings "bindings" - let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval" + make_gen_entry utactic (rawwit wit_bindings) "bindings" + let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" + let uconstr = + make_gen_entry utactic (rawwit wit_uconstr) "uconstr" let quantified_hypothesis = - make_gen_entry utactic rawwit_quant_hyp "quantified_hypothesis" - let int_or_var = make_gen_entry utactic rawwit_int_or_var "int_or_var" - let red_expr = make_gen_entry utactic rawwit_red_expr "red_expr" + make_gen_entry utactic (rawwit wit_quant_hyp) "quantified_hypothesis" + let int_or_var = make_gen_entry utactic (rawwit wit_int_or_var) "int_or_var" + let red_expr = make_gen_entry utactic (rawwit wit_red_expr) "red_expr" let simple_intropattern = - make_gen_entry utactic rawwit_intro_pattern "simple_intropattern" + make_gen_entry utactic (rawwit wit_intro_pattern) "simple_intropattern" + let clause_dft_concl = + make_gen_entry utactic (rawwit wit_clause_dft_concl) "clause" + (* Main entries for ltac *) let tactic_arg = Gram.entry_create "tactic:tactic_arg" let tactic_expr = Gram.entry_create "tactic:tactic_expr" let binder_tactic = Gram.entry_create "tactic:binder_tactic" - let tactic = make_gen_entry utactic (rawwit_tactic tactic_main_level) "tactic" + let tactic = make_gen_entry utactic (rawwit wit_tactic) "tactic" (* Main entry for quotations *) let tactic_eoi = eoi_entry tactic + (* For Ltac definition *) + let tacdef_body = Gram.entry_create "tactic:tacdef_body" + end module Vernac_ = @@ -426,7 +420,7 @@ module Vernac_ = GEXTEND Gram main_entry: - [ [ a = vernac -> Some (loc,a) | EOI -> None ] ] + [ [ a = vernac -> Some (!@loc, a) | EOI -> None ] ] ; END @@ -450,24 +444,23 @@ let main_entry = Vernac_.main_entry let constr_level = string_of_int let default_levels = - [200,RightA,false; - 100,RightA,false; - 99,RightA,true; - 90,RightA,false; - 10,RightA,false; - 9,RightA,false; - 8,RightA,true; - 1,LeftA,false; - 0,RightA,false] + [200,Extend.RightA,false; + 100,Extend.RightA,false; + 99,Extend.RightA,true; + 10,Extend.RightA,false; + 9,Extend.RightA,false; + 8,Extend.RightA,true; + 1,Extend.LeftA,false; + 0,Extend.RightA,false] let default_pattern_levels = - [200,RightA,true; - 100,RightA,false; - 99,RightA,true; - 10,LeftA,false; - 9,RightA,false; - 1,LeftA,false; - 0,RightA,false] + [200,Extend.RightA,true; + 100,Extend.RightA,false; + 99,Extend.RightA,true; + 10,Extend.LeftA,false; + 9,Extend.RightA,false; + 1,Extend.LeftA,false; + 0,Extend.RightA,false] let level_stack = ref [(default_levels, default_pattern_levels)] @@ -475,27 +468,30 @@ let level_stack = (* At a same level, LeftA takes precedence over RightA and NoneA *) (* In case, several associativity exists for a level, we make two levels, *) (* first LeftA, then RightA and NoneA together *) -open Ppextend let admissible_assoc = function - | LeftA, Some (RightA | NonA) -> false - | RightA, Some LeftA -> false + | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false + | Extend.RightA, Some Extend.LeftA -> false | _ -> true let create_assoc = function - | None -> RightA + | None -> Extend.RightA | Some a -> a let error_level_assoc p current expected = let pr_assoc = function - | LeftA -> str "left" - | RightA -> str "right" - | NonA -> str "non" in + | Extend.LeftA -> str "left" + | Extend.RightA -> str "right" + | Extend.NonA -> str "non" in errorlabstrm "" (str "Level " ++ int p ++ str " is already declared " ++ pr_assoc current ++ str " associative while it is now expected to be " ++ pr_assoc expected ++ str " associative.") +let create_pos = function + | None -> Extend.First + | Some lev -> Extend.After (constr_level lev) + let find_position_gen forpat ensure assoc lev = let ccurrent,pcurrent as current = List.hd !level_stack in match lev with @@ -507,9 +503,10 @@ let find_position_gen forpat ensure assoc lev = let init = ref None in let rec add_level q = function | (p,_,_ as pa)::l when p > n -> pa :: add_level (Some p) l - | (p,a,reinit)::l when p = n -> + | (p,a,reinit)::l when Int.equal p n -> if reinit then - let a' = create_assoc assoc in (init := Some a'; (p,a',false)::l) + let a' = create_assoc assoc in + (init := Some (a',create_pos q); (p,a',false)::l) else if admissible_assoc (a,assoc) then raise Exit else @@ -522,35 +519,38 @@ let find_position_gen forpat ensure assoc lev = else (add_level None ccurrent, pcurrent) in level_stack := updated:: !level_stack; let assoc = create_assoc assoc in - if !init = None then + begin match !init with + | None -> (* Create the entry *) - (if !after = None then Some First - else Some (After (constr_level (Option.get !after)))), - Some assoc, Some (constr_level n), None - else + Some (create_pos !after), Some assoc, Some (constr_level n), None + | _ -> (* The reinit flag has been updated *) - Some (Level (constr_level n)), None, None, !init + Some (Extend.Level (constr_level n)), None, None, !init + end with (* Nothing has changed *) Exit -> level_stack := current :: !level_stack; (* Just inherit the existing associativity and name (None) *) - Some (Level (constr_level n)), None, None, None + Some (Extend.Level (constr_level n)), None, None, None let remove_levels n = - level_stack := list_skipn n !level_stack + level_stack := List.skipn n !level_stack let rec list_mem_assoc_triple x = function | [] -> false - | (a,b,c) :: l -> a = x or list_mem_assoc_triple x l + | (a,b,c) :: l -> Int.equal a x || list_mem_assoc_triple x l let register_empty_levels forpat levels = - map_succeed (fun n -> - let levels = (if forpat then snd else fst) (List.hd !level_stack) in - if not (list_mem_assoc_triple n levels) then - find_position_gen forpat true None (Some n) - else - failwith "") levels + let filter n = + try + let levels = (if forpat then snd else fst) (List.hd !level_stack) in + if not (list_mem_assoc_triple n levels) then + Some (find_position_gen forpat true None (Some n)) + else None + with Failure _ -> None + in + List.map_filter filter levels let find_position forpat assoc level = find_position_gen forpat false assoc level @@ -564,8 +564,14 @@ let synchronize_level_positions () = (* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *) let camlp4_assoc = function - | Some NonA | Some RightA -> RightA - | None | Some LeftA -> LeftA + | Some Extend.NonA | Some Extend.RightA -> Extend.RightA + | None | Some Extend.LeftA -> Extend.LeftA + +let assoc_eq al ar = match al, ar with +| Extend.NonA, Extend.NonA +| Extend.RightA, Extend.RightA +| Extend.LeftA, Extend.LeftA -> true +| _, _ -> false (* [adjust_level assoc from prod] where [assoc] and [from] are the name and associativity of the level where to add the rule; the meaning of @@ -580,27 +586,30 @@ let adjust_level assoc from = function | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true)) (* Compute production name on the right side *) (* If NonA or LeftA on the right-hand side, set to NEXT *) - | (NumLevel n,BorderProd (Right,Some (NonA|LeftA))) -> + | (NumLevel n,BorderProd (Right,Some (Extend.NonA|Extend.LeftA))) -> Some None (* If RightA on the right-hand side, set to the explicit (current) level *) - | (NumLevel n,BorderProd (Right,Some RightA)) -> + | (NumLevel n,BorderProd (Right,Some Extend.RightA)) -> Some (Some (n,true)) (* Compute production name on the left side *) (* If NonA on the left-hand side, adopt the current assoc ?? *) - | (NumLevel n,BorderProd (Left,Some NonA)) -> None + | (NumLevel n,BorderProd (Left,Some Extend.NonA)) -> None (* If the expected assoc is the current one, set to SELF *) - | (NumLevel n,BorderProd (Left,Some a)) when a = camlp4_assoc assoc -> + | (NumLevel n,BorderProd (Left,Some a)) when assoc_eq a (camlp4_assoc assoc) -> None (* Otherwise, force the level, n or n-1, according to expected assoc *) | (NumLevel n,BorderProd (Left,Some a)) -> - if a = LeftA then Some (Some (n,true)) else Some None + begin match a with + | Extend.LeftA -> Some (Some (n, true)) + | _ -> Some None + end (* None means NEXT *) | (NextLevel,_) -> Some None (* Compute production name elsewhere *) | (NumLevel n,InternalProd) -> match from with - | ETConstr (p,()) when p = n+1 -> Some None - | ETConstr (p,()) -> Some (Some (n,n=p)) + | ETConstr (p,()) when Int.equal p (n + 1) -> Some None + | ETConstr (p,()) -> Some (Some (n, Int.equal n p)) | _ -> Some (Some (n,false)) let compute_entry allow_create adjust forpat = function @@ -609,15 +618,16 @@ let compute_entry allow_create adjust forpat = function else weaken_entry Constr.operconstr), adjust (n,q), false | ETName -> weaken_entry Prim.name, None, false - | ETBinder true -> anomaly "Should occur only as part of BinderList" + | ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList") | ETBinder false -> weaken_entry Constr.binder, None, false | ETBinderList (true,tkl) -> - assert (tkl=[]); weaken_entry Constr.open_binders, None, false - | ETBinderList (false,_) -> anomaly "List of entries cannot be registered." + let () = match tkl with [] -> () | _ -> assert false in + weaken_entry Constr.open_binders, None, false + | ETBinderList (false,_) -> anomaly (Pp.str "List of entries cannot be registered.") | ETBigint -> weaken_entry Prim.bigint, None, false | ETReference -> weaken_entry Constr.global, None, false | ETPattern -> weaken_entry Constr.pattern, None, false - | ETConstrList _ -> anomaly "List of entries cannot be registered." + | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") | ETOther (u,n) -> let u = get_univ u in let e = @@ -645,10 +655,11 @@ let is_self from e = match from, e with ETConstr(n,()), ETConstr(NumLevel n', BorderProd(Right, _ (* Some(NonA|LeftA) *))) -> false - | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> n=n' + | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> Int.equal n n' | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint | ETPattern, ETPattern) -> true - | ETOther(s1,s2), ETOther(s1',s2') -> s1=s1' & s2=s2' + | ETOther(s1,s2), ETOther(s1',s2') -> + String.equal s1 s1' && String.equal s2 s2' | _ -> false let is_binder_level from e = @@ -716,10 +727,23 @@ let rec symbol_of_prod_entry_key = function | Atactic 5 -> Snterm (Gram.Entry.obj Tactic.binder_tactic) | Atactic n -> Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) - | Agram s -> Snterm s + | Agram s -> + let e = + try + (** ppedrot: we should always generate Agram entries which have already + been registered, so this should not fail. *) + let (u, s) = match String.split ':' s with + | u :: s :: [] -> (u, s) + | _ -> raise Not_found + in + get_entry (get_univ u) s + with Not_found -> + Errors.anomaly (str "Unregistered grammar entry: " ++ str s) + in + Snterm (Gram.Entry.obj (object_of_typed_entry e)) | Aentry (u,s) -> - Snterm (Gram.Entry.obj - (object_of_typed_entry (get_entry (get_univ u) s))) + let e = get_entry (get_univ u) s in + Snterm (Gram.Entry.obj (object_of_typed_entry e)) let level_of_snterml = function | Snterml (_,l) -> int_of_string l @@ -728,44 +752,83 @@ let level_of_snterml = function (**********************************************************************) (* Interpret entry names of the form "ne_constr_list" as entry keys *) +let coincide s pat off = + let len = String.length pat in + let break = ref true in + let i = ref 0 in + while !break && !i < len do + let c = Char.code s.[off + !i] in + let d = Char.code pat.[!i] in + break := Int.equal c d; + incr i + done; + !break + +let tactic_level s = + if Int.equal (String.length s) 7 && coincide s "tactic" 0 then + let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48) + else None + else None + +let type_of_entry u s = + type_of_typed_entry (get_entry u s) + let rec interp_entry_name static up_level s sep = let l = String.length s in - if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then + if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - List1ArgType t, Alist1 g - else if l > 12 & String.sub s 0 3 = "ne_" & - String.sub s (l-9) 9 = "_list_sep" then + ListArgType t, Alist1 g + else if l > 12 && coincide s "ne_" 0 && + coincide s "_list_sep" (l-9) then let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - List1ArgType t, Alist1sep (g,sep) - else if l > 5 & String.sub s (l-5) 5 = "_list" then + ListArgType t, Alist1sep (g,sep) + else if l > 5 && coincide s "_list" (l-5) then let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - List0ArgType t, Alist0 g - else if l > 9 & String.sub s (l-9) 9 = "_list_sep" then + ListArgType t, Alist0 g + else if l > 9 && coincide s "_list_sep" (l-9) then let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - List0ArgType t, Alist0sep (g,sep) - else if l > 4 & String.sub s (l-4) 4 = "_opt" then + ListArgType t, Alist0sep (g,sep) + else if l > 4 && coincide s "_opt" (l-4) then let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in OptArgType t, Aopt g - else if l > 5 & String.sub s (l-5) 5 = "_mods" then + else if l > 5 && coincide s "_mods" (l-5) then let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - List0ArgType t, Amodifiers g + ListArgType t, Amodifiers g else - let s = if s = "hyp" then "var" else s in + let s = match s with "hyp" -> "var" | _ -> s in + let check_lvl n = match up_level with + | None -> false + | Some m -> Int.equal m n + && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) + && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) + in let t, se = - match Extrawit.tactic_genarg_level s with - | Some n when Some n = up_level & up_level <> Some 5 -> None, Aself - | Some n when Some (n+1) = up_level & up_level <> Some 5 -> None, Anext - | Some n -> None, Atactic n - | None -> - try Some (get_entry uprim s), Aentry ("prim",s) with Not_found -> - try Some (get_entry uconstr s), Aentry ("constr",s) with Not_found -> - try Some (get_entry utactic s), Aentry ("tactic",s) with Not_found -> + match tactic_level s with + | Some n -> + (** Quite ad-hoc *) + let t = unquote (rawwit wit_tactic) in + let se = + if check_lvl n then Aself + else if check_lvl (n + 1) then Anext + else Atactic n + in + (Some t, se) + | None -> + try Some (type_of_entry uprim s), Aentry ("prim",s) with Not_found -> + try Some (type_of_entry uconstr s), Aentry ("constr",s) with Not_found -> + try Some (type_of_entry utactic s), Aentry ("tactic",s) with Not_found -> if static then error ("Unknown entry "^s^".") else None, Aentry ("",s) in let t = match t with - | Some t -> type_of_typed_entry t + | Some t -> t | None -> ExtraArgType s in t, se + +let list_entry_names () = + let add_entry key (entry, _) accu = (key, entry) :: accu in + let ans = Hashtbl.fold add_entry (snd uprim) [] in + let ans = Hashtbl.fold add_entry (snd uconstr) ans in + Hashtbl.fold add_entry (snd utactic) ans diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 1b04b117..dbd2aadf 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -1,21 +1,22 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Gram.symbol (** The superclass of all grammar entries *) type grammar_object +(** Type of reinitialization data *) +type gram_reinit = gram_assoc * gram_position + (** Add one extension at some camlp4 position of some camlp4 entry *) val grammar_extend : grammar_object Gram.entry -> - gram_assoc option (** for reinitialization if ever needed *) -> + gram_reinit option (** for reinitialization if ever needed *) -> Gram.extend_statment -> unit (** Remove the last n extensions *) @@ -153,29 +157,28 @@ val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> module Prim : sig - open Util open Names open Libnames val preident : string Gram.entry - val ident : identifier Gram.entry - val name : name located Gram.entry - val identref : identifier located Gram.entry - val pattern_ident : identifier Gram.entry - val pattern_identref : identifier located Gram.entry - val base_ident : identifier Gram.entry + val ident : Id.t Gram.entry + val name : Name.t located Gram.entry + val identref : Id.t located Gram.entry + val pattern_ident : Id.t Gram.entry + val pattern_identref : Id.t located Gram.entry + val base_ident : Id.t Gram.entry val natural : int Gram.entry val bigint : Bigint.bigint Gram.entry val integer : int Gram.entry val string : string Gram.entry val qualid : qualid located Gram.entry - val fullyqualid : identifier list located Gram.entry + val fullyqualid : Id.t list located Gram.entry val reference : reference Gram.entry - val by_notation : (loc * string * string option) Gram.entry + val by_notation : (Loc.t * string * string option) Gram.entry val smart_global : reference or_by_notation Gram.entry - val dirpath : dir_path Gram.entry + val dirpath : DirPath.t Gram.entry val ne_string : string Gram.entry val ne_lstring : string located Gram.entry - val var : identifier located Gram.entry + val var : Id.t located Gram.entry end module Constr : @@ -185,7 +188,7 @@ module Constr : val lconstr : constr_expr Gram.entry val binder_constr : constr_expr Gram.entry val operconstr : constr_expr Gram.entry - val ident : identifier Gram.entry + val ident : Id.t Gram.entry val global : reference Gram.entry val sort : glob_sort Gram.entry val pattern : cases_pattern_expr Gram.entry @@ -195,8 +198,8 @@ module Constr : val binder : local_binder list Gram.entry (* closed_binder or variable *) val binders : local_binder list Gram.entry (* list of binder *) val open_binders : local_binder list Gram.entry - val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.entry - val typeclass_constraint : (name located * bool * constr_expr) Gram.entry + val binders_fixannot : (local_binder list * (Id.t located option * recursion_order_expr)) Gram.entry + val typeclass_constraint : (Name.t located * bool * constr_expr) Gram.entry val record_declaration : constr_expr Gram.entry val appl_arg : (constr_expr * explicitation located option) Gram.entry end @@ -209,28 +212,27 @@ module Module : module Tactic : sig - open Glob_term val open_constr : open_constr_expr Gram.entry - val open_constr_wTC : open_constr_expr Gram.entry - val casted_open_constr : open_constr_expr Gram.entry val constr_with_bindings : constr_expr with_bindings Gram.entry val bindings : constr_expr bindings Gram.entry val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry + val uconstr : constr_expr Gram.entry val quantified_hypothesis : quantified_hypothesis Gram.entry val int_or_var : int or_var Gram.entry val red_expr : raw_red_expr Gram.entry - val simple_tactic : raw_atomic_tactic_expr Gram.entry - val simple_intropattern : Genarg.intro_pattern_expr located Gram.entry + val simple_tactic : raw_tactic_expr Gram.entry + val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry + val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry val tactic_arg : raw_tactic_arg Gram.entry val tactic_expr : raw_tactic_expr Gram.entry val binder_tactic : raw_tactic_expr Gram.entry val tactic : raw_tactic_expr Gram.entry val tactic_eoi : raw_tactic_expr Gram.entry + val tacdef_body : (reference * bool * raw_tactic_expr) Gram.entry end module Vernac_ : sig - open Decl_kinds val gallina : vernac_expr Gram.entry val gallina_ext : vernac_expr Gram.entry val command : vernac_expr Gram.entry @@ -241,7 +243,7 @@ module Vernac_ : end (** The main entry: reads an optional vernac command *) -val main_entry : (loc * vernac_expr) option Gram.entry +val main_entry : (Loc.t * vernac_expr) option Gram.entry (** Mapping formal entries into concrete ones *) @@ -271,7 +273,7 @@ type prod_entry_key = | Aself | Anext | Atactic of int - | Agram of Gram.internal_entry + | Agram of string | Aentry of string * string (** Binding general entry keys to symbols *) @@ -284,19 +286,22 @@ val symbol_of_prod_entry_key : val interp_entry_name : bool (** true to fail on unknown entry *) -> int option -> string -> string -> entry_type * prod_entry_key +(** Recover the list of all known tactic notation entries. *) +val list_entry_names : unit -> (string * entry_type) list + (** Registering/resetting the level of a constr entry *) val find_position : bool (** true if for creation in pattern entry; false if in constr entry *) -> - gram_assoc option -> int option -> - gram_position option * gram_assoc option * string option * - (** for reinitialization: *) gram_assoc option + Extend.gram_assoc option -> int option -> + Extend.gram_position option * Extend.gram_assoc option * string option * + (** for reinitialization: *) gram_reinit option val synchronize_level_positions : unit -> unit val register_empty_levels : bool -> int list -> - (gram_position option * gram_assoc option * - string option * gram_assoc option) list + (Extend.gram_position option * Extend.gram_assoc option * + string option * gram_reinit option) list val remove_levels : int -> unit diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml deleted file mode 100644 index 4fde091d..00000000 --- a/parsing/ppconstr.ml +++ /dev/null @@ -1,654 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* str"," ++ spc() -let pr_tight_coma () = str "," ++ cut () - -let latom = 0 -let lprod = 200 -let llambda = 200 -let lif = 200 -let lletin = 200 -let lletpattern = 200 -let lfix = 200 -let larrow = 90 -let lcast = 100 -let larg = 9 -let lapp = 10 -let lposint = 0 -let lnegint = 35 (* must be consistent with Notation "- x" *) -let ltop = (200,E) -let lproj = 1 -let ldelim = 1 -let lsimpleconstr = (8,E) -let lsimplepatt = (1,E) - -let prec_less child (parent,assoc) = - if parent < 0 && child = lprod then true - else - let parent = abs parent in - match assoc with - | E -> (<=) child parent - | L -> (<) child parent - | Prec n -> child<=n - | Any -> true - -let prec_of_prim_token = function - | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint - | String _ -> latom - -open Notation - -let print_hunks n pr pr_binders (terms,termlists,binders) unp = - let env = ref terms and envlist = ref termlists and bll = ref binders in - let pop r = let a = List.hd !r in r := List.tl !r; a in - let rec aux = function - | [] -> mt () - | UnpMetaVar (_,prec) :: l -> - let c = pop env in pr (n,prec) c ++ aux l - | UnpListMetaVar (_,prec,sl) :: l -> - let cl = pop envlist in - let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in - let pp2 = aux l in - pp1 ++ pp2 - | UnpBinderListMetaVar (_,isopen,sl) :: l -> - let cl = pop bll in pr_binders (fun () -> aux sl) isopen cl ++ aux l - | UnpTerminal s :: l -> str s ++ aux l - | UnpBox (b,sub) :: l -> - (* Keep order: side-effects *) - let pp1 = ppcmd_of_box b (aux sub) in - let pp2 = aux l in - pp1 ++ pp2 - | UnpCut cut :: l -> ppcmd_of_cut cut ++ aux l in - aux unp - -let pr_notation pr pr_binders s env = - let unpl, level = find_notation_printing_rule s in - print_hunks level pr pr_binders env unpl, level - -let pr_delimiters key strm = - strm ++ str ("%"^key) - -let pr_generalization bk ak c = - let hd, tl = - match bk with - | Implicit -> "{", "}" - | Explicit -> "(", ")" - in (* TODO: syntax Abstraction Kind *) - str "`" ++ str hd ++ c ++ str tl - -let pr_com_at n = - if Flags.do_beautify() && n <> 0 then comment n - else mt() - -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_in_comment pr x = str "(* " ++ pr x ++ str " *)" - -let pr_universe = Univ.pr_uni - -let pr_glob_sort = function - | GProp Term.Null -> str "Prop" - | GProp Term.Pos -> str "Set" - | GType u -> hov 0 (str "Type" ++ pr_opt (pr_in_comment pr_universe) u) - -let pr_id = pr_id -let pr_name = pr_name -let pr_qualid = pr_qualid -let pr_patvar = pr_id - -let pr_expl_args pr (a,expl) = - match expl with - | None -> pr (lapp,L) a - | Some (_,ExplByPos (n,_id)) -> - anomaly("Explicitation by position not implemented") - | Some (_,ExplByName id) -> - str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")" - -let pr_opt_type pr = function - | CHole _ -> mt () - | t -> cut () ++ str ":" ++ pr t - -let pr_opt_type_spc pr = function - | CHole _ -> mt () - | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t - -let pr_lident (loc,id) = - if loc <> dummy_loc then - let (b,_) = unloc loc in - pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id) - else pr_id id - -let pr_lname = function - (loc,Name id) -> pr_lident (loc,id) - | lna -> pr_located pr_name lna - -let pr_or_var pr = function - | ArgArg x -> pr x - | ArgVar (loc,s) -> pr_lident (loc,s) - -let pr_prim_token = function - | Numeral n -> str (Bigint.to_string n) - | String s -> qs s - -let pr_evar pr n l = - hov 0 (str (Evd.string_of_existential n) ++ - (match l with - | Some l -> - spc () ++ pr_in_comment - (fun l -> - str"[" ++ hov 0 (prlist_with_sep pr_comma (pr ltop) l) ++ str"]") - (List.rev l) - | None -> mt())) - -let las = lapp -let lpator = 100 -let lpatrec = 0 - -let rec pr_patt sep inh p = - let (strm,prec) = match p 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 - | CPatCstr (_,c,[]) -> pr_reference c, latom - | CPatCstr (_,c,args) -> - pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp - | CPatCstrExpl (_,c,args) -> - str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp - | CPatAtom (_,None) -> str "_", latom - | CPatAtom (_,Some r) -> pr_reference r, latom - | CPatOr (_,pl) -> - hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator - | CPatNotation (_,"( _ )",([p],[])) -> - pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom - | CPatNotation (_,s,(l,ll)) -> - pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[]) - | CPatPrim (_,p) -> pr_prim_token p, latom - | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimplepatt p), 1 - in - let loc = cases_pattern_expr_loc p 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 - spc() ++ hov 4 - (pr_with_comments loc - (str "| " ++ - hov 0 (prlist_with_sep pr_bar (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 (unloc loc) - | LocalRawAssum((loc,_)::_,_,_) -> fst (unloc loc) - | _ -> assert false - -let begin_of_binders = function - | b::_ -> begin_of_binder b - | _ -> 0 - -let surround_impl k p = - match k with - | Explicit -> str"(" ++ p ++ str")" - | Implicit -> str"{" ++ p ++ str"}" - -let surround_implicit k p = - match k with - | Explicit -> p - | Implicit -> (str"{" ++ p ++ str"}") - -let pr_binder many pr (nal,k,t) = - match k with - | Generalized (b, b', t') -> - assert (b=Implicit); - begin match nal with - |[loc,Anonymous] -> - hov 1 (str"`" ++ (surround_impl b' - ((if t' then str "!" else mt ()) ++ pr t))) - |[loc,Name id] -> - hov 1 (str "`" ++ (surround_impl b' - (pr_lident (loc,id) ++ str " : " ++ - (if t' then str "!" else mt()) ++ pr t))) - |_ -> anomaly "List of generalized binders have alwais one element." - end - | Default b -> - match t with - | CHole _ -> - let s = prlist_with_sep spc pr_lname nal in - hov 1 (surround_implicit b s) - | _ -> - let s = prlist_with_sep spc pr_lname nal ++ str " : " ++ pr t in - 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) -> - pr_binder true pr_c (nal,k,t) - | LocalRawDef (na,c) -> - let c,topt = match c with - | CCast(_,c, CastConv (_,t)) -> c, t - | _ -> c, CHole (dummy_loc, None) in - surround (pr_lname na ++ pr_opt_type pr_c topt ++ - str":=" ++ cut() ++ pr_c c) - -let pr_undelimited_binders sep pr_c = - prlist_with_sep sep (pr_binder_among_many pr_c) - -let pr_delimited_binders kw sep pr_c bl = - let n = begin_of_binders bl in - match bl with - | [LocalRawAssum (nal,k,t)] -> - pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t) - | LocalRawAssum _ :: _ as bdl -> - pr_com_at n ++ kw() ++ pr_undelimited_binders sep pr_c bdl - | _ -> assert false - -let pr_binders_gen pr_c sep is_open = - if is_open then pr_delimited_binders mt 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,(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,(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 "ill-formed fixpoint body" - -let rename na na' t c = - match (na,na') with - | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c) - | (_,Name id), (_,Anonymous) -> (na,t,c) - | _ -> (na',t,c) - -let split_product na' = function - | CArrow (loc,t,c) -> (na',t,c) - | 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 "ill-formed fixpoint body" - -let rec split_fix n typ def = - if 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" " ++ - 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 - -let pr_guard_annot pr_aux bl (n,ro) = - match n with - | None -> mt () - | Some (loc, id) -> - match (ro : Topconstr.recursion_order_expr) with - | CStructRec -> - let names_of_binder = function - | LocalRawAssum (nal,_,_) -> nal - | LocalRawDef (_,_) -> [] - in let ids = List.flatten (List.map names_of_binder bl) in - if List.length ids > 1 then - spc() ++ str "{struct " ++ pr_id id ++ str"}" - else mt() - | CWfRec c -> - spc() ++ str "{wf " ++ pr_aux c ++ spc() ++ pr_id id ++ str"}" - | CMeasureRec (m,r) -> - spc() ++ str "{measure " ++ 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 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) = - pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c - -let pr_recursive pr_decl id = function - | [] -> anomaly "(co)fixpoint with no definition" - | [d1] -> pr_decl false d1 - | dl -> - prlist_with_sep (fun () -> fnl() ++ str "with ") - (pr_decl true) dl ++ - fnl() ++ str "for " ++ pr_id id - -let pr_asin pr (na,indnalopt) = - (match na with (* Decision of printing "_" or not moved to constrextern.ml *) - | Some na -> spc () ++ str "as " ++ pr_lname na - | None -> mt ()) ++ - (match indnalopt with - | None -> mt () - | Some t -> spc () ++ str "in " ++ pr lsimpleconstr t) - -let pr_case_item pr (tm,asin) = - hov 0 (pr (lcast,E) tm ++ pr_asin pr asin) - -let pr_case_type pr po = - match po with - | None | Some (CHole _) -> mt() - | Some p -> - spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimpleconstr) p) - -let pr_simple_return_type pr na po = - (match na with - | Some (_,Name id) -> - spc () ++ str "as " ++ pr_id id - | _ -> mt ()) ++ - pr_case_type pr po - -let pr_proj pr pr_app a f l = - hov 0 (pr (lproj,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")") - -let pr_appexpl pr f l = - hov 2 ( - str "@" ++ pr_reference f ++ - prlist (pr_sep_com spc (pr (lapp,L))) l) - -let pr_app pr a l = - hov 2 ( - pr (lapp,L) a ++ - prlist (fun a -> spc () ++ pr_expl_args pr a) l) - -let pr_forall () = str"forall" ++ spc () - -let pr_fun () = str"fun" ++ spc () - -let pr_fun_sep = str " =>" - - -let pr_dangling_with_for sep pr inherited a = - match a with - | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a - | _ -> pr sep inherited a - -let pr pr sep inherited a = - let (strm,prec) = match a with - | CRef r -> pr_reference r, latom - | CFix (_,id,fix) -> - hov 0 (str"fix " ++ - pr_recursive - (pr_fixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) fix), - lfix - | CCoFix (_,id,cofix) -> - hov 0 (str "cofix " ++ - pr_recursive - (pr_cofixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) cofix), - lfix - | CArrow (_,a,b) -> - hov 0 (pr mt (larrow,L) a ++ str " ->" ++ - pr (fun () ->brk(1,0)) (-larrow,E) b), - larrow - | CProdN _ -> - let (bl,a) = extract_prod_binders a in - hov 0 ( - hov 2 (pr_delimited_binders pr_forall spc - (pr mt ltop) bl) ++ - str "," ++ pr spc ltop a), - lprod - | CLambdaN _ -> - let (bl,a) = extract_lam_binders a in - hov 0 ( - hov 2 (pr_delimited_binders pr_fun spc - (pr mt ltop) bl) ++ - pr_fun_sep ++ pr spc ltop a), - llambda - | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b) - when x=x' -> - hv 0 ( - hov 2 (str "let " ++ pr mt ltop fx ++ str " in") ++ - pr spc ltop b), - lletin - | CLetIn (_,x,a,b) -> - hv 0 ( - hov 2 (str "let " ++ pr_lname x ++ str " :=" ++ - pr spc ltop a ++ str " in") ++ - pr spc ltop b), - lletin - | CAppExpl (_,(Some i,f),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 l1 in - if l2<>[] then - p ++ prlist (pr spc (lapp,L)) l2, lapp - else - p, lproj - | CAppExpl (_,(None,Ident (_,var)),[t]) - | CApp (_,(_,CRef(Ident(_,var))),[t,None]) - when var = Topconstr.ldots_var -> - hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg - | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp - | CApp (_,(Some i,f),l) -> - let l1,l2 = list_chop i l in - let c,l1 = list_sep_last l1 in - assert (snd c = None); - let p = pr_proj (pr mt) pr_app (fst c) f l1 in - if l2<>[] then - p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp - else - p, lproj - | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp - | CRecord (_,w,l) -> - let beg = - match w with - | None -> spc () - | Some t -> spc () ++ pr spc ltop t ++ spc () ++ str"with" ++ spc () - in - hv 0 (str"{|" ++ beg ++ - prlist_with_sep pr_semicolon - (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr spc ltop c)) l - ++ str" |}"), latom - - | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) -> - hv 0 ( - str "let '" ++ - hov 0 (pr_patt ltop p ++ - pr_asin (pr_dangling_with_for mt pr) asin ++ - str " :=" ++ pr spc ltop c ++ - pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++ - str " in" ++ pr spc ltop b)), - lletpattern - | CCases(_,_,rtntypopt,c,eqns) -> - v 0 - (hv 0 (str "match" ++ brk (1,2) ++ - hov 0 ( - prlist_with_sep sep_v - (pr_case_item (pr_dangling_with_for mt pr)) c - ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt) ++ - spc () ++ str "with") ++ - prlist (pr_eqn (pr mt)) eqns ++ spc() ++ str "end"), - latom - | CLetTuple (_,nal,(na,po),c,b) -> - hv 0 ( - str "let " ++ - hov 0 (str "(" ++ - prlist_with_sep sep_v pr_lname nal ++ - str ")" ++ - pr_simple_return_type (pr mt) na po ++ str " :=" ++ - pr spc ltop c ++ str " in") ++ - pr spc ltop b), - lletin - | 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) *) - hv 0 ( - hov 1 (str "if " ++ pr mt ltop c ++ pr_simple_return_type (pr mt) na po) ++ - spc () ++ - hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++ - hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)), - lif - - | CHole _ -> str "_", latom - | CEvar (_,n,l) -> pr_evar (pr mt) n l, latom - | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom - | CSort (_,s) -> pr_glob_sort s, latom - | CCast (_,a,CastConv (k,b)) -> - let s = match k with VMcast -> "<:" | DEFAULTcast | REVERTcast -> ":" in - hv 0 (pr mt (lcast,L) a ++ cut () ++ str s ++ pr mt (-lcast,E) b), - lcast - | CCast (_,a,CastCoerce) -> - hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":>"), - lcast - | CNotation (_,"( _ )",([t],[],[])) -> - 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) -> pr_generalization bk ak (pr mt ltop c), latom - | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p - | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt (ldelim,E) a), ldelim - in - let loc = constr_loc a in - 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 -} - -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 pr_simpleconstr = function - | CAppExpl (_,(None,f),[]) -> str "@" ++ pr_reference f - | c -> pr lsimpleconstr c - -let default_term_pr = { - pr_constr_expr = pr_simpleconstr; - pr_lconstr_expr = pr ltop; - pr_constr_pattern_expr = pr_simpleconstr; - pr_lconstr_pattern_expr = pr ltop -} - -let term_pr = ref default_term_pr - -let set_term_pr = (:=) term_pr - -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 -let pr_lconstr_pattern_expr c = !term_pr.pr_lconstr_pattern_expr c - -let pr_cases_pattern_expr = pr_patt ltop - -let pr_binders = pr_undelimited_binders spc (pr ltop) - -let pr_with_occurrences pr occs = - match occs with - ((false,[]),c) -> pr c - | ((nowhere_except_in,nl),c) -> - hov 1 (pr c ++ spc() ++ str"at " ++ - (if nowhere_except_in then mt() else str "- ") ++ - hov 0 (prlist_with_sep spc (pr_or_var int) nl)) - -let pr_red_flag pr r = - (if r.rBeta then pr_arg str "beta" else mt ()) ++ - (if r.rIota then pr_arg str "iota" else mt ()) ++ - (if r.rZeta then pr_arg str "zeta" else mt ()) ++ - (if 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 "]")) - -open Genarg - -let pr_metaid id = str"?" ++ pr_id id - -let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) = function - | Red false -> str "red" - | Hnf -> str "hnf" - | Simpl o -> str "simpl" ++ pr_opt (pr_with_occurrences pr_pattern) o - | Cbv f -> - if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then - str "compute" - else - hov 1 (str "cbv" ++ pr_red_flag pr_ref f) - | Lazy f -> - hov 1 (str "lazy" ++ pr_red_flag pr_ref f) - | Unfold l -> - hov 1 (str "unfold" ++ spc() ++ - prlist_with_sep pr_comma (pr_with_occurrences pr_ref) l) - | Fold l -> hov 1 (str "fold" ++ prlist (pr_arg pr_constr) l) - | Pattern l -> - hov 1 (str "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 -> str "vm_compute" - -let rec pr_may_eval test prc prlc pr2 pr3 = function - | ConstrEval (r,c) -> - hov 0 - (str "eval" ++ brk (1,1) ++ - pr_red_expr (prc,prlc,pr2,pr3) r ++ - str " in" ++ spc() ++ prc c) - | ConstrContext ((_,id),c) -> - hov 0 - (str "context " ++ pr_id id ++ spc () ++ - str "[" ++ prlc c ++ str "]") - | ConstrTypeOf c -> hov 1 (str "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 diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli deleted file mode 100644 index bc3a6668..00000000 --- a/parsing/ppconstr.mli +++ /dev/null @@ -1,102 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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_metaid : identifier -> std_ppcmds - -val pr_lident : identifier located -> std_ppcmds -val pr_lname : name located -> std_ppcmds - -val pr_with_comments : loc -> 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 : identifier -> std_ppcmds -val pr_name : name -> std_ppcmds -val pr_qualid : qualid -> std_ppcmds -val pr_patvar : patvar -> std_ppcmds - -val pr_with_occurrences : - ('a -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds -val pr_red_expr : - ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> - ('a,'b,'c) red_expr_gen -> std_ppcmds -val pr_may_eval : - ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('c -> std_ppcmds) -> ('a,'b,'c) may_eval -> std_ppcmds - -val pr_glob_sort : glob_sort -> std_ppcmds -val pr_guard_annot : (constr_expr -> std_ppcmds) -> - local_binder list -> - ('a * Names.identifier) option * recursion_order_expr -> - 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 diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml deleted file mode 100644 index fa573c8a..00000000 --- a/parsing/pptactic.ml +++ /dev/null @@ -1,1072 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 -> glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -let genarg_pprule = ref Stringmap.empty - -let declare_extra_genarg_pprule (rawwit, f) (globwit, g) (wit, h) = - let s = match unquote wit with - | ExtraArgType s -> 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 x) in - let g prc prlc prtac x = g prc prlc prtac (out_gen globwit x) in - let h prc prlc prtac x = h prc prlc prtac (out_gen wit x) in - genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule - -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_or_metaid pr = function - | AI x -> pr x - | _ -> failwith "pr_hyp_location: unexpected quotation meta-variable" - -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 (Libnames.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) ++ str "with" ++ brk (1,1) ++ - prlist_with_sep spc prc l - | ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - 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 (1,1) ++ - prlist_with_sep spc prc l - | ExplicitBindings l -> - brk (1,1) ++ - prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | NoBindings -> mt () - -let pr_with_bindings prc prlc (c,bl) = - prc c ++ hv 0 (pr_bindings prc prlc bl) - -let pr_with_constr prc = function - | None -> mt () - | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c) - -let rec pr_message_token prid = function - | MsgString s -> qs s - | MsgInt n -> int n - | MsgIdent id -> prid id - -let pr_fresh_ids = prlist (fun s -> spc() ++ pr_or_var qs s) - -let with_evars ev s = if ev then "e" ^ s else s - -let if_pattern_ident b pr c = (if b then str "?" else mt()) ++ pr c - -let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = - match Genarg.genarg_tag x with - | BoolArgType -> str (if out_gen rawwit_bool x then "true" else "false") - | IntArgType -> int (out_gen rawwit_int x) - | IntOrVarArgType -> pr_or_var pr_int (out_gen rawwit_int_or_var x) - | StringArgType -> str "\"" ++ str (out_gen rawwit_string x) ++ str "\"" - | PreIdentArgType -> str (out_gen rawwit_pre_ident x) - | IntroPatternArgType -> pr_intro_pattern (out_gen rawwit_intro_pattern x) - | IdentArgType b -> if_pattern_ident b pr_id (out_gen rawwit_ident x) - | VarArgType -> pr_located pr_id (out_gen rawwit_var x) - | RefArgType -> prref (out_gen rawwit_ref x) - | SortArgType -> pr_glob_sort (out_gen rawwit_sort x) - | ConstrArgType -> prc (out_gen rawwit_constr x) - | ConstrMayEvalArgType -> - pr_may_eval prc prlc (pr_or_by_notation prref) prpat - (out_gen rawwit_constr_may_eval x) - | QuantHypArgType -> pr_quantified_hypothesis (out_gen rawwit_quant_hyp x) - | RedExprArgType -> - pr_red_expr (prc,prlc,pr_or_by_notation prref,prpat) - (out_gen rawwit_red_expr x) - | OpenConstrArgType (b1,b2) -> prc (snd (out_gen (rawwit_open_constr_gen (b1,b2)) x)) - | ConstrWithBindingsArgType -> - pr_with_bindings prc prlc (out_gen rawwit_constr_with_bindings x) - | BindingsArgType -> - pr_bindings_no_with prc prlc (out_gen rawwit_bindings x) - | List0ArgType _ -> - hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prpat prref) - (fold_list0 (fun a l -> a::l) x [])) - | List1ArgType _ -> - hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prpat prref) - (fold_list1 (fun a l -> a::l) x [])) - | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prpat prref) (mt()) x) - | PairArgType _ -> - hov 0 - (fold_pair - (fun a b -> pr_sequence (pr_raw_generic prc prlc prtac prpat prref) - [a;b]) - x) - | ExtraArgType s -> - try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x - with Not_found -> str "[no printer for " ++ str s ++ str "]" - - -let rec pr_glob_generic prc prlc prtac prpat x = - match Genarg.genarg_tag x with - | BoolArgType -> str (if out_gen globwit_bool x then "true" else "false") - | IntArgType -> int (out_gen globwit_int x) - | IntOrVarArgType -> pr_or_var pr_int (out_gen globwit_int_or_var x) - | StringArgType -> str "\"" ++ str (out_gen globwit_string x) ++ str "\"" - | PreIdentArgType -> str (out_gen globwit_pre_ident x) - | IntroPatternArgType -> pr_intro_pattern (out_gen globwit_intro_pattern x) - | IdentArgType b -> if_pattern_ident b pr_id (out_gen globwit_ident x) - | VarArgType -> pr_located pr_id (out_gen globwit_var x) - | RefArgType -> pr_or_var (pr_located pr_global) (out_gen globwit_ref x) - | SortArgType -> pr_glob_sort (out_gen globwit_sort x) - | ConstrArgType -> prc (out_gen globwit_constr x) - | ConstrMayEvalArgType -> - pr_may_eval prc prlc - (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat - (out_gen globwit_constr_may_eval x) - | QuantHypArgType -> - pr_quantified_hypothesis (out_gen globwit_quant_hyp x) - | RedExprArgType -> - pr_red_expr - (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference),prpat) - (out_gen globwit_red_expr x) - | OpenConstrArgType (b1,b2) -> prc (snd (out_gen (globwit_open_constr_gen (b1,b2)) x)) - | ConstrWithBindingsArgType -> - pr_with_bindings prc prlc (out_gen globwit_constr_with_bindings x) - | BindingsArgType -> - pr_bindings_no_with prc prlc (out_gen globwit_bindings x) - | List0ArgType _ -> - hov 0 (pr_sequence (pr_glob_generic prc prlc prtac prpat) - (fold_list0 (fun a l -> a::l) x [])) - | List1ArgType _ -> - hov 0 (pr_sequence (pr_glob_generic prc prlc prtac prpat) - (fold_list1 (fun a l -> a::l) x [])) - | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac prpat) (mt()) x) - | PairArgType _ -> - hov 0 - (fold_pair - (fun a b -> pr_sequence (pr_glob_generic prc prlc prtac prpat) [a;b]) - x) - | ExtraArgType s -> - try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x - with Not_found -> str "[no printer for " ++ str s ++ str "]" - -open Closure - -let rec pr_generic prc prlc prtac prpat x = - match Genarg.genarg_tag x with - | BoolArgType -> str (if out_gen wit_bool x then "true" else "false") - | IntArgType -> int (out_gen wit_int x) - | IntOrVarArgType -> pr_or_var pr_int (out_gen wit_int_or_var x) - | StringArgType -> str "\"" ++ str (out_gen wit_string x) ++ str "\"" - | PreIdentArgType -> str (out_gen wit_pre_ident x) - | IntroPatternArgType -> pr_intro_pattern (out_gen wit_intro_pattern x) - | IdentArgType b -> if_pattern_ident b pr_id (out_gen wit_ident x) - | VarArgType -> pr_id (out_gen wit_var x) - | RefArgType -> pr_global (out_gen wit_ref x) - | SortArgType -> pr_sort (out_gen wit_sort x) - | ConstrArgType -> prc (out_gen wit_constr x) - | ConstrMayEvalArgType -> prc (out_gen wit_constr_may_eval x) - | QuantHypArgType -> pr_quantified_hypothesis (out_gen wit_quant_hyp x) - | RedExprArgType -> - pr_red_expr (prc,prlc,pr_evaluable_reference,prpat) - (out_gen wit_red_expr x) - | OpenConstrArgType (b1,b2) -> prc (snd (out_gen (wit_open_constr_gen (b1,b2)) x)) - | ConstrWithBindingsArgType -> - let (c,b) = (out_gen wit_constr_with_bindings x).Evd.it in - pr_with_bindings prc prlc (c,b) - | BindingsArgType -> - pr_bindings_no_with prc prlc (out_gen wit_bindings x).Evd.it - | List0ArgType _ -> - hov 0 (pr_sequence (pr_generic prc prlc prtac prpat) - (fold_list0 (fun a l -> a::l) x [])) - | List1ArgType _ -> - hov 0 (pr_sequence (pr_generic prc prlc prtac prpat) - (fold_list1 (fun a l -> a::l) x [])) - | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac prpat) (mt()) x) - | PairArgType _ -> - hov 0 - (fold_pair (fun a b -> pr_sequence (pr_generic prc prlc prtac prpat) - [a;b]) - x) - | ExtraArgType s -> - try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x - with Not_found -> str "[no printer for " ++ str s ++ str "]" - -let rec tacarg_using_rule_token pr_gen = function - | Some s :: l, al -> str s :: tacarg_using_rule_token pr_gen (l,al) - | None :: l, a :: al -> - let print_it = - match genarg_tag a with - | OptArgType _ -> fold_opt (fun _ -> true) false a - | _ -> true - in - let r = tacarg_using_rule_token pr_gen (l,al) in - if print_it then pr_gen a :: r else r - | [], [] -> [] - | _ -> failwith "Inconsistent arguments of extended tactic" - -let pr_tacarg_using_rule pr_gen l= - pr_sequence (fun x -> x) (tacarg_using_rule_token pr_gen l) - -let pr_extend_gen pr_gen lev s l = - try - let tags = List.map genarg_tag l in - let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in - let p = pr_tacarg_using_rule pr_gen (pl,l) in - if lev' > lev then surround p else p - with Not_found -> - str s ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" - -let pr_raw_extend prc prlc prtac prpat = - pr_extend_gen (pr_raw_generic prc prlc prtac prpat pr_reference) -let pr_glob_extend prc prlc prtac prpat = - pr_extend_gen (pr_glob_generic prc prlc prtac prpat) -let pr_extend prc prlc prtac prpat = - pr_extend_gen (pr_generic prc prlc prtac prpat) - -(**********************************************************************) -(* The tactic printer *) - -let strip_prod_binders_expr n ty = - let rec strip_ty acc n ty = - match ty with - Topconstr.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 - | Topconstr.CArrow(_,a,b) -> - if n=1 then - (List.rev (([(dummy_loc,Anonymous)],a)::acc), b) - else strip_ty (([(dummy_loc,Anonymous)],a)::acc) (n-1) b - | _ -> 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 sp = - pr_qualid (Nametab.shortest_qualid_of_tactic sp) - -let pr_evaluable_reference_env env = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> - Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.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 prlc prc = function - | ImplicitBindings l -> - spc () ++ - hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++ - prlist_with_sep spc prc l) - | ExplicitBindings l -> - spc () ++ - hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++ - pr_esubst prlc l) - | NoBindings -> mt () - -let pr_bindings prlc prc = pr_bindings_gen false prlc prc - -let pr_with_bindings prlc prc (c,bl) = - hov 1 (prc c ++ pr_bindings prlc prc bl) - -let pr_as_ipat pat = str "as " ++ pr_intro_pattern pat -let pr_eqn_ipat pat = str "eqn:" ++ pr_intro_pattern pat - -let pr_with_induction_names = function - | None, None -> mt () - | Some eqpat, None -> spc () ++ hov 1 (pr_eqn_ipat eqpat) - | None, Some ipat -> spc () ++ hov 1 (pr_as_ipat ipat) - | Some eqpat, Some ipat -> - spc () ++ hov 1 (pr_as_ipat ipat ++ spc () ++ pr_eqn_ipat eqpat) - -let pr_as_intro_pattern ipat = - spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat) - -let pr_with_inversion_names = function - | None -> mt () - | Some ipat -> pr_as_intro_pattern ipat - -let pr_as_ipat = function - | None -> mt () - | Some ipat -> pr_as_intro_pattern ipat - -let pr_as_name = function - | Anonymous -> mt () - | Name id -> str " as " ++ pr_lident (dummy_loc,id) - -let pr_pose_as_style prc na c = - spc() ++ prc c ++ pr_as_name na - -let pr_pose prlc prc na c = match na with - | Anonymous -> spc() ++ prc c - | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c) - -let pr_assertion _prlc prc 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 ipat - -let pr_assumption prlc prc 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 ipat - -let pr_by_tactic prt = function - | TacId [] -> mt () - | tac -> spc() ++ str "by " ++ prt tac - -let pr_hyp_location pr_id = function - | occs, Termops.InHyp -> spc () ++ pr_with_occurrences pr_id occs - | occs, Termops.InHypTypeOnly -> - spc () ++ - pr_with_occurrences (fun id -> str "(type of " ++ pr_id id ++ str ")") occs - | occs, Termops.InHypValueOnly -> - spc () ++ - pr_with_occurrences (fun id -> str "(value of " ++ pr_id id ++ str ")") occs - -let pr_in pp = spc () ++ hov 0 (str "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 pr_id = function - | None -> mt () - | Some (id,ipat) -> pr_simple_hyp_clause pr_id [id] ++ pr_as_ipat ipat - -let pr_clauses default_is_concl pr_id = function - | { onhyps=Some []; concl_occs=occs } - when occs = all_occurrences_expr & default_is_concl = Some true -> mt () - | { onhyps=None; concl_occs=occs } - when occs = all_occurrences_expr & default_is_concl = Some false -> mt () - | { onhyps=None; concl_occs=occs } -> - if occs = no_occurrences_expr then pr_in (str " * |-") - else pr_in (pr_with_occurrences (fun () -> str " *") (occs,())) - | { onhyps=Some l; concl_occs=occs } -> - pr_in - (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l ++ - (if occs = no_occurrences_expr then mt () - else pr_with_occurrences (fun () -> str" |- *") (occs,()))) - -let pr_orient b = if b then mt () else str "<- " - -let pr_multi = function - | Precisely 1 -> mt () - | Precisely n -> pr_int n ++ str "!" - | UpTo n -> pr_int n ++ str "?" - | RepeatStar -> str "?" - | RepeatPlus -> str "!" - -let pr_induction_arg prlc prc = function - | ElimOnConstr c -> pr_with_bindings prlc prc c - | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id) - | ElimOnAnonHyp n -> int n - -let pr_induction_kind = function - | SimpleInversion -> str "simple inversion" - | FullInversion -> str "inversion" - | FullInversionClear -> str "inversion_clear" - -let pr_lazy lz = if lz then str "lazy" else mt () - -let pr_match_pattern pr_pat = function - | Term a -> pr_pat a - | Subterm (b,None,a) -> (if b then str"appcontext [" else str "context [") ++ pr_pat a ++ str "]" - | Subterm (b,Some id,a) -> - (if b then str"appcontext " else str "context ") ++ 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 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 (str k ++ pr_lident id ++ prlist pr_funvar bl ++ - str " :=" ++ brk (1,1) ++ pr (TacArg (dummy_loc,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 "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_opt_tactic pr = function - | TacId [] -> mt () - | t -> pr t - -let pr_then_gen pr tf tm tl = - hv 0 (str "[ " ++ - 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 ++ - str " ]") - -let pr_hintbases = function - | None -> spc () ++ str "with *" - | Some [] -> mt () - | Some l -> - spc () ++ hov 2 (str "with" ++ prlist (fun s -> spc () ++ str s) l) - -let pr_auto_using prc = function - | [] -> mt () - | l -> spc () ++ - hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_comma prc l) - -let string_of_debug = function - | Off -> "" - | Debug -> "debug " - | Info -> "info_" - -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 - -open Closure - -(** A printer for tactics that polymorphically works on the three - "raw", "glob" and "typed" levels; in practice, the environment is - used only at the glob and typed level: it is used to feed the - constr printers *) - -let make_pr_tac - (pr_tac_level,pr_constr,pr_lconstr,pr_pat, - pr_cst,pr_ind,pr_ref,pr_ident, - pr_extend,strip_prod_binders) env = - -(* The environment is not used by the tactic printer: it is passed to the - constr and cst printers; hence we can make some abbreviations *) -let pr_constr = pr_constr env in -let pr_lconstr = pr_lconstr env in -let pr_lpat = pr_pat true in -let pr_pat = pr_pat false in -let pr_cst = pr_cst env in -let pr_ind = pr_ind env in -let pr_tac_level = pr_tac_level env in - -(* Other short cuts *) -let pr_bindings = pr_bindings pr_lconstr pr_constr in -let pr_ex_bindings = pr_bindings_gen true pr_lconstr pr_constr in -let pr_with_bindings = pr_with_bindings pr_lconstr pr_constr in -let pr_extend = pr_extend pr_constr pr_lconstr pr_tac_level pr_pat in -let pr_red_expr = pr_red_expr (pr_constr,pr_lconstr,pr_cst,pr_pat) in - -let pr_constrarg c = spc () ++ pr_constr c in -let pr_lconstrarg c = spc () ++ pr_lconstr c in -let pr_intarg n = spc () ++ int n in - -(* Some printing combinators *) -let pr_eliminator cb = str "using" ++ pr_arg pr_with_bindings cb in - -let extract_binders = function - | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) - | body -> ([],body) 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_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 = - if List.length names = 1 then mt() - else spc() ++ str"{struct " ++ 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 = function - | TacIntroPattern [] -> str "intros" - | TacIntroMove (None,hto) when hto = no_move -> str "intro" - | TacAssumption -> str "assumption" - | TacAnyConstructor (false,None) -> str "constructor" - | TacAnyConstructor (true,None) -> str "econstructor" - | TacTrivial (d,[],Some []) -> str (string_of_debug d ^ "trivial") - | TacAuto (d,None,[],Some []) -> str (string_of_debug d ^ "auto") - | TacReflexivity -> str "reflexivity" - | TacClear (true,[]) -> str "clear" - | t -> str "(" ++ pr_atom1 t ++ str ")" - - (* Main tactic printer *) -and pr_atom1 = function - | TacExtend (loc,s,l) -> - pr_with_comments loc (pr_extend 1 s l) - | TacAlias (loc,s,l,_) -> - pr_with_comments loc (pr_extend 1 s (List.map snd l)) - - (* Basic tactics *) - | TacIntroPattern [] as t -> pr_atom0 t - | TacIntroPattern (_::_ as p) -> - hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p) - | TacIntrosUntil h -> - hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h) - | TacIntroMove (None,hto) as t when hto = no_move -> pr_atom0 t - | TacIntroMove (Some id,hto) when hto = no_move -> str "intro " ++ pr_id id - | TacIntroMove (ido,hto) -> - hov 1 (str"intro" ++ pr_opt pr_id ido ++ pr_move_location pr_ident hto) - | TacAssumption as t -> pr_atom0 t - | TacExact c -> hov 1 (str "exact" ++ pr_constrarg c) - | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg c) - | TacVmCastNoCheck c -> hov 1 (str "vm_cast_no_check" ++ pr_constrarg c) - | TacApply (a,ev,cb,inhyp) -> - hov 1 ((if a then mt() else str "simple ") ++ - str (with_evars ev "apply") ++ spc () ++ - prlist_with_sep pr_comma pr_with_bindings cb ++ - pr_in_hyp_as pr_ident inhyp) - | TacElim (ev,cb,cbo) -> - hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++ - pr_opt pr_eliminator cbo) - | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg c) - | TacCase (ev,cb) -> - hov 1 (str (with_evars ev "case") ++ spc () ++ pr_with_bindings cb) - | TacCaseType c -> hov 1 (str "casetype" ++ pr_constrarg c) - | TacFix (ido,n) -> hov 1 (str "fix" ++ pr_opt pr_id ido ++ pr_intarg n) - | TacMutualFix (hidden,id,n,l) -> - if hidden then str "idtac" (* should caught before! *) else - hov 1 (str "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++ - str"with " ++ prlist_with_sep spc pr_fix_tac l) - | TacCofix ido -> hov 1 (str "cofix" ++ pr_opt pr_id ido) - | TacMutualCofix (hidden,id,l) -> - if hidden then str "idtac" (* should be caught before! *) else - hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++ - str"with " ++ prlist_with_sep spc pr_cofix_tac l) - | TacCut c -> hov 1 (str "cut" ++ pr_constrarg c) - | TacAssert (Some tac,ipat,c) -> - hov 1 (str "assert" ++ - pr_assumption pr_lconstr pr_constr ipat c ++ - pr_by_tactic (pr_tac_level ltop) tac) - | TacAssert (None,ipat,c) -> - hov 1 (str "pose proof" ++ - pr_assertion pr_lconstr pr_constr ipat c) - | TacGeneralize l -> - hov 1 (str "generalize" ++ spc () ++ - prlist_with_sep pr_comma (fun (cl,na) -> - pr_with_occurrences pr_constr cl ++ pr_as_name na) - l) - | TacGeneralizeDep c -> - hov 1 (str "generalize" ++ spc () ++ str "dependent" ++ - pr_constrarg c) - | TacLetTac (na,c,cl,true,_) when cl = nowhere -> - hov 1 (str "pose" ++ pr_pose pr_lconstr pr_constr na c) - | TacLetTac (na,c,cl,b,e) -> - hov 1 ((if b then str "set" else str "remember") ++ - (if b then pr_pose pr_lconstr else pr_pose_as_style) - pr_constr na c ++ - pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ - pr_clauses (Some b) pr_ident 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_ident (id,[],(hloc,ref None))) -*) - (* Derived basic tactics *) - | TacSimpleInductionDestruct (isrec,h) -> - hov 1 (str "simple " ++ str (if isrec then "induction" else "destruct") - ++ pr_arg pr_quantified_hypothesis h) - | TacInductionDestruct (isrec,ev,(l,el,cl)) -> - hov 1 (str (with_evars ev (if isrec then "induction" else "destruct")) ++ - spc () ++ - prlist_with_sep pr_comma (fun (h,ids) -> - pr_induction_arg pr_lconstr pr_constr h ++ - pr_with_induction_names ids) l ++ - pr_opt pr_eliminator el ++ - pr_opt_no_spc (pr_clauses None pr_ident) cl) - | TacDoubleInduction (h1,h2) -> - hov 1 - (str "double induction" ++ - pr_arg pr_quantified_hypothesis h1 ++ - pr_arg pr_quantified_hypothesis h2) - | TacDecomposeAnd c -> - hov 1 (str "decompose record" ++ pr_constrarg c) - | TacDecomposeOr c -> - hov 1 (str "decompose sum" ++ pr_constrarg c) - | TacDecompose (l,c) -> - hov 1 (str "decompose" ++ spc () ++ - hov 0 (str "[" ++ prlist_with_sep spc pr_ind l - ++ str "]" ++ pr_constrarg c)) - | TacSpecialize (n,c) -> - hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ - pr_with_bindings c) - | TacLApply c -> - hov 1 (str "lapply" ++ pr_constrarg c) - - (* Automation tactics *) - | TacTrivial (_,[],Some []) as x -> pr_atom0 x - | TacTrivial (d,lems,db) -> - hov 0 (str (string_of_debug d ^ "trivial") ++ - pr_auto_using pr_constr lems ++ pr_hintbases db) - | TacAuto (_,None,[],Some []) as x -> pr_atom0 x - | TacAuto (d,n,lems,db) -> - hov 0 (str (string_of_debug d ^ "auto") ++ - pr_opt (pr_or_var int) n ++ - pr_auto_using pr_constr lems ++ pr_hintbases db) - - (* Context management *) - | TacClear (true,[]) as t -> pr_atom0 t - | TacClear (keep,l) -> - hov 1 (str "clear" ++ spc () ++ (if keep then str "- " else mt ()) ++ - prlist_with_sep spc pr_ident l) - | TacClearBody l -> - hov 1 (str "clearbody" ++ spc () ++ prlist_with_sep spc pr_ident l) - | TacMove (b,id1,id2) -> - (* Rem: only b = true is available for users *) - assert b; - hov 1 - (str "move" ++ brk (1,1) ++ pr_ident id1 ++ - pr_move_location pr_ident id2) - | TacRename l -> - hov 1 - (str "rename" ++ brk (1,1) ++ - prlist_with_sep - (fun () -> str "," ++ brk (1,1)) - (fun (i1,i2) -> - pr_ident i1 ++ spc () ++ str "into" ++ spc () ++ pr_ident i2) - l) - | TacRevert l -> - hov 1 (str "revert" ++ spc () ++ prlist_with_sep spc pr_ident l) - - (* Constructors *) - | TacLeft (ev,l) -> hov 1 (str (with_evars ev "left") ++ pr_bindings l) - | TacRight (ev,l) -> hov 1 (str (with_evars ev "right") ++ pr_bindings l) - | TacSplit (ev,false,l) -> hov 1 (str (with_evars ev "split") ++ prlist_with_sep pr_comma pr_bindings l) - | TacSplit (ev,true,l) -> hov 1 (str (with_evars ev "exists") ++ prlist_with_sep (fun () -> str",") pr_ex_bindings l) - | TacAnyConstructor (ev,Some t) -> - hov 1 (str (with_evars ev "constructor") ++ pr_arg (pr_tac_level (latom,E)) t) - | TacAnyConstructor (ev,None) as t -> pr_atom0 t - | TacConstructor (ev,n,l) -> - hov 1 (str (with_evars ev "constructor") ++ - pr_or_var pr_intarg n ++ pr_bindings l) - - (* Conversion *) - | TacReduce (r,h) -> - hov 1 (pr_red_expr r ++ - pr_clauses (Some true) pr_ident h) - | TacChange (op,c,h) -> - hov 1 (str "change" ++ brk (1,1) ++ - (match op with - None -> mt() - | Some p -> pr_pat p ++ spc () ++ str "with ") ++ - pr_constr c ++ pr_clauses (Some true) pr_ident h) - - (* Equivalence relations *) - | TacReflexivity as x -> pr_atom0 x - | TacSymmetry cls -> str "symmetry" ++ pr_clauses (Some true) pr_ident cls - | TacTransitivity (Some c) -> str "transitivity" ++ pr_constrarg c - | TacTransitivity None -> str "etransitivity" - - (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - hov 1 (str (with_evars ev "rewrite") ++ spc () ++ - prlist_with_sep - (fun () -> str ","++spc()) - (fun (b,m,c) -> - pr_orient b ++ pr_multi m ++ pr_with_bindings c) - l - ++ pr_clauses (Some true) pr_ident cl - ++ (match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt())) - | TacInversion (DepInversion (k,c,ids),hyp) -> - hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++ - pr_quantified_hypothesis hyp ++ - pr_with_inversion_names ids ++ pr_with_constr pr_constr c) - | TacInversion (NonDepInversion (k,cl,ids),hyp) -> - hov 1 (pr_induction_kind k ++ spc () ++ - pr_quantified_hypothesis hyp ++ - pr_with_inversion_names ids ++ pr_simple_hyp_clause pr_ident cl) - | TacInversion (InversionUsing (c,cl),hyp) -> - hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ - spc () ++ str "using" ++ spc () ++ pr_constr c ++ - pr_simple_hyp_clause pr_ident cl) - -in - -let rec pr_tac inherited tac = - let (strm,prec) = match tac with - | TacAbstract (t,None) -> - str "abstract " ++ pr_tac (labstract,L) t, labstract - | TacAbstract (t,Some s) -> - hov 0 - (str "abstract (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () ++ - str "using " ++ 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 ++ str " in") ++ - fnl () ++ pr_tac (llet,E) u), - llet - | TacMatch (lz,t,lrul) -> - hov 0 (pr_lazy lz ++ str "match " ++ pr_tac ltop t ++ str " with" - ++ prlist - (fun r -> fnl () ++ str "| " ++ - pr_match_rule true (pr_tac ltop) pr_lpat r) - lrul - ++ fnl() ++ str "end"), - lmatch - | TacMatchGoal (lz,lr,lrul) -> - hov 0 (pr_lazy lz ++ - str (if lr then "match reverse goal with" else "match goal with") - ++ prlist - (fun r -> fnl () ++ str "| " ++ - pr_match_rule false (pr_tac ltop) pr_lpat r) - lrul - ++ fnl() ++ str "end"), - lmatch - | TacFun (lvar,body) -> - hov 2 (str "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_tac ltop) tl), - lseq - | TacThen (t1,[||],t2,[||]) -> - hov 1 (pr_tac (lseq,E) t1 ++ pr_then () ++ spc () ++ - pr_tac (lseq,L) t2), - lseq - | TacThen (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 (str "try" ++ spc () ++ pr_tac (ltactical,E) t), - ltactical - | TacDo (n,t) -> - hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ - pr_tac (ltactical,E) t), - ltactical - | TacTimeout (n,t) -> - hov 1 (str "timeout " ++ pr_or_var int n ++ spc () ++ - pr_tac (ltactical,E) t), - ltactical - | TacRepeat t -> - hov 1 (str "repeat" ++ spc () ++ pr_tac (ltactical,E) t), - ltactical - | TacProgress t -> - hov 1 (str "progress" ++ spc () ++ pr_tac (ltactical,E) t), - ltactical - | TacInfo t -> - hov 1 (str "info" ++ spc () ++ pr_tac (ltactical,E) t), - linfo - | TacOrelse (t1,t2) -> - hov 1 (pr_tac (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++ - pr_tac (lorelse,E) t2), - lorelse - | TacFail (n,l) -> - hov 1 (str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++ - prlist (pr_arg (pr_message_token pr_ident)) l), latom - | TacFirst tl -> - str "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet - | TacSolve tl -> - str "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet - | TacComplete t -> - pr_tac (lcomplete,E) t, lcomplete - | TacId l -> - str "idtac" ++ prlist (pr_arg (pr_message_token pr_ident)) l, latom - | TacAtom (loc,TacAlias (_,s,l,_)) -> - pr_with_comments loc - (pr_extend (level_of inherited) s (List.map snd l)), - latom - | TacAtom (loc,t) -> - pr_with_comments loc (hov 1 (pr_atom1 t)), ltatom - | TacArg(_,Tacexp e) -> pr_tac_level (latom,E) e, latom - | TacArg(_,ConstrMayEval (ConstrTerm c)) -> - str "constr:" ++ pr_constr c, latom - | TacArg(_,ConstrMayEval c) -> - pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c, leval - | TacArg(_,TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom - | TacArg(_,Integer n) -> int n, latom - | TacArg(_,TacCall(loc,f,[])) -> pr_ref f, latom - | TacArg(_,TacCall(loc,f,l)) -> - pr_with_comments loc - (hov 1 (pr_ref f ++ spc () ++ - prlist_with_sep spc pr_tacarg l)), - lcall - | TacArg (_,a) -> pr_tacarg a, latom - in - if prec_less prec inherited then strm - else str"(" ++ strm ++ str")" - -and pr_tacarg = function - | TacDynamic (loc,t) -> - pr_with_comments loc (str ("")) - | MetaIdArg (loc,true,s) -> pr_with_comments loc (str ("$" ^ s)) - | MetaIdArg (loc,false,s) -> pr_with_comments loc (str ("constr: $" ^ s)) - | IntroPattern ipat -> str "ipattern:" ++ pr_intro_pattern ipat - | TacVoid -> str "()" - | Reference r -> pr_ref r - | ConstrMayEval c -> pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c - | TacFreshId l -> str "fresh" ++ pr_fresh_ids l - | TacExternal (_,com,req,la) -> - str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++ - spc() ++ prlist_with_sep spc pr_tacarg la - | (TacCall _|Tacexp _|Integer _) as a -> - str "ltac:" ++ pr_tac (latom,E) (TacArg (dummy_loc,a)) - -in (pr_tac, pr_match_rule) - -let strip_prod_binders_glob_constr n (ty,_) = - let rec strip_ty acc n ty = - if n=0 then (List.rev acc, (ty,None)) else - match ty with - Glob_term.GProd(loc,na,Explicit,a,b) -> - strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b - | _ -> error "Cannot translate fix tactic: not enough products" in - strip_ty [] n ty - -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 (([dummy_loc,na],a)::acc) (n-1) b - | _ -> error "Cannot translate fix tactic: not enough products" in - strip_ty [] n ty - -let drop_env f _env = f - -let pr_constr_or_lconstr_pattern_expr b = - if b then pr_lconstr_pattern_expr else pr_constr_pattern_expr - -let rec raw_printers = - (pr_raw_tactic_level, - drop_env pr_constr_expr, - drop_env pr_lconstr_expr, - pr_constr_or_lconstr_pattern_expr, - drop_env (pr_or_by_notation pr_reference), - drop_env (pr_or_by_notation pr_reference), - pr_reference, - pr_or_metaid pr_lident, - pr_raw_extend, - strip_prod_binders_expr) - -and pr_raw_tactic_level env n (t:raw_tactic_expr) = - fst (make_pr_tac raw_printers env) n t - -let pr_and_constr_expr pr (c,_) = pr c - -let pr_pat_and_constr_expr b (c,_) = - pr_and_constr_expr ((if b then pr_lglob_constr_env else pr_glob_constr_env) - (Global.env())) c - -let rec glob_printers = - (pr_glob_tactic_level, - (fun env -> pr_and_constr_expr (pr_glob_constr_env env)), - (fun env -> pr_and_constr_expr (pr_lglob_constr_env env)), - pr_pat_and_constr_expr, - (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))), - (fun env -> pr_or_var (pr_inductive env)), - pr_ltac_or_var (pr_located pr_ltac_constant), - pr_lident, - pr_glob_extend, - strip_prod_binders_glob_constr) - -and pr_glob_tactic_level env n (t:glob_tactic_expr) = - fst (make_pr_tac glob_printers env) n t - -let pr_constr_or_lconstr_pattern b = - if b then pr_lconstr_pattern else pr_constr_pattern - -let typed_printers = - (pr_glob_tactic_level, - pr_constr_env, - pr_lconstr_env, - pr_constr_or_lconstr_pattern, - pr_evaluable_reference_env, - pr_inductive, - pr_ltac_constant, - pr_id, - pr_extend, - strip_prod_binders_constr) - -let pr_tactic_level env = fst (make_pr_tac typed_printers env) - -let pr_raw_tactic env = pr_raw_tactic_level env ltop -let pr_glob_tactic env = pr_glob_tactic_level env ltop -let pr_tactic env = pr_tactic_level env ltop - -let _ = Tactic_debug.set_tactic_printer - (fun x -> pr_glob_tactic (Global.env()) x) - -let _ = Tactic_debug.set_match_pattern_printer - (fun env hyp -> pr_match_pattern (pr_constr_pattern_env env) hyp) - -let _ = Tactic_debug.set_match_rule_printer - (fun rl -> - pr_match_rule false (pr_glob_tactic (Global.env())) - (fun (_,p) -> pr_constr_pattern p) rl) - -open Extrawit - -let pr_tac_polymorphic n _ _ prtac = prtac (n,E) - -let _ = for i=0 to 5 do - declare_extra_genarg_pprule - (rawwit_tactic i, pr_tac_polymorphic i) - (globwit_tactic i, pr_tac_polymorphic i) - (wit_tactic i, pr_tac_polymorphic i) -done - diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli deleted file mode 100644 index c5953da1..00000000 --- a/parsing/pptactic.mli +++ /dev/null @@ -1,100 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds) -> 'a or_var -> std_ppcmds -val pr_or_metaid : ('a -> std_ppcmds) -> 'a or_metaid -> 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 - -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 -> glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - - (** if the boolean is false then the extension applies only to old syntax *) -val declare_extra_genarg_pprule : - ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) -> - ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) -> - ('b typed_abstract_argument_type * 'b extra_genarg_printer) -> unit - -type grammar_terminals = string option list - - (** if the boolean is false then the extension applies only to old syntax *) -val declare_extra_tactic_pprule : - string * argument_type list * (int * grammar_terminals) -> unit - -val exists_extra_tactic_pprule : string -> argument_type list -> bool - -val pr_raw_generic : - (constr_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (Libnames.reference -> std_ppcmds) -> rlevel generic_argument -> - std_ppcmds - -val pr_raw_extend: - (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> int -> - string -> raw_generic_argument list -> std_ppcmds - -val pr_glob_extend: - (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (glob_constr_pattern_and_expr -> std_ppcmds) -> int -> - string -> glob_generic_argument list -> std_ppcmds - -val pr_extend : - (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (constr_pattern -> std_ppcmds) -> int -> - string -> typed_generic_argument list -> std_ppcmds - -val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds - -val pr_raw_tactic : env -> raw_tactic_expr -> std_ppcmds - -val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds - -val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds - -val pr_tactic : env -> Proof_type.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 diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml deleted file mode 100644 index 98c02567..00000000 --- a/parsing/ppvernac.ml +++ /dev/null @@ -1,979 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* dummy_loc then - let (b,_) = unloc loc in - pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id) - else pr_id id - -let string_of_fqid fqid = - String.concat "." (List.map string_of_id fqid) - -let pr_fqid fqid = str (string_of_fqid fqid) - -let pr_lfqid (loc,fqid) = - if loc <> dummy_loc then - let (b,_) = unloc loc in - pr_located pr_fqid (make_loc (b,b+String.length(string_of_fqid fqid)),fqid) - else - pr_fqid fqid - -let pr_lname = function - (loc,Name id) -> pr_lident (loc,id) - | lna -> pr_located pr_name lna - -let pr_smart_global = pr_or_by_notation pr_reference - -let pr_ltac_ref = Libnames.pr_reference - -let pr_module = Libnames.pr_reference - -let pr_import_module = Libnames.pr_reference - -let sep_end = function - | VernacBullet _ - | VernacSubproof None - | VernacEndSubproof -> str"" - | _ -> str"." - -(* Warning: [pr_raw_tactic] globalises and fails if globalisation fails *) - -let pr_raw_tactic_env l env t = - pr_glob_tactic env (Tacinterp.glob_tactic_env l env t) - -let pr_gen env t = - pr_raw_generic - pr_constr_expr - pr_lconstr_expr - (pr_raw_tactic_level env) pr_constr_expr pr_reference t - -let pr_raw_tactic tac = pr_raw_tactic (Global.env()) tac - -let rec extract_signature = function - | [] -> [] - | Egrammar.GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l - | _::l -> extract_signature l - -let rec match_vernac_rule tys = function - [] -> raise Not_found - | pargs::rls -> - if extract_signature pargs = tys then pargs - else match_vernac_rule tys rls - -let sep = fun _ -> spc() -let sep_v2 = fun _ -> str"," ++ spc() - -let pr_ne_sep sep pr = function - [] -> mt() - | l -> sep() ++ pr l - -let pr_set_entry_type = function - | ETName -> str"ident" - | ETReference -> str"global" - | ETPattern -> str"pattern" - | ETConstr _ -> str"constr" - | ETOther (_,e) -> str e - | ETBigint -> str "bigint" - | ETBinder true -> str "binder" - | ETBinder false -> str "closed binder" - | ETBinderList _ | ETConstrList _ -> failwith "Internal entry type" - -let strip_meta id = - let s = string_of_id id in - if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) - else id - -let pr_production_item = function - | TacNonTerm (loc,nt,Some (p,sep)) -> - let pp_sep = if sep <> "" then str "," ++ quote (str sep) else mt () in - str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")" - | TacNonTerm (loc,nt,None) -> str nt - | TacTerm s -> qs s - -let pr_comment pr_c = function - | CommentConstr c -> pr_c c - | CommentString s -> qs s - | CommentInt n -> int n - -let pr_in_out_modules = function - | SearchInside l -> spc() ++ str"inside" ++ spc() ++ prlist_with_sep sep pr_module l - | SearchOutside [] -> mt() - | SearchOutside l -> spc() ++ str"outside" ++ spc() ++ prlist_with_sep sep pr_module l - -let pr_search_about (b,c) = - (if b then str "-" else mt()) ++ - match c with - | SearchSubPattern p -> pr_constr_pattern_expr p - | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc - -let pr_search a b pr_p = match a with - | SearchHead c -> str"Search" ++ spc() ++ pr_p c ++ pr_in_out_modules b - | SearchPattern c -> str"SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b - | SearchRewrite c -> str"SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b - | SearchAbout sl -> str"SearchAbout" ++ spc() ++ str "[" ++ prlist_with_sep spc pr_search_about sl ++ str "]" ++ pr_in_out_modules b - -let pr_locality_full = function - | None -> mt() - | Some true -> str"Local " - | Some false -> str"Global " -let pr_locality local = if local then str "Local " else str "" -let pr_non_locality local = if local then str "" else str "Global " -let pr_section_locality local = - if Lib.sections_are_opened () && not local then str "Global " - else if not (Lib.sections_are_opened ()) && local then str "Local " - else mt () - -let pr_explanation (e,b,f) = - let a = match e with - | ExplByPos (n,_) -> anomaly "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 - -let pr_option_ref_value = function - | QualidRefValue id -> pr_reference id - | StringRefValue s -> qs s - -let pr_printoption table b = - prlist_with_sep spc str table ++ - pr_opt (prlist_with_sep sep pr_option_ref_value) b - -let pr_set_option a b = - let pr_opt_value = function - | IntValue None -> assert false - (* This should not happen because of the grammar *) - | IntValue (Some n) -> spc() ++ int n - | StringValue s -> spc() ++ str s - | BoolValue b -> mt() - in pr_printoption a None ++ pr_opt_value b - -let pr_topcmd _ = str"(* : No printer for toplevel commands *)" - -let pr_destruct_location = function - | Tacexpr.ConclLocation () -> str"Conclusion" - | Tacexpr.HypLocation b -> if b then str"Discardable Hypothesis" else str"Hypothesis" - -let pr_opt_hintbases l = match l with - | [] -> mt() - | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z - -let pr_hints local db h pr_c pr_pat = - let opth = pr_opt_hintbases db in - let pph = - match h with - | HintsResolve l -> - str "Resolve " ++ prlist_with_sep sep - (fun (pri, _, c) -> pr_c c ++ - match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ()) - l - | HintsImmediate l -> - str"Immediate" ++ spc() ++ prlist_with_sep sep pr_c l - | HintsUnfold l -> - str "Unfold " ++ prlist_with_sep sep pr_reference l - | HintsTransparency (l, b) -> - str (if b then "Transparent " else "Opaque ") ++ prlist_with_sep sep - pr_reference l - | HintsConstructors c -> - str"Constructors" ++ spc() ++ prlist_with_sep spc pr_reference c - | HintsExtern (n,c,tac) -> - let pat = match c with None -> mt () | Some pat -> pr_pat pat in - str "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ - spc() ++ pr_raw_tactic tac - in - hov 2 (str"Hint "++pr_locality local ++ pph ++ opth) - -let pr_with_declaration pr_c = function - | CWith_Definition (id,c) -> - let p = pr_c c in - str"Definition" ++ spc() ++ pr_lfqid id ++ str" := " ++ p - | CWith_Module (id,qid) -> - str"Module" ++ spc() ++ pr_lfqid id ++ str" := " ++ - pr_located pr_qualid qid - -let rec pr_module_ast pr_c = function - | CMident qid -> spc () ++ pr_located pr_qualid qid - | CMwith (_,mty,decl) -> - let m = pr_module_ast pr_c mty in - let p = pr_with_declaration pr_c decl in - m ++ spc() ++ str"with" ++ spc() ++ p - | CMapply (_,me1,(CMident _ as me2)) -> - pr_module_ast pr_c me1 ++ spc() ++ pr_module_ast pr_c me2 - | CMapply (_,me1,me2) -> - pr_module_ast pr_c me1 ++ spc() ++ - hov 1 (str"(" ++ pr_module_ast pr_c me2 ++ str")") - -let pr_annot { ann_inline = ann; ann_scope_subst = scl } = - let sep () = if scl=[] then mt () else str "," in - if ann = DefaultInline && scl = [] then mt () - else - str " [" ++ - (match ann with - | DefaultInline -> mt () - | NoInline -> str "no inline" ++ sep () - | InlineAt i -> str "inline at level " ++ int i ++ sep ()) ++ - prlist_with_sep (fun () -> str ", ") - (fun (sc1,sc2) -> str ("scope "^sc1^" to "^sc2)) scl ++ - str "]" - -let pr_module_ast_inl pr_c (mast,ann) = - pr_module_ast pr_c mast ++ pr_annot ann - -let pr_of_module_type prc = function - | Enforce mty -> str ":" ++ pr_module_ast_inl prc mty - | Check mtys -> - prlist_strict (fun m -> str "<:" ++ pr_module_ast_inl prc m) mtys - -let pr_require_token = function - | Some true -> str "Export " - | Some false -> str "Import " - | None -> mt() - -let pr_module_vardecls pr_c (export,idl,(mty,inl)) = - let m = pr_module_ast pr_c mty in - (* Update the Nametab for interpreting the body of module/modtype *) - let lib_dir = Lib.library_dp() in - List.iter (fun (_,id) -> - Declaremods.process_module_bindings [id] - [make_mbid lib_dir id, - (Modintern.interp_modtype (Global.env()) mty, inl)]) idl; - (* Builds the stream *) - spc() ++ - hov 1 (str"(" ++ pr_require_token export ++ - prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")") - -let pr_module_binders l pr_c = - (* Effet de bord complexe pour garantir la declaration des noms des - modules parametres dans la Nametab des l'appel de pr_module_binders - malgre l'aspect paresseux des streams *) - let ml = List.map (pr_module_vardecls pr_c) l in - prlist (fun id -> id) ml - -let pr_module_binders_list l pr_c = pr_module_binders l pr_c - -let pr_type_option pr_c = function - | CHole (loc, k) -> mt() - | _ as c -> brk(0,2) ++ str":" ++ pr_c c - -let pr_decl_notation prc ((loc,ntn),c,scopt) = - fnl () ++ str "where " ++ qs ntn ++ str " := " ++ prc c ++ - pr_opt (fun sc -> str ": " ++ str sc) scopt - -let pr_binders_arg = - pr_ne_sep spc pr_binders - -let pr_and_type_binders_arg bl = - pr_binders_arg bl - -let pr_onescheme (idop,schem) = - match schem with - | InductionScheme (dep,ind,s) -> - (match idop with - | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() - | None -> spc () - ) ++ - hov 0 ((if dep then str"Induction for" else str"Minimality for") - ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s) - | CaseScheme (dep,ind,s) -> - (match idop with - | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() - | None -> spc () - ) ++ - hov 0 ((if dep then str"Elimination for" else str"Case for") - ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s) - | EqualityScheme ind -> - (match idop with - | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() - | None -> spc() - ) ++ - hov 0 (str"Equality for") - ++ spc() ++ pr_smart_global ind - -let begin_of_inductive = function - [] -> 0 - | (_,((loc,_),_))::_ -> fst (unloc loc) - -let pr_class_rawexpr = function - | FunClass -> str"Funclass" - | SortClass -> str"Sortclass" - | RefClass qid -> pr_smart_global qid - -let pr_assumption_token many = function - | (Local,Logical) -> - str (if many then "Hypotheses" else "Hypothesis") - | (Local,Definitional) -> - str (if many then "Variables" else "Variable") - | (Global,Logical) -> - str (if many then "Axioms" else "Axiom") - | (Global,Definitional) -> - str (if many then "Parameters" else "Parameter") - | (Global,Conjectural) -> str"Conjecture" - | (Local,Conjectural) -> - anomaly "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() ++ - (if c then str":>" else str":" ++ - spc() ++ pr_c t)) - -let rec factorize = function - | [] -> [] - | (c,(idl,t))::l -> - match factorize l with - | (xl,t')::l' when t' = (c,t) -> (idl@xl,t')::l' - | l' -> (idl,(c,t))::l' - -let pr_ne_params_list pr_c l = - match factorize l with - | [p] -> pr_params pr_c p - | l -> - prlist_with_sep spc - (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l -(* - prlist_with_sep pr_semicolon (pr_params pr_c) -*) - -let pr_thm_token k = str (string_of_theorem_kind k) - -let pr_syntax_modifier = function - | SetItemLevel (l,NextLevel) -> - prlist_with_sep sep_v2 str l ++ - spc() ++ str"at next level" - | SetItemLevel (l,NumLevel n) -> - prlist_with_sep sep_v2 str l ++ - spc() ++ str"at level" ++ spc() ++ int n - | SetLevel n -> str"at level" ++ spc() ++ int n - | SetAssoc LeftA -> str"left associativity" - | SetAssoc RightA -> str"right associativity" - | SetAssoc NonA -> str"no associativity" - | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ - | SetOnlyParsing Flags.Current -> str"only parsing" - | SetOnlyParsing v -> str("compat \"" ^ Flags.pr_version v ^ "\"") - | SetFormat s -> str"format " ++ pr_located qs s - -let pr_syntax_modifiers = function - | [] -> mt() - | l -> spc() ++ - hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") - -let print_level n = - if n <> 0 then str " (at level " ++ int n ++ str ")" else mt () - -let pr_grammar_tactic_rule n (_,pil,t) = - hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++ - hov 0 (prlist_with_sep sep pr_production_item pil ++ - spc() ++ str":=" ++ spc() ++ pr_raw_tactic t)) - -let pr_statement head (id,(bl,c,guard)) = - assert (id<>None); - hov 1 - (head ++ spc() ++ pr_lident (Option.get id) ++ spc() ++ - (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ - pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++ - str":" ++ pr_spc_lconstr c) - -(**************************************) -(* Pretty printer for vernac commands *) -(**************************************) -let make_pr_vernac pr_constr pr_lconstr = - -let pr_constrarg c = spc () ++ pr_constr c in -let pr_lconstrarg c = spc () ++ pr_lconstr c in -let pr_intarg n = spc () ++ int n in -let pr_oc = function - None -> str" :" - | Some true -> str" :>" - | Some false -> str" :>>" -in -let pr_record_field ((x, pri), ntn) = - let prx = match x with - | (oc,AssumExpr (id,t)) -> - hov 1 (pr_lname id ++ - pr_oc oc ++ spc() ++ - pr_lconstr_expr t) - | (oc,DefExpr(id,b,opt)) -> (match opt with - | Some t -> - hov 1 (pr_lname id ++ - pr_oc oc ++ spc() ++ - pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b) - | None -> - hov 1 (pr_lname id ++ str" :=" ++ spc() ++ - pr_lconstr b)) in - let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in - prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn -in -let pr_record_decl b c fs = - pr_opt pr_lident c ++ str"{" ++ - hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}") -in - -let rec pr_vernac = function - - (* Proof management *) - | VernacAbortAll -> str "Abort All" - | VernacRestart -> str"Restart" - | VernacUnfocus -> str"Unfocus" - | VernacUnfocused -> str"Unfocused" - | VernacGoal c -> str"Goal" ++ pr_lconstrarg c - | VernacAbort id -> str"Abort" ++ pr_opt pr_lident id - | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i - | VernacUndoTo i -> str"Undo" ++ spc() ++ str"To" ++ pr_intarg i - | VernacBacktrack (i,j,k) -> - str "Backtrack" ++ spc() ++ prlist_with_sep sep int [i;j;k] - | VernacFocus i -> str"Focus" ++ pr_opt int i - | VernacShow s -> - let pr_goal_reference = function - | OpenSubgoals -> mt () - | NthGoal n -> spc () ++ int n - | GoalId n -> spc () ++ str n in - let pr_showable = function - | ShowGoal n -> str"Show" ++ pr_goal_reference n - | ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n - | ShowProof -> str"Show Proof" - | ShowNode -> str"Show Node" - | ShowScript -> str"Show Script" - | ShowExistentials -> str"Show Existentials" - | ShowTree -> str"Show Tree" - | ShowProofNames -> str"Show Conjectures" - | ShowIntros b -> str"Show " ++ (if b then str"Intros" else str"Intro") - | ShowMatch id -> str"Show Match " ++ pr_lident id - | ShowThesis -> str "Show Thesis" - in pr_showable s - | VernacCheckGuard -> str"Guarded" - - (* Resetting *) - | VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id - | VernacResetInitial -> str"Reset Initial" - | VernacBack i -> if i=1 then str"Back" else str"Back" ++ pr_intarg i - | VernacBackTo i -> str"BackTo" ++ pr_intarg i - - (* State management *) - | VernacWriteState s -> str"Write State" ++ spc () ++ qs s - | VernacRestoreState s -> str"Restore State" ++ spc() ++ qs s - - (* Control *) - | VernacList l -> - hov 2 (str"[" ++ spc() ++ - prlist (fun v -> pr_located pr_vernac v ++ sep_end (snd v) ++ fnl()) l - ++ spc() ++ str"]") - | VernacLoad (f,s) -> str"Load" ++ if f then (spc() ++ str"Verbose" - ++ spc()) else spc() ++ qs s - | VernacTime v -> str"Time" ++ spc() ++ pr_vernac v - | VernacTimeout(n,v) -> str"Timeout " ++ int n ++ spc() ++ pr_vernac v - | VernacFail v -> str"Fail" ++ spc() ++ pr_vernac v - - (* Syntax *) - | VernacTacticNotation (n,r,e) -> pr_grammar_tactic_rule n ("",r,e) - | VernacOpenCloseScope (local,opening,sc) -> - pr_section_locality local ++ - str (if opening then "Open " else "Close ") ++ - str "Scope" ++ spc() ++ str sc - | VernacDelimiters (sc,key) -> - str"Delimit Scope" ++ spc () ++ str sc ++ - spc() ++ str "with " ++ str key - | VernacBindScope (sc,cll) -> - str"Bind Scope" ++ spc () ++ str sc ++ - spc() ++ str "with " ++ prlist_with_sep spc pr_class_rawexpr cll - | VernacArgumentsScope (local,q,scl) -> let pr_opt_scope = function - | None -> str"_" - | Some sc -> str sc in - pr_section_locality local ++ str"Arguments Scope" ++ spc() ++ - pr_smart_global q - ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]" - | VernacInfix (local,((_,s),mv),q,sn) -> (* A Verifier *) - hov 0 (hov 0 (pr_locality local ++ str"Infix " - ++ qs s ++ str " :=" ++ pr_constrarg q) ++ - pr_syntax_modifiers mv ++ - (match sn with - | None -> mt() - | Some sc -> spc() ++ str":" ++ spc() ++ str sc)) - | VernacNotation (local,c,((_,s),l),opt) -> - let ps = - let n = String.length s in - if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' - then - let s' = String.sub s 1 (n-2) in - if String.contains s' '\'' then qs s else str s' - else qs s in - hov 2 (pr_locality local ++ str"Notation" ++ spc() ++ ps ++ - str " :=" ++ pr_constrarg c ++ pr_syntax_modifiers l ++ - (match opt with - | None -> mt() - | Some sc -> str" :" ++ spc() ++ str sc)) - | VernacSyntaxExtension (local,(s,l)) -> - pr_locality local ++ str"Reserved Notation" ++ spc() ++ pr_located qs s ++ - pr_syntax_modifiers l - - (* Gallina *) - | VernacDefinition (d,id,b,f) -> (* A verifier... *) - let pr_def_token dk = str (string_of_definition_kind dk) in - let pr_reduce = function - | None -> mt() - | Some r -> - str"Eval" ++ spc() ++ - pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++ - str" in" ++ spc() in - let pr_def_body = function - | DefineBody (bl,red,body,d) -> - let ty = match d with - | None -> mt() - | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty - 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 (binds,typ,c) = pr_def_body b in - hov 2 (pr_def_token d ++ spc() ++ pr_lident id ++ binds ++ typ ++ - (match c with - | None -> mt() - | Some cc -> str" :=" ++ spc() ++ cc)) - - | VernacStartTheoremProof (ki,l,_,_) -> - hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++ - prlist (pr_statement (spc () ++ str "with")) (List.tl l)) - - | VernacEndProof Admitted -> str"Admitted" - | VernacEndProof (Proved (opac,o)) -> (match o with - | None -> if opac then str"Qed" else str"Defined" - | Some (id,th) -> (match th with - | None -> (if opac then str"Save" else str"Defined") ++ spc() ++ pr_lident id - | Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)) - | VernacExactProof c -> - hov 2 (str"Proof" ++ pr_lconstrarg c) - | VernacAssumption (stre,_,l) -> - let n = List.length (List.flatten (List.map fst (List.map snd l))) in - hov 2 - (pr_assumption_token (n > 1) stre ++ spc() ++ - pr_ne_params_list pr_lconstr_expr l) - | VernacInductive (f,i,l) -> - - let pr_constructor (coe,(id,c)) = - hov 2 (pr_lident id ++ str" " ++ - (if coe then str":>" else str":") ++ - pr_spc_lconstr c) in - let pr_constructor_list b l = match l with - | Constructors [] -> mt() - | Constructors l -> - pr_com_at (begin_of_inductive l) ++ - fnl() ++ - str (if List.length l = 1 then " " else " | ") ++ - prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l - | RecordDecl (c,fs) -> - spc() ++ - pr_record_decl b c fs in - let pr_oneind key (((coe,id),indpar,s,k,lc),ntn) = - hov 0 ( - str key ++ spc() ++ - (if i then str"Infer " else str"") ++ - (if coe then str"> " else str"") ++ pr_lident id ++ - pr_and_type_binders_arg indpar ++ spc() ++ - Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++ - str" :=") ++ pr_constructor_list k lc ++ - prlist (pr_decl_notation pr_constr) ntn - in - let key = - let (_,_,_,k,_),_ = List.hd l in - match k with Record -> "Record" | Structure -> "Structure" - | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" - | Class _ -> "Class" in - hov 1 (pr_oneind key (List.hd l)) ++ - (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) - - - | VernacFixpoint recs -> - let pr_onerec = function - | ((loc,id),ro,bl,type_,def),ntn -> - let annot = pr_guard_annot pr_lconstr_expr bl ro in - pr_id id ++ 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_lconstr def) def ++ - prlist (pr_decl_notation pr_constr) ntn - in - hov 0 (str "Fixpoint" ++ spc() ++ - prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onerec recs) - - | VernacCoFixpoint corecs -> - let pr_onecorec (((loc,id),bl,c,def),ntn) = - pr_id id ++ 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 - in - hov 0 (str "CoFixpoint" ++ spc() ++ - prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs) - | VernacScheme l -> - hov 2 (str"Scheme" ++ spc() ++ - prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onescheme l) - | VernacCombinedScheme (id, l) -> - hov 2 (str"Combined Scheme" ++ spc() ++ - pr_lident id ++ spc() ++ str"from" ++ spc() ++ - prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l) - - - (* Gallina extensions *) - | VernacBeginSection id -> hov 2 (str"Section" ++ spc () ++ pr_lident id) - | VernacEndSegment id -> hov 2 (str"End" ++ spc() ++ pr_lident id) - | VernacRequire (exp,spe,l) -> hov 2 - (str "Require" ++ spc() ++ pr_require_token exp ++ - (match spe with - | None -> mt() - | Some flag -> - (if flag then str"Specification" else str"Implementation") ++ - spc ()) ++ - prlist_with_sep sep pr_module l) - | VernacImport (f,l) -> - (if f then str"Export" else str"Import") ++ spc() ++ - prlist_with_sep sep pr_import_module l - | VernacCanonical q -> str"Canonical Structure" ++ spc() ++ pr_smart_global q - | VernacCoercion (s,id,c1,c2) -> - hov 1 ( - str"Coercion" ++ (match s with | Local -> spc() ++ - str"Local" ++ spc() | Global -> spc()) ++ - pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ - spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) - | VernacIdentityCoercion (s,id,c1,c2) -> - hov 1 ( - str"Identity Coercion" ++ (match s with | Local -> spc() ++ - str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++ - spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ - spc() ++ pr_class_rawexpr c2) - - | VernacInstance (abst,glob, sup, (instid, bk, cl), props, pri) -> - hov 1 ( - pr_non_locality (not glob) ++ - (if abst then str"Declare " else mt ()) ++ - str"Instance" ++ - (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () | - Anonymous -> mt ()) ++ - pr_and_type_binders_arg sup ++ - str":" ++ spc () ++ - pr_constr_expr cl ++ spc () ++ - (match props with - | Some p -> spc () ++ str":=" ++ spc () ++ pr_constr_expr p - | None -> mt())) - - | VernacContext l -> - hov 1 ( - str"Context" ++ spc () ++ pr_and_type_binders_arg l) - - - | VernacDeclareInstances (glob, ids) -> - hov 1 (pr_non_locality (not glob) ++ - str"Existing" ++ spc () ++ str(plural (List.length ids) "Instance") ++ - spc () ++ prlist_with_sep spc pr_reference ids) - - | VernacDeclareClass id -> - hov 1 (str"Existing" ++ spc () ++ str"Class" ++ spc () ++ pr_reference id) - - (* Modules and Module Types *) - | VernacDefineModule (export,m,bl,tys,bd) -> - let b = pr_module_binders_list bl pr_lconstr in - hov 2 (str"Module" ++ spc() ++ pr_require_token export ++ - pr_lident m ++ b ++ - pr_of_module_type pr_lconstr tys ++ - (if bd = [] then mt () else str ":= ") ++ - prlist_with_sep (fun () -> str " <+ ") - (pr_module_ast_inl pr_lconstr) bd) - | VernacDeclareModule (export,id,bl,m1) -> - let b = pr_module_binders_list bl pr_lconstr in - hov 2 (str"Declare Module" ++ spc() ++ pr_require_token export ++ - pr_lident id ++ b ++ - pr_module_ast_inl pr_lconstr m1) - | VernacDeclareModuleType (id,bl,tyl,m) -> - let b = pr_module_binders_list bl pr_lconstr in - let pr_mt = pr_module_ast_inl pr_lconstr in - hov 2 (str"Module Type " ++ pr_lident id ++ b ++ - prlist_strict (fun m -> str " <: " ++ pr_mt m) tyl ++ - (if m = [] then mt () else str ":= ") ++ - prlist_with_sep (fun () -> str " <+ ") pr_mt m) - | VernacInclude (mexprs) -> - let pr_m = pr_module_ast_inl pr_lconstr in - hov 2 (str"Include " ++ - prlist_with_sep (fun () -> str " <+ ") pr_m mexprs) - (* Solving *) - | VernacSolve (i,tac,deftac) -> - (if i = 1 then mt() else int i ++ str ": ") ++ - pr_raw_tactic tac - ++ (try if deftac then str ".." else mt () - with UserError _|Loc.Exc_located _ -> mt()) - - | VernacSolveExistential (i,c) -> - str"Existential " ++ int i ++ pr_lconstrarg c - - (* Auxiliary file and library management *) - | VernacRequireFrom (exp,spe,f) -> hov 2 - (str"Require" ++ spc() ++ pr_require_token exp ++ - (match spe with - | None -> mt() - | Some false -> str"Implementation" ++ spc() - | Some true -> str"Specification" ++ spc ()) ++ - qs f) - | VernacAddLoadPath (fl,s,d) -> hov 2 - (str"Add" ++ - (if fl then str" Rec " else spc()) ++ - str"LoadPath" ++ spc() ++ qs s ++ - (match d with - | None -> mt() - | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir)) - | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qs s - | VernacAddMLPath (fl,s) -> - str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qs s - | VernacDeclareMLModule (local, l) -> - pr_locality local ++ - hov 2 (str"Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l) - | VernacChdir s -> str"Cd" ++ pr_opt qs s - - (* Commands *) - | VernacDeclareTacticDefinition (local,rc,l) -> - let pr_tac_body (id, redef, body) = - let idl, body = - match body with - | Tacexpr.TacFun (idl,b) -> idl,b - | _ -> [], body in - pr_ltac_ref id ++ - prlist (function None -> str " _" - | Some id -> spc () ++ pr_id id) idl - ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ - let idl = List.map Option.get (List.filter (fun x -> not (x=None)) idl)in - pr_raw_tactic_env - (idl @ List.map coerce_reference_to_id - (List.map (fun (x, _, _) -> x) (List.filter (fun (_, redef, _) -> not redef) l))) - (Global.env()) - body in - hov 1 - (pr_locality local ++ str "Ltac " ++ - prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l) - | VernacCreateHintDb (local,dbname,b) -> - hov 1 (pr_locality local ++ str "Create HintDb " ++ - str dbname ++ (if b then str" discriminated" else mt ())) - | VernacRemoveHints (local, dbnames, ids) -> - hov 1 (pr_locality local ++ str "Remove Hints " ++ - prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ - pr_opt_hintbases dbnames) - | VernacHints (local,dbnames,h) -> - pr_hints local dbnames h pr_constr pr_constr_pattern_expr - | VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) -> - hov 2 - (pr_locality local ++ str"Notation " ++ pr_lident id ++ spc () ++ - prlist (fun x -> spc() ++ pr_id x) ids ++ str":=" ++ pr_constrarg c ++ - pr_syntax_modifiers - (match onlyparsing with None -> [] | Some v -> [SetOnlyParsing v])) - | VernacDeclareImplicits (local,q,[]) -> - hov 2 (pr_section_locality local ++ str"Implicit Arguments" ++ spc() ++ - pr_smart_global q) - | VernacDeclareImplicits (local,q,impls) -> - hov 1 (pr_section_locality local ++ str"Implicit Arguments " ++ - spc() ++ pr_smart_global q ++ spc() ++ - prlist_with_sep spc (fun imps -> - str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]") - impls) - | VernacArguments (local, q, impl, nargs, mods) -> - hov 2 (pr_section_locality local ++ str"Arguments" ++ spc() ++ - pr_smart_global q ++ - let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in - let pr_if b x = if b then x else str "" in - let pr_br imp max x = match imp, max with - | true, false -> str "[" ++ x ++ str "]" - | true, true -> str "{" ++ x ++ str "}" - | _ -> x in - let rec aux n l = - match n, l with - | 0, l -> spc () ++ str"/" ++ aux ~-1 l - | _, [] -> mt() - | n, (id,k,s,imp,max) :: tl -> - spc() ++ pr_br imp max (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++ - aux (n-1) tl in - prlist_with_sep (fun () -> str", ") (aux nargs) impl ++ - if mods <> [] then str" : " else str"" ++ - prlist_with_sep (fun () -> str", " ++ spc()) (function - | `SimplDontExposeCase -> str "simpl nomatch" - | `SimplNeverUnfold -> str "simpl never" - | `DefaultImplicits -> str "default implicits" - | `Rename -> str "rename" - | `ExtraScopes -> str "extra scopes" - | `ClearImplicits -> str "clear implicits" - | `ClearScopes -> str "clear scopes") - mods) - | VernacReserve bl -> - let n = List.length (List.flatten (List.map fst bl)) in - hov 2 (str"Implicit Type" ++ - str (if n > 1 then "s " else " ") ++ - pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl)) - | VernacGeneralizable (local, g) -> - hov 1 (pr_locality local ++ str"Generalizable Variable" ++ - match g with - | None -> str "s none" - | Some [] -> str "s all" - | Some idl -> - str (if List.length idl > 1 then "s " else " ") ++ - prlist_with_sep spc pr_lident idl) - | VernacSetOpacity(b,[k,l]) when k=Conv_oracle.transparent -> - hov 1 (str"Transparent" ++ pr_non_locality b ++ - spc() ++ prlist_with_sep sep pr_smart_global l) - | VernacSetOpacity(b,[Conv_oracle.Opaque,l]) -> - hov 1 (str"Opaque" ++ pr_non_locality b ++ - spc() ++ prlist_with_sep sep pr_smart_global l) - | VernacSetOpacity (local,l) -> - let pr_lev = function - Conv_oracle.Opaque -> str"opaque" - | Conv_oracle.Expand -> str"expand" - | l when l = Conv_oracle.transparent -> str"transparent" - | Conv_oracle.Level n -> int n in - let pr_line (l,q) = - hov 2 (pr_lev l ++ spc() ++ - str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]") in - hov 1 (pr_non_locality local ++ str"Strategy" ++ spc() ++ - hv 0 (prlist_with_sep sep pr_line l)) - | VernacUnsetOption (l,na) -> - hov 1 (pr_locality_full l ++ str"Unset" ++ spc() ++ pr_printoption na None) - | VernacSetOption (l,na,v) -> - hov 2 (pr_locality_full l ++ str"Set" ++ spc() ++ pr_set_option na v) - | VernacAddOption (na,l) -> hov 2 (str"Add" ++ spc() ++ pr_printoption na (Some l)) - | VernacRemoveOption (na,l) -> hov 2 (str"Remove" ++ spc() ++ pr_printoption na (Some l)) - | VernacMemOption (na,l) -> hov 2 (str"Test" ++ spc() ++ pr_printoption na (Some l)) - | VernacPrintOption na -> hov 2 (str"Test" ++ spc() ++ pr_printoption na None) - | VernacCheckMayEval (r,io,c) -> - let pr_mayeval r c = match r with - | Some r0 -> - hov 2 (str"Eval" ++ spc() ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++ - spc() ++ str"in" ++ spc () ++ pr_lconstr c) - | None -> hov 2 (str"Check" ++ spc() ++ pr_lconstr c) - in - (if io = None then mt() else int (Option.get io) ++ str ": ") ++ - pr_mayeval r c - | VernacGlobalCheck c -> hov 2 (str"Type" ++ pr_constrarg c) - | VernacDeclareReduction (b,s,r) -> - pr_locality b ++ str "Declare Reduction " ++ str s ++ str " := " ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r - | VernacPrint p -> - let pr_printable = function - | PrintFullContext -> str"Print All" - | PrintSectionContext s -> - str"Print Section" ++ spc() ++ Libnames.pr_reference s - | PrintGrammar ent -> - str"Print Grammar" ++ spc() ++ str ent - | PrintLoadPath dir -> str"Print LoadPath" ++ pr_opt pr_dirpath dir - | PrintModules -> str"Print Modules" - | PrintMLLoadPath -> str"Print ML Path" - | PrintMLModules -> str"Print ML Modules" - | PrintGraph -> str"Print Graph" - | PrintClasses -> str"Print Classes" - | PrintTypeClasses -> str"Print TypeClasses" - | PrintInstances qid -> str"Print Instances" ++ spc () ++ pr_smart_global qid - | PrintLtac qid -> str"Print Ltac" ++ spc() ++ pr_ltac_ref qid - | PrintCoercions -> str"Print Coercions" - | PrintCoercionPaths (s,t) -> str"Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t - | PrintCanonicalConversions -> str"Print Canonical Structures" - | PrintTables -> str"Print Tables" - | PrintHintGoal -> str"Print Hint" - | PrintHint qid -> str"Print Hint" ++ spc() ++ pr_smart_global qid - | PrintHintDb -> str"Print Hint *" - | PrintHintDbName s -> str"Print HintDb" ++ spc() ++ str s - | PrintRewriteHintDbName s -> str"Print Rewrite HintDb" ++ spc() ++ str s - | PrintUniverses (b, fopt) -> Printf.ksprintf str "Print %sUniverses" (if b then "Sorted " else "") ++ pr_opt str fopt - | PrintName qid -> str"Print" ++ spc() ++ pr_smart_global qid - | PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid - | PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid - | PrintInspect n -> str"Inspect" ++ spc() ++ int n - | PrintScopes -> str"Print Scopes" - | PrintScope s -> str"Print Scope" ++ spc() ++ str s - | PrintVisibility s -> str"Print Visibility" ++ pr_opt str s - | PrintAbout qid -> str"About" ++ spc() ++ pr_smart_global qid - | PrintImplicit qid -> str"Print Implicit" ++ spc() ++ pr_smart_global qid -(* spiwack: command printing all the axioms and section variables used in a - term *) - | PrintAssumptions (b,qid) -> (if b then str"Print Assumptions" else str"Print Opaque Dependencies") - ++ spc() ++ pr_smart_global qid - in pr_printable p - | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_constr_pattern_expr - | VernacLocate loc -> - let pr_locate =function - | LocateTerm qid -> pr_smart_global qid - | LocateFile f -> str"File" ++ spc() ++ qs f - | LocateLibrary qid -> str"Library" ++ spc () ++ pr_module qid - | LocateModule qid -> str"Module" ++ spc () ++ pr_module qid - | LocateTactic qid -> str"Ltac" ++ spc () ++ pr_ltac_ref qid - in str"Locate" ++ spc() ++ pr_locate loc - | VernacComments l -> - hov 2 - (str"Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l) - | VernacNop -> mt() - - (* Toplevel control *) - | VernacToplevelControl exn -> pr_topcmd exn - - (* For extension *) - | VernacExtend (s,c) -> pr_extend s c - | VernacProof (None, None) -> str "Proof" - | VernacProof (None, Some l) -> str "Proof using" ++spc()++ prlist pr_lident l - | VernacProof (Some te, None) -> str "Proof with" ++ spc() ++ pr_raw_tactic te - | VernacProof (Some te, Some l) -> - str "Proof using" ++spc()++ prlist pr_lident l ++ spc() ++ - str "with" ++ spc() ++pr_raw_tactic te - | VernacProofMode s -> str ("Proof Mode "^s) - | VernacBullet b -> begin match b with - | Dash -> str"-" - | Star -> str"*" - | Plus -> str"+" - end ++ spc() - | VernacSubproof None -> str "{" - | VernacSubproof (Some i) -> str "BeginSubproof " ++ pr_int i - | VernacEndSubproof -> str "}" - -and pr_extend s cl = - let pr_arg a = - try pr_gen (Global.env()) a - with Failure _ -> str ("") in - try - let rls = List.assoc s (Egrammar.get_extend_vernac_grammars()) in - let rl = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in - let start,rl,cl = - match rl with - | Egrammar.GramTerminal s :: rl -> str s, rl, cl - | Egrammar.GramNonTerminal _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl - | [] -> anomaly "Empty entry" in - let (pp,_) = - List.fold_left - (fun (strm,args) pi -> - let pp,args = match pi with - | Egrammar.GramNonTerminal _ -> (pr_arg (List.hd args), List.tl args) - | Egrammar.GramTerminal s -> (str s, args) in - (strm ++ spc() ++ pp), args) - (start,cl) rl in - hov 1 pp - with Not_found -> - hov 1 (str ("TODO("^s) ++ prlist_with_sep sep pr_arg cl ++ str ")") - -in pr_vernac - -let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end v diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli deleted file mode 100644 index 87b4fe56..00000000 --- a/parsing/ppvernac.mli +++ /dev/null @@ -1,24 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml deleted file mode 100644 index 3b3fb2c3..00000000 --- a/parsing/prettyp.ml +++ /dev/null @@ -1,794 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - * on May-June 2006 for implementation of abstraction of pretty-printing of objects. - *) - -open Pp -open Util -open Names -open Nameops -open Term -open Termops -open Declarations -open Inductive -open Inductiveops -open Sign -open Reduction -open Environ -open Declare -open Impargs -open Libobject -open Printer -open Printmod -open Libnames -open Nametab -open Recordops - -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 : identifier * constr option * types -> 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 -> Term.constr * Term.types -> Pp.std_ppcmds; - print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Topconstr.constr_expr -> unsafe_judgment -> std_ppcmds; -} - -let gallina_print_module = print_module -let gallina_print_modtype = print_modtype - -(**************) -(** Utilities *) - -let print_closed_sections = ref false - -let pr_infos_list l = v 0 (prlist_with_sep cut (fun x -> x) l) ++ fnl() - -let with_line_skip l = if l = [] then mt() else fnl() ++ pr_infos_list l - -let blankline = mt() (* add a blank sentence in the list of infos *) - -let add_colon prefix = if ismt prefix then mt () else prefix ++ str ": " - -let int_or_no n = if n=0 then str "no" else int n - -(*******************) -(** Basic printing *) - -let print_basename sp = pr_global (ConstRef sp) - -let print_ref reduce ref = - let typ = Global.type_of_global ref 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 - else typ in - hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ) - -(********************************) -(** Printing implicit arguments *) - -let conjugate_verb_to_be = function [_] -> "is" | _ -> "are" - -let pr_impl_name imp = pr_id (name_of_implicit imp) - -let print_impargs_by_name max = function - | [] -> [] - | impls -> - [hov 0 (str (plural (List.length impls) "Argument") ++ spc() ++ - prlist_with_sep pr_comma pr_impl_name impls ++ spc() ++ - str (conjugate_verb_to_be impls) ++ str" implicit" ++ - (if max then strbrk " and maximally inserted" else mt()))] - -let print_one_impargs_list l = - let imps = List.filter is_status_implicit l in - let maximps = List.filter Impargs.maximal_insertion_of imps in - let nonmaximps = list_subtract imps maximps in - print_impargs_by_name false nonmaximps @ - print_impargs_by_name true maximps - -let print_impargs_list prefix l = - let l = extract_impargs_data l in - List.flatten (List.map (fun (cond,imps) -> - match cond with - | None -> - List.map (fun pp -> add_colon prefix ++ pp) - (print_one_impargs_list imps) - | Some (n1,n2) -> - [v 2 (prlist_with_sep cut (fun x -> x) - [(if ismt prefix then str "When" else prefix ++ str ", when") ++ - str " applied to " ++ - (if n1 = n2 then int_or_no n2 else - if n1 = 0 then str "less than " ++ int n2 - else int n1 ++ str " to " ++ int_or_no n2) ++ - str (plural n2 " argument") ++ str ":"; - v 0 (prlist_with_sep cut (fun x -> x) - (if List.exists is_status_implicit imps - then print_one_impargs_list imps - else [str "No implicit arguments"]))])]) l) - -let print_renames_list prefix l = - if 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))] - -let need_expansion impl ref = - let typ = Global.type_of_global ref in - let ctx = (prod_assum typ) in - let nprods = List.length (List.filter (fun (_,b,_) -> b=None) ctx) in - impl <> [] & List.length impl >= nprods & - let _,lastimpl = list_chop nprods impl in - List.filter is_status_implicit lastimpl <> [] - -let print_impargs ref = - let ref = Smartlocate.smart_global ref in - let impl = implicits_of_global ref in - let has_impl = 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; - blankline ] @ - (if has_impl then print_impargs_list (mt()) impl - else [str "No implicit arguments"])) - -(*********************) -(** Printing Scopes *) - -let print_argument_scopes prefix = function - | [Some sc] -> - [add_colon prefix ++ str"Argument scope is [" ++ str sc ++ str"]"] - | l when not (List.for_all ((=) None) l) -> - [add_colon prefix ++ hov 2 (str"Argument scopes are" ++ spc() ++ - str "[" ++ - prlist_with_sep spc (function Some sc -> str sc | None -> str "_") l ++ - str "]")] - | _ -> [] - -(*****************************) -(** Printing simpl behaviour *) - -let print_simpl_behaviour ref = - match Tacred.get_simpl_behaviour ref with - | None -> [] - | Some (recargs, nargs, flags) -> - let never = List.mem `SimplNeverUnfold flags in - let nomatch = List.mem `SimplDontExposeCase flags in - let pp_nomatch = spc() ++ if nomatch then - str "avoiding to expose match constructs" else str"" in - let pp_recargs = spc() ++ str "when the " ++ - let rec aux = function - | [] -> mt() - | [x] -> str (ordinal (x+1)) - | [x;y] -> str (ordinal (x+1)) ++ str " and " ++ str (ordinal (y+1)) - | x::tl -> str (ordinal (x+1)) ++ str ", " ++ aux tl in - aux recargs ++ str (plural (List.length recargs) " argument") ++ - str (plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++ - str " to a constructor" in - let pp_nargs = - spc() ++ str "when applied to " ++ int nargs ++ - str (plural nargs " argument") in - [hov 2 (str "The simpl tactic " ++ - match recargs, nargs, never with - | _,_, true -> str "never unfolds " ++ pr_global ref - | [], 0, _ -> str "always unfolds " ++ pr_global ref - | _::_, n, _ when n < 0 -> - str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch - | _::_, n, _ when n > List.fold_left max 0 recargs -> - str "unfolds " ++ pr_global ref ++ pp_recargs ++ - str " and" ++ pp_nargs ++ pp_nomatch - | _::_, _, _ -> - str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch - | [], n, _ when n > 0 -> - str "unfolds " ++ pr_global ref ++ pp_nargs ++ pp_nomatch - | _ -> str "unfolds " ++ pr_global ref ++ pp_nomatch )] -;; - -(*********************) -(** Printing Opacity *) - -type opacity = - | FullyOpaque - | TransparentMaybeOpacified of Conv_oracle.level - -let opacity env = function - | VarRef v when pi2 (Environ.lookup_named v env) <> None -> - Some(TransparentMaybeOpacified (Conv_oracle.get_strategy(VarKey v))) - | ConstRef cst -> - let cb = Environ.lookup_constant cst env in - (match cb.const_body with - | Undef _ -> None - | OpaqueDef _ -> Some FullyOpaque - | Def _ -> Some - (TransparentMaybeOpacified (Conv_oracle.get_strategy(ConstKey cst)))) - | _ -> None - -let print_opacity ref = - match opacity (Global.env()) ref with - | None -> [] - | Some s -> - [pr_global ref ++ str " is " ++ - str (match s with - | FullyOpaque -> "opaque" - | TransparentMaybeOpacified Conv_oracle.Opaque -> - "basically transparent but considered opaque for reduction" - | TransparentMaybeOpacified lev when lev = Conv_oracle.transparent -> - "transparent" - | TransparentMaybeOpacified (Conv_oracle.Level n) -> - "transparent (with expansion weight "^string_of_int n^")" - | TransparentMaybeOpacified Conv_oracle.Expand -> - "transparent (with minimal expansion weight)")] - -(*******************) -(* *) - -let print_name_infos ref = - let impls = implicits_of_global ref in - let scopes = Notation.find_arguments_scope ref in - let renames = - try List.hd (Arguments_renaming.arguments_names ref) with Not_found -> [] in - let type_info_for_implicit = - 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] - else - [] in - type_info_for_implicit @ - print_renames_list (mt()) renames @ - print_impargs_list (mt()) impls @ - print_argument_scopes (mt()) scopes - -let print_id_args_data test pr id l = - if List.exists test l then - pr (str "For " ++ pr_id id) l - else - [] - -let print_args_data_of_inductive_ids get test pr sp mipv = - List.flatten (Array.to_list (Array.mapi - (fun i mip -> - print_id_args_data test pr mip.mind_typename (get (IndRef (sp,i))) @ - List.flatten (Array.to_list (Array.mapi - (fun j idc -> - print_id_args_data test pr idc (get (ConstructRef ((sp,i),j+1)))) - mip.mind_consnames))) - mipv)) - -let print_inductive_implicit_args = - print_args_data_of_inductive_ids - implicits_of_global (fun l -> positions_of_implicits l <> []) - print_impargs_list - -let print_inductive_renames = - print_args_data_of_inductive_ids - (fun r -> - try List.hd (Arguments_renaming.arguments_names r) - with e when Errors.noncritical e -> []) - ((<>) Anonymous) - print_renames_list - -let print_inductive_argument_scopes = - print_args_data_of_inductive_ids - Notation.find_arguments_scope ((<>) None) print_argument_scopes - -(*********************) -(* "Locate" commands *) - -type logical_name = - | Term of global_reference - | Dir of global_dir_reference - | Syntactic of kernel_name - | ModuleType of qualid * module_path - | Undefined of qualid - -let locate_any_name ref = - let module N = Nametab in - let (loc,qid) = qualid_of_reference ref in - try Term (N.locate qid) - with Not_found -> - try Syntactic (N.locate_syndef qid) - with Not_found -> - try Dir (N.locate_dir qid) - with Not_found -> - try ModuleType (qid, N.locate_modtype qid) - with Not_found -> Undefined qid - -let pr_located_qualid = function - | Term ref -> - let ref_str = match ref with - ConstRef _ -> "Constant" - | IndRef _ -> "Inductive" - | ConstructRef _ -> "Constructor" - | VarRef _ -> "Variable" in - str ref_str ++ spc () ++ pr_path (Nametab.path_of_global ref) - | Syntactic kn -> - 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 - | DirClosedSection dir -> "Closed Section", dir - in - str s ++ spc () ++ pr_dirpath dir - | ModuleType (qid,_) -> - str "Module Type" ++ spc () ++ pr_path (Nametab.full_name_modtype qid) - | Undefined qid -> - pr_qualid qid ++ spc () ++ str "not a defined object." - -let print_located_qualid ref = - let (loc,qid) = qualid_of_reference ref in - let module N = Nametab in - let expand = function - | TrueGlobal ref -> - Term ref, N.shortest_qualid_of_global Idset.empty ref - | SynDef kn -> - Syntactic kn, N.shortest_qualid_of_syndef Idset.empty kn in - match List.map expand (N.locate_extended_all qid) with - | [] -> - let (dir,id) = repr_qualid qid in - if dir = empty_dirpath then - str "No object of basename " ++ pr_id id - else - str "No object of suffix " ++ pr_qualid qid - | l -> - prlist_with_sep fnl - (fun (o,oqid) -> - hov 2 (pr_located_qualid o ++ - (if oqid <> qid then - spc() ++ str "(shorter name to refer to it in current context is " ++ pr_qualid oqid ++ str")" - else - mt ()))) l - -(******************************************) -(**** Printing declarations and judgments *) -(**** Gallina layer *****) - -let gallina_print_typed_value_in_env env (trm,typ) = - (pr_lconstr_env env trm ++ fnl () ++ - str " : " ++ pr_ltype_env env typ ++ fnl ()) - -(* 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 - (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 gallina_print_named_decl (id,c,typ) = - let s = string_of_id id in - match c with - | Some body -> print_named_def s body typ - | None -> print_named_assum s typ - -let assumptions_for_print lna = - List.fold_right (fun na env -> add_name na env) lna empty_names_context - -(*********************) -(* *) - -let gallina_print_inductive sp = - 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 ++ fnl () ++ - with_line_skip - (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 gallina_print_section_variable id = - print_named_decl id ++ - with_line_skip (print_name_infos (VarRef id)) - -let print_body = function - | Some lc -> pr_lconstr (Declarations.force lc) - | None -> (str"") - -let print_typed_body (val_0,typ) = - (print_body val_0 ++ fnl () ++ str " : " ++ pr_ltype typ) - -let ungeneralized_type_of_constant_type = function - | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level) - | NonPolymorphicType t -> t - -let print_constant with_values sep sp = - let cb = Global.lookup_constant sp in - let val_0 = body_of_constant cb in - let typ = ungeneralized_type_of_constant_type cb.const_type in - hov 0 ( - match val_0 with - | None -> - str"*** [ " ++ - print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ - str" ]" - | _ -> - print_basename sp ++ str sep ++ cut () ++ - (if with_values then print_typed_body (val_0,typ) else pr_ltype typ)) - ++ fnl () - -let gallina_print_constant_with_infos sp = - print_constant true " = " sp ++ - with_line_skip (print_name_infos (ConstRef sp)) - -let gallina_print_syntactic_def kn = - let qid = Nametab.shortest_qualid_of_syndef Idset.empty kn - and (vars,a) = Syntax_def.search_syntactic_definition kn in - let c = Topconstr.glob_constr_of_aconstr dummy_loc a in - hov 2 - (hov 4 - (str "Notation " ++ pr_qualid qid ++ - prlist (fun id -> spc () ++ pr_id id) (List.map fst vars) ++ - spc () ++ str ":=") ++ - spc () ++ Constrextern.without_symbols pr_glob_constr c) ++ fnl () - -let gallina_print_leaf_entry 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) - | (_,"CONSTANT") -> - Some (print_constant with_values sep (constant_of_kn kn)) - | (_,"INDUCTIVE") -> - Some (gallina_print_inductive (mind_of_kn kn)) - | (_,"MODULE") -> - let (mp,_,l) = repr_kn kn in - Some (print_module with_values (MPdot (mp,l))) - | (_,"MODULE TYPE") -> - let (mp,_,l) = repr_kn 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 - match ent with - | (oname,Lib.Leaf lobj) -> - gallina_print_leaf_entry 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) - | (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 rec prec n = function - | h::rest when n = None or Option.get n > 0 -> - (match gallina_print_library_entry with_values h with - | None -> prec n rest - | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) - | _ -> mt () - in - prec - -let gallina_print_eval red_fun env evmap _ {uj_val=trm;uj_type=typ} = - let ntrm = red_fun env evmap trm in - (str " = " ++ gallina_print_typed_value_in_env env (ntrm,typ)) - -(******************************************) -(**** Printing abstraction layer *) - -let default_object_pr = { - print_inductive = gallina_print_inductive; - print_constant_with_infos = gallina_print_constant_with_infos; - print_section_variable = gallina_print_section_variable; - print_syntactic_def = gallina_print_syntactic_def; - print_module = gallina_print_module; - print_modtype = gallina_print_modtype; - print_named_decl = gallina_print_named_decl; - print_library_entry = gallina_print_library_entry; - print_context = gallina_print_context; - print_typed_value_in_env = gallina_print_typed_value_in_env; - print_eval = gallina_print_eval; -} - -let object_pr = ref default_object_pr -let set_object_pr = (:=) object_pr - -let print_inductive x = !object_pr.print_inductive x -let print_constant_with_infos c = !object_pr.print_constant_with_infos c -let print_section_variable c = !object_pr.print_section_variable c -let print_syntactic_def x = !object_pr.print_syntactic_def x -let print_module x = !object_pr.print_module x -let print_modtype x = !object_pr.print_modtype x -let print_named_decl x = !object_pr.print_named_decl x -let print_library_entry x = !object_pr.print_library_entry x -let print_context x = !object_pr.print_context x -let print_typed_value_in_env x = !object_pr.print_typed_value_in_env x -let print_eval x = !object_pr.print_eval x - -(******************************************) -(**** Printing declarations and judgments *) -(**** Abstract layer *****) - -let print_typed_value x = print_typed_value_in_env (Global.env ()) x - -let print_judgment env {uj_val=trm;uj_type=typ} = - print_typed_value_in_env env (trm, typ) - -let print_safe_judgment env j = - let trm = Safe_typing.j_val j in - let typ = Safe_typing.j_type j in - print_typed_value_in_env env (trm, typ) - -(*********************) -(* *) - -let print_full_context () = - print_context true None (Lib.contents_after None) - -let print_full_context_typ () = - print_context false None (Lib.contents_after None) - -let print_full_pure_context () = - 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 - hov 0 ( - match cb.const_body with - | Undef _ -> - str "Parameter " ++ - print_basename con ++ str " : " ++ cut () ++ pr_ltype typ - | OpaqueDef lc -> - str "Theorem " ++ print_basename con ++ cut () ++ - str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++ - str "Proof " ++ pr_lconstr (Declarations.force_opaque lc) - | Def c -> - str "Definition " ++ print_basename con ++ cut () ++ - str " : " ++ pr_ltype typ ++ cut () ++ str " := " ++ - pr_lconstr (Declarations.force 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 ++ - str "." ++ fnl () ++ fnl () - | "MODULE" -> - (* TODO: make it reparsable *) - let (mp,_,l) = repr_kn 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 - print_modtype (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () - | _ -> mt () in - prec rest ++ pp - | _::rest -> prec rest - | _ -> mt () in - prec (Lib.contents_after None) - -(* For printing an inductive definition with - its constructors and elimination, - assume that the declaration of constructors and eliminations - follows the definition of the inductive type *) - -(* 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 dir = - try Nametab.locate_section qid - with Not_found -> - user_err_loc (loc,"read_sec_context", str "Unknown section.") in - let rec get_cxt in_cxt = function - | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> - if dir = dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest - | (_,Lib.ClosedSection _)::rest -> - error "Cannot print the contents of a closed section." - (* LEM: Actually, we could if we wanted to. *) - | [] -> [] - | hd::rest -> get_cxt (hd::in_cxt) rest - in - let cxt = (Lib.contents_after None) 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 - | Dir _ -> mt () - | ModuleType (_,kn) -> print_modtype kn - | Undefined qid -> - try (* Var locale de but, pas var de section... donc pas d'implicits *) - let dir,str = repr_qualid qid in - if (repr_dirpath dir) <> [] then raise Not_found; - let (_,c,typ) = Global.lookup_named str in - (print_named_decl (str,c,typ)) - with Not_found -> - errorlabstrm - "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") - -let print_name = function - | Genarg.ByNotation (loc,ntn,sc) -> - print_any_name - (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) - ntn sc)) - | Genarg.AN ref -> - print_any_name (locate_any_name ref) - -let print_opaque_name qid = - let env = Global.env () in - match global qid with - | ConstRef cst -> - let cb = Global.lookup_constant cst in - if constant_has_body cb then - print_constant_with_infos cst - else - error "Not a defined constant." - | IndRef (sp,_) -> - print_inductive sp - | ConstructRef cstr -> - let ty = Inductiveops.type_of_constructor env cstr in - print_typed_value (mkConstruct cstr, ty) - | VarRef id -> - let (_,c,ty) = lookup_named id env in - print_named_decl (id,c,ty) - -let print_about_any loc k = - match k with - | Term ref -> - Dumpglob.add_glob loc ref; - pr_infos_list - (print_ref false ref :: blankline :: - print_name_infos ref @ - print_simpl_behaviour ref @ - print_opacity ref @ - [hov 0 (str "Expands to: " ++ pr_located_qualid k)]) - | Syntactic kn -> - let () = match Syntax_def.search_syntactic_definition kn with - | [],Topconstr.ARef ref -> Dumpglob.add_glob loc ref - | _ -> () in - v 0 ( - print_syntactic_def kn ++ - hov 0 (str "Expands to: " ++ pr_located_qualid k)) ++ fnl() - | Dir _ | ModuleType _ | Undefined _ -> - hov 0 (pr_located_qualid k) ++ fnl() - -let print_about = function - | Genarg.ByNotation (loc,ntn,sc) -> - print_about_any loc - (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) - ntn sc)) - | Genarg.AN ref -> - print_about_any (loc_of_reference ref) (locate_any_name ref) - -(* for debug *) -let inspect depth = - print_context false (Some depth) (Lib.contents_after None) - - -(*************************************************************************) -(* Pretty-printing functions coming from classops.ml *) - -open Classops - -let print_coercion_value v = pr_lconstr (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) = - hov 2 ( - str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++ - str"] : ") ++ - print_class i ++ str" >-> " ++ print_class j - -let _ = Classops.install_path_printer print_path - -let print_graph () = - prlist_with_sep pr_fnl print_path (inheritance_graph()) - -let print_classes () = - prlist_with_sep pr_spc pr_class (classes()) - -let print_coercions () = - prlist_with_sep pr_spc print_coercion_value (coercions()) - -let index_of_class cl = - try - fst (class_info cl) - with e when Errors.noncritical e -> - errorlabstrm "index_of_class" - (pr_class cl ++ spc() ++ str "not a defined class.") - -let print_path_between 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 e when Errors.noncritical e -> - errorlabstrm "index_cl_of_id" - (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt - ++ str ".") - in - print_path ((i,j),p) - -let print_canonical_projections () = - prlist_with_sep pr_fnl - (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ - str " <- " ++ - pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )") - (canonical_projections ()) - -(*************************************************************************) - -(*************************************************************************) -(* Pretty-printing functions for type classes *) - -open Typeclasses - -let pr_typeclass env t = - print_ref false t.cl_impl ++ fnl () - -let print_typeclasses () = - let env = Global.env () in - prlist_with_sep fnl (pr_typeclass env) (typeclasses ()) - -let pr_instance env i = - (* gallina_print_constant_with_infos i.is_impl *) - (* lighter *) - print_ref false (instance_impl i) ++ fnl () - -let print_all_instances () = - let env = Global.env () in - let inst = all_instances () in - prlist_with_sep fnl (pr_instance env) inst - -let print_instances r = - let env = Global.env () in - let inst = instances r in - prlist_with_sep fnl (pr_instance env) inst - diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli deleted file mode 100644 index 4cf3e489..00000000 --- a/parsing/prettyp.mli +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 -> unsafe_judgment -> std_ppcmds -val print_safe_judgment : env -> Safe_typing.judgment -> std_ppcmds -val print_eval : - reduction_function -> env -> Evd.evar_map -> Topconstr.constr_expr -> unsafe_judgment -> std_ppcmds - -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 - -(** 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 - -(** 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 inspect : int -> std_ppcmds - -(** Locate *) -val print_located_qualid : reference -> std_ppcmds - -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 : identifier * constr option * types -> 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 -> Term.constr * Term.types -> Pp.std_ppcmds; - print_eval : reduction_function -> env -> Evd.evar_map -> Topconstr.constr_expr -> unsafe_judgment -> std_ppcmds -} - -val set_object_pr : object_pr -> unit -val default_object_pr : object_pr diff --git a/parsing/printer.ml b/parsing/printer.ml deleted file mode 100644 index 1b887e6e..00000000 --- a/parsing/printer.ml +++ /dev/null @@ -1,790 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (Name id,(* dummy *) mkProp)) ids in - pr (Termops.push_rels_assum assums env) 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 c = pr_constr_under_binders_env (Global.env()) c -let pr_lconstr_under_binders c = pr_lconstr_under_binders_env (Global.env()) c - -let pr_type_core goal_concl_style env t = - pr_constr_expr (extern_type goal_concl_style env t) -let pr_ltype_core goal_concl_style env t = - pr_lconstr_expr (extern_type goal_concl_style env 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 t = pr_ltype_env (Global.env()) t -let pr_type t = pr_type_env (Global.env()) t - -let pr_ljudge_env env j = - (pr_lconstr_env env j.uj_val, pr_lconstr_env env j.uj_type) - -let pr_ljudge j = pr_ljudge_env (Global.env()) j - -let pr_lglob_constr_env env c = - pr_lconstr_expr (extern_glob_constr (Termops.vars_of_env env) c) -let pr_glob_constr_env env c = - pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c) - -let pr_lglob_constr c = - pr_lconstr_expr (extern_glob_constr Idset.empty c) -let pr_glob_constr c = - pr_constr_expr (extern_glob_constr Idset.empty c) - -let pr_cases_pattern t = - pr_cases_pattern_expr (extern_cases_pattern Idset.empty t) - -let pr_lconstr_pattern_env env c = - pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) c) -let pr_constr_pattern_env env c = - pr_constr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) c) - -let pr_lconstr_pattern t = - pr_lconstr_pattern_expr (extern_constr_pattern Termops.empty_names_context t) -let pr_constr_pattern t = - pr_constr_pattern_expr (extern_constr_pattern Termops.empty_names_context t) - -let pr_sort s = pr_glob_sort (extern_sort s) - -let _ = Termops.set_print_constr pr_lconstr_env - - -(** Term printers resilient to [Nametab] errors *) - -(** When the nametab isn't up-to-date, the term printers above - could raise [Not_found] during [Nametab.shortest_qualid_of_global]. - In this case, we build here a fully-qualified name based upon - the kernel modpath and label of constants, and the idents in - the [mutual_inductive_body] for the inductives and constructors - (needs an environment for this). *) - -let id_of_global env = function - | ConstRef kn -> id_of_label (con_label kn) - | IndRef (kn,0) -> id_of_label (mind_label kn) - | IndRef (kn,i) -> - (Environ.lookup_mind kn env).mind_packets.(i).mind_typename - | ConstructRef ((kn,i),j) -> - (Environ.lookup_mind kn env).mind_packets.(i).mind_consnames.(j-1) - | VarRef v -> v - -let cons_dirpath id dp = make_dirpath (id :: repr_dirpath dp) - -let rec dirpath_of_mp = function - | MPfile sl -> sl - | MPbound uid -> make_dirpath [id_of_mbid uid] - | MPdot (mp,l) -> cons_dirpath (id_of_label l) (dirpath_of_mp mp) - -let dirpath_of_global = function - | ConstRef kn -> dirpath_of_mp (con_modpath kn) - | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - dirpath_of_mp (mind_modpath kn) - | VarRef _ -> empty_dirpath - -let qualid_of_global env r = - Libnames.make_qualid (dirpath_of_global r) (id_of_global env r) - -let safe_gen f env c = - let orig_extern_ref = Constrextern.get_extern_reference () in - let extern_ref loc vars r = - try orig_extern_ref loc vars r - with e when Errors.noncritical e -> - Libnames.Qualid (loc, qualid_of_global env r) - in - Constrextern.set_extern_reference extern_ref; - try - let p = f env c in - Constrextern.set_extern_reference orig_extern_ref; - p - with e when Errors.noncritical e -> - Constrextern.set_extern_reference orig_extern_ref; - str "??" - -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 = safe_pr_lconstr_env (Global.env()) t -let safe_pr_constr t = safe_pr_constr_env (Global.env()) t - - -(**********************************************************************) -(* Global references *) - -let pr_global_env = pr_global_env -let pr_global = pr_global_env Idset.empty - -let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) -let pr_existential env ev = pr_lconstr_env env (mkEvar ev) -let pr_inductive env ind = pr_lconstr_env env (mkInd ind) -let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr) - -let pr_evaluable_reference ref = - pr_global (Tacred.global_of_evaluable_reference ref) - -(*let pr_glob_constr t = - pr_lconstr (Constrextern.extern_glob_constr Idset.empty t)*) - -(*open Pattern - -let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t*) - -(**********************************************************************) -(* Contexts and declarations *) - -let pr_var_decl env (id,c,typ) = - let pbody = match c with - | None -> (mt ()) - | Some c -> - (* Force evaluation *) - let pb = pr_lconstr_core true env c in - let pb = if isCast c then surround pb else pb in - (str" := " ++ pb ++ cut () ) in - let pt = pr_ltype_core true env typ in - let ptyp = (str" : " ++ pt) in - (pr_id id ++ hov 0 (pbody ++ ptyp)) - -let pr_rel_decl env (na,c,typ) = - let pbody = match c with - | None -> mt () - | Some c -> - (* Force evaluation *) - let pb = pr_lconstr_core true env c in - let pb = if isCast c then surround pb else pb in - (str":=" ++ spc () ++ pb ++ spc ()) in - let ptyp = pr_ltype_core true env typ in - match na with - | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) - | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) - - -(* Prints out an "env" in a nice format. We print out the - * signature,then a horizontal bar, then the debruijn environment. - * It's printed out from outermost to innermost, so it's readable. *) - -(* Prints a signature, all declarations on the same line if possible *) -let pr_named_context_of env = - let make_decl_list env d pps = pr_var_decl env 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_named_context env ne_context = - hv 0 (Sign.fold_named_context - (fun d pps -> pps ++ ws 2 ++ pr_var_decl env d) - ne_context ~init:(mt ())) - -let pr_rel_context env rel_context = - pr_binders (extern_rel_context None env rel_context) - -let pr_rel_context_of env = - pr_rel_context env (rel_context env) - -(* Prints an env (variables and de Bruijn). Separator: newline *) -let pr_context_unlimited env = - let sign_env = - fold_named_context - (fun env d pps -> - let pidt = pr_var_decl env d in (pps ++ fnl () ++ pidt)) - env ~init:(mt ()) - in - let db_env = - fold_rel_context - (fun env d pps -> - let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat)) - env ~init:(mt ()) - in - (sign_env ++ db_env) - -let pr_ne_context_of header env = - if Environ.rel_context env = empty_rel_context & - Environ.named_context env = empty_named_context then (mt ()) - else let penv = pr_context_unlimited env in (header ++ penv ++ fnl ()) - -let pr_context_limit n env = - let named_context = Environ.named_context env in - let lgsign = List.length named_context in - if n >= lgsign then - pr_context_unlimited env - else - let k = lgsign-n in - let _,sign_env = - fold_named_context - (fun env d (i,pps) -> - if i < k then - (i+1, (pps ++str ".")) - else - let pidt = pr_var_decl env d in - (i+1, (pps ++ fnl () ++ - str (emacs_str "") ++ - pidt))) - env ~init:(0,(mt ())) - in - let db_env = - fold_rel_context - (fun env d pps -> - let pnat = pr_rel_decl env d in - (pps ++ fnl () ++ - str (emacs_str "") ++ - pnat)) - env ~init:(mt ()) - in - (sign_env ++ db_env) - -let pr_context_of env = match Flags.print_hyps_limit () with - | None -> hv 0 (pr_context_unlimited env) - | Some n -> hv 0 (pr_context_limit n env) - -(* display goal parts (Proof mode) *) - -let pr_predicate pr_elt (b, elts) = - let pr_elts = prlist_with_sep spc pr_elt elts in - if b then - str"all" ++ - (if elts = [] then mt () else str" except: " ++ pr_elts) - else - if 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 (Idpred.elements p) - -let pr_transparent_state (ids, csts) = - hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++ - str"CONSTANTS: " ++ pr_cpred csts ++ fnl ()) - -(* display complete goal *) -let default_pr_goal gs = - let (g,sigma) = Goal.V82.nf_evar (project gs) (sig_it gs) in - let env = Goal.V82.unfiltered_env sigma g in - let preamb,thesis,penv,pc = - mt (), mt (), - pr_context_of env, - pr_goal_concl_style_env env (Goal.V82.concl sigma g) - in - preamb ++ - str" " ++ hv 0 (penv ++ fnl () ++ - str (emacs_str "") ++ - str "============================" ++ fnl () ++ - thesis ++ str " " ++ pc) ++ fnl () - -(* display a goal tag *) -let pr_goal_tag g = - let s = " (ID " ^ Goal.uid g ^ ")" in - str (emacs_str s) - -(* 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 (Goal.V82.concl sigma g) in - str (emacs_str "") ++ - str "subgoal " ++ int n ++ pr_goal_tag g ++ - str " is:" ++ cut () ++ str" " ++ pc - -(* display evar type: a context and a type *) -let pr_evgl_sign gl = - let ps = pr_named_context_of (evar_unfiltered_env gl) in - let _,l = list_filter2 (fun b c -> not b) (evar_filter gl,evar_context gl) in - let ids = List.rev (List.map pi1 l) in - let warn = - if ids = [] then mt () else - (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)") - in - let pc = pr_lconstr gl.evar_concl in - hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]" ++ spc () ++ warn) - -(* Print an existential variable *) - -let pr_evar (ev, evd) = - let pegl = pr_evgl_sign evd in - (hov 0 (str (string_of_existential ev) ++ str " : " ++ pegl)) - -(* Print an enumerated list of existential variables *) -let rec pr_evars_int i = function - | [] -> (mt ()) - | (ev,evd)::rest -> - let pegl = pr_evgl_sign evd in - let pei = pr_evars_int (i+1) rest in - (hov 0 (str "Existential " ++ int i ++ str " =" ++ spc () ++ - str (string_of_existential ev) ++ str " : " ++ pegl)) ++ - fnl () ++ pei - -let default_pr_subgoal n sigma = - let rec prrec p = function - | [] -> error "No such goal." - | g::rest -> - if p = 1 then - let pg = default_pr_goal { sigma=sigma ; it=g } in - v 0 (str "subgoal " ++ int n ++ pr_goal_tag g - ++ str " is:" ++ cut () ++ pg) - else - prrec (p-1) rest - in - prrec n - -let emacs_print_dependent_evars sigma seeds = - let evars () = - let evars = Evarutil.gather_dependent_evars sigma seeds in - let evars = - Intmap.fold begin fun e i s -> - let e' = str (string_of_existential e) in - match i with - | None -> s ++ str" " ++ e' ++ str " open," - | Some i -> - s ++ str " " ++ e' ++ str " using " ++ - Intset.fold begin fun d s -> - str (string_of_existential d) ++ str " " ++ s - end i (str ",") - end evars (str "") - in - cut () ++ - str "(dependent evars:" ++ evars ++ str ")" ++ fnl () - in - delayed_emacs_cmd 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 stack goals = - let rec print_stack a = function - | [] -> Pp.int a - | b::l -> Pp.int a ++ str"-" ++ print_stack b l - in - let print_unfocused a l = - str"unfocused: " ++ print_stack a l - in - let rec pr_rec n = function - | [] -> (mt ()) - | g::rest -> - let pc = pr_concl n sigma g in - let prest = pr_rec (n+1) rest in - (cut () ++ pc ++ prest) - in - let print_multiple_goals g l = - if pr_first then - default_pr_goal { it = g ; sigma = sigma } ++ - pr_rec 2 l - else - pr_rec 1 (g::l) - in - match goals,stack with - | [],_ -> - begin - match close_cmd with - Some cmd -> - (str "Subproof completed, now type " ++ str cmd ++ - str "." ++ fnl ()) - | None -> - let exl = Evarutil.non_instantiated sigma in - if exl = [] then - (str"No more subgoals." ++ fnl () - ++ emacs_print_dependent_evars sigma seeds) - else - let pei = pr_evars_int 1 exl in - (str "No more subgoals but non-instantiated existential " ++ - str "variables:" ++ fnl () ++ (hov 0 pei) - ++ emacs_print_dependent_evars sigma seeds ++ fnl () ++ - str "You can use Grab Existential Variables.") - end - | [g],[] when not !Flags.print_emacs -> - let pg = default_pr_goal { it = g ; sigma = sigma } in - v 0 ( - str "1 subgoal" ++ pr_goal_tag g ++ cut () ++ pg - ++ emacs_print_dependent_evars sigma seeds - ) - | [g],a::l when not !Flags.print_emacs -> - let pg = default_pr_goal { it = g ; sigma = sigma } in - v 0 ( - str "1 focused subgoal (" ++ print_unfocused a l ++ str")" ++ pr_goal_tag g ++ cut () ++ pg - ++ emacs_print_dependent_evars sigma seeds - ) - | g1::rest,[] -> - let goals = print_multiple_goals g1 rest in - v 0 ( - int(List.length rest+1) ++ str" subgoals" ++ - str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut () - ++ goals ++ fnl () - ++ emacs_print_dependent_evars sigma seeds - ) - | g1::rest,a::l -> - let goals = print_multiple_goals g1 rest in - v 0 ( - int(List.length rest+1) ++ str" focused subgoals (" ++ - print_unfocused a l ++ str")" ++ cut () ++ - str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut () - ++ goals - ++ emacs_print_dependent_evars sigma seeds - ) - -(**********************************************************************) -(* Abstraction layer *) - - -type printer_pr = { - pr_subgoals : ?pr_first:bool -> string option -> evar_map -> evar list -> int list -> goal list -> std_ppcmds; - pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; - pr_goal : goal sigma -> std_ppcmds; -} - -let default_printer_pr = { - pr_subgoals = default_pr_subgoals; - pr_subgoal = default_pr_subgoal; - pr_goal = default_pr_goal; -} - -let printer_pr = ref default_printer_pr - -let set_printer_pr = (:=) printer_pr - -let pr_subgoals ?pr_first x = !printer_pr.pr_subgoals ?pr_first x -let pr_subgoal x = !printer_pr.pr_subgoal x -let pr_goal x = !printer_pr.pr_goal x - -(* End abstraction layer *) -(**********************************************************************) - -let pr_open_subgoals () = - (* 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 - [evar_info]-s instead. *) - let p = Proof_global.give_me_the_proof () in - let (goals , stack , sigma ) = Proof.proof p in - let stack = List.map (fun (l,r) -> List.length l + List.length r) stack in - let seeds = Proof.V82.top_evars p in - begin match goals with - | [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in - begin match bgoals with - | [] -> pr_subgoals None sigma seeds stack goals - | _ -> - (* emacs mode: xml-like flag for detecting information message *) - str (emacs_str "") ++ - str"This subproof is complete, but there are still unfocused goals." - ++ str (emacs_str "") - ++ fnl () ++ fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds [] bgoals - end - | _ -> pr_subgoals None sigma seeds stack goals - end - -let pr_nth_open_subgoal n = - let pf = get_pftreestate () in - let { it=gls ; sigma=sigma } = Proof.V82.subgoals pf in - pr_subgoal n sigma gls - -let pr_goal_by_id id = - let p = Proof_global.give_me_the_proof () in - let g = Goal.get_by_uid id in - let pr gs = - v 0 (str ("goal / evar " ^ id ^ " 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." - -(* Elementary tactics *) - -let pr_prim_rule = function - | Intro id -> - str"intro " ++ pr_id id - - | 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]") - - | FixRule (f,n,[],_) -> - (str"fix " ++ pr_id f ++ str"/" ++ int n) - - | FixRule (f,n,others,j) -> - if j<>0 then msg_warn "Unsupported printing of \"fix\""; - let rec print_mut = function - | (f,n,ar)::oth -> - pr_id f ++ str"/" ++ int n ++ str" : " ++ pr_lconstr ar ++ print_mut oth - | [] -> mt () in - (str"fix " ++ pr_id f ++ str"/" ++ int n ++ - str" with " ++ print_mut others) - - | Cofix (f,[],_) -> - (str"cofix " ++ pr_id f) - - | Cofix (f,others,j) -> - if j<>0 then msg_warn "Unsupported printing of \"fix\""; - let rec print_mut = function - | (f,ar)::oth -> - (pr_id f ++ str" : " ++ pr_lconstr ar ++ print_mut oth) - | [] -> mt () in - (str"cofix " ++ pr_id f ++ str" with " ++ print_mut others) - | Refine c -> - str(if Termops.occur_meta c then "refine " else "exact ") ++ - Constrextern.with_meta_as_hole pr_constr c - - | Convert_concl (c,_) -> - (str"change " ++ pr_constr c) - - | Convert_hyp (id,None,t) -> - (str"change " ++ pr_constr t ++ spc () ++ str"in " ++ pr_id id) - - | Convert_hyp (id,Some c,t) -> - (str"change " ++ pr_constr c ++ spc () ++ str"in " - ++ pr_id id ++ str" (type of " ++ pr_id id ++ str ")") - - | Thin ids -> - (str"clear " ++ prlist_with_sep pr_spc pr_id ids) - - | ThinBody ids -> - (str"clearbody " ++ prlist_with_sep pr_spc pr_id ids) - - | Move (withdep,id1,id2) -> - (str (if withdep then "dependent " else "") ++ - str"move " ++ pr_id id1 ++ pr_move_location pr_id id2) - - | Order ord -> - (str"order " ++ prlist_with_sep pr_spc pr_id ord) - - | Rename (id1,id2) -> - (str "rename " ++ pr_id id1 ++ str " into " ++ pr_id id2) - - | Change_evars -> - (* This is internal tactic and cannot be replayed at user-level. - Function pr_rule_dot below is used when we want to hide - Change_evars *) - str "Evar change" - - -(* Backwards compatibility *) - -let prterm = pr_lconstr - - -(* Printer function for sets of Assumptions.assumptions. - It is used primarily by the Print Assumptions command. *) - -open Assumptions - -let pr_assumptionset env s = - if ContextObjectMap.is_empty s then - str "Closed under the global context" ++ fnl() - else - 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 ^ "." ^ string_of_label lab) - in - let safe_pr_ltype typ = - try str " : " ++ pr_ltype typ with e when Errors.noncritical e -> mt () - in - let (vars,axioms,opaque) = - ContextObjectMap.fold (fun t typ r -> - let (v,a,o) = r in - match t with - | Variable id -> ( Some ( - Option.default (fnl ()) v - ++ str (string_of_id id) - ++ str " : " - ++ pr_ltype typ - ++ fnl () - ) - , - a, o) - | Axiom kn -> ( v , - Some ( - Option.default (fnl ()) a - ++ safe_pr_constant env kn - ++ safe_pr_ltype typ - ++ fnl () - ) - , o - ) - | Opaque kn -> ( v , a , - Some ( - Option.default (fnl ()) o - ++ safe_pr_constant env kn - ++ safe_pr_ltype typ - ++ fnl () - ) - ) - ) - s (None,None,None) - in - let (vars,axioms,opaque) = - ( Option.map (fun p -> str "Section Variables:" ++ p) vars , - Option.map (fun p -> str "Axioms:" ++ p) axioms , - Option.map (fun p -> str "Opaque constants:" ++ p) opaque - ) - in - (Option.default (mt ()) vars) ++ (Option.default (mt ()) axioms) - ++ (Option.default (mt ()) opaque) - -let cmap_to_list m = Cmap.fold (fun k v acc -> v :: acc) m [] - -open Typeclasses - -let pr_instance i = - pr_global (instance_impl i) - -let pr_instance_gmap insts = - prlist_with_sep fnl (fun (gr, insts) -> - prlist_with_sep fnl pr_instance (cmap_to_list insts)) - (Gmap.to_list insts) - -(** Inductive declarations *) - -open Termops -open Reduction -open Inductive -open Inductiveops - -let print_params env params = - if params = [] then mt () else pr_rel_context env params ++ brk(1,2) - -let print_constructors envpar names types = - let pc = - prlist_with_sep (fun () -> brk(1,0) ++ str "| ") - (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c) - (Array.to_list (array_map2 (fun n t -> (n,t)) names types)) - in - hv 0 (str " " ++ pc) - -let build_ind_type env mip = - match mip.mind_arity with - | Monomorphic ar -> ar.mind_user_arity - | Polymorphic ar -> - it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt - -let print_one_inductive env mib ((_,i) as ind) = - let mip = mib.mind_packets.(i) in - let params = mib.mind_params_ctxt in - let args = extended_rel_list 0 params in - let arity = hnf_prod_applist env (build_ind_type env mip) args in - let cstrtypes = Inductive.type_of_constructors ind (mib,mip) in - let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in - let envpar = push_rel_context params env in - hov 0 ( - pr_id mip.mind_typename ++ brk(1,4) ++ print_params env params ++ - str ": " ++ pr_lconstr_env envpar arity ++ str " :=") ++ - brk(0,2) ++ print_constructors envpar mip.mind_consnames cstrtypes - -let print_mutual_inductive env mind mib = - let inds = list_tabulate (fun x -> (mind,x)) (Array.length mib.mind_packets) - in - hov 0 ( - str (if mib.mind_finite then "Inductive " else "CoInductive ") ++ - prlist_with_sep (fun () -> fnl () ++ str" with ") - (print_one_inductive env mib) inds) - -let get_fields = - let rec prodec_rec l subst c = - match kind_of_term c with - | Prod (na,t,c) -> - let id = match na with Name id -> id | Anonymous -> id_of_string "_" in - prodec_rec ((id,true,substl subst t)::l) (mkVar id::subst) c - | LetIn (na,b,_,c) -> - let id = match na with Name id -> id | Anonymous -> id_of_string "_" in - prodec_rec ((id,false,substl subst b)::l) (mkVar id::subst) c - | _ -> List.rev l - in - prodec_rec [] [] - -let print_record env mind mib = - let mip = mib.mind_packets.(0) in - let params = mib.mind_params_ctxt in - let args = extended_rel_list 0 params in - let arity = hnf_prod_applist env (build_ind_type env mip) args in - let cstrtypes = Inductive.type_of_constructors (mind,0) (mib,mip) in - let cstrtype = hnf_prod_applist env cstrtypes.(0) args in - let fields = get_fields cstrtype in - let envpar = push_rel_context params env in - hov 0 ( - hov 0 ( - str "Record " ++ pr_id mip.mind_typename ++ brk(1,4) ++ - print_params env params ++ - str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++ - str ":= " ++ pr_id 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 " := ") ++ - pr_lconstr_env envpar c) fields) ++ str" }") - -let pr_mutual_inductive_body env mind mib = - if mib.mind_record & not !Flags.raw_print then - print_record env mind mib - else - print_mutual_inductive env mind mib diff --git a/parsing/printer.mli b/parsing/printer.mli deleted file mode 100644 index c0ef1932..00000000 --- a/parsing/printer.mli +++ /dev/null @@ -1,169 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> std_ppcmds -val pr_lconstr : constr -> std_ppcmds - -val pr_constr_env : env -> constr -> std_ppcmds -val pr_constr : constr -> std_ppcmds - -(** 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 -> constr -> std_ppcmds -val safe_pr_lconstr : constr -> std_ppcmds - -val safe_pr_constr_env : env -> constr -> std_ppcmds -val safe_pr_constr : constr -> std_ppcmds - - -val pr_open_constr_env : env -> open_constr -> std_ppcmds -val pr_open_constr : open_constr -> std_ppcmds - -val pr_open_lconstr_env : env -> open_constr -> std_ppcmds -val pr_open_lconstr : open_constr -> std_ppcmds - -val pr_constr_under_binders_env : env -> constr_under_binders -> std_ppcmds -val pr_constr_under_binders : constr_under_binders -> std_ppcmds - -val pr_lconstr_under_binders_env : env -> constr_under_binders -> std_ppcmds -val pr_lconstr_under_binders : constr_under_binders -> std_ppcmds - -val pr_goal_concl_style_env : env -> types -> std_ppcmds -val pr_ltype_env : env -> types -> std_ppcmds -val pr_ltype : types -> std_ppcmds - -val pr_type_env : env -> types -> std_ppcmds -val pr_type : types -> std_ppcmds - -val pr_ljudge_env : env -> unsafe_judgment -> std_ppcmds * std_ppcmds -val pr_ljudge : unsafe_judgment -> std_ppcmds * std_ppcmds - -val pr_lglob_constr_env : env -> glob_constr -> std_ppcmds -val pr_lglob_constr : glob_constr -> std_ppcmds - -val pr_glob_constr_env : env -> glob_constr -> std_ppcmds -val pr_glob_constr : glob_constr -> std_ppcmds - -val pr_lconstr_pattern_env : env -> constr_pattern -> std_ppcmds -val pr_lconstr_pattern : constr_pattern -> std_ppcmds - -val pr_constr_pattern_env : env -> constr_pattern -> std_ppcmds -val pr_constr_pattern : constr_pattern -> std_ppcmds - -val pr_cases_pattern : cases_pattern -> std_ppcmds - -val pr_sort : sorts -> std_ppcmds - -(** Printing global references using names as short as possible *) - -val pr_global_env : Idset.t -> global_reference -> std_ppcmds -val pr_global : global_reference -> std_ppcmds - -val pr_constant : env -> constant -> std_ppcmds -val pr_existential : env -> 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 - -(** Contexts *) - -val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds - -val pr_var_decl : env -> named_declaration -> std_ppcmds -val pr_rel_decl : env -> rel_declaration -> std_ppcmds - -val pr_named_context : env -> named_context -> std_ppcmds -val pr_named_context_of : env -> std_ppcmds -val pr_rel_context : env -> rel_context -> std_ppcmds -val pr_rel_context_of : env -> std_ppcmds -val pr_context_of : env -> std_ppcmds - -(** Predicates *) - -val pr_predicate : ('a -> std_ppcmds) -> (bool * 'a list) -> std_ppcmds -val pr_cpred : Cpred.t -> std_ppcmds -val pr_idpred : Idpred.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 -> string option -> evar_map -> evar 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 : unit -> std_ppcmds -val pr_nth_open_subgoal : int -> std_ppcmds -val pr_evar : (evar * evar_info) -> std_ppcmds -val pr_evars_int : int -> (evar * evar_info) list -> 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 tag in the prompt when in - emacs mode. *) -val emacs_str : string -> string - -(** Backwards compatibility *) - -val prterm : constr -> std_ppcmds (** = pr_lconstr *) - - -(** spiwack: printer function for sets of Environ.assumption. - It is used primarily by the Print Assumption command. *) -val pr_assumptionset : - env -> Term.types Assumptions.ContextObjectMap.t ->std_ppcmds - -val pr_goal_by_id : string -> std_ppcmds - -type printer_pr = { - pr_subgoals : ?pr_first:bool -> string option -> evar_map -> evar list -> int list -> goal list -> std_ppcmds; - pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; - pr_goal : goal sigma -> std_ppcmds; -};; - -val set_printer_pr : printer_pr -> unit - -val default_printer_pr : printer_pr - -val pr_instance_gmap : (global_reference, Typeclasses.instance Names.Cmap.t) Gmap.t -> - Pp.std_ppcmds - -(** Inductive declarations *) - -val pr_mutual_inductive_body : - env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds diff --git a/parsing/printmod.ml b/parsing/printmod.ml deleted file mode 100644 index ad791de9..00000000 --- a/parsing/printmod.ml +++ /dev/null @@ -1,279 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* !short) ; - optwrite = ((:=) short) } - -let get_new_id locals id = - let rec get_id l id = - let dir = make_dirpath [id] in - if not (Nametab.exists_module dir) then - id - else - get_id (id::l) (Namegen.next_ident_away id l) - in - get_id (List.map snd locals) id - -let rec print_local_modpath locals = function - | MPbound mbid -> pr_id (List.assoc mbid locals) - | MPdot(mp,l) -> - print_local_modpath locals mp ++ str "." ++ pr_lab l - | MPfile _ -> raise Not_found - -let print_modpath locals mp = - try (* must be with let because streams are lazy! *) - let qid = Nametab.shortest_qualid_of_module mp in - pr_qualid qid - with - | Not_found -> print_local_modpath locals mp - -let print_kn locals kn = - try - let qid = Nametab.shortest_qualid_of_modtype kn in - pr_qualid qid - with - Not_found -> - try - print_local_modpath locals kn - with - Not_found -> print_modpath locals kn - -(** Each time we have to print a non-globally visible structure, - we place its elements in a fake fresh namespace. *) - -let mk_fake_top = - let r = ref 0 in - fun () -> incr r; id_of_string ("FAKETOP"^(string_of_int !r)) - -let nametab_register_dir mp = - let id = mk_fake_top () in - let dir = make_dirpath [id] in - Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath))) - -(** Nota: the [global_reference] we register in the nametab below - might differ from internal ones, since we cannot recreate here - the canonical part of constant and inductive names, but only - the user names. This works nonetheless since we search now - [Nametab.the_globrevtab] modulo user name. *) - -let nametab_register_body mp dir (l,body) = - let push id ref = - Nametab.push (Nametab.Until (1+List.length (repr_dirpath dir))) - (make_path dir id) ref - in - match body with - | SFBmodule _ -> () (* TODO *) - | SFBmodtype _ -> () (* TODO *) - | SFBconst _ -> - push (id_of_label l) (ConstRef (make_con mp empty_dirpath l)) - | SFBmind mib -> - let mind = make_mind mp empty_dirpath l in - Array.iteri - (fun i mip -> - push mip.mind_typename (IndRef (mind,i)); - Array.iteri (fun j id -> push id (ConstructRef ((mind,i),j+1))) - mip.mind_consnames) - mib.mind_packets - -let nametab_register_module_body mp struc = - (* If [mp] is a globally visible module, we simply import it *) - try Declaremods.really_import_module mp - with Not_found -> - (* Otherwise we try to emulate an import by playing with nametab *) - nametab_register_dir mp; - List.iter (nametab_register_body mp empty_dirpath) struc - -let nametab_register_module_param mbid seb = - (* For algebraic seb, we use a Declaremods function that converts into mse *) - try Declaremods.process_module_seb_binding mbid seb - with e when Errors.noncritical e -> - (* Otherwise, for expanded structure, we try to play with the nametab *) - match seb with - | SEBstruct struc -> - let mp = MPbound mbid in - let dir = make_dirpath [id_of_mbid mbid] in - nametab_register_dir mp; - List.iter (nametab_register_body mp dir) struc - | _ -> () - -let print_body is_impl env mp (l,body) = - let name = str (string_of_label l) in - hov 2 (match body with - | SFBmodule _ -> str "Module " ++ name - | SFBmodtype _ -> str "Module Type " ++ name - | SFBconst cb -> - (match cb.const_body with - | Def _ -> str "Definition " - | OpaqueDef _ when is_impl -> str "Theorem " - | _ -> str "Parameter ") ++ name ++ - (match env with - | None -> mt () - | Some env -> - str " :" ++ spc () ++ - hov 0 (Printer.pr_ltype_env env - (Typeops.type_of_constant_type env cb.const_type)) ++ - (match cb.const_body with - | Def l when is_impl -> - spc () ++ - hov 2 (str ":= " ++ - Printer.pr_lconstr_env env (Declarations.force l)) - | _ -> mt ()) ++ - str ".") - | SFBmind mib -> - try - let env = Option.get env in - Printer.pr_mutual_inductive_body env (make_mind mp empty_dirpath l) mib - with e when Errors.noncritical e -> - (if mib.mind_finite then str "Inductive " else str "CoInductive") - ++ name) - -let print_struct is_impl env mp struc = - prlist_with_sep spc (print_body is_impl env mp) struc - -let rec flatten_app mexpr l = match mexpr with - | SEBapply (mexpr, SEBident arg,_) -> flatten_app mexpr (arg::l) - | SEBident mp -> mp::l - | _ -> assert false - -let rec print_modtype env mp locals mty = - match mty with - | SEBident kn -> print_kn locals kn - | SEBfunctor (mbid,mtb1,mtb2) -> - let mp1 = MPbound mbid in - let env' = Option.map - (Modops.add_module (Modops.module_body_of_type mp1 mtb1)) env in - let seb1 = Option.default mtb1.typ_expr mtb1.typ_expr_alg in - let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals - in - nametab_register_module_param mbid seb1; - hov 2 (str "Funsig" ++ spc () ++ str "(" ++ - pr_id (id_of_mbid mbid) ++ str ":" ++ - print_modtype env mp1 locals seb1 ++ - str ")" ++ spc() ++ print_modtype env' mp locals' mtb2) - | SEBstruct (sign) -> - let env' = Option.map - (Modops.add_signature mp sign Mod_subst.empty_delta_resolver) env in - nametab_register_module_body mp sign; - hv 2 (str "Sig" ++ spc () ++ print_struct false env' mp sign ++ - brk (1,-2) ++ str "End") - | SEBapply _ -> - let lapp = flatten_app mty [] in - let fapp = List.hd lapp in - let mapp = List.tl lapp in - hov 3 (str"(" ++ (print_kn locals fapp) ++ spc () ++ - prlist_with_sep spc (print_modpath locals) mapp ++ str")") - | SEBwith(seb,With_definition_body(idl,cb))-> - let env' = None in (* TODO: build a proper environment if env <> None *) - let s = (String.concat "." (List.map string_of_id idl)) in - hov 2 (print_modtype env' mp locals seb ++ spc() ++ str "with" ++ spc() ++ - str "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) - | SEBwith(seb,With_module_body(idl,mp))-> - let s =(String.concat "." (List.map string_of_id idl)) in - hov 2 (print_modtype env mp locals seb ++ spc() ++ str "with" ++ spc() ++ - str "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) - -let rec print_modexpr env mp locals mexpr = match mexpr with - | SEBident mp -> print_modpath locals mp - | SEBfunctor (mbid,mty,mexpr) -> - let mp' = MPbound mbid in - let env' = Option.map - (Modops.add_module (Modops.module_body_of_type mp' mty)) env in - let typ = Option.default mty.typ_expr mty.typ_expr_alg in - let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in - nametab_register_module_param mbid typ; - hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++ - str ":" ++ print_modtype env mp' locals typ ++ - str ")" ++ spc () ++ print_modexpr env' mp locals' mexpr) - | SEBstruct struc -> - let env' = Option.map - (Modops.add_signature mp struc Mod_subst.empty_delta_resolver) env in - nametab_register_module_body mp struc; - hv 2 (str "Struct" ++ spc () ++ print_struct true env' mp struc ++ - brk (1,-2) ++ str "End") - | SEBapply _ -> - let lapp = flatten_app mexpr [] in - hov 3 (str"(" ++ prlist_with_sep spc (print_modpath locals) lapp ++ str")") - | SEBwith (_,_)-> anomaly "Not available yet" - - -let rec printable_body dir = - let dir = pop_dirpath dir in - dir = empty_dirpath || - try - match Nametab.locate_dir (qualid_of_dirpath dir) with - DirOpenModtype _ -> false - | DirModule _ | DirOpenModule _ -> printable_body dir - | _ -> true - with - Not_found -> true - -(** Since we might play with nametab above, we should reset to prior - state after the printing *) - -let print_modexpr' env mp mexpr = - States.with_state_protection (fun e -> eval_ppcmds (print_modexpr env mp [] e)) mexpr -let print_modtype' env mp mty = - States.with_state_protection (fun e -> eval_ppcmds (print_modtype env mp [] e)) mty - -let print_module' env mp with_body mb = - let name = print_modpath [] mp in - let body = match with_body, mb.mod_expr with - | false, _ - | true, None -> mt() - | true, Some mexpr -> - spc () ++ str ":= " ++ print_modexpr' env mp mexpr - in - let modtype = brk (1,1) ++ str": " ++ print_modtype' env mp mb.mod_type - in - hv 0 (str "Module " ++ name ++ modtype ++ body) - -exception ShortPrinting - -let print_module with_body mp = - let me = Global.lookup_module mp in - try - if !short then raise ShortPrinting; - print_module' (Some (Global.env ())) mp with_body me ++ fnl () - with e when Errors.noncritical e -> - print_module' None mp with_body me ++ fnl () - -let print_modtype kn = - let mtb = Global.lookup_modtype kn in - let name = print_kn [] kn in - hv 1 - (str "Module Type " ++ name ++ str " =" ++ spc () ++ - (try - if !short then raise ShortPrinting; - print_modtype' (Some (Global.env ())) kn mtb.typ_expr - with e when Errors.noncritical e -> - print_modtype' None kn mtb.typ_expr)) diff --git a/parsing/printmod.mli b/parsing/printmod.mli deleted file mode 100644 index f60d19b3..00000000 --- a/parsing/printmod.mli +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool - -val print_module : bool -> module_path -> std_ppcmds - -val print_modtype : module_path -> std_ppcmds diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4 deleted file mode 100644 index 7e69163e..00000000 --- a/parsing/q_constr.ml4 +++ /dev/null @@ -1,126 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* > - -let apply_ref f l = - <:expr< - Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$) - >> - -EXTEND - GLOBAL: expr; - expr: - [ [ "PATTERN"; "["; c = constr; "]" -> - <:expr< snd (Pattern.pattern_of_glob_constr $c$) >> ] ] - ; - sort: - [ [ "Set" -> GProp Pos - | "Prop" -> GProp Null - | "Type" -> GType None ] ] - ; - ident: - [ [ s = string -> <:expr< Names.id_of_string $str:s$ >> ] ] - ; - name: - [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ] - ; - string: - [ [ s = UIDENT -> s | s = LIDENT -> s ] ] - ; - constr: - [ "200" RIGHTA - [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr -> - <:expr< Glob_term.GProd ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >> - | "fun"; id = ident; ":"; c1 = constr; "=>"; c2 = constr -> - <:expr< Glob_term.GLambda ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >> - | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr -> - <:expr< Glob_term.RLetin ($dloc$,Name $id$,$c1$,$c2$) >> - (* fix todo *) - ] - | "100" RIGHTA - [ c1 = constr; ":"; c2 = SELF -> - <:expr< Glob_term.GCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ] - | "90" RIGHTA - [ c1 = constr; "->"; c2 = SELF -> - <:expr< Glob_term.GProd ($dloc$,Anonymous,Glob_term.Explicit,$c1$,$c2$) >> ] - | "75" RIGHTA - [ "~"; c = constr -> - apply_ref <:expr< coq_not_ref >> [c] ] - | "70" RIGHTA - [ c1 = constr; "="; c2 = NEXT; ":>"; t = NEXT -> - apply_ref <:expr< coq_eq_ref >> [t;c1;c2] ] - | "10" LEFTA - [ f = constr; args = LIST1 NEXT -> - let args = mlexpr_of_list (fun x -> x) args in - <:expr< Glob_term.GApp ($dloc$,$f$,$args$) >> ] - | "0" - [ s = sort -> <:expr< Glob_term.GSort ($dloc$,s) >> - | id = ident -> <:expr< Glob_term.GVar ($dloc$,$id$) >> - | "_" -> <:expr< Glob_term.GHole ($dloc$, QuestionMark (Define False)) >> - | "?"; id = ident -> <:expr< Glob_term.GPatVar($dloc$,(False,$id$)) >> - | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" -> - apply_ref <:expr< coq_sumbool_ref >> [c1;c2] - | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$) >> - | c = match_constr -> c - | "("; c = constr LEVEL "200"; ")" -> c ] ] - ; - match_constr: - [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type; - "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> - let br = mlexpr_of_list (fun x -> x) br in - <:expr< Glob_term.GCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> - ] ] - ; - match_type: - [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name; - "return"; ty = constr LEVEL "100" -> - let nal = mlexpr_of_list (fun x -> x) nal in - <:expr< Some $ty$ >>, - <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >> - | -> <:expr< None >>, <:expr< (Anonymous, None) >> ] ] - ; - eqn: - [ [ (lid,pl) = pattern; "=>"; rhs = constr -> - let lid = mlexpr_of_list (fun x -> x) lid in - <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >> - ] ] - ; - pattern: - [ [ "%"; e = string; lip = LIST0 patvar -> - let lp = mlexpr_of_list (fun (_,x) -> x) lip in - let lid = List.flatten (List.map fst lip) in - lid, <:expr< Glob_term.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >> - | p = patvar -> p - | "("; p = pattern; ")" -> p ] ] - ; - patvar: - [ [ "_" -> [], <:expr< Glob_term.PatVar ($dloc$,Anonymous) >> - | id = ident -> [id], <:expr< Glob_term.PatVar ($dloc$,Name $id$) >> - ] ] - ; - END;; - -(* Example -open Coqlib -let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ] -*) - diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 deleted file mode 100644 index f5508352..00000000 --- a/parsing/q_coqast.ml4 +++ /dev/null @@ -1,568 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 && s.[0] == '$' - -let purge_str s = - if String.length s == 0 || s.[0] <> '$' then s - else String.sub s 1 (String.length s - 1) - -let anti loc x = - expl_anti loc <:expr< $lid:purge_str x$ >> - -(* We don't give location for tactic quotation! *) -let loc = dummy_loc - -let dloc = <:expr< Util.dummy_loc >> - -let mlexpr_of_ident id = - <:expr< Names.id_of_string $str:Names.string_of_id id$ >> - -let mlexpr_of_name = function - | Names.Anonymous -> <:expr< Names.Anonymous >> - | Names.Name id -> - <:expr< Names.Name (Names.id_of_string $str:Names.string_of_id id$) >> - -let mlexpr_of_dirpath dir = - let l = Names.repr_dirpath dir in - <:expr< Names.make_dirpath $mlexpr_of_list mlexpr_of_ident l$ >> - -let mlexpr_of_qualid qid = - let (dir, id) = repr_qualid qid in - <:expr< make_qualid $mlexpr_of_dirpath dir$ $mlexpr_of_ident id$ >> - -let mlexpr_of_reference = function - | Libnames.Qualid (loc,qid) -> <:expr< Libnames.Qualid $dloc$ $mlexpr_of_qualid qid$ >> - | Libnames.Ident (loc,id) -> <:expr< Libnames.Ident $dloc$ $mlexpr_of_ident id$ >> - -let mlexpr_of_located f (loc,x) = <:expr< ($dloc$, $f x$) >> - -let mlexpr_of_loc loc = <:expr< $dloc$ >> - -let mlexpr_of_by_notation f = function - | Genarg.AN x -> <:expr< Genarg.AN $f x$ >> - | Genarg.ByNotation (loc,s,sco) -> - <:expr< Genarg.ByNotation $dloc$ $str:s$ $mlexpr_of_option mlexpr_of_string sco$ >> - -let mlexpr_of_intro_pattern = function - | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >> - | Genarg.IntroAnonymous -> <:expr< Genarg.IntroAnonymous >> - | Genarg.IntroFresh id -> <:expr< Genarg.IntroFresh (mlexpr_of_ident $dloc$ id) >> - | Genarg.IntroForthcoming b -> <:expr< Genarg.IntroForthcoming (mlexpr_of_bool $dloc$ b) >> - | Genarg.IntroIdentifier id -> - <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >> - | Genarg.IntroOrAndPattern _ | Genarg.IntroRewrite _ -> - failwith "mlexpr_of_intro_pattern: TODO" - -let mlexpr_of_ident_option = mlexpr_of_option (mlexpr_of_ident) - -let mlexpr_of_or_metaid f = function - | Tacexpr.AI a -> <:expr< Tacexpr.AI $f a$ >> - | Tacexpr.MetaId (_,id) -> <:expr< Tacexpr.AI $anti loc id$ >> - -let mlexpr_of_quantified_hypothesis = function - | Glob_term.AnonHyp n -> <:expr< Glob_term.AnonHyp $mlexpr_of_int n$ >> - | Glob_term.NamedHyp id -> <:expr< Glob_term.NamedHyp $mlexpr_of_ident id$ >> - -let mlexpr_of_or_var f = function - | Glob_term.ArgArg x -> <:expr< Glob_term.ArgArg $f x$ >> - | Glob_term.ArgVar id -> <:expr< Glob_term.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >> - -let mlexpr_of_hyp = mlexpr_of_or_metaid (mlexpr_of_located mlexpr_of_ident) - -let mlexpr_of_occs = - mlexpr_of_pair - mlexpr_of_bool (mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int)) - -let mlexpr_of_occurrences f = mlexpr_of_pair mlexpr_of_occs f - -let mlexpr_of_hyp_location = function - | occs, Termops.InHyp -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHyp) >> - | occs, Termops.InHypTypeOnly -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHypTypeOnly) >> - | occs, Termops.InHypValueOnly -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHypValueOnly) >> - -let mlexpr_of_clause cl = - <:expr< {Tacexpr.onhyps= - $mlexpr_of_option (mlexpr_of_list mlexpr_of_hyp_location) - cl.Tacexpr.onhyps$; - Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >> - -let mlexpr_of_red_flags { - Glob_term.rBeta = bb; - Glob_term.rIota = bi; - Glob_term.rZeta = bz; - Glob_term.rDelta = bd; - Glob_term.rConst = l -} = <:expr< { - Glob_term.rBeta = $mlexpr_of_bool bb$; - Glob_term.rIota = $mlexpr_of_bool bi$; - Glob_term.rZeta = $mlexpr_of_bool bz$; - Glob_term.rDelta = $mlexpr_of_bool bd$; - Glob_term.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$ -} >> - -let mlexpr_of_explicitation = function - | Topconstr.ExplByName id -> <:expr< Topconstr.ExplByName $mlexpr_of_ident id$ >> - | Topconstr.ExplByPos (n,_id) -> <:expr< Topconstr.ExplByPos $mlexpr_of_int n$ >> - -let mlexpr_of_binding_kind = function - | Glob_term.Implicit -> <:expr< Glob_term.Implicit >> - | Glob_term.Explicit -> <:expr< Glob_term.Explicit >> - -let mlexpr_of_binder_kind = function - | Topconstr.Default b -> <:expr< Topconstr.Default $mlexpr_of_binding_kind b$ >> - | Topconstr.Generalized (b,b',b'') -> - <:expr< Topconstr.TypeClass $mlexpr_of_binding_kind b$ - $mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >> - -let rec mlexpr_of_constr = function - | Topconstr.CRef (Libnames.Ident (loc,id)) when is_meta (string_of_id id) -> - anti loc (string_of_id id) - | Topconstr.CRef r -> <:expr< Topconstr.CRef $mlexpr_of_reference r$ >> - | Topconstr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" - | Topconstr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" - | Topconstr.CArrow (loc,a,b) -> - <:expr< Topconstr.CArrow $dloc$ $mlexpr_of_constr a$ $mlexpr_of_constr b$ >> - | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list - (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> - | Topconstr.CLambdaN (loc,l,a) -> <:expr< Topconstr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> - | Topconstr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Topconstr.CAppExpl (loc,a,l) -> <:expr< Topconstr.CAppExpl $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >> - | Topconstr.CApp (loc,a,l) -> <:expr< Topconstr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >> - | Topconstr.CCases (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Topconstr.CHole (loc, None) -> <:expr< Topconstr.CHole $dloc$ None >> - | Topconstr.CHole (loc, Some _) -> failwith "mlexpr_of_constr: TODO CHole (Some _)" - | Topconstr.CNotation(_,ntn,(subst,substl,[])) -> - <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$ - ($mlexpr_of_list mlexpr_of_constr subst$, - $mlexpr_of_list (mlexpr_of_list mlexpr_of_constr) substl$,[]) >> - | Topconstr.CPatVar (loc,n) -> - <:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >> - | _ -> failwith "mlexpr_of_constr: TODO" - -let mlexpr_of_occ_constr = - mlexpr_of_occurrences mlexpr_of_constr - -let mlexpr_of_red_expr = function - | Glob_term.Red b -> <:expr< Glob_term.Red $mlexpr_of_bool b$ >> - | Glob_term.Hnf -> <:expr< Glob_term.Hnf >> - | Glob_term.Simpl o -> <:expr< Glob_term.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >> - | Glob_term.Cbv f -> - <:expr< Glob_term.Cbv $mlexpr_of_red_flags f$ >> - | Glob_term.Lazy f -> - <:expr< Glob_term.Lazy $mlexpr_of_red_flags f$ >> - | Glob_term.Unfold l -> - let f1 = mlexpr_of_by_notation mlexpr_of_reference in - let f = mlexpr_of_list (mlexpr_of_occurrences f1) in - <:expr< Glob_term.Unfold $f l$ >> - | Glob_term.Fold l -> - <:expr< Glob_term.Fold $mlexpr_of_list mlexpr_of_constr l$ >> - | Glob_term.Pattern l -> - let f = mlexpr_of_list mlexpr_of_occ_constr in - <:expr< Glob_term.Pattern $f l$ >> - | Glob_term.CbvVm -> <:expr< Glob_term.CbvVm >> - | Glob_term.ExtraRedExpr s -> - <:expr< Glob_term.ExtraRedExpr $mlexpr_of_string s$ >> - -let rec mlexpr_of_argtype loc = function - | Genarg.BoolArgType -> <:expr< Genarg.BoolArgType >> - | Genarg.IntArgType -> <:expr< Genarg.IntArgType >> - | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >> - | Genarg.RefArgType -> <:expr< Genarg.RefArgType >> - | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >> - | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >> - | Genarg.IdentArgType b -> <:expr< Genarg.IdentArgType $mlexpr_of_bool b$ >> - | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> - | Genarg.StringArgType -> <:expr< Genarg.StringArgType >> - | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >> - | Genarg.OpenConstrArgType (b1,b2) -> <:expr< Genarg.OpenConstrArgType ($mlexpr_of_bool b1$, $mlexpr_of_bool b2$) >> - | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >> - | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >> - | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >> - | Genarg.SortArgType -> <:expr< Genarg.SortArgType >> - | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> - | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >> - | Genarg.List0ArgType t -> <:expr< Genarg.List0ArgType $mlexpr_of_argtype loc t$ >> - | Genarg.List1ArgType t -> <:expr< Genarg.List1ArgType $mlexpr_of_argtype loc t$ >> - | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> - | Genarg.PairArgType (t1,t2) -> - let t1 = mlexpr_of_argtype loc t1 in - let t2 = mlexpr_of_argtype loc t2 in - <:expr< Genarg.PairArgType $t1$ $t2$ >> - | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >> - -let rec mlexpr_of_may_eval f = function - | Glob_term.ConstrEval (r,c) -> - <:expr< Glob_term.ConstrEval $mlexpr_of_red_expr r$ $f c$ >> - | Glob_term.ConstrContext ((loc,id),c) -> - let id = mlexpr_of_ident id in - <:expr< Glob_term.ConstrContext (loc,$id$) $f c$ >> - | Glob_term.ConstrTypeOf c -> - <:expr< Glob_term.ConstrTypeOf $mlexpr_of_constr c$ >> - | Glob_term.ConstrTerm c -> - <:expr< Glob_term.ConstrTerm $mlexpr_of_constr c$ >> - -let mlexpr_of_binding_kind = function - | Glob_term.ExplicitBindings l -> - let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in - <:expr< Glob_term.ExplicitBindings $l$ >> - | Glob_term.ImplicitBindings l -> - let l = mlexpr_of_list mlexpr_of_constr l in - <:expr< Glob_term.ImplicitBindings $l$ >> - | Glob_term.NoBindings -> - <:expr< Glob_term.NoBindings >> - -let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr - -let mlexpr_of_constr_with_binding = - mlexpr_of_pair mlexpr_of_constr mlexpr_of_binding_kind - -let mlexpr_of_move_location f = function - | Tacexpr.MoveAfter id -> <:expr< Tacexpr.MoveAfter $f id$ >> - | Tacexpr.MoveBefore id -> <:expr< Tacexpr.MoveBefore $f id$ >> - | Tacexpr.MoveToEnd b -> <:expr< Tacexpr.MoveToEnd $mlexpr_of_bool b$ >> - -let mlexpr_of_induction_arg = function - | Tacexpr.ElimOnConstr c -> - <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr_with_binding c$ >> - | Tacexpr.ElimOnIdent (_,id) -> - <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >> - | Tacexpr.ElimOnAnonHyp n -> - <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >> - -let mlexpr_of_clause_pattern _ = failwith "mlexpr_of_clause_pattern: TODO" - -let mlexpr_of_pattern_ast = mlexpr_of_constr - -let mlexpr_of_entry_type = function - _ -> failwith "mlexpr_of_entry_type: TODO" - -let mlexpr_of_match_pattern = function - | Tacexpr.Term t -> <:expr< Tacexpr.Term $mlexpr_of_pattern_ast t$ >> - | Tacexpr.Subterm (b,ido,t) -> - <:expr< Tacexpr.Subterm $mlexpr_of_bool b$ $mlexpr_of_option mlexpr_of_ident ido$ $mlexpr_of_pattern_ast t$ >> - -let mlexpr_of_match_context_hyps = function - | Tacexpr.Hyp (id,l) -> - let f = mlexpr_of_located mlexpr_of_name in - <:expr< Tacexpr.Hyp $f id$ $mlexpr_of_match_pattern l$ >> - | Tacexpr.Def (id,v,l) -> - let f = mlexpr_of_located mlexpr_of_name in - <:expr< Tacexpr.Def $f id$ $mlexpr_of_match_pattern v$ $mlexpr_of_match_pattern l$ >> - -let mlexpr_of_match_rule f = function - | Tacexpr.Pat (l,mp,t) -> <:expr< Tacexpr.Pat $mlexpr_of_list mlexpr_of_match_context_hyps l$ $mlexpr_of_match_pattern mp$ $f t$ >> - | Tacexpr.All t -> <:expr< Tacexpr.All $f t$ >> - -let mlexpr_of_message_token = function - | Tacexpr.MsgString s -> <:expr< Tacexpr.MsgString $str:s$ >> - | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >> - | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >> - -let mlexpr_of_debug = function - | Tacexpr.Off -> <:expr< Tacexpr.Off >> - | Tacexpr.Debug -> <:expr< Tacexpr.Debug >> - | Tacexpr.Info -> <:expr< Tacexpr.Info >> - -let rec mlexpr_of_atomic_tactic = function - (* Basic tactics *) - | Tacexpr.TacIntroPattern pl -> - let pl = mlexpr_of_list (mlexpr_of_located mlexpr_of_intro_pattern) pl in - <:expr< Tacexpr.TacIntroPattern $pl$ >> - | Tacexpr.TacIntrosUntil h -> - <:expr< Tacexpr.TacIntrosUntil $mlexpr_of_quantified_hypothesis h$ >> - | Tacexpr.TacIntroMove (idopt,idopt') -> - let idopt = mlexpr_of_ident_option idopt in - let idopt'= mlexpr_of_move_location mlexpr_of_hyp idopt' in - <:expr< Tacexpr.TacIntroMove $idopt$ $idopt'$ >> - | Tacexpr.TacAssumption -> - <:expr< Tacexpr.TacAssumption >> - | Tacexpr.TacExact c -> - <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >> - | Tacexpr.TacExactNoCheck c -> - <:expr< Tacexpr.TacExactNoCheck $mlexpr_of_constr c$ >> - | Tacexpr.TacVmCastNoCheck c -> - <:expr< Tacexpr.TacVmCastNoCheck $mlexpr_of_constr c$ >> - | Tacexpr.TacApply (b,false,cb,None) -> - <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_list mlexpr_of_constr_with_binding cb$ None >> - | Tacexpr.TacElim (false,cb,cbo) -> - let cb = mlexpr_of_constr_with_binding cb in - let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in - <:expr< Tacexpr.TacElim False $cb$ $cbo$ >> - | Tacexpr.TacElimType c -> - <:expr< Tacexpr.TacElimType $mlexpr_of_constr c$ >> - | Tacexpr.TacCase (false,cb) -> - let cb = mlexpr_of_constr_with_binding cb in - <:expr< Tacexpr.TacCase False $cb$ >> - | Tacexpr.TacCaseType c -> - <:expr< Tacexpr.TacCaseType $mlexpr_of_constr c$ >> - | Tacexpr.TacFix (ido,n) -> - let ido = mlexpr_of_ident_option ido in - let n = mlexpr_of_int n in - <:expr< Tacexpr.TacFix $ido$ $n$ >> - | Tacexpr.TacMutualFix (b,id,n,l) -> - let b = mlexpr_of_bool b in - let id = mlexpr_of_ident id in - let n = mlexpr_of_int n in - let f =mlexpr_of_triple mlexpr_of_ident mlexpr_of_int mlexpr_of_constr in - let l = mlexpr_of_list f l in - <:expr< Tacexpr.TacMutualFix $b$ $id$ $n$ $l$ >> - | Tacexpr.TacCofix ido -> - let ido = mlexpr_of_ident_option ido in - <:expr< Tacexpr.TacCofix $ido$ >> - | Tacexpr.TacMutualCofix (b,id,l) -> - let b = mlexpr_of_bool b in - let id = mlexpr_of_ident id in - let f = mlexpr_of_pair mlexpr_of_ident mlexpr_of_constr in - let l = mlexpr_of_list f l in - <:expr< Tacexpr.TacMutualCofix $b$ $id$ $l$ >> - - | Tacexpr.TacCut c -> - <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >> - | Tacexpr.TacAssert (t,ipat,c) -> - let ipat = mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) ipat in - <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ - $mlexpr_of_constr c$ >> - | Tacexpr.TacGeneralize cl -> - <:expr< Tacexpr.TacGeneralize - $mlexpr_of_list - (mlexpr_of_pair mlexpr_of_occ_constr mlexpr_of_name) cl$ >> - | Tacexpr.TacGeneralizeDep c -> - <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >> - | Tacexpr.TacLetTac (na,c,cl,b,e) -> - let na = mlexpr_of_name na in - let cl = mlexpr_of_clause_pattern cl in - <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$ - $mlexpr_of_bool b$ - (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) e) - >> - - (* Derived basic tactics *) - | Tacexpr.TacSimpleInductionDestruct (isrec,h) -> - <:expr< Tacexpr.TacSimpleInductionDestruct $mlexpr_of_bool isrec$ - $mlexpr_of_quantified_hypothesis h$ >> - | Tacexpr.TacInductionDestruct (isrec,ev,l) -> - <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$ - $mlexpr_of_triple - (mlexpr_of_list - (mlexpr_of_pair - mlexpr_of_induction_arg - (mlexpr_of_pair - (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern)) - (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern))))) - (mlexpr_of_option mlexpr_of_constr_with_binding) - (mlexpr_of_option mlexpr_of_clause) l$ >> - - (* Context management *) - | Tacexpr.TacClear (b,l) -> - let l = mlexpr_of_list (mlexpr_of_hyp) l in - <:expr< Tacexpr.TacClear $mlexpr_of_bool b$ $l$ >> - | Tacexpr.TacClearBody l -> - let l = mlexpr_of_list (mlexpr_of_hyp) l in - <:expr< Tacexpr.TacClearBody $l$ >> - | Tacexpr.TacMove (dep,id1,id2) -> - <:expr< Tacexpr.TacMove $mlexpr_of_bool dep$ - $mlexpr_of_hyp id1$ - $mlexpr_of_move_location mlexpr_of_hyp id2$ >> - - (* Constructors *) - | Tacexpr.TacLeft (ev,l) -> - <:expr< Tacexpr.TacLeft $mlexpr_of_bool ev$ $mlexpr_of_binding_kind l$>> - | Tacexpr.TacRight (ev,l) -> - <:expr< Tacexpr.TacRight $mlexpr_of_bool ev$ $mlexpr_of_binding_kind l$>> - | Tacexpr.TacSplit (ev,b,l) -> - <:expr< Tacexpr.TacSplit - ($mlexpr_of_bool ev$,$mlexpr_of_bool b$,$mlexpr_of_list mlexpr_of_binding_kind l$)>> - | Tacexpr.TacAnyConstructor (ev,t) -> - <:expr< Tacexpr.TacAnyConstructor $mlexpr_of_bool ev$ $mlexpr_of_option mlexpr_of_tactic t$>> - | Tacexpr.TacConstructor (ev,n,l) -> - let n = mlexpr_of_or_var mlexpr_of_int n in - <:expr< Tacexpr.TacConstructor $mlexpr_of_bool ev$ $n$ $mlexpr_of_binding_kind l$>> - - (* Conversion *) - | Tacexpr.TacReduce (r,cl) -> - let l = mlexpr_of_clause cl in - <:expr< Tacexpr.TacReduce $mlexpr_of_red_expr r$ $l$ >> - | Tacexpr.TacChange (p,c,cl) -> - let l = mlexpr_of_clause cl in - let g = mlexpr_of_option mlexpr_of_constr in - <:expr< Tacexpr.TacChange $g p$ $mlexpr_of_constr c$ $l$ >> - - (* Equivalence relations *) - | Tacexpr.TacReflexivity -> <:expr< Tacexpr.TacReflexivity >> - | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >> - | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_option mlexpr_of_constr c$ >> - - (* Automation tactics *) - | Tacexpr.TacAuto (debug,n,lems,l) -> - let d = mlexpr_of_debug debug in - let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in - let lems = mlexpr_of_list mlexpr_of_constr lems in - let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - <:expr< Tacexpr.TacAuto $d$ $n$ $lems$ $l$ >> - | Tacexpr.TacTrivial (debug,lems,l) -> - let d = mlexpr_of_debug debug in - let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - let lems = mlexpr_of_list mlexpr_of_constr lems in - <:expr< Tacexpr.TacTrivial $d$ $lems$ $l$ >> - - | _ -> failwith "Quotation of atomic tactic expressions: TODO" - -and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function - | Tacexpr.TacAtom (loc,t) -> - <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >> - | Tacexpr.TacThen (t1,[||],t2,[||]) -> - <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ [||] $mlexpr_of_tactic t2$ [||]>> - | Tacexpr.TacThens (t,tl) -> - <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>> - | Tacexpr.TacFirst tl -> - <:expr< Tacexpr.TacFirst $mlexpr_of_list mlexpr_of_tactic tl$ >> - | Tacexpr.TacSolve tl -> - <:expr< Tacexpr.TacSolve $mlexpr_of_list mlexpr_of_tactic tl$ >> - | Tacexpr.TacTry t -> - <:expr< Tacexpr.TacTry $mlexpr_of_tactic t$ >> - | Tacexpr.TacOrelse (t1,t2) -> - <:expr< Tacexpr.TacOrelse $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >> - | Tacexpr.TacDo (n,t) -> - <:expr< Tacexpr.TacDo $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacTimeout (n,t) -> - <:expr< Tacexpr.TacTimeout $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacRepeat t -> - <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >> - | Tacexpr.TacProgress t -> - <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >> - | Tacexpr.TacId l -> - <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >> - | Tacexpr.TacFail (n,l) -> - <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >> -(* - | Tacexpr.TacInfo t -> TacInfo (loc,f t) - - | Tacexpr.TacRec (id,(idl,t)) -> TacRec (loc,(id,(idl,f t))) - | Tacexpr.TacRecIn (l,t) -> TacRecIn(loc,List.map (fun (id,t) -> (id,f t)) l,f t) -*) - | Tacexpr.TacLetIn (isrec,l,t) -> - let f = - mlexpr_of_pair - (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_ident) - mlexpr_of_tactic_arg in - <:expr< Tacexpr.TacLetIn $mlexpr_of_bool isrec$ $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacMatch (lz,t,l) -> - <:expr< Tacexpr.TacMatch - $mlexpr_of_bool lz$ - $mlexpr_of_tactic t$ - $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> - | Tacexpr.TacMatchGoal (lz,lr,l) -> - <:expr< Tacexpr.TacMatchGoal - $mlexpr_of_bool lz$ - $mlexpr_of_bool lr$ - $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> - - | Tacexpr.TacFun (idol,body) -> - <:expr< Tacexpr.TacFun - ($mlexpr_of_list mlexpr_of_ident_option idol$, - $mlexpr_of_tactic body$) >> - | Tacexpr.TacArg (_,Tacexpr.MetaIdArg (_,true,id)) -> anti loc id - | Tacexpr.TacArg (_,t) -> - <:expr< Tacexpr.TacArg $dloc$ $mlexpr_of_tactic_arg t$ >> - | Tacexpr.TacComplete t -> - <:expr< Tacexpr.TacComplete $mlexpr_of_tactic t$ >> - | _ -> failwith "Quotation of tactic expressions: TODO" - -and mlexpr_of_tactic_arg = function - | Tacexpr.MetaIdArg (loc,true,id) -> anti loc id - | Tacexpr.MetaIdArg (loc,false,id) -> - <:expr< Tacexpr.ConstrMayEval (Glob_term.ConstrTerm $anti loc id$) >> - | Tacexpr.TacCall (loc,t,tl) -> - <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>> - | Tacexpr.Tacexp t -> - <:expr< Tacexpr.Tacexp $mlexpr_of_tactic t$ >> - | Tacexpr.ConstrMayEval c -> - <:expr< Tacexpr.ConstrMayEval $mlexpr_of_may_eval mlexpr_of_constr c$ >> - | Tacexpr.Reference r -> - <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >> - | _ -> failwith "mlexpr_of_tactic_arg: TODO" - - -IFDEF CAMLP5 THEN - -let not_impl x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - failwith (" PaAcc (loc, patt_of_expr e1, patt_of_expr e2) - | ExApp (_, e1, e2) -> PaApp (loc, patt_of_expr e1, patt_of_expr e2) - | ExLid (_, x) when x = vala "loc" -> PaAny loc - | ExLid (_, s) -> PaLid (loc, s) - | ExUid (_, s) -> PaUid (loc, s) - | ExStr (_, s) -> PaStr (loc, s) - | ExAnt (_, e) -> PaAnt (loc, patt_of_expr e) - | _ -> not_impl e - -let fconstr e = - let ee s = - mlexpr_of_constr (Pcoq.Gram.entry_parse e - (Pcoq.Gram.parsable (Stream.of_string s))) - in - let ep s = patt_of_expr (ee s) in - Quotation.ExAst (ee, ep) - -let ftac e = - let ee s = - mlexpr_of_tactic (Pcoq.Gram.entry_parse e - (Pcoq.Gram.parsable (Stream.of_string s))) - in - let ep s = patt_of_expr (ee s) in - Quotation.ExAst (ee, ep) - -let _ = - Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi); - Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi); - Quotation.default := "constr" - -ELSE - -open Pcaml - -let expand_constr_quot_expr loc _loc_name_opt contents = - mlexpr_of_constr - (Pcoq.Gram.parse_string Pcoq.Constr.constr_eoi loc contents) - -let expand_tactic_quot_expr loc _loc_name_opt contents = - mlexpr_of_tactic - (Pcoq.Gram.parse_string Pcoq.Tactic.tactic_eoi loc contents) - -let _ = - (* FIXME: for the moment, we add quotations in expressions only, not pattern *) - Quotation.add "constr" Quotation.DynAst.expr_tag expand_constr_quot_expr; - Quotation.add "tactic" Quotation.DynAst.expr_tag expand_tactic_quot_expr; - Quotation.default := "constr" - -END diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4 deleted file mode 100644 index 947e7e54..00000000 --- a/parsing/q_util.ml4 +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let e1 = f e1 in - let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in - <:expr< [$e1$ :: $e2$] >>) - l (let loc = dummy_loc in <:expr< [] >>) - -let mlexpr_of_pair m1 m2 (a1,a2) = - let e1 = m1 a1 and e2 = m2 a2 in - let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in - <:expr< ($e1$, $e2$) >> - -let mlexpr_of_triple m1 m2 m3 (a1,a2,a3)= - let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 in - let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e3) in - <:expr< ($e1$, $e2$, $e3$) >> - -let mlexpr_of_quadruple m1 m2 m3 m4 (a1,a2,a3,a4)= - let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 and e4 = m4 a4 in - let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e4) in - <:expr< ($e1$, $e2$, $e3$, $e4$) >> - -(* We don't give location for tactic quotation! *) -let loc = dummy_loc - - -let mlexpr_of_bool = function - | true -> <:expr< True >> - | false -> <:expr< False >> - -let mlexpr_of_int n = <:expr< $int:string_of_int n$ >> - -let mlexpr_of_string s = <:expr< $str:s$ >> - -let mlexpr_of_option f = function - | None -> <:expr< None >> - | Some e -> <:expr< Some $f e$ >> - -open Vernacexpr -open Genarg - -let rec mlexpr_of_prod_entry_key = function - | Pcoq.Alist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Alist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Pcoq.Alist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Alist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Pcoq.Aopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Amodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Aself -> <:expr< Pcoq.Aself >> - | Pcoq.Anext -> <:expr< Pcoq.Anext >> - | Pcoq.Atactic n -> <:expr< Pcoq.Atactic $mlexpr_of_int n$ >> - | Pcoq.Agram s -> Util.anomaly "Agram not supported" - | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Agram (Pcoq.Gram.Entry.obj $lid:s$) >> - | Pcoq.Aentry (u,s) -> <:expr< Pcoq.Aentry $str:u$ $str:s$ >> diff --git a/parsing/q_util.mli b/parsing/q_util.mli deleted file mode 100644 index babbfb8a..00000000 --- a/parsing/q_util.mli +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* MLast.expr) -> 'a list -> MLast.expr - -val mlexpr_of_pair : - ('a -> MLast.expr) -> ('b -> MLast.expr) - -> 'a * 'b -> MLast.expr - -val mlexpr_of_triple : - ('a -> MLast.expr) -> ('b -> MLast.expr) -> ('c -> MLast.expr) - -> 'a * 'b * 'c -> MLast.expr - -val mlexpr_of_quadruple : - ('a -> MLast.expr) -> ('b -> MLast.expr) -> - ('c -> MLast.expr) -> ('d -> MLast.expr) -> 'a * 'b * 'c * 'd -> MLast.expr - -val mlexpr_of_bool : bool -> MLast.expr - -val mlexpr_of_int : int -> MLast.expr - -val mlexpr_of_string : string -> MLast.expr - -val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr - -val mlexpr_of_prod_entry_key : Pcoq.prod_entry_key -> MLast.expr diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 deleted file mode 100644 index 7bcd1cf2..00000000 --- a/parsing/tacextend.ml4 +++ /dev/null @@ -1,238 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <:patt< [] >> - | GramNonTerminal(loc',_,_,Some p)::l -> - let p = Names.string_of_id p in - <:patt< [ $lid:p$ :: $make_patt l$ ] >> - | _::l -> make_patt l - -let rec make_when loc = function - | [] -> <:expr< True >> - | GramNonTerminal(loc',t,_,Some p)::l -> - let p = Names.string_of_id p in - let l = make_when loc l in - let loc = join_loc loc' loc in - let t = mlexpr_of_argtype loc' t in - <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >> - | _::l -> make_when loc l - -let rec make_let e = function - | [] -> e - | GramNonTerminal(loc,t,_,Some p)::l -> - let p = Names.string_of_id p in - let loc = join_loc loc (MLast.loc_of_expr e) in - let e = make_let e l in - let v = <:expr< Genarg.out_gen $make_wit loc t$ $lid:p$ >> in - <:expr< let $lid:p$ = $v$ in $e$ >> - | _::l -> make_let e l - -let rec extract_signature = function - | [] -> [] - | GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l - | _::l -> extract_signature l - -let check_unicity s l = - let l' = List.map (fun (l,_) -> extract_signature l) l in - if not (Util.list_distinct l') then - Pp.warning_with !Pp_control.err_ft - ("Two distinct rules of tactic entry "^s^" have the same\n"^ - "non-terminals in the same order: put them in distinct tactic entries") - -let make_clause (pt,e) = - (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr e) pt)), - make_let e pt) - -let make_fun_clauses loc s l = - check_unicity s l; - Compat.make_fun loc (List.map make_clause l) - -let rec make_args = function - | [] -> <:expr< [] >> - | GramNonTerminal(loc,t,_,Some p)::l -> - let p = Names.string_of_id p in - <:expr< [ Genarg.in_gen $make_wit loc t$ $lid:p$ :: $make_args l$ ] >> - | _::l -> make_args l - -let rec make_eval_tactic e = function - | [] -> e - | GramNonTerminal(loc,tag,_,Some p)::l when is_tactic_genarg tag -> - let p = Names.string_of_id p in - let loc = join_loc loc (MLast.loc_of_expr e) in - let e = make_eval_tactic e l in - <:expr< let $lid:p$ = $lid:p$ in $e$ >> - | _::l -> make_eval_tactic e l - -let rec make_fun e = function - | [] -> e - | GramNonTerminal(loc,_,_,Some p)::l -> - let p = Names.string_of_id p in - <:expr< fun $lid:p$ -> $make_fun e l$ >> - | _::l -> make_fun e l - -let mlexpr_terminals_of_grammar_tactic_prod_item_expr = function - | GramTerminal s -> <:expr< Some $mlexpr_of_string s$ >> - | GramNonTerminal (loc,nt,_,sopt) -> <:expr< None >> - -let make_prod_item = function - | GramTerminal s -> <:expr< Egrammar.GramTerminal $str:s$ >> - | GramNonTerminal (loc,nt,g,sopt) -> - <:expr< Egrammar.GramNonTerminal $default_loc$ $mlexpr_of_argtype loc nt$ - $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >> - -let mlexpr_of_clause = - mlexpr_of_list (fun (a,b) -> mlexpr_of_list make_prod_item a) - -let rec make_tags loc = function - | [] -> <:expr< [] >> - | GramNonTerminal(loc',t,_,Some p)::l -> - let l = make_tags loc l in - let loc = join_loc loc' loc in - let t = mlexpr_of_argtype loc' t in - <:expr< [ $t$ :: $l$ ] >> - | _::l -> make_tags loc l - -let make_one_printing_rule se (pt,e) = - let level = mlexpr_of_int 0 in (* only level 0 supported here *) - let loc = MLast.loc_of_expr e in - let prods = mlexpr_of_list mlexpr_terminals_of_grammar_tactic_prod_item_expr pt in - <:expr< ($se$, $make_tags loc pt$, ($level$, $prods$)) >> - -let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se) - -let rec possibly_empty_subentries loc = function - | [] -> [] - | (s,prodsl) :: l -> - let rec aux = function - | [] -> (false,<:expr< None >>) - | prods :: rest -> - try - let l = List.map (function - | GramNonTerminal(_,(List0ArgType _| - OptArgType _| - ExtraArgType _ as t),_,_)-> - (* This possibly parses epsilon *) - let rawwit = make_rawwit loc t in - <:expr< match Genarg.default_empty_value $rawwit$ with - [ None -> failwith "" - | Some v -> - Tacinterp.intern_genarg Tacinterp.fully_empty_glob_sign - (Genarg.in_gen $rawwit$ v) ] >> - | GramTerminal _ | GramNonTerminal(_,_,_,_) -> - (* This does not parse epsilon (this Exit is static time) *) - raise Exit) prods in - if has_extraarg prods then - (true,<:expr< try Some $mlexpr_of_list (fun x -> x) l$ - with [ Failure "" -> $snd (aux rest)$ ] >>) - else - (true, <:expr< Some $mlexpr_of_list (fun x -> x) l$ >>) - with Exit -> aux rest in - let (nonempty,v) = aux prodsl in - if nonempty then (s,v) :: possibly_empty_subentries loc l - else possibly_empty_subentries loc l - -let possibly_atomic loc prods = - let l = list_map_filter (function - | GramTerminal s :: l, _ -> Some (s,l) - | _ -> None) prods in - possibly_empty_subentries loc (list_factorize_left l) - -let declare_tactic loc s cl = - let se = mlexpr_of_string s in - let pp = make_printing_rule se cl in - let gl = mlexpr_of_clause cl in - let hide_tac (p,e) = - (* reste a definir les fonctions cachees avec des noms frais *) - let stac = "h_"^s in - let e = - make_fun - <:expr< - Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$ - >> - p in - <:str_item< value $lid:stac$ = $e$ >> - in - let hidden = if List.length cl = 1 then List.map hide_tac cl else [] in - let atomic_tactics = - mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x)) - (possibly_atomic loc cl) in - declare_str_items loc - (hidden @ - [ <:str_item< do { - try - let _=Tacinterp.add_tactic $se$ $make_fun_clauses loc s cl$ in - List.iter - (fun (s,l) -> match l with - [ Some l -> - Tacinterp.add_primitive_tactic s - (Tacexpr.TacAtom($default_loc$, - Tacexpr.TacExtend($default_loc$,$se$,l))) - | None -> () ]) - $atomic_tactics$ - with [ e when Errors.noncritical e -> - Pp.msg_warning - (Stream.iapp - (Pp.str ("Exception in tactic extend " ^ $se$ ^": ")) - (Errors.print e)) ]; - Egrammar.extend_tactic_grammar $se$ $gl$; - List.iter Pptactic.declare_extra_tactic_pprule $pp$; } >> - ]) - -open Pcaml -open PcamlSig - -EXTEND - GLOBAL: str_item; - str_item: - [ [ "TACTIC"; "EXTEND"; s = tac_name; - OPT "|"; l = LIST1 tacrule SEP "|"; - "END" -> - declare_tactic loc s l ] ] - ; - tacrule: - [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]" - -> - if match List.hd l with GramNonTerminal _ -> true | _ -> false then - (* En attendant la syntaxe de tacticielles *) - failwith "Tactic syntax must start with an identifier"; - (l,e) - ] ] - ; - tacargs: - [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name false None e "" in - GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) - | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let t, g = interp_entry_name false None e sep in - GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) - | s = STRING -> - if s = "" then Util.user_err_loc (loc,"",Pp.str "Empty terminal."); - GramTerminal s - ] ] - ; - tac_name: - [ [ s = LIDENT -> s - | s = UIDENT -> s - ] ] - ; - END - diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml deleted file mode 100644 index 9355a2a5..00000000 --- a/parsing/tactic_printer.ml +++ /dev/null @@ -1,172 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - (*top tactic from tacinterp*) - Pptactic.pr_glob_tactic (Global.env()) t - | t -> - Pptactic.pr_tactic (Global.env()) t - -let pr_rule = function - | Prim r -> hov 0 (pr_prim_rule r) - | Nested(cmpd,_) -> - begin - match cmpd with - | Tactic (texp,_) -> hov 0 (pr_tactic texp) - end - | Daimon -> str "" - | Decl_proof _ -> str "proof" - -let uses_default_tac = function - | Nested(Tactic(_,dflt),_) -> dflt - | _ -> false - -(* Does not print change of evars *) -let pr_rule_dot = function - | Prim Change_evars ->str "PC: ch_evars" ++ mt () - (* PC: this might be redundant *) - | r -> - pr_rule r ++ if uses_default_tac r then str "..." else str"." - -let pr_rule_dot_fnl = function - | Nested (Tactic (TacAtom (_,(TacMutualFix (true,_,_,_) - | TacMutualCofix (true,_,_))),_),_) -> - (* Very big hack to not display hidden tactics in "Theorem with" *) - (* (would not scale!) *) - mt () - | Prim Change_evars -> mt () - | r -> pr_rule_dot r ++ fnl () - -exception Different - -let rec print_proof sigma osign pf = - (* spiwack: [osign] is currently ignored, not sure if this function is even used. *) - let hyps = Environ.named_context_of_val (Goal.V82.hyps sigma pf.goal) in - match pf.ref with - | None -> - hov 0 (pr_goal {sigma = sigma; it=pf.goal }) - | Some(r,spfl) -> - hov 0 - (hov 0 (pr_goal {sigma = sigma; it=pf.goal }) ++ - spc () ++ str" BY " ++ - hov 0 (pr_rule r) ++ fnl () ++ - str" " ++ - hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl)) - -let pr_change sigma gl = - str"change " ++ - pr_lconstr_env (Goal.V82.env sigma gl) (Goal.V82.concl sigma gl) ++ str"." - -let print_decl_script tac_printer ?(nochange=true) sigma pf = - let rec print_prf pf = - match pf.ref with - | None -> - (if nochange then - (str"") - else - pr_change sigma pf.goal) - ++ fnl () - | Some (Daimon,[]) -> str "(* Some proof has been skipped here *)" - | Some (Prim Change_evars,[subpf]) -> print_prf subpf - | _ -> anomaly "Not Applicable" in - print_prf pf - -let print_script ?(nochange=true) sigma pf = - let rec print_prf pf = - match pf.ref with - | None -> - (if nochange then - (str"") - else - pr_change sigma pf.goal) - ++ fnl () - | Some(Decl_proof opened,script) -> - assert (List.length script = 1); - begin - if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ()) - end ++ - begin - hov 0 (str "proof." ++ fnl () ++ - print_decl_script print_prf - ~nochange sigma (List.hd script)) - end ++ fnl () ++ - begin - if opened then mt () else (str "end proof." ++ fnl ()) - end - | Some(Daimon,spfl) -> - ((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++ - prlist_with_sep pr_fnl print_prf spfl ) - | Some(rule,spfl) -> - ((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++ - pr_rule_dot_fnl rule ++ - prlist_with_sep pr_fnl print_prf spfl ) in - print_prf pf - -(* printed by Show Script command *) - -let print_treescript ?(nochange=true) sigma pf = - let rec print_prf pf = - match pf.ref with - | None -> - if nochange then - str"" - else pr_change sigma pf.goal - | Some(Decl_proof opened,script) -> - assert (List.length script = 1); - begin - if nochange then mt () else pr_change sigma pf.goal ++ fnl () - end ++ - hov 0 - begin str "proof." ++ fnl () ++ - print_decl_script print_prf ~nochange sigma (List.hd script) - end ++ fnl () ++ - begin - if opened then mt () else (str "end proof." ++ fnl ()) - end - | Some(Daimon,spfl) -> - (if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++ - prlist_with_sep pr_fnl (print_script ~nochange sigma) spfl - | Some(r,spfl) -> - let indent = if List.length spfl >= 2 then 1 else 0 in - (if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++ - hv indent (pr_rule_dot_fnl r ++ prlist_with_sep fnl print_prf spfl) - in hov 0 (print_prf pf) - -let rec print_info_script sigma osign pf = - let sign = Goal.V82.hyps sigma pf.goal in - match pf.ref with - | None -> (mt ()) - | Some(r,spfl) -> - (pr_rule r ++ - match spfl with - | [pf1] -> - if pf1.ref = None then - (str "." ++ fnl ()) - else - (str";" ++ brk(1,3) ++ - print_info_script sigma - (Environ.named_context_of_val sign) pf1) - | _ -> (str"." ++ fnl () ++ - prlist_with_sep pr_fnl - (print_info_script sigma - (Environ.named_context_of_val sign)) spfl)) - -let format_print_info_script sigma osign pf = - hov 0 (print_info_script sigma osign pf) - - diff --git a/parsing/tactic_printer.mli b/parsing/tactic_printer.mli deleted file mode 100644 index 2348706f..00000000 --- a/parsing/tactic_printer.mli +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* named_context -> proof_tree -> std_ppcmds -val pr_rule : rule -> std_ppcmds -val pr_tactic : tactic_expr -> std_ppcmds -val print_script : - ?nochange:bool -> evar_map -> proof_tree -> std_ppcmds -val print_treescript : - ?nochange:bool -> evar_map -> proof_tree -> std_ppcmds diff --git a/parsing/tok.ml b/parsing/tok.ml index 5b9aed6d..efd57968 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* CString.equal s1 s2 +| METAIDENT s1, METAIDENT s2 -> CString.equal s1 s2 +| PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2 +| IDENT s1, IDENT s2 -> CString.equal s1 s2 +| FIELD s1, FIELD s2 -> CString.equal s1 s2 +| INT s1, INT s2 -> CString.equal s1 s2 +| STRING s1, STRING s2 -> CString.equal s1 s2 +| LEFTQMARK, LEFTQMARK -> true +| BULLET s1, BULLET s2 -> CString.equal s1 s2 +| EOI, EOI -> true +| _ -> false + let extract_string = function | KEYWORD s -> s | IDENT s -> s @@ -28,6 +42,7 @@ let extract_string = function | FIELD s -> s | INT s -> s | LEFTQMARK -> "?" + | BULLET s -> s | EOI -> "" let to_string = function @@ -39,13 +54,16 @@ let to_string = function | INT s -> Format.sprintf "INT %s" s | STRING s -> Format.sprintf "STRING %S" s | LEFTQMARK -> "LEFTQMARK" + | BULLET s -> Format.sprintf "STRING %S" s | EOI -> "EOI" let match_keyword kwd = function | KEYWORD kwd' when kwd = kwd' -> true | _ -> false -let print ppf tok = Format.fprintf ppf "%s" (to_string tok) +(* Needed to fix Camlp4 signature. + Cannot use Pp because of silly Tox -> Compat -> Pp dependency *) +let print ppf tok = Format.pp_print_string ppf (to_string tok) (** For camlp5, conversion from/to [Plexing.pattern], and a match function analoguous to [Plexing.default_match] *) @@ -59,6 +77,7 @@ let of_pattern = function | "INT", s -> INT s | "STRING", s -> STRING s | "LEFTQMARK", _ -> LEFTQMARK + | "BULLET", s -> BULLET s | "EOI", _ -> EOI | _ -> failwith "Tok.of_pattern: not a constructor" @@ -71,6 +90,7 @@ let to_pattern = function | INT s -> "INT", s | STRING s -> "STRING", s | LEFTQMARK -> "LEFTQMARK", "" + | BULLET s -> "BULLET", s | EOI -> "EOI", "" let match_pattern = @@ -84,7 +104,8 @@ let match_pattern = | "INT", "" -> (function INT s -> s | _ -> err ()) | "STRING", "" -> (function STRING s -> s | _ -> err ()) | "LEFTQMARK", "" -> (function LEFTQMARK -> "" | _ -> err ()) + | "BULLET", "" -> (function BULLET s -> s | _ -> err ()) | "EOI", "" -> (function EOI -> "" | _ -> err ()) | pat -> let tok = of_pattern pat in - function tok' -> if tok = tok' then snd pat else err () + function tok' -> if equal tok tok' then snd pat else err () diff --git a/parsing/tok.mli b/parsing/tok.mli index 50a51198..feee1983 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string val to_string : t -> string +(* Needed to fit Camlp4 signature *) val print : Format.formatter -> t -> unit val match_keyword : string -> t -> bool (** for camlp5 *) diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 deleted file mode 100644 index 1df5fbbd..00000000 --- a/parsing/vernacextend.ml4 +++ /dev/null @@ -1,105 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* e - | GramNonTerminal(loc,t,_,Some p)::l -> - let p = Names.string_of_id p in - let loc = join_loc loc (MLast.loc_of_expr e) in - let e = make_let e l in - <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> - | _::l -> make_let e l - -let check_unicity s l = - let l' = List.map (fun (_,l,_) -> extract_signature l) l in - if not (Util.list_distinct l') then - Pp.warning_with !Pp_control.err_ft - ("Two distinct rules of entry "^s^" have the same\n"^ - "non-terminals in the same order: put them in distinct vernac entries") - -let make_clause (_,pt,e) = - (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr e) pt)), - make_let e pt) - -let make_fun_clauses loc s l = - check_unicity s l; - Compat.make_fun loc (List.map make_clause l) - -let mlexpr_of_clause = - mlexpr_of_list - (fun (a,b,c) -> mlexpr_of_list make_prod_item - (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b)) - -let declare_command loc s nt cl = - let se = mlexpr_of_string s in - let gl = mlexpr_of_clause cl in - let funcl = make_fun_clauses loc s cl in - declare_str_items loc - [ <:str_item< do { - try Vernacinterp.vinterp_add $se$ $funcl$ - with [ e when Errors.noncritical e -> - Pp.msg_warning - (Stream.iapp - (Pp.str ("Exception in vernac extend " ^ $se$ ^": ")) - (Errors.print e)) ]; - Egrammar.extend_vernac_command_grammar $se$ $nt$ $gl$ - } >> ] - -open Pcaml -open PcamlSig - -EXTEND - GLOBAL: str_item; - str_item: - [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT; - OPT "|"; l = LIST1 rule SEP "|"; - "END" -> - declare_command loc s <:expr> l - | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT; - OPT "|"; l = LIST1 rule SEP "|"; - "END" -> - declare_command loc s <:expr> l ] ] - ; - (* spiwack: comment-by-guessing: it seems that the isolated string (which - otherwise could have been another argument) is not passed to the - VernacExtend interpreter function to discriminate between the clauses. *) - rule: - [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]" - -> - if s = "" then Util.user_err_loc (loc,"",Pp.str"Command name is empty."); - (Some s,l,<:expr< fun () -> $e$ >>) - | "[" ; "-" ; l = LIST1 args ; "]" ; "->" ; "[" ; e = Pcaml.expr ; "]" -> - (None,l,<:expr< fun () -> $e$ >>) - ] ] - ; - args: - [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name false None e "" in - GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) - | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let t, g = interp_entry_name false None e sep in - GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) - | s = STRING -> - GramTerminal s - ] ] - ; - END -;; -- cgit v1.2.3