From 6b649aba925b6f7462da07599fe67ebb12a3460e Mon Sep 17 00:00:00 2001 From: Samuel Mimram Date: Wed, 28 Jul 2004 21:54:47 +0000 Subject: Imported Upstream version 8.0pl1 --- parsing/argextend.ml4 | 289 ++++++++++++++++ parsing/ast.ml | 600 +++++++++++++++++++++++++++++++++ parsing/ast.mli | 123 +++++++ parsing/coqast.ml | 123 +++++++ parsing/coqast.mli | 51 +++ parsing/egrammar.ml | 479 +++++++++++++++++++++++++++ parsing/egrammar.mli | 54 +++ parsing/esyntax.ml | 276 ++++++++++++++++ parsing/esyntax.mli | 63 ++++ parsing/extend.ml | 378 +++++++++++++++++++++ parsing/extend.mli | 153 +++++++++ parsing/g_basevernac.ml4 | 524 +++++++++++++++++++++++++++++ parsing/g_cases.ml4 | 73 +++++ parsing/g_constr.ml4 | 368 +++++++++++++++++++++ parsing/g_constrnew.ml4 | 336 +++++++++++++++++++ parsing/g_ltac.ml4 | 213 ++++++++++++ parsing/g_ltacnew.ml4 | 189 +++++++++++ parsing/g_minicoq.ml4 | 175 ++++++++++ parsing/g_minicoq.mli | 31 ++ parsing/g_module.ml4 | 47 +++ parsing/g_natsyntax.ml | 229 +++++++++++++ parsing/g_natsyntax.mli | 11 + parsing/g_natsyntaxnew.mli | 11 + parsing/g_prim.ml4 | 138 ++++++++ parsing/g_primnew.ml4 | 84 +++++ parsing/g_proofs.ml4 | 135 ++++++++ parsing/g_proofsnew.ml4 | 126 +++++++ parsing/g_rsyntax.ml | 332 +++++++++++++++++++ parsing/g_tactic.ml4 | 367 +++++++++++++++++++++ parsing/g_tacticnew.ml4 | 401 ++++++++++++++++++++++ parsing/g_vernac.ml4 | 524 +++++++++++++++++++++++++++++ parsing/g_vernacnew.ml4 | 729 ++++++++++++++++++++++++++++++++++++++++ parsing/g_zsyntax.ml | 406 +++++++++++++++++++++++ parsing/g_zsyntax.mli | 11 + parsing/g_zsyntaxnew.mli | 11 + parsing/lexer.ml4 | 539 ++++++++++++++++++++++++++++++ parsing/lexer.mli | 50 +++ parsing/pcoq.ml4 | 803 +++++++++++++++++++++++++++++++++++++++++++++ parsing/pcoq.mli | 192 +++++++++++ parsing/ppconstr.ml | 388 ++++++++++++++++++++++ parsing/ppconstr.mli | 41 +++ parsing/pptactic.ml | 758 ++++++++++++++++++++++++++++++++++++++++++ parsing/pptactic.mli | 84 +++++ parsing/prettyp.ml | 605 ++++++++++++++++++++++++++++++++++ parsing/prettyp.mli | 64 ++++ parsing/printer.ml | 249 ++++++++++++++ parsing/printer.mli | 60 ++++ parsing/printmod.ml | 133 ++++++++ parsing/printmod.mli | 17 + parsing/q_coqast.ml4 | 567 ++++++++++++++++++++++++++++++++ parsing/q_util.ml4 | 68 ++++ parsing/q_util.mli | 30 ++ parsing/search.ml | 224 +++++++++++++ parsing/search.mli | 49 +++ parsing/tacextend.ml4 | 283 ++++++++++++++++ parsing/termast.ml | 503 ++++++++++++++++++++++++++++ parsing/termast.mli | 55 ++++ parsing/vernacextend.ml4 | 162 +++++++++ 58 files changed, 13984 insertions(+) create mode 100644 parsing/argextend.ml4 create mode 100755 parsing/ast.ml create mode 100755 parsing/ast.mli create mode 100644 parsing/coqast.ml create mode 100644 parsing/coqast.mli create mode 100644 parsing/egrammar.ml create mode 100644 parsing/egrammar.mli create mode 100644 parsing/esyntax.ml create mode 100644 parsing/esyntax.mli create mode 100644 parsing/extend.ml create mode 100644 parsing/extend.mli create mode 100644 parsing/g_basevernac.ml4 create mode 100644 parsing/g_cases.ml4 create mode 100644 parsing/g_constr.ml4 create mode 100644 parsing/g_constrnew.ml4 create mode 100644 parsing/g_ltac.ml4 create mode 100644 parsing/g_ltacnew.ml4 create mode 100644 parsing/g_minicoq.ml4 create mode 100644 parsing/g_minicoq.mli create mode 100644 parsing/g_module.ml4 create mode 100644 parsing/g_natsyntax.ml create mode 100644 parsing/g_natsyntax.mli create mode 100644 parsing/g_natsyntaxnew.mli create mode 100644 parsing/g_prim.ml4 create mode 100644 parsing/g_primnew.ml4 create mode 100644 parsing/g_proofs.ml4 create mode 100644 parsing/g_proofsnew.ml4 create mode 100644 parsing/g_rsyntax.ml create mode 100644 parsing/g_tactic.ml4 create mode 100644 parsing/g_tacticnew.ml4 create mode 100644 parsing/g_vernac.ml4 create mode 100644 parsing/g_vernacnew.ml4 create mode 100644 parsing/g_zsyntax.ml create mode 100644 parsing/g_zsyntax.mli create mode 100644 parsing/g_zsyntaxnew.mli create mode 100644 parsing/lexer.ml4 create mode 100644 parsing/lexer.mli create mode 100644 parsing/pcoq.ml4 create mode 100644 parsing/pcoq.mli create mode 100644 parsing/ppconstr.ml create mode 100644 parsing/ppconstr.mli create mode 100644 parsing/pptactic.ml create mode 100644 parsing/pptactic.mli create mode 100644 parsing/prettyp.ml create mode 100644 parsing/prettyp.mli create mode 100644 parsing/printer.ml create mode 100644 parsing/printer.mli create mode 100644 parsing/printmod.ml create mode 100644 parsing/printmod.mli create mode 100644 parsing/q_coqast.ml4 create mode 100644 parsing/q_util.ml4 create mode 100644 parsing/q_util.mli create mode 100644 parsing/search.ml create mode 100644 parsing/search.mli create mode 100644 parsing/tacextend.ml4 create mode 100644 parsing/termast.ml create mode 100644 parsing/termast.mli create mode 100644 parsing/vernacextend.ml4 (limited to 'parsing') diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 new file mode 100644 index 00000000..5fa781ad --- /dev/null +++ b/parsing/argextend.ml4 @@ -0,0 +1,289 @@ +(************************************************************************) +(* 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 -> <:expr< Genarg.rawwit_ident >> + | HypArgType -> <: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 >> + | TacticArgType -> <:expr< Genarg.rawwit_tactic >> + | RedExprArgType -> <:expr< Genarg.rawwit_red_expr >> + | CastedOpenConstrArgType -> <:expr< Genarg.rawwit_casted_open_constr >> + | 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< $lid:"rawwit_"^s$ >> + +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 -> <:expr< Genarg.globwit_ident >> + | HypArgType -> <: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 >> + | TacticArgType -> <:expr< Genarg.globwit_tactic >> + | RedExprArgType -> <:expr< Genarg.globwit_red_expr >> + | CastedOpenConstrArgType -> <:expr< Genarg.globwit_casted_open_constr >> + | 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< $lid:"globwit_"^s$ >> + +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 -> <:expr< Genarg.wit_ident >> + | HypArgType -> <: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 >> + | TacticArgType -> <:expr< Genarg.wit_tactic >> + | RedExprArgType -> <:expr< Genarg.wit_red_expr >> + | CastedOpenConstrArgType -> <:expr< Genarg.wit_casted_open_constr >> + | 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< $lid:"wit_"^s$ >> + +let make_act loc act pil = + let rec make = function + | [] -> <:expr< Gramext.action (fun loc -> ($act$ : 'a)) >> + | None :: tl -> <:expr< Gramext.action (fun _ -> $make tl$) >> + | Some (p, t) :: tl -> + <:expr< + Gramext.action + (fun $lid:p$ -> let _ = in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) + >> in + make (List.rev pil) + +let make_rule loc (prods,act) = + let (symbs,pil) = List.split prods in + <:expr< ($mlexpr_of_list (fun x -> x) symbs$,$make_act loc act pil$) >> + +let declare_tactic_argument for_v8 loc s typ pr f g h rawtyppr globtyppr cl = + let interp = match f with + | None -> <:expr< Tacinterp.interp_genarg >> + | Some f -> <:expr< $lid:f$>> in + let glob = match g with + | None -> <:expr< Tacinterp.intern_genarg >> + | Some f -> <:expr< $lid:f$>> in + let substitute = match h with + | None -> <:expr< Tacinterp.subst_genarg >> + | Some f -> <:expr< $lid:f$>> in + let rawtyp, rawpr = match rawtyppr with + | None -> typ,pr + | Some (t,p) -> t,p in + let globtyp, globpr = match globtyppr with + | None -> typ,pr + | Some (t,p) -> t,p 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 + <:str_item< + declare + value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) = + Genarg.create_arg $se$; + value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$; + Tacinterp.add_interp_genarg $se$ + ((fun e x -> + (in_gen $globwit$ + (out_gen $make_globwit loc typ$ + ($glob$ e + (in_gen $make_rawwit loc rawtyp$ + (out_gen $rawwit$ x)))))), + (fun ist gl x -> + (in_gen $wit$ + (out_gen $make_wit loc typ$ + ($interp$ ist gl + (in_gen $make_globwit loc rawtyp$ + (out_gen $globwit$ x)))))), + (fun subst x -> + (in_gen $globwit$ + (out_gen $make_globwit loc typ$ + ($substitute$ subst + (in_gen $make_globwit loc rawtyp$ + (out_gen $globwit$ x))))))); + Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None + [(None, None, $rules$)]; + Pptactic.declare_extra_genarg_pprule + $mlexpr_of_bool for_v8$ + ($rawwit$, $lid:rawpr$) + ($globwit$, $lid:globpr$) + ($wit$, $lid:pr$); + end + >> + +let declare_vernac_argument for_v8 loc s cl = + let se = mlexpr_of_string s in + let typ = ExtraArgType s in + let rawwit = <:expr< $lid:"rawwit_"^s$ >> in + let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in + <:str_item< + declare + value $lid:"rawwit_"^s$ = let (_,_,x) = Genarg.create_arg $se$ in x; + value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$; + Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None + [(None, None, $rules$)]; + end + >> + +open Vernacexpr +open Pcoq + +let rec interp_entry_name loc s = + let l = String.length s in + if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in + List1ArgType t, <:expr< Gramext.Slist1 $g$ >> + else if l > 5 & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in + List0ArgType t, <:expr< Gramext.Slist0 $g$ >> + else if l > 4 & String.sub s (l-4) 4 = "_opt" then + let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in + OptArgType t, <:expr< Gramext.Sopt $g$ >> + else + let t, se = + match Pcoq.entry_type (Pcoq.get_univ "prim") s with + | Some _ as x -> x, <:expr< Prim. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "constr") s with + | Some _ as x -> x, <:expr< Constr. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "tactic") s with + | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> + | None -> None, <:expr< $lid:s$ >> in + let t = + match t with + | Some t -> t + | None -> +(* Pp.warning_with Pp_control.err_ft + ("Unknown primitive grammar entry: "^s);*) + ExtraArgType s + in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> + +open Pcaml + +EXTEND + GLOBAL: str_item; + str_item: + [ [ "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; + "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 ]; + rawtyppr = + (* Necessary if the globalized type is different from the final type *) + OPT [ "RAW_TYPED"; "AS"; t = argtype; + "RAW_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; + globtyppr = + OPT [ "GLOB_TYPED"; "AS"; t = argtype; + "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; + OPT "|"; l = LIST1 argrule SEP "|"; + "END" -> + if String.capitalize s = s then + failwith "Argument entry names must be lowercase"; + declare_tactic_argument true loc s typ pr f g h rawtyppr globtyppr l + | "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; + OPT "|"; l = LIST1 argrule SEP "|"; + "END" -> + if String.capitalize s = s then + failwith "Argument entry names must be lowercase"; + declare_vernac_argument true loc s l + | "V7"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; + "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 ]; + rawtyppr = + OPT [ "GLOB_TYPED"; "AS"; t = argtype; + "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; + globtyppr = + OPT [ "GLOB_TYPED"; "AS"; t = argtype; + "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; + OPT "|"; l = LIST1 argrule SEP "|"; + "END" -> + if String.capitalize s = s then + failwith "Argument entry names must be lowercase"; + declare_tactic_argument false loc s typ pr f g h rawtyppr globtyppr l + | "V7"; "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; + OPT "|"; l = LIST1 argrule SEP "|"; + "END" -> + if String.capitalize s = s then + failwith "Argument entry names must be lowercase"; + declare_vernac_argument false loc s l ] ] + ; + argtype: + [ [ e = LIDENT -> fst (interp_entry_name loc e) + | e1 = LIDENT; "*"; e2 = LIDENT -> + let e1 = fst (interp_entry_name loc e1) in + let e2 = fst (interp_entry_name loc e2) in + PairArgType (e1, e2) ] ] + ; + argrule: + [ [ "["; l = LIST0 genarg; "]"; "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ] + ; + genarg: + [ [ e = LIDENT; "("; s = LIDENT; ")" -> + let t, g = interp_entry_name loc e in (g, Some (s,t)) + | s = STRING -> + if String.length s > 0 && Util.is_letter s.[0] then + Pcoq.lexer.Token.using ("", s); + (<:expr< (Gramext.Stoken (Extend.terminal $str:s$)) >>, None) + ] ] + ; + END + diff --git a/parsing/ast.ml b/parsing/ast.ml new file mode 100755 index 00000000..b2a30f9c --- /dev/null +++ b/parsing/ast.ml @@ -0,0 +1,600 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 0 & s.[0]='$' + +let loc = function + | Node (loc,_,_) -> loc + | Nvar (loc,_) -> loc + | Nmeta (loc,_) -> loc + | Slam (loc,_,_) -> loc + | Smetalam (loc,_,_) -> loc + | Num (loc,_) -> loc + | Id (loc,_) -> loc + | Str (loc,_) -> loc + | Path (loc,_) -> loc + | Dynamic (loc,_) -> loc + +(* patterns of ast *) +type astpat = + | Pquote of t + | Pmeta of string * tok_kind + | Pnode of string * patlist + | Pslam of identifier option * astpat + | Pmeta_slam of string * astpat + +and patlist = + | Pcons of astpat * patlist + | Plmeta of string + | Pnil + +and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist + +type pat = + | AstListPat of patlist + | PureAstPat of astpat + +(* building a node with dummy location *) + +let ope(op,l) = Node(dummy_loc,op,l) +let slam(idl,b) = Slam(dummy_loc,idl,b) +let ide s = Id(dummy_loc,s) +let nvar s = Nvar(dummy_loc,s) +let num n = Num(dummy_loc,n) +let string s = Str(dummy_loc,s) +let path sl = Path(dummy_loc,sl) +let dynamic d = Dynamic(dummy_loc,d) + +let rec set_loc loc = function + | Node(_,op,al) -> Node(loc, op, List.map (set_loc loc) al) + | Slam(_,idl,b) -> Slam(loc,idl, set_loc loc b) + | Smetalam(_,idl,b) -> Smetalam(loc,idl, set_loc loc b) + | Nvar(_,s) -> Nvar(loc,s) + | Nmeta(_,s) -> Nmeta(loc,s) + | Id(_,s) -> Id(loc,s) + | Str(_,s) -> Str(loc,s) + | Num(_,s) -> Num(loc,s) + | Path(_,sl) -> Path(loc,sl) + | Dynamic(_,d) -> Dynamic(loc,d) + +let path_section loc sp = Coqast.Path(loc, sp) + +let section_path sp = sp + +(* ast destructors *) +let num_of_ast = function + | Num(_,n) -> n + | ast -> invalid_arg_loc (loc ast, "Ast.num_of_ast") + +let nvar_of_ast = function + | Nvar(_,s) -> s + | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast") + +let meta_of_ast = function + | Nmeta(_,s) -> s + | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast") + +let id_of_ast = function + | Id(_,s) -> s + | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast") + +(* semantic actions of grammar rules *) +type act = + | Act of constr_expr + | ActCase of act * (pat * act) list + | ActCaseList of act * (pat * act) list + +(* values associated to variables *) +(* +type typed_ast = + | AstListNode of Coqast.t list + | PureAstNode of Coqast.t +*) +type typed_ast = + | AstListNode of Coqast.t list + | PureAstNode of Coqast.t + +type ast_action_type = ETast | ETastl + +type dynamic_grammar = + | ConstrNode of constr_expr + | CasesPatternNode of cases_pattern_expr + +type grammar_action = + | SimpleAction of loc * dynamic_grammar + | CaseAction of + loc * grammar_action * ast_action_type * (t list * grammar_action) list + +type env = (string * typed_ast) list + +let string_of_dirpath = function + | [] -> "" + | sl -> + String.concat "." (List.map string_of_id (List.rev sl)) + +let pr_id id = str (string_of_id id) + +let print_kn kn = + let (mp,dp,l) = repr_kn kn in + let dpl = repr_dirpath dp in + str (string_of_mp mp) ++ str "." ++ + prlist_with_sep (fun _ -> str".") pr_id dpl ++ + str (string_of_label l) + +(* Pretty-printing *) +let rec print_ast ast = + match ast with + | Num(_,n) -> int n + | Str(_,s) -> qs s + | Path(_,sl) -> print_kn sl + | Id (_,s) -> str "{" ++ str s ++ str "}" + | Nvar(_,s) -> pr_id s + | Nmeta(_,s) -> str s + | Node(_,op,l) -> + hov 3 (str "(" ++ str op ++ spc () ++ print_astl l ++ str ")") + | Slam(_,None,ast) -> hov 1 (str "[<>]" ++ print_ast ast) + | Slam(_,Some x,ast) -> + hov 1 + (str "[" ++ pr_id x ++ str "]" ++ cut () ++ + print_ast ast) + | Smetalam(_,id,ast) -> hov 1 (str id ++ print_ast ast) + | Dynamic(_,d) -> + hov 0 (str "") + +and print_astl astl = + prlist_with_sep pr_spc print_ast astl + +let print_ast_cast = function + | Tany -> (mt ()) + | Tvar -> (str":var") + | Tid -> (str":id") + | Tstr -> (str":str") + | Tpath -> (str":path") + | Tnum -> (str":num") + | Tlist -> (str":list") + +let rec print_astpat = function + | Pquote ast -> + str"'" ++ print_ast ast + | Pmeta(s,tk) -> + str s ++ print_ast_cast tk + | Pmeta_slam(s,b) -> + hov 1 (str "[" ++ str s ++ str"]" ++ cut () ++ print_astpat b) + | Pnode(op,al) -> + hov 2 (str"(" ++ str op ++ spc () ++ print_astlpat al ++ str")" ) + | Pslam(None,b) -> + hov 1 (str"[<" ++ cut () ++ print_astpat b) + | Pslam(Some id,b) -> + hov 1 + (str"[" ++ str(string_of_id id) ++ str"]" ++ cut () ++ print_astpat b) + +and print_astlpat = function + | Pnil -> mt () + | Pcons(h,Pnil) -> hov 1 (print_astpat h) + | Pcons(h,t) -> hov 1 (print_astpat h ++ spc () ++ print_astlpat t) + | Plmeta(s) -> str"| " ++ str s + + +let print_val = function + | PureAstNode a -> print_ast a + | AstListNode al -> + hov 1 (str"[" ++ prlist_with_sep pr_spc print_ast al ++ str"]") + +(* Ast values environments *) + +let grammar_type_error (loc,s) = + anomaly_loc (loc,s,(str"grammar type error: " ++ str s)) + + +(* Coercions enforced by the user *) +let check_cast loc a k = + match (k,a) with + | (Tany, _) -> () + | (Tid, Id _) -> () + | (Tvar, Nvar _) -> () + | (Tpath, Path _) -> () + | (Tstr, Str _) -> () + | (Tnum, Num _) -> () + | (Tlist, _) -> grammar_type_error (loc,"Ast.cast_val") + | _ -> user_err_loc (loc,"Ast.cast_val", + (str"cast _" ++ print_ast_cast k ++ str"failed")) + +let rec coerce_to_var = function + | Nvar(_,id) as var -> var + | Nmeta(_,id) as var -> var + | Node(_,"QUALID",[Nvar(_,id) as var]) -> var + | ast -> user_err_loc + (loc ast,"Ast.coerce_to_var", + (str"This expression should be a simple identifier")) + +let coerce_to_id_ast a = match coerce_to_var a with + | Nvar (_,id) -> id + | ast -> user_err_loc + (loc ast,"Ast.coerce_to_id", + str"This expression should be a simple identifier") + +let coerce_to_id = function + | CRef (Ident (loc,id)) -> (loc,id) + | a -> user_err_loc + (constr_loc a,"Ast.coerce_to_id", + str"This expression should be a simple identifier") + +let coerce_reference_to_id = function + | Ident (_,id) -> id + | Qualid (loc,_) -> + user_err_loc (loc, "Ast.coerce_reference_to_id", + str"This expression should be a simple identifier") + +let coerce_global_to_id = coerce_reference_to_id + +(* Pattern-matching on ast *) + +let env_assoc_value loc v env = + try + List.assoc v env + with Not_found -> + anomaly_loc + (loc,"Ast.env_assoc_value", + (str"metavariable " ++ str v ++ str" is unbound")) + +let env_assoc_list sigma (loc,v) = + match env_assoc_value loc v sigma with + | AstListNode al -> al + | PureAstNode a -> [a] + +let env_assoc sigma k (loc,v) = + match env_assoc_value loc v sigma with + | PureAstNode a -> check_cast loc a k; a + | _ -> grammar_type_error (loc,"Ast.env_assoc: "^v^" is an ast list") + +let env_assoc_nvars sigma (dloc,v) = + match env_assoc_value dloc v sigma with + | AstListNode al -> List.map coerce_to_id_ast al + | PureAstNode ast -> [coerce_to_id_ast ast] + +let build_lams dloc idl ast = + List.fold_right (fun id lam -> Slam(dloc,Some id,lam)) idl ast + +(* Alpha-conversion *) + +let rec alpha_var id1 id2 = function + | (i1,i2)::_ when i1=id1 -> i2 = id2 + | (i1,i2)::_ when i2=id2 -> i1 = id1 + | _::idl -> alpha_var id1 id2 idl + | [] -> id1 = id2 + +let rec alpha alp a1 a2 = + match (a1,a2) with + | (Node(_,op1,tl1),Node(_,op2,tl2)) -> + (op1 = op2) & (List.length tl1 = List.length tl2) + & (List.for_all2 (alpha alp) tl1 tl2) + | (Nvar(_,id1),Nvar(_,id2)) -> alpha_var id1 id2 alp + | (Slam(_,None,body1),Slam(_,None,body2)) -> alpha alp body1 body2 + | (Slam(_,Some s1,body1),Slam(_,Some s2,body2)) -> + alpha ((s1,s2)::alp) body1 body2 + | (Id(_,s1),Id(_,s2)) -> s1=s2 + | (Str(_,s1),Str(_,s2)) -> s1=s2 + | (Num(_,n1),Num(_,n2)) -> n1=n2 + | (Path(_,sl1),Path(_,sl2)) -> sl1=sl2 + | ((Smetalam _ | Nmeta _ | Dynamic _), _) -> false + | (_, (Smetalam _ | Nmeta _ | Dynamic _)) -> false + | _ -> false + +let alpha_eq (a1,a2)= alpha [] a1 a2 + +let alpha_eq_val (x,y) = x = y +(* +let alpha_eq_val = function + | (Vast a1, Vast a2) -> alpha_eq (a1,a2) + | (Vastlist al1, Vastlist al2) -> + (List.length al1 = List.length al2) + & List.for_all2 (fun x y -> alpha_eq (x,y)) al1 al2 + | _ -> false +*) + +exception No_match of string + +let no_match_loc (loc,s) = Stdpp.raise_with_loc loc (No_match s) + +(* Binds value v to variable var. If var is already bound, checks if + its value is alpha convertible with v. This allows non-linear patterns. + + Important note: The Metavariable $_ is a special case; it cannot be + bound, which is like _ in the ML matching. *) + +let bind_env sigma var v = + if var = "$_" then + sigma + else + try + let vvar = List.assoc var sigma in + if alpha_eq_val (v,vvar) then sigma + else raise (No_match "Ast.bind_env: values do not match") + with Not_found -> + (var,v)::sigma + +let bind_env_ast sigma var ast = + try + bind_env sigma var (PureAstNode ast) + with e -> + Stdpp.raise_with_loc (loc ast) e + +let alpha_define sigma loc ps s = + try + let _ = List.assoc ps sigma in sigma + with Not_found -> + if ps = "$_" then sigma else (ps, PureAstNode(Nvar(loc,s)))::sigma + + +(* Match an ast with an ast pattern. Returns the new environnement. *) + +let rec amatch alp sigma spat ast = + match (spat,ast) with + | (Pquote a, _) -> + if alpha alp a ast then + sigma + else + no_match_loc (loc ast,"quote does not match") + | (Pmeta(pv,Tany), _) -> bind_env_ast sigma pv ast + | (Pmeta(pv,Tvar), Nvar _) -> bind_env_ast sigma pv ast + | (Pmeta(pv,Tid), Id _) -> bind_env_ast sigma pv ast + | (Pmeta(pv,Tnum), Num _) -> bind_env_ast sigma pv ast + | (Pmeta(pv,Tstr), Str _) -> bind_env_ast sigma pv ast + | (Pmeta(pv,Tpath), Path _) -> bind_env_ast sigma pv ast + | (Pmeta(pv,Tlist),_) -> grammar_type_error (loc ast,"Ast.amatch") + | (Pmeta_slam(pv,pb), Slam(loc, Some s, b)) -> + amatch alp (bind_env_ast sigma pv (Nvar(loc,s))) pb b + | (Pmeta_slam(pv,pb), Slam(loc, None, b)) -> + amatch alp (bind_env_ast sigma pv (Nvar(loc,id_of_string "_"))) pb b + | (Pmeta_slam(pv,pb), Smetalam(loc, s, b)) -> + anomaly "amatch: match a pattern with an open ast" + | (Pnode(nodp,argp), Node(loc,op,args)) when nodp = op -> + (try amatchl alp sigma argp args + with e -> Stdpp.raise_with_loc loc e) + | (Pslam(None,bp), Slam(_,None,b)) -> amatch alp sigma bp b + | (Pslam(Some ps,bp), Slam(_,Some s,b)) -> amatch ((ps,s)::alp) sigma bp b + | _ -> no_match_loc (loc ast, "Ast.amatch") + +and amatchl alp sigma spatl astl = + match (spatl,astl) with + | (Pnil, []) -> sigma + | (Pcons(pat,patl), ast::asttl) -> + amatchl alp (amatch alp sigma pat ast) patl asttl + | (Plmeta pv, _) -> bind_env sigma pv (AstListNode astl) + | _ -> raise (No_match "Ast.amatchl") + +let ast_match = amatch [] + +let typed_ast_match env p a = match (p,a) with + | PureAstPat p, PureAstNode a -> amatch [] env p a + | AstListPat pl, AstListNode al -> amatchl [] env pl al + | _ -> failwith "Ast.typed_ast_match: TODO" + +let astl_match = amatchl [] + +let first_match pat_of_fun env ast sl = + let rec aux = function + | [] -> None + | h::t -> + (try Some (h, ast_match env (pat_of_fun h) ast) + with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t) + in + aux sl + +let find_all_matches pat_of_fun env ast sl = + let rec aux = function + | [] -> [] + | (h::t) -> + let l = aux t in + (try (h, ast_match env (pat_of_fun h) ast)::l + with (No_match _| Stdpp.Exc_located (_,No_match _)) -> l) + in + aux sl + +let first_matchl patl_of_fun env astl sl = + let rec aux = function + | [] -> None + | (h::t) -> + (try Some (h, astl_match env (patl_of_fun h) astl) + with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t) + in + aux sl + +let bind_patvar env loc v etyp = + try + if List.assoc v env = etyp then + env + else + user_err_loc + (loc,"Ast.bind_patvar", + (str"variable " ++ str v ++ + str" is bound several times with different types")) + with Not_found -> + if v="$_" then env else (v,etyp)::env + +let make_astvar env loc v cast = + let env' = bind_patvar env loc v ETast in + (Pmeta(v,cast), env') + +(* Note: no metavar in operator position. necessary ? *) +let rec pat_of_ast env ast = + match ast with + | Nmeta(loc,pv) -> make_astvar env loc pv Tany +(* Obsolète + | Id(loc,pv) when isMeta pv -> make_astvar env loc pv Tid +*) + | Smetalam(loc,s,a) -> + let senv = bind_patvar env loc s ETast in + let (pa,env') = pat_of_ast senv a in + (Pmeta_slam(s, pa), env') + | Node(_,"$VAR",[Nmeta(loc,pv)]) -> + make_astvar env loc pv Tvar + | Node(_,"$ID",[Nmeta(loc,pv)]) -> + make_astvar env loc pv Tid + | Node(_,"$NUM",[Nmeta(loc,pv)]) -> + make_astvar env loc pv Tnum + | Node(_,"$STR",[Nmeta(loc,pv)]) -> + make_astvar env loc pv Tstr + | Node(_,"$PATH",[Nmeta(loc,pv)]) -> + make_astvar env loc pv Tpath + | Node(_,"$QUOTE",[qast]) -> (Pquote (set_loc dummy_loc qast), env) + + (* This may occur when the meta is not textual but bound by coerce_to_id*) + | Slam(loc,Some id,b) when isMeta (string_of_id id) -> + let s = string_of_id id in + let senv = bind_patvar env loc s ETast in + let (pb,env') = pat_of_ast senv b in + (Pmeta_slam(s, pb), env') + + | Slam(_,os,b) -> + let (pb,env') = pat_of_ast env b in + (Pslam(os,pb), env') + | Node(loc,op,_) when isMeta op -> + user_err_loc(loc,"Ast.pat_of_ast", + (str"no patvar in operator position.")) + | Node(_,op,args) -> + let (pargs, env') = patl_of_astl env args in + (Pnode(op,pargs), env') +(* Compatibility with new parsing mode *) + | Nvar(loc,id) when (string_of_id id).[0] = '$' -> make_astvar env loc (string_of_id id) Tany + | (Path _|Num _|Id _|Str _ |Nvar _) -> (Pquote (set_loc dummy_loc ast), env) + | Dynamic(loc,_) -> + invalid_arg_loc(loc,"pat_of_ast: dynamic") + +and patl_of_astl env astl = + match astl with + | [Node(_,"$LIST",[Nmeta(loc,pv)])] -> + let penv = bind_patvar env loc pv ETastl in + (Plmeta pv, penv) + | [] -> (Pnil,env) + | ast::asttl -> + let (p1,env1) = pat_of_ast env ast in + let (ptl,env2) = patl_of_astl env1 asttl in + (Pcons (p1,ptl), env2) + +type entry_env = (string * ast_action_type) list + +let to_pat = pat_of_ast + +(* Substitution *) + +(* Locations in quoted ast are wrong (they refer to the right hand + side of a grammar rule). A default location dloc is used whenever + we create an ast constructor. Locations in the binding list are trusted. *) + +(* For old ast printer *) +let rec pat_sub dloc sigma pat = + match pat with + | Pmeta(pv,c) -> env_assoc sigma c (dloc,pv) + | Pmeta_slam(pv,p) -> + let idl = env_assoc_nvars sigma (dloc,pv) in + build_lams dloc idl (pat_sub dloc sigma p) + | Pquote a -> set_loc dloc a + | Pnode(op,pl) -> Node(dloc, op, patl_sub dloc sigma pl) + | Pslam(os,p) -> Slam(dloc, os, pat_sub dloc sigma p) + +and patl_sub dloc sigma pl = + match pl with + | Pnil -> + [] + | Plmeta pv -> + env_assoc_list sigma (dloc,pv) + | Pcons(Pmeta(pv,Tlist), ptl) -> + (env_assoc_list sigma (dloc,pv))@(patl_sub dloc sigma ptl) + | Pcons(p1,ptl) -> + (pat_sub dloc sigma p1)::(patl_sub dloc sigma ptl) + +(* Converting and checking free meta-variables *) + +(* For old ast printer *) +let type_of_meta env loc pv = + try + List.assoc pv env + with Not_found -> + user_err_loc (loc,"Ast.type_of_meta", + (str"variable " ++ str pv ++ str" is unbound")) + +(* For old ast printer *) +let check_ast_meta env loc pv = + match type_of_meta env loc pv with + | ETast -> () + | _ -> + user_err_loc (loc,"Ast.check_ast_meta", + (str"variable " ++ str pv ++ str" is not of ast type")) + +(* For old ast printer *) +let rec val_of_ast env = function + | Nmeta(loc,pv) -> + check_ast_meta env loc pv; + Pmeta(pv,Tany) + | Node(_,"$QUOTE",[qast]) -> Pquote (set_loc dummy_loc qast) + | Smetalam(loc,s,a) -> + let _ = type_of_meta env loc s in (* ids are coerced to id lists *) + Pmeta_slam(s, val_of_ast env a) + | (Path _|Num _|Id _|Str _|Nvar _ as ast) -> Pquote (set_loc dummy_loc ast) + | Slam(_,os,b) -> Pslam(os, val_of_ast env b) + | Node(loc,op,_) when isMeta op -> + user_err_loc(loc,"Ast.val_of_ast", + (str"no patvar in operator position.")) + | Node(_,op,args) -> Pnode(op, vall_of_astl env args) + | Dynamic(loc,_) -> + invalid_arg_loc(loc,"val_of_ast: dynamic") + +and vall_of_astl env = function + | (Node(loc,"$LIST",[Nmeta(locv,pv)]))::asttl -> + if type_of_meta env locv pv = ETastl then + if asttl = [] then + Plmeta pv + else + Pcons(Pmeta(pv,Tlist), vall_of_astl env asttl) + else + user_err_loc + (loc,"Ast.vall_of_astl", + str"variable " ++ str pv ++ str" is not a List") + | ast::asttl -> Pcons (val_of_ast env ast, vall_of_astl env asttl) + | [] -> Pnil + +(* For old ast printer *) +let rec occur_var_ast s = function + | Node(_,"QUALID",_::_::_) -> false + | Node(_,"QUALID",[Nvar(_,s2)]) -> s = s2 + | Nvar(_,s2) -> s = s2 + | Node(loc,op,args) -> List.exists (occur_var_ast s) args + | Smetalam _ | Nmeta _ -> anomaly "occur_var: metas should not occur here" + | Slam(_,sopt,body) -> (Some s <> sopt) & occur_var_ast s body + | Id _ | Str _ | Num _ | Path _ -> false + | Dynamic _ -> (* Hum... what to do here *) false + + +(**********************************************************************) +(* Object substitution in modules *) + +let rec subst_astpat subst = function + | Pquote a -> Pquote (subst_ast subst a) + | Pmeta _ as p -> p + | Pnode (s,pl) -> Pnode (s,subst_astpatlist subst pl) + | Pslam (ido,p) -> Pslam (ido,subst_astpat subst p) + | Pmeta_slam (s,p) -> Pmeta_slam (s,subst_astpat subst p) + +and subst_astpatlist subst = function + | Pcons (p,pl) -> Pcons (subst_astpat subst p, subst_astpatlist subst pl) + | (Plmeta _ | Pnil) as pl -> pl + +let subst_pat subst = function + | AstListPat pl -> AstListPat (subst_astpatlist subst pl) + | PureAstPat p -> PureAstPat (subst_astpat subst p) diff --git a/parsing/ast.mli b/parsing/ast.mli new file mode 100755 index 00000000..7bc0b607 --- /dev/null +++ b/parsing/ast.mli @@ -0,0 +1,123 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* loc + +(* ast constructors with dummy location *) +val ope : string * Coqast.t list -> Coqast.t +val slam : identifier option * Coqast.t -> Coqast.t +val nvar : identifier -> Coqast.t +val ide : string -> Coqast.t +val num : int -> Coqast.t +val string : string -> Coqast.t +val path : kernel_name -> Coqast.t +val dynamic : Dyn.t -> Coqast.t + +val set_loc : loc -> Coqast.t -> Coqast.t + +val path_section : loc -> kernel_name -> Coqast.t +val section_path : kernel_name -> kernel_name + +(* ast destructors *) +val num_of_ast : Coqast.t -> int +val id_of_ast : Coqast.t -> string +val nvar_of_ast : Coqast.t -> identifier +val meta_of_ast : Coqast.t -> string + +(* patterns of ast *) +type astpat = + | Pquote of t + | Pmeta of string * tok_kind + | Pnode of string * patlist + | Pslam of identifier option * astpat + | Pmeta_slam of string * astpat + +and patlist = + | Pcons of astpat * patlist + | Plmeta of string + | Pnil + +and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist + +type pat = + | AstListPat of patlist + | PureAstPat of astpat + +(* semantic actions of grammar rules *) +type act = + | Act of constr_expr + | ActCase of act * (pat * act) list + | ActCaseList of act * (pat * act) list + +(* values associated to variables *) +type typed_ast = + | AstListNode of Coqast.t list + | PureAstNode of Coqast.t + +type ast_action_type = ETast | ETastl + +type dynamic_grammar = + | ConstrNode of constr_expr + | CasesPatternNode of cases_pattern_expr + +type grammar_action = + | SimpleAction of loc * dynamic_grammar + | CaseAction of + loc * grammar_action * ast_action_type * (t list * grammar_action) list + +type env = (string * typed_ast) list + +val coerce_to_id : constr_expr -> identifier located + +val coerce_global_to_id : reference -> identifier +val coerce_reference_to_id : reference -> identifier + +exception No_match of string + +val isMeta : string -> bool + +val print_ast : Coqast.t -> std_ppcmds +val print_astl : Coqast.t list -> std_ppcmds +val print_astpat : astpat -> std_ppcmds +val print_astlpat : patlist -> std_ppcmds + +(* Meta-syntax operations: matching and substitution *) + +type entry_env = (string * ast_action_type) list + +val grammar_type_error : loc * string -> 'a + +(* Converting and checking free meta-variables *) + +(* For old ast printer *) +val pat_sub : loc -> env -> astpat -> Coqast.t +val val_of_ast : entry_env -> Coqast.t -> astpat +val alpha_eq : Coqast.t * Coqast.t -> bool +val alpha_eq_val : typed_ast * typed_ast -> bool +val occur_var_ast : identifier -> Coqast.t -> bool +val find_all_matches : ('a -> astpat) -> env -> t -> 'a list -> ('a * env) list +val first_matchl : ('a -> patlist) -> env -> Coqast.t list -> 'a list -> + ('a * env) option +val to_pat : entry_env -> Coqast.t -> (astpat * entry_env) + +(* Object substitution in modules *) +val subst_astpat : Names.substitution -> astpat -> astpat diff --git a/parsing/coqast.ml b/parsing/coqast.ml new file mode 100644 index 00000000..0f447766 --- /dev/null +++ b/parsing/coqast.ml @@ -0,0 +1,123 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* List.assoc n bl + | Node(loc, node_name, args) -> + Node(loc, node_name, List.map aux args) + | Slam(loc, var, arg) -> Slam(loc, var, aux arg) + | Smetalam(loc, var, arg) -> Smetalam(loc, var, aux arg) + | other -> other + in + aux ast + +let rec collect_metas = function + | Node (_,"META", [Num(_, n)]) -> [n] + | Node(_, _, args) -> List.concat (List.map collect_metas args) + | Slam(loc, var, arg) -> collect_metas arg + | Smetalam(loc, var, arg) -> collect_metas arg + | _ -> [] + +(* Hash-consing *) +module Hloc = Hashcons.Make( + struct + type t = loc + type u = unit + let equal (b1,e1) (b2,e2) = b1=b2 & e1=e2 + let hash_sub () x = x + let hash = Hashtbl.hash + end) + +module Hast = Hashcons.Make( + struct + type t = the_coq_ast + type u = + (the_coq_ast -> the_coq_ast) * + ((loc -> loc) * (string -> string) + * (identifier -> identifier) * (kernel_name -> kernel_name)) + let hash_sub (hast,(hloc,hstr,hid,hsp)) = function + | Node(l,s,al) -> Node(hloc l, hstr s, List.map hast al) + | Nmeta(l,s) -> Nmeta(hloc l, hstr s) + | Nvar(l,s) -> Nvar(hloc l, hid s) + | Slam(l,None,t) -> Slam(hloc l, None, hast t) + | Slam(l,Some s,t) -> Slam(hloc l, Some (hid s), hast t) + | Smetalam(l,s,t) -> Smetalam(hloc l, hstr s, hast t) + | Num(l,n) -> Num(hloc l, n) + | Id(l,s) -> Id(hloc l, hstr s) + | Str(l,s) -> Str(hloc l, hstr s) + | Path(l,d) -> Path(hloc l, hsp d) + | Dynamic(l,d) -> Dynamic(hloc l, d) + let equal a1 a2 = + match (a1,a2) with + | (Node(l1,s1,al1), Node(l2,s2,al2)) -> + (l1==l2 & s1==s2 & List.length al1 = List.length al2) + & List.for_all2 (==) al1 al2 + | (Nmeta(l1,s1), Nmeta(l2,s2)) -> l1==l2 & s1==s2 + | (Nvar(l1,s1), Nvar(l2,s2)) -> l1==l2 & s1==s2 + | (Slam(l1,None,t1), Slam(l2,None,t2)) -> l1==l2 & t1==t2 + | (Slam(l1,Some s1,t1), Slam(l2,Some s2,t2)) ->l1==l2 & s1==s2 & t1==t2 + | (Smetalam(l1,s1,t1), Smetalam(l2,s2,t2)) -> l1==l2 & s1==s2 & t1==t2 + | (Num(l1,n1), Num(l2,n2)) -> l1==l2 & n1=n2 + | (Id(l1,s1), Id(l2,s2)) -> l1==l2 & s1==s2 + | (Str(l1,s1),Str(l2,s2)) -> l1==l2 & s1==s2 + | (Path(l1,d1), Path(l2,d2)) -> (l1==l2 & d1==d2) + | _ -> false + let hash = Hashtbl.hash + end) + +let hcons_ast (hstr,hid,hpath) = + let hloc = Hashcons.simple_hcons Hloc.f () in + let hast = Hashcons.recursive_hcons Hast.f (hloc,hstr,hid,hpath) in + (hast,hloc) + +let rec subst_ast subst ast = match ast with + | Node (l,s,astl) -> + let astl' = Util.list_smartmap (subst_ast subst) astl in + if astl' == astl then ast else + Node (l,s,astl') + | Slam (l,ido,ast1) -> + let ast1' = subst_ast subst ast1 in + if ast1' == ast1 then ast else + Slam (l,ido,ast1') + | Smetalam (l,s,ast1) -> + let ast1' = subst_ast subst ast1 in + if ast1' == ast1 then ast else + Smetalam (l,s,ast1') + | Path (loc,kn) -> + let kn' = Names.subst_kn subst kn in + if kn' == kn then ast else + Path(loc,kn') + | Nmeta _ + | Nvar _ -> ast + | Num _ + | Str _ + | Id _ + | Dynamic _ -> ast diff --git a/parsing/coqast.mli b/parsing/coqast.mli new file mode 100644 index 00000000..546725c0 --- /dev/null +++ b/parsing/coqast.mli @@ -0,0 +1,51 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int list + +(* [subst_meta bl ast]: for each binding [(i,c_i)] in [bl], + replace the metavar [?i] by [c_i] in [ast] *) +val subst_meta : (int * t) list -> t -> t + +(* hash-consing function *) +val hcons_ast: + (string -> string) * (Names.identifier -> Names.identifier) + * (kernel_name -> kernel_name) + -> (t -> t) * (loc -> loc) + +val subst_ast: Names.substitution -> t -> t + +(* +val map_tactic_expr : (t -> t) -> (tactic_expr -> tactic_expr) -> tactic_expr -> tactic_expr +val fold_tactic_expr : + ('a -> t -> 'a) -> ('a -> tactic_expr -> 'a) -> 'a -> tactic_expr -> 'a +val iter_tactic_expr : (tactic_expr -> unit) -> tactic_expr -> unit +*) diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml new file mode 100644 index 00000000..9886bbf1 --- /dev/null +++ b/parsing/egrammar.ml @@ -0,0 +1,479 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* anomaly "Notation not in GRAMMAR summary" + | Grammar gc -> Grammar (subst_grammar_command subst gc) + | TacticGrammar g -> TacticGrammar g (* TODO ... *) + +let (grammar_state : all_grammar_command list ref) = ref [] + + +(**************************************************************************) +(* Interpretation of the right hand side of grammar rules *) + +(* When reporting errors, we add the name of the grammar rule that failed *) +let specify_name name e = + match e with + | UserError(lab,strm) -> + UserError(lab, (str"during interpretation of grammar rule " ++ + str name ++ str"," ++ spc () ++ strm)) + | Anomaly(lab,strm) -> + Anomaly(lab, (str"during interpretation of grammar rule " ++ + str name ++ str"," ++ spc () ++ strm)) + | Failure s -> + Failure("during interpretation of grammar rule "^name^", "^s) + | e -> e + +(* Translation of environments: a production + * [ nt1(x1) ... nti(xi) ] -> 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, + * make_act builds the following closure: + * + * ((fun env -> + * (fun vi -> + * (fun env -> ... + * + * (fun v1 -> + * (fun env -> gram_action .. env act) + * ((x1,v1)::env)) + * ...) + * ((xi,vi)::env))) + * []) + *) + +open Names + +type 'a action_env = (identifier * 'a) list + +let make_act (f : loc -> constr_expr action_env -> constr_expr) pil = + let rec make (env : constr_expr action_env) = function + | [] -> + Gramext.action (fun loc -> f loc env) + | None :: tl -> (* parse a non-binding item *) + Gramext.action (fun _ -> make env tl) + | Some (p, (ETConstr _| ETOther _)) :: tl -> (* constr non-terminal *) + Gramext.action (fun (v:constr_expr) -> make ((p,v) :: env) tl) + | Some (p, ETReference) :: tl -> (* non-terminal *) + Gramext.action (fun (v:reference) -> make ((p,CRef v) :: env) tl) + | Some (p, ETIdent) :: tl -> (* non-terminal *) + Gramext.action (fun (v:identifier) -> + make ((p,CRef (Ident (dummy_loc,v))) :: env) tl) + | Some (p, ETBigint) :: tl -> (* non-terminal *) + Gramext.action (fun (v:Bignat.bigint) -> + make ((p,CNumeral (dummy_loc,v)) :: env) tl) + | Some (p, ETConstrList _) :: tl -> + Gramext.action (fun (v:constr_expr list) -> + let dummyid = Ident (dummy_loc,id_of_string "") in + make ((p,CAppExpl (dummy_loc,(None,dummyid),v)) :: env) tl) + | Some (p, ETPattern) :: tl -> + failwith "Unexpected entry of type cases pattern" in + make [] (List.rev pil) + +let make_act_in_cases_pattern (* For Notations *) + (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil = + let rec make (env : cases_pattern_expr action_env) = function + | [] -> + Gramext.action (fun loc -> f loc env) + | None :: tl -> (* parse a non-binding item *) + Gramext.action (fun _ -> make env tl) + | Some (p, ETConstr _) :: tl -> (* pattern non-terminal *) + Gramext.action (fun (v:cases_pattern_expr) -> make ((p,v) :: env) tl) + | Some (p, ETReference) :: tl -> (* non-terminal *) + Gramext.action (fun (v:reference) -> + make ((p,CPatAtom (dummy_loc,Some v)) :: env) tl) + | Some (p, ETIdent) :: tl -> (* non-terminal *) + Gramext.action (fun (v:identifier) -> + make ((p,CPatAtom (dummy_loc,Some (Ident (dummy_loc,v)))) :: env) tl) + | Some (p, ETBigint) :: tl -> (* non-terminal *) + Gramext.action (fun (v:Bignat.bigint) -> + make ((p,CPatNumeral (dummy_loc,v)) :: env) tl) + | Some (p, ETConstrList _) :: tl -> + Gramext.action (fun (v:cases_pattern_expr list) -> + let dummyid = Ident (dummy_loc,id_of_string "") in + make ((p,CPatCstr (dummy_loc,dummyid,v)) :: env) tl) + | Some (p, (ETPattern | ETOther _)) :: tl -> + failwith "Unexpected entry of type cases pattern or other" in + make [] (List.rev pil) + +(* For V7 Grammar only *) +let make_cases_pattern_act + (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil = + let rec make (env : cases_pattern_expr action_env) = function + | [] -> + Gramext.action (fun loc -> f loc env) + | None :: tl -> (* parse a non-binding item *) + Gramext.action (fun _ -> make env tl) + | Some (p, ETPattern) :: tl -> (* non-terminal *) + Gramext.action (fun v -> make ((p,v) :: env) tl) + | Some (p, ETReference) :: tl -> (* non-terminal *) + Gramext.action (fun v -> make ((p,CPatAtom(dummy_loc,Some v)) :: env) + tl) + | Some (p, ETBigint) :: tl -> (* non-terminal *) + Gramext.action (fun v -> make ((p,CPatNumeral(dummy_loc,v)) :: env) tl) + | Some (p, (ETConstrList _ | ETIdent | ETConstr _ | ETOther _)) :: tl -> + error "ident and constr entry not admitted in patterns cases syntax extensions" in + make [] (List.rev pil) + +(* Grammar extension command. Rules are assumed correct. + * Type-checking of grammar rules is done during the translation of + * ast to the type grammar_command. We only check that the existing + * entries have the type assumed in the grammar command (these types + * annotations are added when type-checking the command, function + * Extend.of_ast) *) + +let symbol_of_prod_item univ assoc from forpat = function + | Term tok -> (Gramext.Stoken tok, None) + | NonTerm (nt, ovar) -> + let eobj = symbol_of_production assoc from forpat nt in + (eobj, ovar) + +let coerce_to_id = function + | CRef (Ident (_,id)) -> id + | c -> + user_err_loc (constr_loc c, "subst_rawconstr", + str"This expression should be a simple identifier") + +let coerce_to_ref = function + | CRef r -> r + | c -> + user_err_loc (constr_loc c, "subst_rawconstr", + str"This expression should be a simple reference") + +let subst_ref loc subst id = + try coerce_to_ref (List.assoc id subst) with Not_found -> Ident (loc,id) + +let subst_pat_id loc subst id = + try List.assoc id subst + with Not_found -> CPatAtom (loc,Some (Ident (loc,id))) + +let subst_id subst id = + try coerce_to_id (List.assoc id subst) with Not_found -> id + +(* +let subst_cases_pattern_expr a loc subs = + let rec subst = function + | CPatAlias (_,p,x) -> CPatAlias (loc,subst p,x) + (* No subst in compound pattern ? *) + | CPatCstr (_,ref,pl) -> CPatCstr (loc,ref,List.map subst pl) + | CPatAtom (_,Some (Ident (_,id))) -> subst_pat_id loc subs id + | CPatAtom (_,x) -> CPatAtom (loc,x) + | CPatNotation (_,ntn,l) -> CPatNotation + | CPatNumeral (_,n) -> CPatNumeral (loc,n) + | CPatDelimiters (_,key,p) -> CPatDelimiters (loc,key,subst p) + in subst a +*) + +let subst_constr_expr a loc subs = + let rec subst = function + | CRef (Ident (_,id)) -> + (try List.assoc id subs with Not_found -> CRef (Ident (loc,id))) + (* Temporary: no robust treatment of substituted binders *) + | CLambdaN (_,[],c) -> subst c + | CLambdaN (_,([],t)::bl,c) -> subst (CLambdaN (loc,bl,c)) + | CLambdaN (_,((_,na)::bl,t)::bll,c) -> + let na = name_app (subst_id subs) na in + CLambdaN (loc,[[loc,na],subst t], subst (CLambdaN (loc,(bl,t)::bll,c))) + | CProdN (_,[],c) -> subst c + | CProdN (_,([],t)::bl,c) -> subst (CProdN (loc,bl,c)) + | CProdN (_,((_,na)::bl,t)::bll,c) -> + let na = name_app (subst_id subs) na in + CProdN (loc,[[loc,na],subst t], subst (CProdN (loc,(bl,t)::bll,c))) + | CLetIn (_,(_,na),b,c) -> + let na = name_app (subst_id subs) na in + CLetIn (loc,(loc,na),subst b,subst c) + | CArrow (_,a,b) -> CArrow (loc,subst a,subst b) + | CAppExpl (_,(p,Ident (_,id)),l) -> + CAppExpl (loc,(p,subst_ref loc subs id),List.map subst l) + | CAppExpl (_,r,l) -> CAppExpl (loc,r,List.map subst l) + | CApp (_,(p,a),l) -> + CApp (loc,(p,subst a),List.map (fun (a,i) -> (subst a,i)) l) + | CCast (_,a,b) -> CCast (loc,subst a,subst b) + | CNotation (_,n,l) -> CNotation (loc,n,List.map subst l) + | CDelimiters (_,s,a) -> CDelimiters (loc,s,subst a) + | CHole _ | CEvar _ | CPatVar _ | CSort _ + | CNumeral _ | CDynamic _ | CRef _ as x -> x + | CCases (_,(po,rtntypo),a,bl) -> + (* TODO: apply g on the binding variables in pat... *) + let bl = List.map (fun (_,pat,rhs) -> (loc,pat,subst rhs)) bl in + CCases (loc,(option_app subst po,option_app subst rtntypo), + List.map (fun (tm,x) -> subst tm,x) a,bl) + | COrderedCase (_,s,po,a,bl) -> + COrderedCase (loc,s,option_app subst po,subst a,List.map subst bl) + | CLetTuple (_,nal,(na,po),a,b) -> + let na = option_app (name_app (subst_id subs)) na in + let nal = List.map (name_app (subst_id subs)) nal in + CLetTuple (loc,nal,(na,option_app subst po),subst a,subst b) + | CIf (_,c,(na,po),b1,b2) -> + let na = option_app (name_app (subst_id subs)) na in + CIf (loc,subst c,(na,option_app subst po),subst b1,subst b2) + | CFix (_,id,dl) -> + CFix (loc,id,List.map (fun (id,n,bl, t,d) -> + (id,n, + List.map(function + LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty) + | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl, + subst t,subst d)) dl) + | CCoFix (_,id,dl) -> + CCoFix (loc,id,List.map (fun (id,bl,t,d) -> + (id, + List.map(function + LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty) + | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl, + subst t,subst d)) dl) + in subst a + +(* For V7 Grammar only *) +let make_rule univ assoc etyp rule = + if not !Options.v7 then anomaly "No Grammar in new syntax"; + let pil = List.map (symbol_of_prod_item univ assoc etyp false) rule.gr_production in + let (symbs,ntl) = List.split pil in + let act = match etyp with + | ETPattern -> + (* Ugly *) + let f loc env = match rule.gr_action, env with + | CRef (Ident(_,p)), [p',a] when p=p' -> a + | CDelimiters (_,s,CRef (Ident(_,p))), [p',a] when p=p' -> + CPatDelimiters (loc,s,a) + | _ -> error "Unable to handle this grammar extension of pattern" in + make_cases_pattern_act f ntl + | ETConstrList _ | ETIdent | ETBigint | ETReference -> error "Cannot extend" + | ETConstr _ | ETOther _ -> + make_act (subst_constr_expr rule.gr_action) ntl in + (symbs, act) + +(* Rules of a level are entered in reverse order, so that the first rules + are applied before the last ones *) +(* For V7 Grammar only *) +let extend_entry univ (te, etyp, pos, name, ass, p4ass, rls) = + let rules = List.rev (List.map (make_rule univ ass etyp) rls) in + grammar_extend te pos [(name, p4ass, rules)] + +(* Defines new entries. If the entry already exists, check its type *) +let define_entry univ {ge_name=typ; gl_assoc=ass; gl_rules=rls} = + let e,lev,keepassoc = get_constr_entry false typ in + let pos,p4ass,name = find_position false keepassoc ass lev in + (e,typ,pos,name,ass,p4ass,rls) + +(* Add a bunch of grammar rules. Does not check if it is well formed *) +(* For V7 Grammar only *) +let extend_grammar_rules gram = + let univ = get_univ gram.gc_univ in + let tl = List.map (define_entry univ) gram.gc_entries in + List.iter (extend_entry univ) tl + +(* Add a grammar rules for tactics *) +type grammar_tactic_production = + | TacTerm of string + | TacNonTerm of loc * (Gram.te Gramext.g_symbol * argument_type) * string option + +let make_prod_item = function + | TacTerm s -> (Gramext.Stoken (Extend.terminal s), None) + | TacNonTerm (_,(nont,t), po) -> + (nont, option_app (fun p -> (p,t)) po) + +let make_gen_act f pil = + let rec make env = function + | [] -> + Gramext.action (fun loc -> f loc env) + | None :: tl -> (* parse a non-binding item *) + Gramext.action (fun _ -> make env tl) + | Some (p, t) :: tl -> (* non-terminal *) + Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in + make [] (List.rev pil) + +let extend_constr entry (n,assoc,pos,p4assoc,name) make_act (forpat,pt) = + let univ = get_univ "constr" in + let pil = List.map (symbol_of_prod_item univ assoc n forpat) pt in + let (symbs,ntl) = List.split pil in + let act = make_act ntl in + grammar_extend entry pos [(name, p4assoc, [symbs, act])] + +let extend_constr_notation (n,assoc,ntn,rule,permut) = + let mkact = + match permut with + None -> (fun loc env -> CNotation (loc,ntn,List.map snd env)) + | Some p -> (fun loc env -> + CNotation (loc,ntn,List.map (fun i -> snd (List.nth env i)) p)) in + let (e,level,keepassoc) = get_constr_entry false (ETConstr (n,())) in + let pos,p4assoc,name = find_position false keepassoc assoc level in + extend_constr e (ETConstr(n,()),assoc,pos,p4assoc,name) + (make_act mkact) (false,rule); + if not !Options.v7 then + let mkact loc env = CPatNotation (loc,ntn,List.map snd env) in + let (e,level,keepassoc) = get_constr_entry true (ETConstr (n,())) in + let pos,p4assoc,name = find_position true keepassoc assoc level in + extend_constr e (ETConstr (n,()),assoc,pos,p4assoc,name) + (make_act_in_cases_pattern mkact) (true,rule) + +(* These grammars are not a removable *) +let make_rule univ f g (s,pt) = + let hd = Gramext.Stoken ("IDENT", s) in + let pil = (hd,None) :: List.map g pt in + let (symbs,ntl) = List.split pil in + let act = make_gen_act f ntl in + (symbs, act) + +let tac_exts = ref [] +let get_extend_tactic_grammars () = !tac_exts + +let extend_tactic_grammar s gl = + tac_exts := (s,gl) :: !tac_exts; + let univ = get_univ "tactic" in + let make_act loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in + let rules = List.map (make_rule univ make_act make_prod_item) gl in + Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)] + +let vernac_exts = ref [] +let get_extend_vernac_grammars () = !vernac_exts + +let extend_vernac_command_grammar s gl = + vernac_exts := (s,gl) :: !vernac_exts; + let univ = get_univ "vernac" in + let make_act loc l = Vernacexpr.VernacExtend (s,List.map snd l) in + let rules = List.map (make_rule univ make_act make_prod_item) gl in + Gram.extend Vernac_.command None [(None, None, List.rev rules)] + +let rec interp_entry_name u s = + let l = String.length s in + if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name u (String.sub s 3 (l-8)) in + List1ArgType t, Gramext.Slist1 g + else if l > 5 & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name u (String.sub s 0 (l-5)) in + List0ArgType t, Gramext.Slist0 g + else if l > 4 & String.sub s (l-4) 4 = "_opt" then + let t, g = interp_entry_name u (String.sub s 0 (l-4)) in + OptArgType t, Gramext.Sopt g + else + let e = + if !Options.v7 then get_entry (get_univ u) s + else + (* Qualified entries are no longer in use *) + try get_entry (get_univ "tactic") s + with _ -> + try get_entry (get_univ "prim") s + with _ -> + try get_entry (get_univ "constr") s + with _ -> error ("Unknown entry "^s) + in + let o = object_of_typed_entry e in + let t = type_of_typed_entry e in + t,Gramext.Snterm (Pcoq.Gram.Entry.obj o) + +let qualified_nterm current_univ = function + | NtQual (univ, en) -> if !Options.v7 then (univ, en) else assert false + | NtShort en -> (current_univ, en) + +let make_vprod_item univ = function + | VTerm s -> (Gramext.Stoken (Extend.terminal s), None) + | VNonTerm (loc, nt, po) -> + let (u,nt) = qualified_nterm univ nt in + let (etyp, e) = interp_entry_name u nt in + e, option_app (fun p -> (p,etyp)) po + +let add_tactic_entries gl = + let univ = get_univ "tactic" in + let make_act s tac loc l = Tacexpr.TacAlias (loc,s,l,tac) in + let f (s,l,tac) = + make_rule univ (make_act s tac) (make_vprod_item "tactic") l in + let rules = List.map f gl in + let _ = find_position true true None None (* to synchronise with remove *) in + grammar_extend Tactic.simple_tactic None [(None, None, List.rev rules)] + +let extend_grammar gram = + (match gram with + | Notation a -> extend_constr_notation a + | Grammar g -> extend_grammar_rules g + | TacticGrammar l -> add_tactic_entries l); + grammar_state := gram :: !grammar_state + +let reset_extend_grammars_v8 () = + let te = List.rev !tac_exts in + let tv = List.rev !vernac_exts in + tac_exts := []; + vernac_exts := []; + List.iter (fun (s,gl) -> extend_tactic_grammar s gl) te; + List.iter (fun (s,gl) -> extend_vernac_command_grammar s gl) tv + + +(* 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 -> function + | Notation _ -> + if !Options.v7 then n + 1 + else n + 2 (* 1 for operconstr, 1 for pattern *) + | Grammar gc -> + n + (List.length gc.gc_entries) + | TacticGrammar _ -> n + 1) + 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 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; + survive_module = false; + survive_section = false } diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli new file mode 100644 index 00000000..c601c5fc --- /dev/null +++ b/parsing/egrammar.mli @@ -0,0 +1,54 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit + +(* Add grammar rules for tactics *) +type grammar_tactic_production = + | TacTerm of string + | TacNonTerm of loc * (Token.t Gramext.g_symbol * Genarg.argument_type) * string option + +val extend_tactic_grammar : + string -> (string * grammar_tactic_production list) list -> unit + +val extend_vernac_command_grammar : + string -> (string * grammar_tactic_production list) list -> unit + +val get_extend_tactic_grammars : + unit -> (string * (string * grammar_tactic_production list) list) list +val get_extend_vernac_grammars : + unit -> (string * (string * grammar_tactic_production list) list) list +val reset_extend_grammars_v8 : unit -> unit + +val subst_all_grammar_command : + Names.substitution -> all_grammar_command -> all_grammar_command + +val interp_entry_name : string -> string -> + entry_type * Token.t Gramext.g_symbol diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml new file mode 100644 index 00000000..6a4758ab --- /dev/null +++ b/parsing/esyntax.ml @@ -0,0 +1,276 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + [Cst sl; Nod "APPLIST"; All] + | Node(_,"APPLIST", Node(_,"SECVAR", [Nvar (_,s)]) ::_) -> + [SecVar s; Nod "APPLIST"; All] + | Node(_,"APPLIST", Node(_,"MUTIND", [Path (_,sl); Num (_,tyi)]) ::_) -> + [Ind (sl,tyi); Nod "APPLIST"; All] + | Node(_,"APPLIST", Node(_,"MUTCONSTRUCT", + [Path (_,sl); Num (_,tyi); Num (_,i)]) ::_) -> + [Cstr ((sl,tyi),i); Nod "APPLIST"; All] + | Node(_,s,_) -> [Nod s; All] + | _ -> [Oth; All] + +let spat_key astp = + match astp with + | Pnode("APPLIST", + Pcons(Pnode("CONST", + Pcons(Pquote(Path (_,sl)),_)), _)) + -> Cst sl + | Pnode("APPLIST", + Pcons(Pnode("SECVAR", + Pcons(Pquote(Nvar (_,s)),_)), _)) + -> SecVar s + | Pnode("APPLIST", + Pcons(Pnode("MUTIND", + Pcons(Pquote(Path (_,sl)), + Pcons(Pquote(Num (_,tyi)),_))), _)) + -> Ind (sl,tyi) + | Pnode("APPLIST", + Pcons(Pnode("MUTCONSTRUCT", + Pcons(Pquote(Path (_,sl)), + Pcons(Pquote(Num (_,tyi)), + Pcons(Pquote(Num (_,i)),_)))), _)) + -> Cstr ((sl,tyi),i) + | Pnode(na,_) -> Nod na + | Pquote ast -> List.hd (ast_keys ast) + | Pmeta _ -> All + | _ -> Oth + +let se_key se = spat_key se.syn_astpat + +(** Syntax entry tables (state of the pretty_printer) **) +let from_name_table = ref Gmap.empty +let from_key_table = ref Gmapl.empty + +(* Summary operations *) +type frozen_t = (string * string, astpat syntax_entry) Gmap.t * + (string * key, astpat syntax_entry) Gmapl.t + +let freeze () = + (!from_name_table, !from_key_table) + +let unfreeze (fnm,fkm) = + from_name_table := fnm; + from_key_table := fkm + +let init () = + from_name_table := Gmap.empty; + from_key_table := Gmapl.empty + +let find_syntax_entry whatfor gt = + let gt_keys = ast_keys gt in + let entries = + List.flatten + (List.map (fun k -> Gmapl.find (whatfor,k) !from_key_table) gt_keys) + in + find_all_matches (fun se -> se.syn_astpat) [] gt entries + +let remove_with_warning name = + if Gmap.mem name !from_name_table then begin + let se = Gmap.find name !from_name_table in + let key = (fst name, se_key se) in + if !warning_verbose then + (Options.if_verbose + warning ("overriding syntax rule "^(fst name)^":"^(snd name)^".")); + from_name_table := Gmap.remove name !from_name_table; + from_key_table := Gmapl.remove key se !from_key_table + end + +let add_rule whatfor se = + let name = (whatfor,se.syn_id) in + let key = (whatfor, se_key se) in + remove_with_warning name; + from_name_table := Gmap.add name se !from_name_table; + from_key_table := Gmapl.add key se !from_key_table + +let add_ppobject {sc_univ=wf;sc_entries=sel} = List.iter (add_rule wf) sel + + +(* Pretty-printing machinery *) + +type std_printer = Coqast.t -> std_ppcmds +type unparsing_subfunction = string -> tolerability option -> std_printer +type primitive_printer = Coqast.t -> std_ppcmds option + +(* Module of primitive printers *) +module Ppprim = + struct + type t = std_printer -> std_printer + let tab = ref ([] : (string * t) list) + let map a = List.assoc a !tab + let add (a,ppr) = tab := (a,ppr)::!tab + end + +(**********************************************************************) +(* Primitive printers (e.g. for numerals) *) + +(* This is the map associating to a printer the scope it belongs to *) +(* and its ML code *) + +let primitive_printer_tab = + ref (Stringmap.empty : (scope_name * primitive_printer) Stringmap.t) +let declare_primitive_printer s sc pp = + primitive_printer_tab := Stringmap.add s (sc,pp) !primitive_printer_tab +let lookup_primitive_printer s = + Stringmap.find s !primitive_printer_tab + +(* Register the primitive printer for "token". It is not used in syntax/PP*.v, + * but any ast matching no PP rule is printed with it. *) +(* +let _ = declare_primitive_printer "token" token_printer +*) + +(* A printer for the tokens. *) +let token_printer stdpr = function + | (Id _ | Num _ | Str _ | Path _ as ast) -> print_ast ast + | a -> stdpr a + +(* Unused ?? +(* A primitive printer to do "print as" (to specify a length for a string) *) +let print_as_printer = function + | Node (_, "AS", [Num(_,n); Str(_,s)]) -> Some (stras (n,s)) + | ast -> None + +let _ = declare_primitive_printer "print_as" default_scope print_as_printer +*) + +(* Handle infix symbols *) + +let pr_parenthesis inherited se strm = + if tolerable_prec inherited se.syn_prec then + strm + else + (str"(" ++ strm ++ str")") + +let print_delimiters inh se strm = function + | None -> pr_parenthesis inh se strm + | Some key -> + let left = "'"^key^":" and right = "'" in + let lspace = + if is_letter (left.[String.length left -1]) then str " " else mt () in + let rspace = + let c = right.[0] in + if is_ident_tail c then str " " else mt () in + hov 0 (str left ++ lspace ++ strm ++ rspace ++ str right) + +(* Print the syntax entry. In the unparsing hunks, the tokens are + * printed using the token_printer, unless another primitive printer + * is specified. *) + +let print_syntax_entry sub_pr scopes env se = + let rec print_hunk rule_prec scopes = function + | PH(e,externpr,reln) -> + let node = Ast.pat_sub dummy_loc env e in + let printer = + match externpr with (* May branch to an other printer *) + | Some c -> + (try (* Test for a primitive printer *) Ppprim.map c + with Not_found -> token_printer) + | _ -> token_printer in + printer (sub_pr scopes (Some(rule_prec,reln))) node + | RO s -> str s + | UNP_TAB -> tab () + | UNP_FNL -> fnl () + | UNP_BRK(n1,n2) -> brk(n1,n2) + | UNP_TBRK(n1,n2) -> tbrk(n1,n2) + | UNP_BOX (b,sub) -> ppcmd_of_box b (prlist (print_hunk rule_prec scopes) sub) + | UNP_SYMBOLIC _ -> anomaly "handled by call_primitive_parser" + in + prlist (print_hunk se.syn_prec scopes) se.syn_hunks + +let call_primitive_parser rec_pr otherwise inherited scopes (se,env) = + try ( + match se.syn_hunks with + | [PH(e,Some c,reln)] -> + (* Test for a primitive printer; may raise Not_found *) + let sc,pr = lookup_primitive_printer c in + (* Look if scope [sc] associated to this printer is OK *) + (match Symbols.availability_of_numeral sc scopes with + | None -> otherwise () + | Some key -> + (* We can use this printer *) + let node = Ast.pat_sub dummy_loc env e in + match pr node with + | Some strm -> print_delimiters inherited se strm key + | None -> otherwise ()) + | [UNP_SYMBOLIC (sc,pat,sub)] -> + (match Symbols.availability_of_notation (sc,pat) scopes with + | None -> otherwise () + | Some (scopt,key) -> + print_delimiters inherited se + (print_syntax_entry rec_pr + (option_fold_right Symbols.push_scope scopt scopes) env + {se with syn_hunks = [sub]}) key) + | _ -> + pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se) + ) + with Not_found -> (* To handle old style printer *) + pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se) + +(* [genprint whatfor dflt inhprec ast] prints out the ast of + * 'universe' whatfor. If the term is not matched by any + * pretty-printing rule, then it will call dflt on it, which is + * responsible for printing out the term (usually #GENTERM...). + * In the case of tactics and commands, dflt also prints + * global constants basenames. *) + +let genprint dflt whatfor inhprec ast = + let rec rec_pr scopes inherited gt = + let entries = find_syntax_entry whatfor gt in + let rec test_rule = function + | se_env::rules -> + call_primitive_parser + rec_pr + (fun () -> test_rule rules) + inherited scopes se_env + | [] -> dflt gt (* No rule found *) + in test_rule entries + in + try + rec_pr (Symbols.current_scopes ()) inhprec ast + with + | Failure _ -> (str"") + | Not_found -> (str"") diff --git a/parsing/esyntax.mli b/parsing/esyntax.mli new file mode 100644 index 00000000..e05e1ca4 --- /dev/null +++ b/parsing/esyntax.mli @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit +val freeze : unit -> frozen_t +val unfreeze : frozen_t -> unit + +(* Search and add a PP rule for an ast in the summary *) +val find_syntax_entry : + string -> Coqast.t -> (Ast.astpat syntax_entry * Ast.env) list +val add_rule : string -> Ast.astpat syntax_entry -> unit +val add_ppobject : Ast.astpat syntax_command -> unit +val warning_verbose : bool ref + +(* Pretty-printing *) + +type std_printer = Coqast.t -> std_ppcmds +type unparsing_subfunction = string -> tolerability option -> std_printer +type primitive_printer = Coqast.t -> std_ppcmds option + +(* Module of constr primitive printers [old style - no scope] *) +module Ppprim : + sig + type t = std_printer -> std_printer + val add : string * t -> unit + end + +val declare_primitive_printer : + string -> scope_name -> primitive_printer -> unit + +(* +val declare_infix_symbol : Libnames.section_path -> string -> unit +*) + +(* Generic printing functions *) +(* +val token_printer: std_printer -> std_printer +*) +(* +val print_syntax_entry : + string -> unparsing_subfunction -> Ast.env -> Ast.astpat syntax_entry -> std_ppcmds +*) +val genprint : std_printer -> unparsing_subfunction diff --git a/parsing/extend.ml b/parsing/extend.ml new file mode 100644 index 00000000..2778de44 --- /dev/null +++ b/parsing/extend.ml @@ -0,0 +1,378 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* CHole dummy_loc) +let set_constr_globalizer f = globalizer := f + +let act_of_ast vars = function + | SimpleAction (loc,ConstrNode a) -> !globalizer vars a + | SimpleAction (loc,CasesPatternNode a) -> + failwith "TODO:act_of_ast: cases_pattern" + | CaseAction _ -> failwith "case/let not supported" + +let to_act_check_vars = act_of_ast + +type syntax_modifier = + | SetItemLevel of string list * production_level + | SetLevel of int + | SetAssoc of Gramext.g_assoc + | SetEntryType of string * simple_constr_production_entry + | SetOnlyParsing + | SetFormat of string located + +type nonterm = + | NtShort of string + | NtQual of string * string +type grammar_production = + | VTerm of string + | VNonTerm of loc * nonterm * Names.identifier option +type raw_grammar_rule = string * grammar_production list * grammar_action +type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list + +(* No kernel names in Grammar's *) +let subst_constr_expr _ a = a + +let subst_grammar_rule subst gr = + { gr with gr_action = subst_constr_expr subst gr.gr_action } + +let subst_grammar_entry subst ge = + { ge with gl_rules = List.map (subst_grammar_rule subst) ge.gl_rules } + +let subst_grammar_command subst gc = + { gc with gc_entries = List.map (subst_grammar_entry subst) gc.gc_entries } + + +(*s Terminal symbols interpretation *) + +let is_ident_not_keyword s = + match s.[0] with + | 'a'..'z' | 'A'..'Z' | '_' -> not (Lexer.is_keyword s) + | _ -> false + +let is_number s = + match s.[0] with + | '0'..'9' -> true + | _ -> false + +let strip s = + let len = + let rec loop i len = + if i = String.length s then len + else if s.[i] == ' ' then loop (i + 1) len + else loop (i + 1) (len + 1) + in + loop 0 0 + in + if len == String.length s then s + else + let s' = String.create len in + let rec loop i i' = + if i == String.length s then s' + else if s.[i] == ' ' then loop (i + 1) i' + else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end + in + loop 0 0 + +let terminal s = + let s = strip s in + if s = "" then failwith "empty token"; + if is_ident_not_keyword s then ("IDENT", s) + else if is_number s then ("INT", s) + else ("", s) + +(*s Non-terminal symbols interpretation *) + +(* For compatibility *) +let warn nt nt' = + warning ("'"^nt^"' grammar entry is obsolete; use name '"^nt'^"' instead"); + nt' + +let rename_command_entry nt = + if String.length nt >= 7 & String.sub nt 0 7 = "command" + then warn nt ("constr"^(String.sub nt 7 (String.length nt - 7))) + else if nt = "lcommand" then warn nt "lconstr" + else if nt = "lassoc_command4" then warn nt "lassoc_constr4" + else nt + +(* This translates constr0, constr1, ... level into camlp4 levels of constr *) + +let explicitize_prod_entry inj pos univ nt = + if univ = "prim" & nt = "var" then ETIdent else + if univ = "prim" & nt = "bigint" then ETBigint else + if univ <> "constr" then ETOther (univ,nt) else + match nt with + | "constr0" -> ETConstr (inj 0,pos) + | "constr1" -> ETConstr (inj 1,pos) + | "constr2" -> ETConstr (inj 2,pos) + | "constr3" -> ETConstr (inj 3,pos) + | "lassoc_constr4" -> ETConstr (inj 4,pos) + | "constr5" -> ETConstr (inj 5,pos) + | "constr6" -> ETConstr (inj 6,pos) + | "constr7" -> ETConstr (inj 7,pos) + | "constr8" -> ETConstr (inj 8,pos) + | "constr" when !Options.v7 -> ETConstr (inj 8,pos) + | "constr9" -> ETConstr (inj 9,pos) + | "constr10" | "lconstr" -> ETConstr (inj 10,pos) + | "pattern" -> ETPattern + | "ident" -> ETIdent + | "global" -> ETReference + | _ -> ETOther (univ,nt) + +let explicitize_entry = explicitize_prod_entry (fun x -> x) () + +(* Express border sub entries in function of the from level and an assoc *) +(* We're cheating: not necessarily the same assoc on right and left *) +let clever_explicitize_prod_entry pos univ from en = + let t = explicitize_prod_entry (fun x -> NumLevel x) pos univ en in + match from with + | ETConstr (from,()) -> + (match t with + | ETConstr (n,BorderProd (left,None)) + when (n=NumLevel from & left) -> + ETConstr (n,BorderProd (left,Some Gramext.LeftA)) + | ETConstr (NumLevel n,BorderProd (left,None)) + when (n=from-1 & not left) -> + ETConstr + (NumLevel (n+1),BorderProd (left,Some Gramext.LeftA)) + | ETConstr (NumLevel n,BorderProd (left,None)) + when (n=from-1 & left) -> + ETConstr + (NumLevel (n+1),BorderProd (left,Some Gramext.RightA)) + | ETConstr (n,BorderProd (left,None)) + when (n=NumLevel from & not left) -> + ETConstr (n,BorderProd (left,Some Gramext.RightA)) + | t -> t) + | _ -> t + +let qualified_nterm current_univ pos from = function + | NtQual (univ, en) -> + clever_explicitize_prod_entry pos univ from en + | NtShort en -> + clever_explicitize_prod_entry pos current_univ from en + +let check_entry check_entry_type = function + | ETOther (u,n) -> check_entry_type (u,n) + | _ -> () + +let nterm loc (((check_entry_type,univ),from),pos) nont = + let typ = qualified_nterm univ pos from nont in + check_entry check_entry_type typ; + typ + +let prod_item univ env = function + | VTerm s -> env, Term (terminal s) + | VNonTerm (loc, nt, Some p) -> + let typ = nterm loc univ nt in + (p :: env, NonTerm (typ, Some (p,typ))) + | VNonTerm (loc, nt, None) -> + let typ = nterm loc univ nt in + env, NonTerm (typ, None) + +let rec prod_item_list univ penv pil current_pos = + match pil with + | [] -> [], penv + | pi :: pitl -> + let pos = if pitl=[] then (BorderProd (false,None)) else current_pos in + let (env, pic) = prod_item (univ,pos) penv pi in + let (pictl, act_env) = prod_item_list univ env pitl InternalProd in + (pic :: pictl, act_env) + +let gram_rule univ (name,pil,act) = + let (pilc, act_env) = prod_item_list univ [] pil (BorderProd (true,None)) in + let a = to_act_check_vars act_env act in + { gr_name = name; gr_production = pilc; gr_action = a } + +let border = function + | NonTerm (ETConstr(_,BorderProd (_,a)),_) :: _ -> a + | _ -> None + +let clever_assoc ass g = + if g.gr_production <> [] then + (match border g.gr_production, border (List.rev g.gr_production) with + | Some LeftA, Some RightA -> ass (* Untractable; we cheat *) + | Some LeftA, _ -> Some LeftA + | _, Some RightA -> Some RightA + | _ -> Some NonA) + else ass + +let gram_entry univ (nt, ass, rl) = + let from = explicitize_entry (snd univ) nt in + let l = List.map (gram_rule (univ,from)) rl in + let ass = List.fold_left clever_assoc ass l in + { ge_name = from; + gl_assoc = ass; + gl_rules = l } + +let interp_grammar_command univ ge entryl = + { gc_univ = univ; + gc_entries = List.map (gram_entry (ge,univ)) entryl } + +(* unparsing objects *) + +type 'pat unparsing_hunk = + | PH of 'pat * string option * parenRelation + | RO of string + | UNP_BOX of ppbox * 'pat unparsing_hunk list + | UNP_BRK of int * int + | UNP_TBRK of int * int + | UNP_TAB + | UNP_FNL + | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk + +let rec subst_hunk subst_pat subst hunk = match hunk with + | PH (pat,so,pr) -> + let pat' = subst_pat subst pat in + if pat'==pat then hunk else + PH (pat',so,pr) + | RO _ -> hunk + | UNP_BOX (ppbox, hunkl) -> + let hunkl' = list_smartmap (subst_hunk subst_pat subst) hunkl in + if hunkl' == hunkl then hunk else + UNP_BOX (ppbox, hunkl') + | UNP_BRK _ + | UNP_TBRK _ + | UNP_TAB + | UNP_FNL -> hunk + | UNP_SYMBOLIC (s1, s2, pat) -> + let pat' = subst_hunk subst_pat subst pat in + if pat' == pat then hunk else + UNP_SYMBOLIC (s1, s2, pat') + +(* Checks if the precedence of the parent printer (None means the + highest precedence), and the child's one, follow the given + relation. *) + +let tolerable_prec oparent_prec_reln child_prec = + match oparent_prec_reln with + | Some (pprec, L) -> child_prec < pprec + | Some (pprec, E) -> child_prec <= pprec + | Some (_, Prec level) -> child_prec <= level + | _ -> true + +type 'pat syntax_entry = { + syn_id : string; + syn_prec: precedence; + syn_astpat : 'pat; + syn_hunks : 'pat unparsing_hunk list } + +let subst_syntax_entry subst_pat subst sentry = + let syn_astpat' = subst_pat subst sentry.syn_astpat in + let syn_hunks' = list_smartmap (subst_hunk subst_pat subst) sentry.syn_hunks + in + if syn_astpat' == sentry.syn_astpat + && syn_hunks' == sentry.syn_hunks then sentry + else + { sentry with + syn_astpat = syn_astpat' ; + syn_hunks = syn_hunks' ; + } + +type 'pat syntax_command = { + sc_univ : string; + sc_entries : 'pat syntax_entry list } + +let subst_syntax_command subst_pat subst scomm = + let sc_entries' = + list_smartmap (subst_syntax_entry subst_pat subst) scomm.sc_entries + in + if sc_entries' == scomm.sc_entries then scomm else + { scomm with sc_entries = sc_entries' } + +type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list +type raw_syntax_entry = precedence * syntax_rule list + +let rec interp_unparsing env = function + | PH (ast,ext,pr) -> PH (Ast.val_of_ast env ast,ext,pr) + | UNP_BOX (b,ul) -> UNP_BOX (b,List.map (interp_unparsing env) ul) + | UNP_BRK _ | RO _ | UNP_TBRK _ | UNP_TAB | UNP_FNL as x -> x + | UNP_SYMBOLIC (x,y,u) -> UNP_SYMBOLIC (x,y,interp_unparsing env u) + +let rule_of_ast univ prec (s,spat,unp) = + let (astpat,meta_env) = Ast.to_pat [] spat in + let hunks = List.map (interp_unparsing meta_env) unp in + { syn_id = s; + syn_prec = prec; + syn_astpat = astpat; + syn_hunks = hunks } + +let level_of_ast univ (prec,rl) = List.map (rule_of_ast univ prec) rl + +let interp_syntax_entry univ sel = + { sc_univ = univ; + sc_entries = List.flatten (List.map (level_of_ast univ) sel)} + + diff --git a/parsing/extend.mli b/parsing/extend.mli new file mode 100644 index 00000000..761d0e04 --- /dev/null +++ b/parsing/extend.mli @@ -0,0 +1,153 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr_expr -> constr_expr) -> unit + +type syntax_modifier = + | SetItemLevel of string list * production_level + | SetLevel of int + | SetAssoc of Gramext.g_assoc + | SetEntryType of string * simple_constr_production_entry + | SetOnlyParsing + | SetFormat of string located + +type nonterm = + | NtShort of string + | NtQual of string * string +type grammar_production = + | VTerm of string + | VNonTerm of loc * nonterm * Names.identifier option +type raw_grammar_rule = string * grammar_production list * grammar_action +type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list + +val terminal : string -> string * string + +val rename_command_entry : string -> string + +val explicitize_entry : string -> string -> constr_entry + +val subst_grammar_command : + Names.substitution -> grammar_command -> grammar_command + +(* unparsing objects *) + +type 'pat unparsing_hunk = + | PH of 'pat * string option * parenRelation + | RO of string + | UNP_BOX of ppbox * 'pat unparsing_hunk list + | UNP_BRK of int * int + | UNP_TBRK of int * int + | UNP_TAB + | UNP_FNL + | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk + +(*val subst_unparsing_hunk : + Names.substitution -> (Names.substitution -> 'pat -> 'pat) -> + 'pat unparsing_hunk -> 'pat unparsing_hunk +*) + +(* Checks if the precedence of the parent printer (None means the + highest precedence), and the child's one, follow the given + relation. *) + +val tolerable_prec : tolerability option -> precedence -> bool + +type 'pat syntax_entry = { + syn_id : string; + syn_prec: precedence; + syn_astpat : 'pat; + syn_hunks : 'pat unparsing_hunk list } + +val subst_syntax_entry : + (Names.substitution -> 'pat -> 'pat) -> + Names.substitution -> 'pat syntax_entry -> 'pat syntax_entry + + +type 'pat syntax_command = { + sc_univ : string; + sc_entries : 'pat syntax_entry list } + +val subst_syntax_command : + (Names.substitution -> 'pat -> 'pat) -> + Names.substitution -> 'pat syntax_command -> 'pat syntax_command + +type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list +type raw_syntax_entry = precedence * syntax_rule list + +val interp_grammar_command : + string -> (string * string -> unit) -> + raw_grammar_entry list -> grammar_command + +val interp_syntax_entry : + string -> raw_syntax_entry list -> Ast.astpat syntax_command diff --git a/parsing/g_basevernac.ml4 b/parsing/g_basevernac.ml4 new file mode 100644 index 00000000..c4badbc3 --- /dev/null +++ b/parsing/g_basevernac.ml4 @@ -0,0 +1,524 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ->" ] +let _ = + if !Options.v7 then + List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw + +let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" +let lstring = Gram.Entry.create "lstring" + + +if !Options.v7 then +GEXTEND Gram + GLOBAL: class_rawexpr; + + class_rawexpr: + [ [ IDENT "FUNCLASS" -> FunClass + | IDENT "SORTCLASS" -> SortClass + | qid = global -> RefClass qid ] ] + ; +END; + +if !Options.v7 then +GEXTEND Gram + GLOBAL: command lstring; + + lstring: + [ [ s = STRING -> s ] ] + ; + comment: + [ [ c = constr -> CommentConstr c + | s = STRING -> CommentString s + | n = natural -> CommentInt n ] ] + ; + command: + [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l + + (* System directory *) + | IDENT "Pwd" -> VernacChdir None + | IDENT "Cd" -> VernacChdir None + | IDENT "Cd"; dir = lstring -> VernacChdir (Some dir) + + (* Toplevel control *) + | IDENT "Drop" -> VernacToplevelControl Drop + | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop + | "Quit" -> VernacToplevelControl Quit + + (* Dump of the universe graph - to file or to stdout *) + | IDENT "Dump"; IDENT "Universes"; fopt = OPT lstring -> + VernacPrint (PrintUniverses fopt) + + | IDENT "Locate"; l = locatable -> VernacLocate l + + (* Managing load paths *) + | IDENT "Add"; IDENT "LoadPath"; dir = lstring; alias = as_dirpath -> + VernacAddLoadPath (false, dir, alias) + | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = lstring; + alias = as_dirpath -> VernacAddLoadPath (true, dir, alias) + | IDENT "Remove"; IDENT "LoadPath"; dir = lstring -> + VernacRemoveLoadPath dir + + (* For compatibility *) + | IDENT "AddPath"; dir = lstring; alias = as_dirpath -> + VernacAddLoadPath (false, dir, alias) + | IDENT "AddRecPath"; dir = lstring; alias = as_dirpath -> + VernacAddLoadPath (true, dir, alias) + | IDENT "DelPath"; dir = lstring -> + VernacRemoveLoadPath dir + + (* Printing (careful factorization of entries) *) + | IDENT "Print"; p = printable -> VernacPrint p + | IDENT "Print"; qid = global -> VernacPrint (PrintName qid) + | IDENT "Print" -> VernacPrint PrintLocalContext + | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> + VernacPrint (PrintModuleType qid) + | IDENT "Print"; IDENT "Module"; qid = global -> + VernacPrint (PrintModule qid) + | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) + | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid) + + (* Searching the environment *) + | IDENT "Search"; qid = global; l = in_or_out_modules -> + VernacSearch (SearchHead qid, 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"; + sl = [ "["; l = LIST1 [ r = global -> SearchRef r + | s = lstring -> SearchString s ]; "]" -> l + | qid = global -> [SearchRef qid] ]; + l = in_or_out_modules -> + VernacSearch (SearchAbout sl, l) + + (* TODO: rapprocher Eval et Check *) + | IDENT "Eval"; r = Tactic.red_expr; "in"; + c = constr -> VernacCheckMayEval (Some r, None, c) + | IDENT "Check"; c = constr -> + VernacCheckMayEval (None, None, c) + | "Type"; c = constr -> VernacGlobalCheck c (* pas dans le RefMan *) + + | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = lstring -> + VernacAddMLPath (false, dir) + | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = lstring -> + VernacAddMLPath (true, dir) +(* + | IDENT "SearchIsos"; c = constr -> VernacSearch (SearchIsos c) +*) + + (* Pour intervenir sur les tables de paramètres *) + + | "Set"; table = IDENT; field = IDENT; v = option_value -> + VernacSetOption (SecondaryTable (table,field),v) + | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> + VernacAddOption (SecondaryTable (table,field),lv) + | "Set"; table = IDENT; field = IDENT -> + VernacSetOption (SecondaryTable (table,field),BoolValue true) + | IDENT "Unset"; table = IDENT; field = IDENT -> + VernacUnsetOption (SecondaryTable (table,field)) + | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> + VernacRemoveOption (SecondaryTable (table,field),lv) + | "Set"; table = IDENT; value = option_value -> + VernacSetOption (PrimaryTable table, value) + | "Set"; table = IDENT -> + VernacSetOption (PrimaryTable table, BoolValue true) + | IDENT "Unset"; table = IDENT -> + VernacUnsetOption (PrimaryTable table) + + | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT -> + VernacPrintOption (SecondaryTable (table,field)) + | IDENT "Print"; IDENT "Table"; table = IDENT -> + VernacPrintOption (PrimaryTable table) + + | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value + -> VernacAddOption (SecondaryTable (table,field), v) + + (* Un value global ci-dessous va être caché par un field au dessus! *) + | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> + VernacAddOption (PrimaryTable table, v) + + | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value + -> VernacMemOption (SecondaryTable (table,field), v) + | IDENT "Test"; table = IDENT; field = IDENT -> + VernacPrintOption (SecondaryTable (table,field)) + | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value -> + VernacMemOption (PrimaryTable table, v) + | IDENT "Test"; table = IDENT -> + VernacPrintOption (PrimaryTable table) + + | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value + -> VernacRemoveOption (SecondaryTable (table,field), v) + | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> + VernacRemoveOption (PrimaryTable table, v) ] ] + ; + printable: + [ [ IDENT "Term"; qid = global -> PrintOpaqueName qid + | IDENT "All" -> PrintFullContext + | IDENT "Section"; s = global -> PrintSectionContext s + | IDENT "Grammar"; uni = IDENT; ent = IDENT -> + (* This should be in "syntax" section but is here for factorization*) + PrintGrammar (uni, ent) + | IDENT "LoadPath" -> PrintLoadPath + | IDENT "Modules" -> PrintModules + + | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath + | IDENT "ML"; IDENT "Modules" -> PrintMLModules + | IDENT "Graph" -> PrintGraph + | IDENT "Classes" -> PrintClasses + | IDENT "Coercions" -> PrintCoercions + | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr + -> PrintCoercionPaths (s,t) + | IDENT "Tables" -> PrintTables + | "Proof"; qid = global -> PrintOpaqueName qid + | IDENT "Hint" -> PrintHintGoal + | IDENT "Hint"; qid = global -> PrintHint qid + | IDENT "Hint"; "*" -> PrintHintDb + | IDENT "HintDb"; s = IDENT -> PrintHintDbName s + | IDENT "Scopes" -> PrintScopes + | IDENT "Scope"; s = IDENT -> PrintScope s + | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s + | IDENT "Implicit"; qid = global -> PrintImplicit qid ] ] + ; + locatable: + [ [ qid = global -> LocateTerm qid + | IDENT "File"; f = lstring -> LocateFile f + | IDENT "Library"; qid = global -> LocateLibrary qid + | s = lstring -> LocateNotation s ] ] + ; + option_value: + [ [ n = integer -> IntValue n + | s = lstring -> StringValue s ] ] + ; + option_ref_value: + [ [ id = global -> QualidRefValue id + | s = lstring -> StringRefValue s ] ] + ; + as_dirpath: + [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ] + ; + in_or_out_modules: + [ [ IDENT "inside"; l = LIST1 global -> SearchInside l + | IDENT "outside"; l = LIST1 global -> SearchOutside l + | -> SearchOutside [] ] ] + ; +END + +(* Grammar extensions *) + +(* automatic translation of levels *) +let adapt_level n = + if n >= 10 then n*10 else + [| 0; 20; 30; 40; 50; 70; 80; 85; 90; 95; 100|].(n) + +let map_modl = function + | SetItemLevel(ids,NumLevel n) -> SetItemLevel(ids,NumLevel (adapt_level n)) + | SetLevel n -> SetLevel(adapt_level n) + | m -> m + +if !Options.v7 then +GEXTEND Gram + GLOBAL: syntax; + + univ: + [ [ univ = IDENT -> + set_default_action_parser (parser_type_from_name univ); univ ] ] + ; + syntax: + [ [ IDENT "Token"; s = lstring -> + Pp.warning "Token declarations are now useless"; VernacNop + + | IDENT "Grammar"; IDENT "tactic"; IDENT "simple_tactic"; + OPT [ ":"; IDENT "tactic" ]; ":="; + OPT "|"; tl = LIST0 grammar_tactic_rule SEP "|" -> + VernacTacticGrammar tl + + | IDENT "Grammar"; u = univ; + tl = LIST1 grammar_entry SEP "with" -> + VernacGrammar (rename_command_entry u,tl) + + | IDENT "Syntax"; u = univ; el = LIST1 syntax_entry SEP ";" -> + VernacSyntax (u,el) + + | IDENT "Uninterpreted"; IDENT "Notation"; local = locality; s = lstring; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + (s8,mv8) = + [IDENT "V8only"; + s8=OPT lstring; + mv8=OPT["(";mv8=LIST1 syntax_modifier SEP ","; ")" -> mv8] -> + (s8,mv8) + | -> (None,None)] -> + let s8 = match s8 with Some s -> s | _ -> s in + let mv8 = match mv8 with + Some mv8 -> mv8 + | _ -> List.map map_modl modl in + VernacSyntaxExtension (local,Some (s,modl),Some(s8,mv8)) + + | IDENT "Uninterpreted"; IDENT "V8Notation"; local = locality; s = lstring; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> + VernacSyntaxExtension (local,None,Some(s,modl)) + + | IDENT "Open"; local = locality; IDENT "Scope"; + sc = IDENT -> VernacOpenCloseScope (local,true, sc) + + | IDENT "Close"; local = locality; IDENT "Scope"; + sc = IDENT -> VernacOpenCloseScope (local,false,sc) + + | IDENT "Delimits"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> + VernacDelimiters (sc,key) + + | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; + refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) + + | IDENT "Arguments"; IDENT "Scope"; qid = global; + "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl) + + | IDENT "Infix"; local = locality; a = entry_prec; n = OPT natural; + op = lstring; + p = global; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + sc = OPT [ ":"; sc = IDENT -> sc]; + mv8 = + [IDENT "V8only"; + a8=entry_prec; + n8=OPT natural; + op8=OPT lstring; + mv8=["("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> []] + -> + (match (a8,n8,mv8,op8) with + | None,None,[],None -> None + | _,_,mv8,_ -> + Some(op8,Metasyntax.merge_modifiers a8 n8 mv8)) + | -> (* Means: rules are based on V7 rules *) + Some (None,[]) ] -> + let mv = Metasyntax.merge_modifiers a n modl in + let v8 = Util.option_app (function (op8,mv8) -> + let op8 = match op8 with None -> op | Some op -> op in + let mv8 = + if mv8=[] then + let mv8 = List.map map_modl mv in + let mv8 = if List.for_all + (function SetLevel _ -> false | _ -> true) mv8 + then SetLevel 10 :: mv8 else mv8 in + let mv8 = if List.for_all + (function SetAssoc _ -> false | _ -> true) mv8 + then SetAssoc Gramext.LeftA :: mv8 else mv8 in + mv8 + else mv8 in + (op8,mv8)) mv8 in + VernacInfix (local,(op,mv),p,v8,sc) + | IDENT "Distfix"; local = locality; a = entry_prec; n = natural; + s = lstring; p = global; sc = OPT [ ":"; sc = IDENT -> sc ] -> + let (a,s,c) = Metasyntax.translate_distfix a s p in + let mv = Some(s,[SetLevel n;SetAssoc a]) in + VernacNotation (local,c,mv,mv,sc) +(* + VernacDistfix (local,a,n,s,p,sc) +*) + | IDENT "Notation"; local = locality; id = ident; ":="; c = constr; + b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] -> + VernacSyntacticDefinition (id,c,local,b) + | IDENT "Notation"; local = locality; s = lstring; ":="; c = constr; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + sc = OPT [ ":"; sc = IDENT -> sc ]; + (s8,mv8) = + [IDENT "V8only"; + s8=OPT lstring; + mv8=OPT["(";mv8=LIST1 syntax_modifier SEP ","; ")" -> mv8] -> + (s8,mv8) + | -> (* Means: rules are based on V7 rules *) + None, Some [] ] -> + let smv8 = match s8,mv8 with + | None, None -> None (* = only interpretation *) + | Some s8, None -> Some (s8,[]) (* = only interp, new s *) + | None, Some [] -> Some (s,List.map map_modl modl) (*like v7*) + | None, Some mv8 -> Some (s,mv8) (* s like v7 *) + | Some s8, Some mv8 -> Some (s8,mv8) in + VernacNotation (local,c,Some(s,modl),smv8,sc) + | IDENT "V8Notation"; local = locality; s = lstring; ":="; c = constr; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + sc = OPT [ ":"; sc = IDENT -> sc ] -> + VernacNotation (local,c,None,Some(s,modl),sc) + + | IDENT "V8Infix"; local = locality; op8 = lstring; p = global; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + sc = OPT [ ":"; sc = IDENT -> sc] -> + let mv8 = Metasyntax.merge_modifiers None None modl in + VernacInfix (local,("",[]),p,Some (op8,mv8),sc) + + (* "Print" "Grammar" should be here but is in "command" entry in order + to factorize with other "Print"-based vernac entries *) + ] ] + ; + locality: + [ [ IDENT "Local" -> true | -> false ] ] + ; + level: + [ [ IDENT "level"; n = natural -> NumLevel n + | IDENT "next"; IDENT "level" -> NextLevel ] ] + ; + syntax_modifier: + [ [ x = IDENT; IDENT "at"; lev = level -> SetItemLevel ([x],lev) + | x = IDENT; ","; l = LIST1 IDENT SEP ","; IDENT "at"; lev = level -> + SetItemLevel (x::l,lev) + | IDENT "at"; IDENT "level"; n = natural -> SetLevel n + | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA + | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA + | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA + | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) + | IDENT "only"; IDENT "parsing" -> SetOnlyParsing + | IDENT "format"; s = [s = lstring -> (loc,s)] -> SetFormat s ] ] + ; + syntax_extension_type: + [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference + | IDENT "bigint" -> ETBigint + | i=IDENT -> ETOther ("constr",i) + ] ] + ; + opt_scope: + [ [ IDENT "_" -> None | sc = IDENT -> Some sc ] ] + ; + (* Syntax entries for Grammar. Only grammar_entry is exported *) + grammar_entry: + [[ nont = IDENT; set_entry_type; ":="; + ep = entry_prec; OPT "|"; rl = LIST0 grammar_rule SEP "|" -> + (rename_command_entry nont,ep,rl) ]] + ; + entry_prec: + [[ IDENT "LEFTA" -> Some Gramext.LeftA + | IDENT "RIGHTA" -> Some Gramext.RightA + | IDENT "NONA" -> Some Gramext.NonA + | -> None ]] + ; + grammar_tactic_rule: + [[ name = rule_name; "["; s = lstring; pil = LIST0 production_item; "]"; + "->"; "["; t = Tactic.tactic; "]" -> (name, (s,pil), t) ]] + ; + grammar_rule: + [[ name = rule_name; "["; pil = LIST0 production_item; "]"; "->"; + a = action -> (name, pil, a) ]] + ; + rule_name: + [[ name = IDENT -> name ]] + ; + production_item: + [[ s = lstring -> VTerm s + | nt = non_terminal; po = OPT [ "("; p = METAIDENT; ")" -> p ] -> + match po with + | Some p -> VNonTerm (loc,nt,Some (Names.id_of_string p)) + | _ -> VNonTerm (loc,nt,None) ]] + ; + non_terminal: + [[ u = IDENT; ":"; nt = IDENT -> + NtQual(rename_command_entry u, rename_command_entry nt) + | nt = IDENT -> NtShort (rename_command_entry nt) ]] + ; + + + (* Syntax entries for Syntax. Only syntax_entry is exported *) + syntax_entry: + [ [ IDENT "level"; p = precedence; ":"; + OPT "|"; rl = LIST1 syntax_rule SEP "|" -> (p,rl) ] ] + ; + syntax_rule: + [ [ nm = IDENT; "["; s = astpat; "]"; "->"; u = unparsing -> (nm,s,u) ] ] + ; + precedence: + [ [ a = natural -> a +(* | "["; a1 = natural; a2 = natural; a3 = natural; "]" -> (a1,a2,a3)*) + ] ] + ; + unparsing: + [ [ "["; ll = LIST0 next_hunks; "]" -> ll ] ] + ; + next_hunks: + [ [ IDENT "FNL" -> UNP_FNL + | IDENT "TAB" -> UNP_TAB + | c = lstring -> RO c + | "["; + x = + [ b = box; ll = LIST0 next_hunks -> UNP_BOX (b,ll) + | n = natural; m = natural -> UNP_BRK (n, m) + | IDENT "TBRK"; n = natural; m = natural -> UNP_TBRK (n, m) ]; + "]" -> x + | e = Prim.ast; oprec = OPT [ ":"; pr = paren_reln_or_extern -> pr ] -> + match oprec with + | Some (ext,pr) -> PH (e,ext,pr) + | None -> PH (e,None,Any) + ]] + ; + box: + [ [ "<"; bk = box_kind; ">" -> bk ] ] + ; + box_kind: + [ [ IDENT "h"; n = natural -> PpHB n + | IDENT "v"; n = natural -> PpVB n + | IDENT "hv"; n = natural -> PpHVB n + | IDENT "hov"; n = natural -> PpHOVB n + | IDENT "t" -> PpTB ] ] + ; + paren_reln_or_extern: + [ [ IDENT "L" -> None, L + | IDENT "E" -> None, E + | pprim = lstring; precrec = OPT [ ":"; p = precedence -> p ] -> + match precrec with + | Some p -> Some pprim, Prec p + | None -> Some pprim, Any ] ] + ; + (* meta-syntax entries *) + astpat: + [ [ "<<" ; a = Prim.ast; ">>" -> a + | a = Constr.constr -> + Termast.ast_of_rawconstr + (Constrintern.interp_rawconstr Evd.empty (Global.env()) a) + ] ] + ; + action: + [ [ IDENT "let"; p = Prim.astlist; et = set_internal_entry_type; + "="; e1 = action; "in"; e = action -> Ast.CaseAction (loc,e1,et,[p,e]) + | IDENT "case"; a = action; et = set_internal_entry_type; "of"; + cl = LIST1 case SEP "|"; IDENT "esac" -> Ast.CaseAction (loc,a,et,cl) + | "["; a = default_action_parser; "]" -> Ast.SimpleAction (loc,a) ] ] + ; + case: + [[ p = Prim.astlist; "->"; a = action -> (p,a) ]] + ; + set_internal_entry_type: + [[ ":"; IDENT "ast"; IDENT "list" -> Ast.ETastl + | [ ":"; IDENT "ast" -> () | -> () ] -> Ast.ETast ]] + ; + set_entry_type: + [[ ":"; et = entry_type -> set_default_action_parser et + | -> () ]] + ; + entry_type: + [[ IDENT "ast"; IDENT "list" -> Util.error "type ast list no longer supported" + | IDENT "ast" -> Util.error "type ast no longer supported" + | IDENT "constr" -> ConstrParser + | IDENT "pattern" -> CasesPatternParser + | IDENT "tactic" -> assert false + | IDENT "vernac" -> Util.error "vernac extensions no longer supported" ] ] + ; +END diff --git a/parsing/g_cases.ml4 b/parsing/g_cases.ml4 new file mode 100644 index 00000000..b952305d --- /dev/null +++ b/parsing/g_cases.ml4 @@ -0,0 +1,73 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* CPatAtom (loc,Some r) + | IDENT "_" -> CPatAtom (loc,None) + (* Hack to parse syntax "(n)" as a natural number *) + | "("; G_constr.test_int_rparen; n = bigint; ")" -> + (* Delimiter "N" moved to "nat" in V7 *) + CPatDelimiters (loc,"nat",CPatNumeral (loc,n)) + | "("; p = compound_pattern; ")" -> p + | n = bigint -> CPatNumeral (loc,n) + | "'"; G_constr.test_ident_colon; key = IDENT; ":"; c = pattern; "'" -> + CPatDelimiters (loc,key,c) + ] ] + ; + compound_pattern: + [ [ p = pattern ; lp = LIST1 pattern -> + (match p with + | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) + | _ -> Util.user_err_loc + (loc, "compound_pattern", Pp.str "Constructor expected")) + | p = pattern; "as"; id = base_ident -> + CPatAlias (loc, p, id) + | p1 = pattern; ","; p2 = pattern -> + CPatCstr (loc, pair loc, [p1; p2]) + | p = pattern -> p ] ] + ; + equation: + [ [ lhs = LIST1 pattern; "=>"; rhs = operconstr LEVEL "9" -> (loc,lhs,rhs) ] ] + ; + ne_eqn_list: + [ [ leqn = LIST1 equation SEP "|" -> leqn ] ] + ; + operconstr: LEVEL "1" + [ [ "<"; p = annot; ">"; "Cases"; lc = LIST1 constr; "of"; + OPT "|"; eqs = ne_eqn_list; "end" -> + let lc = List.map (fun c -> c,(None,None)) lc in + CCases (loc, (Some p,None), lc, eqs) + | "Cases"; lc = LIST1 constr; "of"; + OPT "|"; eqs = ne_eqn_list; "end" -> + let lc = List.map (fun c -> c,(None,None)) lc in + CCases (loc, (None,None), lc, eqs) + | "<"; p = annot; ">"; "Cases"; lc = LIST1 constr; "of"; "end" -> + let lc = List.map (fun c -> c,(None,None)) lc in + CCases (loc, (Some p,None), lc, []) + | "Cases"; lc = LIST1 constr; "of"; "end" -> + let lc = List.map (fun c -> c,(None,None)) lc in + CCases (loc, (None,None), lc, []) ] ] + ; +END; diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 new file mode 100644 index 00000000..7b0f7da2 --- /dev/null +++ b/parsing/g_constr.ml4 @@ -0,0 +1,368 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "; "="; ":="; "!"; + "::"; "<:"; ":<"; "=>"; "<"; ">"; "|"; "?"; "/"; + "<->"; "\\/"; "/\\"; "`"; "``"; "&"; "*"; "+"; "@"; "^"; "#"; "-"; + "~"; "'"; "<<"; ">>"; "<>" + ] +let _ = + if !Options.v7 then + List.iter (fun s -> Lexer.add_token ("",s)) constr_kw +(* "let" is not a keyword because #Core#let.cci would not parse. + Is it still accurate ? *) + + +let coerce_to_var = function + | CRef (Ident (_,id)) -> id + | ast -> Util.user_err_loc + (constr_loc ast,"Ast.coerce_to_var", + (Pp.str"This expression should be a simple identifier")) + +let coerce_to_name = function + | CRef (Ident (loc,id)) -> (loc, Name id) + | ast -> Util.user_err_loc + (constr_loc ast,"Ast.coerce_to_var", + (Pp.str"This expression should be a simple identifier")) + +let set_loc loc = function + | CRef(Ident(_,i)) -> CRef(Ident(loc,i)) + | CRef(Qualid(_,q)) -> CRef(Qualid(loc,q)) + | CFix(_,x,a) -> CFix(loc,x,a) + | CCoFix(_,x,a) -> CCoFix(loc,x,a) + | CArrow(_,a,b) -> CArrow(loc,a,b) + | CProdN(_,bl,a) -> CProdN(loc,bl,a) + | CLambdaN(_,bl,a) -> CLambdaN(loc,bl,a) + | CLetIn(_,x,a,b) -> CLetIn(loc,x,a,b) + | CAppExpl(_,f,a) -> CAppExpl(loc,f,a) + | CApp(_,f,a) -> CApp(loc,f,a) + | CCases(_,p,a,br) -> CCases(loc,p,a,br) + | COrderedCase(_,s,p,a,br) -> COrderedCase(loc,s,p,a,br) + | CLetTuple(_,ids,p,a,b) -> CLetTuple(loc,ids,p,a,b) + | CIf(_,e,p,a,b) -> CIf(loc,e,p,a,b) + | CHole _ -> CHole loc + | CPatVar(_,v) -> CPatVar(loc,v) + | CEvar(_,ev) -> CEvar(loc,ev) + | CSort(_,s) -> CSort(loc,s) + | CCast(_,a,b) -> CCast(loc,a,b) + | CNotation(_,n,l) -> CNotation(loc,n,l) + | CNumeral(_,i) -> CNumeral(loc,i) + | CDelimiters(_,s,e) -> CDelimiters(loc,s,e) + | CDynamic(_,d) -> CDynamic(loc,d) + +open Util + +let rec abstract_constr loc c = function + | [] -> c + | LocalRawDef ((loc',x),b)::bl -> + CLetIn (join_loc loc' loc, (loc', x), b, abstract_constr loc c bl) + | LocalRawAssum (nal,t)::bl -> + let loc' = join_loc (fst (List.hd nal)) loc in + CLambdaN(loc', [nal, t], abstract_constr loc c bl) + +(* Hack to parse "(n)" as nat without conflicts with the (useless) *) +(* admissible notation "(n)" *) +let test_int_rparen = + Gram.Entry.of_parser "test_int_rparen" + (fun strm -> + match Stream.npeek 1 strm with + | [("INT", _)] -> + begin match Stream.npeek 2 strm with + | [_; ("", ")")] -> () + | _ -> raise Stream.Failure + end + | _ -> raise Stream.Failure) + +(* Hack to parse "n" at level 0 without conflicting with "n!" at level 91 *) +(* admissible notation "(n)" *) +let test_int_bang = + Gram.Entry.of_parser "test_int_bang" + (fun strm -> + match Stream.npeek 1 strm with + | [("INT", n)] -> + begin match Stream.npeek 2 strm with + | [_; ("", "!")] -> () + | _ -> raise Stream.Failure + end + | _ -> raise Stream.Failure) + +(* Hack to parse "`id:...`" at level 0 without conflicting with + "`...`" from ZArith *) +let test_ident_colon = + Gram.Entry.of_parser "test_ident_colon" + (fun strm -> + match Stream.npeek 1 strm with + | [("IDENT", _)] -> + begin match Stream.npeek 2 strm with + | [_; ("", ":")] -> () + | _ -> raise Stream.Failure + end + | _ -> raise Stream.Failure) + + +if !Options.v7 then +GEXTEND Gram + GLOBAL: operconstr lconstr constr sort global constr_pattern Constr.ident annot + (*ne_name_comma_list*); + Constr.ident: + [ [ id = Prim.ident -> id + + (* This is used in quotations and Syntax *) + | id = METAIDENT -> id_of_string id ] ] + ; + global: + [ [ r = Prim.reference -> r + + (* This is used in quotations *) + | id = METAIDENT -> Ident (loc,id_of_string id) ] ] + ; + constr_pattern: + [ [ c = constr -> c ] ] + ; + ne_constr_list: + [ [ cl = LIST1 constr -> cl ] ] + ; + sort: + [ [ "Set" -> RProp Pos + | "Prop" -> RProp Null + | "Type" -> RType None ] ] + ; + constr: + [ [ c = operconstr LEVEL "8" -> c ] ] + ; + lconstr: + [ [ c = operconstr LEVEL "10" -> c ] ] + ; + operconstr: + [ "10" RIGHTA + [ "!"; f = global; args = LIST0 (operconstr LEVEL "9") -> + CAppExpl (loc, (None,f), args) +(* + | "!"; f = global; "with"; b = binding_list -> + <:ast< (APPLISTWITH $f $b) >> +*) + | f = operconstr; args = LIST1 constr91 -> CApp (loc, (None,f), args) ] + | "9" RIGHTA + [ c1 = operconstr; "::"; c2 = operconstr LEVEL "9" -> CCast (loc, c1, c2) ] + | "8" RIGHTA + [ c1 = operconstr; "->"; c2 = operconstr LEVEL "8"-> CArrow (loc, c1, c2) ] + | "1" RIGHTA + [ "<"; p = annot; ">"; IDENT "Match"; c = constr; "with"; + cl = LIST0 constr; "end" -> + COrderedCase (loc, MatchStyle, Some p, c, cl) + | "<"; p = annot; ">"; IDENT "Case"; c = constr; "of"; + cl = LIST0 constr; "end" -> + COrderedCase (loc, RegularStyle, Some p, c, cl) + | IDENT "Case"; c = constr; "of"; cl = LIST0 constr; "end" -> + COrderedCase (loc, RegularStyle, None, c, cl) + | IDENT "Match"; c = constr; "with"; cl = LIST1 constr; "end" -> + COrderedCase (loc, MatchStyle, None, c, cl) + | IDENT "let"; "("; b = ne_name_comma_list; ")"; "="; + c = constr; "in"; c1 = constr -> + (* TODO: right loc *) + COrderedCase + (loc, LetStyle, None, c, [CLambdaN (loc, [b, CHole loc], c1)]) + | IDENT "let"; na = name; "="; c = opt_casted_constr; + "in"; c1 = constr -> + CLetIn (loc, na, c, c1) + | IDENT "if"; c1 = constr; + IDENT "then"; c2 = constr; + IDENT "else"; c3 = constr -> + COrderedCase (loc, IfStyle, None, c1, [c2; c3]) + | "<"; p = annot; ">"; + IDENT "let"; "("; b = ne_name_comma_list; ")"; "="; c = constr; + "in"; c1 = constr -> + (* TODO: right loc *) + COrderedCase (loc, LetStyle, Some p, c, + [CLambdaN (loc, [b, CHole loc], c1)]) + | "<"; p = annot; ">"; + IDENT "if"; c1 = constr; + IDENT "then"; c2 = constr; + IDENT "else"; c3 = constr -> + COrderedCase (loc, IfStyle, Some p, c1, [c2; c3]) + | ".."; c = operconstr LEVEL "0"; ".." -> + CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ] + | "0" RIGHTA + [ "?" -> CHole loc + | "?"; n = Prim.natural -> CPatVar (loc, (false,Pattern.patvar_of_int n)) + | bll = binders; c = constr -> abstract_constr loc c bll + (* Hack to parse syntax "(n)" as a natural number *) + | "("; test_int_rparen; n = bigint; ")" -> + (* Delimiter "N" moved to "nat" in V7 *) + CDelimiters (loc,"nat",CNumeral (loc,n)) + | "("; lc1 = lconstr; ":"; c = constr; (bl,body) = product_tail -> + let id = coerce_to_name lc1 in + CProdN (loc, ([id], c)::bl, body) +(* TODO: Syntaxe (_:t...)t et (_,x...)t *) + | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr; + (bl,body) = product_tail -> + let id1 = coerce_to_name lc1 in + let id2 = coerce_to_name lc2 in + CProdN (loc, ([id1; id2], c)::bl, body) + | "("; lc1 = lconstr; ","; lc2 = lconstr; ","; + idl = ne_name_comma_list; ":"; c = constr; (bl,body) = product_tail -> + let id1 = coerce_to_name lc1 in + let id2 = coerce_to_name lc2 in + CProdN (loc, (id1::id2::idl, c)::bl, body) + | "("; lc1 = lconstr; ")" -> + if Options.do_translate() then set_loc loc lc1 else lc1 + | "("; lc1 = lconstr; ")"; "@"; "["; cl = ne_constr_list; "]" -> + (match lc1 with + | CPatVar (loc2,(false,n)) -> + CApp (loc,(None,CPatVar (loc2, (true,n))), List.map (fun c -> c, None) cl) + | _ -> + Util.error "Second-order pattern-matching expects a head metavariable") + | IDENT "Fix"; id = identref; "{"; fbinders = fixbinders; "}" -> + CFix (loc, id, fbinders) + | IDENT "CoFix"; id = identref; "{"; fbinders = cofixbinders; "}" -> + CCoFix (loc, id, fbinders) + | IDENT "Prefix" ; "(" ; s = STRING ; cl = LIST0 constr ; ")" -> + CNotation(loc, s, cl) + | s = sort -> CSort (loc, s) + | v = global -> CRef v + | n = bigint -> CNumeral (loc,n) + | "!"; f = global -> CAppExpl (loc,(None,f),[]) + | "'"; test_ident_colon; key = IDENT; ":"; c = constr; "'" -> + (* Delimiter "N" implicitly moved to "nat" in V7 *) + let key = if key = "N" then "nat" else key in + let key = if key = "P" then "positive" else key in + let key = if key = "T" then "type" else key in + CDelimiters (loc,key,c) ] ] + ; + constr91: + [ [ test_int_bang; n = INT; "!"; c = operconstr LEVEL "9" -> + (c, Some (loc,ExplByPos (int_of_string n))) + | c = operconstr LEVEL "9" -> (c, None) ] ] + ; + (* annot and product_annot_tail are hacks to forbid concrete syntax *) + (* ">" (e.g. for gt, Zgt, ...) in annotations *) + annot: + [ RIGHTA + [ bll = binders; c = annot -> abstract_constr loc c bll + | "("; lc1 = lconstr; ":"; c = constr; (bl,body) = product_annot_tail -> + let id = coerce_to_name lc1 in + CProdN (loc, ([id], c)::bl, body) + | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr; + (bl,body) = product_annot_tail -> + let id1 = coerce_to_name lc1 in + let id2 = coerce_to_name lc2 in + CProdN (loc, ([id1; id2], c)::bl, body) + | "("; lc1 = lconstr; ","; lc2 = lconstr; ","; + idl = ne_name_comma_list; ":"; c = constr; + (bl,body) = product_annot_tail -> + let id1 = coerce_to_name lc1 in + let id2 = coerce_to_name lc2 in + CProdN (loc, (id1::id2::idl, c)::bl, body) + | "("; lc1 = lconstr; ")" -> lc1 + | c1 = annot; "->"; c2 = annot -> CArrow (loc, c1, c2) ] + | RIGHTA + [ c1 = annot; "\\/"; c2 = annot -> CNotation (loc, "_ \\/ _", [c1;c2]) ] + | RIGHTA + [ c1 = annot; "/\\"; c2 = annot -> CNotation (loc, "_ /\\ _", [c1;c2]) ] + | RIGHTA + [ "~"; c = SELF -> CNotation (loc, "~ _", [c]) ] + | RIGHTA + [ c1 = SELF; "=="; c2 = NEXT -> CNotation (loc, "_ == _", [c1;c2]) ] + | RIGHTA + [ c1 = SELF; "="; c2 = NEXT -> CNotation (loc, "_ = _", [c1;c2]) ] + | [ c = operconstr LEVEL "4L" -> c ] ] + ; + product_annot_tail: + [ [ ";"; idl = ne_name_comma_list; ":"; c = constr; + (bl,c2) = product_annot_tail -> ((idl, c)::bl, c2) + | ";"; idl = ne_name_comma_list; (bl,c2) = product_annot_tail -> + ((idl, CHole (fst (List.hd idl)))::bl, c2) + | ")"; c = annot -> ([], c) ] ] + ; + ne_name_comma_list: + [ [ nal = LIST1 name SEP "," -> nal ] ] + ; + name_comma_list_tail: + [ [ ","; idl = ne_name_comma_list -> idl + | -> [] ] ] + ; + opt_casted_constr: + [ [ c = constr; ":"; t = constr -> CCast (loc, c, t) + | c = constr -> c ] ] + ; + vardecls: + [ [ na = name; nal = name_comma_list_tail; c = type_option -> + LocalRawAssum (na::nal,c) + | na = name; "="; c = opt_casted_constr -> + LocalRawDef (na, c) + | na = name; ":="; c = opt_casted_constr -> + LocalRawDef (na, c) + + (* This is used in quotations *) + | id = METAIDENT; c = type_option -> LocalRawAssum ([loc, Name (id_of_string id)], c) + ] ] + ; + ne_vardecls_list: + [ [ id = vardecls; ";"; idl = ne_vardecls_list -> id :: idl + | id = vardecls -> [id] ] ] + ; + binders: + [ [ "["; bl = ne_vardecls_list; "]" -> bl ] ] + ; + simple_params: + [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c) + | idl = LIST1 name SEP "," -> (idl, CHole loc) + ] ] + ; + simple_binders: + [ [ "["; bll = LIST1 simple_params SEP ";"; "]" -> bll ] ] + ; + ne_simple_binders_list: + [ [ bll = LIST1 simple_binders -> List.flatten bll ] ] + ; + type_option: + [ [ ":"; c = constr -> c + | -> CHole loc ] ] + ; + fixbinder: + [ [ id = base_ident; "/"; recarg = natural; ":"; type_ = constr; + ":="; def = constr -> + (id, recarg-1, [], type_, def) + | id = base_ident; bl = ne_simple_binders_list; ":"; type_ = constr; + ":="; def = constr -> + let ni = List.length (List.flatten (List.map fst bl)) -1 in + let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in + (id, ni, bl, type_, def) ] ] + ; + fixbinders: + [ [ fbs = LIST1 fixbinder SEP "with" -> fbs ] ] + ; + cofixbinder: + [ [ id = base_ident; ":"; type_ = constr; ":="; def = constr -> + (id, [],type_, def) ] ] + ; + cofixbinders: + [ [ fbs = LIST1 cofixbinder SEP "with" -> fbs ] ] + ; + product_tail: + [ [ ";"; idl = ne_name_comma_list; ":"; c = constr; + (bl,c2) = product_tail -> ((idl, c)::bl, c2) + | ";"; idl = ne_name_comma_list; (bl,c2) = product_tail -> + ((idl, CHole (fst (List.hd idl)))::bl, c2) + | ")"; c = constr -> ([], c) ] ] + ; +END;; diff --git a/parsing/g_constrnew.ml4 b/parsing/g_constrnew.ml4 new file mode 100644 index 00000000..18dc5683 --- /dev/null +++ b/parsing/g_constrnew.ml4 @@ -0,0 +1,336 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Lexer.add_token("",s)) constr_kw + +(* For Correctness syntax; doesn't work if in psyntax (freeze pb?) *) +let _ = Lexer.add_token ("","!") + +let mk_cast = function + (c,(_,None)) -> c + | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, ty) + +let mk_lam = function + ([],c) -> c + | (bl,c) -> CLambdaN(constr_loc c, bl,c) + +let mk_match (loc,cil,rty,br) = + CCases(loc,(None,rty),cil,br) + +let loc_of_binder_let = function + | LocalRawAssum ((loc,_)::_,_)::_ -> loc + | LocalRawDef ((loc,_),_)::_ -> loc + | _ -> dummy_loc + +let rec mkCProdN loc bll c = + match bll with + | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> + CProdN (loc,[idl,t],mkCProdN (join_loc loc1 loc) bll c) + | LocalRawDef ((loc1,_) as id,b) :: bll -> + CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c) + | [] -> c + | LocalRawAssum ([],_) :: bll -> mkCProdN loc bll c + +let rec mkCLambdaN loc bll c = + match bll with + | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> + CLambdaN (loc,[idl,t],mkCLambdaN (join_loc loc1 loc) bll c) + | LocalRawDef ((loc1,_) as id,b) :: bll -> + CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c) + | [] -> c + | LocalRawAssum ([],_) :: bll -> mkCLambdaN loc bll c + +let rec index_of_annot loc bl ann = + match names_of_local_assums bl,ann with + | [_], None -> 0 + | lids, Some x -> + let ids = List.map snd lids in + (try list_index (snd x) ids - 1 + with Not_found -> + user_err_loc(fst x,"index_of_annot", Pp.str"no such fix variable")) + | _ -> user_err_loc(loc,"index_of_annot", + Pp.str "cannot guess decreasing argument of fix") + +let mk_fixb (id,bl,ann,body,(loc,tyc)) = + let n = index_of_annot (fst id) bl ann in + let ty = match tyc with + Some ty -> ty + | None -> CHole loc in + (snd id,n,bl,ty,body) + +let mk_cofixb (id,bl,ann,body,(loc,tyc)) = + let _ = option_app (fun (aloc,_) -> + Util.user_err_loc + (aloc,"Constr:mk_cofixb", + Pp.str"Annotation forbidden in cofix expression")) ann in + let ty = match tyc with + Some ty -> ty + | None -> CHole loc in + (snd id,bl,ty,body) + +let mk_fix(loc,kw,id,dcls) = + if kw then + let fb = List.map mk_fixb dcls in + CFix(loc,id,fb) + else + let fb = List.map mk_cofixb dcls in + CCoFix(loc,id,fb) + +let mk_single_fix (loc,kw,dcl) = + let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl]) + +let binder_constr = + create_constr_entry (get_univ "constr") "binder_constr" + +(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) +(* admissible notation "(x t)" *) +let lpar_id_coloneq = + Gram.Entry.of_parser "test_lpar_id_coloneq" + (fun strm -> + match Stream.npeek 1 strm with + | [("","(")] -> + (match Stream.npeek 2 strm with + | [_; ("IDENT",s)] -> + (match Stream.npeek 3 strm with + | [_; _; ("", ":=")] -> + Stream.junk strm; Stream.junk strm; Stream.junk strm; + Names.id_of_string s + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + + +if not !Options.v7 then +GEXTEND Gram + GLOBAL: binder_constr lconstr constr operconstr sort global + constr_pattern lconstr_pattern Constr.ident binder binder_let pattern; + Constr.ident: + [ [ id = Prim.ident -> id + + (* This is used in quotations and Syntax *) + | id = METAIDENT -> id_of_string id ] ] + ; + Prim.name: + [ [ "_" -> (loc, Anonymous) ] ] + ; + Prim.ast: + [ [ "_" -> Coqast.Nvar(loc,id_of_string"_") ] ] + ; + global: + [ [ r = Prim.reference -> r + + (* This is used in quotations *) + | id = METAIDENT -> Ident (loc,id_of_string id) ] ] + ; + constr_pattern: + [ [ c = constr -> c ] ] + ; + lconstr_pattern: + [ [ c = lconstr -> c ] ] + ; + sort: + [ [ "Set" -> RProp Pos + | "Prop" -> RProp Null + | "Type" -> RType None ] ] + ; + lconstr: + [ [ c = operconstr LEVEL "200" -> c ] ] + ; + constr: + [ [ c = operconstr LEVEL "9" -> c ] ] + ; + operconstr: + [ "200" RIGHTA + [ c = binder_constr -> c ] + | "100" RIGHTA + [ c1 = operconstr; ":"; c2 = binder_constr -> CCast(loc,c1,c2) + | c1 = operconstr; ":"; c2 = SELF -> CCast(loc,c1,c2) ] + | "99" RIGHTA [ ] + | "90" RIGHTA + [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2) + | c1 = operconstr; "->"; c2 = SELF -> CArrow(loc,c1,c2)] + | "10" LEFTA + [ f=operconstr; args=LIST1 appl_arg -> CApp(loc,(None,f),args) + | "@"; f=global; args=LIST0 NEXT -> CAppExpl(loc,(None,f),args) ] + | "9" + [ ".."; c = operconstr LEVEL "0"; ".." -> + CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ] + | "1" LEFTA + [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" -> + CApp(loc,(Some (List.length args+1),CRef f),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) ] + | "0" + [ c=atomic_constr -> c + | c=match_constr -> c + | "("; c = operconstr LEVEL "200"; ")" -> + (match c with + CNumeral(_,Bignat.POS _) -> CNotation(loc,"( _ )",[c]) + | _ -> c) ] ] + ; + binder_constr: + [ [ "forall"; bl = binder_list; ","; c = operconstr LEVEL "200" -> + mkCProdN loc bl c + | "fun"; bl = binder_list; "=>"; c = operconstr LEVEL "200" -> + mkCLambdaN loc bl c + | "let"; id=name; bl = LIST0 binder_let; ty = type_cstr; ":="; + c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> + let loc1 = loc_of_binder_let bl 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) + | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []]; + po = return_type; + ":="; c1 = operconstr LEVEL "200"; "in"; + c2 = operconstr LEVEL "200" -> + CLetTuple (loc,List.map snd lb,po,c1,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) + | c=fix_constr -> c ] ] + ; + appl_arg: + [ [ id = lpar_id_coloneq; c=lconstr; ")" -> + (c,Some (loc,ExplByName id)) + | c=constr -> (c,None) ] ] + ; + atomic_constr: + [ [ g=global -> CRef g + | s=sort -> CSort(loc,s) + | n=INT -> CNumeral (loc,Bignat.POS (Bignat.of_string n)) + | "_" -> CHole loc + | "?"; id=ident -> CPatVar(loc,(false,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) + ] ] + ; + single_fix: + [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ] + ; + fix_kw: + [ [ "fix" -> true + | "cofix" -> false ] ] + ; + fix_decl: + [ [ id=identref; bl=LIST0 binder_let; ann=fixannot; ty=type_cstr; ":="; + c=operconstr LEVEL "200" -> (id,bl,ann,c,ty) ] ] + ; + fixannot: + [ [ "{"; IDENT "struct"; id=name; "}" -> Some id + | -> None ] ] + ; + match_constr: + [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with"; + br=branches; "end" -> mk_match (loc,ci,ty,br) ] ] + ; + case_item: + [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] + ; + pred_pattern: + [ [ ona = OPT ["as"; id=name -> snd id]; + ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ] + ; + case_type: + [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ] + ; + return_type: + [ [ a = OPT [ na = OPT["as"; id=name -> snd id]; + ty = case_type -> (na,ty) ] -> + match a with + | None -> None, None + | Some (na,t) -> (na, Some t) + ] ] + ; + branches: + [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ] + ; + eqn: + [ [ pl = LIST1 pattern SEP ","; "=>"; rhs = lconstr -> (loc,pl,rhs) ] ] + ; + pattern: + [ "10" LEFTA + [ p = pattern ; lp = LIST1 (pattern LEVEL "0") -> + (match p with + | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) + | _ -> Util.user_err_loc + (cases_pattern_loc p, "compound_pattern", + Pp.str "Constructor expected")) + | p = pattern; "as"; id = base_ident -> + CPatAlias (loc, p, id) + | c = pattern; "%"; key=IDENT -> + CPatDelimiters (loc,key,c) ] + | "0" + [ r = Prim.reference -> CPatAtom (loc,Some r) + | "_" -> CPatAtom (loc,None) + | "("; p = pattern LEVEL "200"; ")" -> + (match p with + CPatNumeral(_,Bignat.POS _) -> CPatNotation(loc,"( _ )",[p]) + | _ -> p) + | n = INT -> CPatNumeral (loc,Bignat.POS(Bignat.of_string n)) ] ] + ; + binder_list: + [ [ idl=LIST1 name; bl=LIST0 binder_let -> + LocalRawAssum (idl,CHole loc)::bl + | idl=LIST1 name; ":"; c=lconstr -> + [LocalRawAssum (idl,c)] + | "("; idl=LIST1 name; ":"; c=lconstr; ")"; bl=LIST0 binder_let -> + LocalRawAssum (idl,c)::bl ] ] + ; + binder_let: + [ [ id=name -> + LocalRawAssum ([id],CHole loc) + | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> + LocalRawAssum (id::idl,c) + | "("; id=name; ":"; c=lconstr; ")" -> + LocalRawAssum ([id],c) + | "("; id=name; ":="; c=lconstr; ")" -> + LocalRawDef (id,c) + | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> + LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c,t)) + ] ] + ; + binder: + [ [ id=name -> ([id],CHole loc) + | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,c) ] ] + ; + type_cstr: + [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ] + ; + END;; diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 new file mode 100644 index 00000000..7349a6f8 --- /dev/null +++ b/parsing/g_ltac.ml4 @@ -0,0 +1,213 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* user_err_loc (loc, "", (str "Syntax Error")) + | LETCLAUSE (id,c,d) -> (id,c,d) + +let make_letin_clause loc = List.map (out_letin_clause loc) + +let arg_of_expr = function + TacArg a -> a + | e -> Tacexp (e:raw_tactic_expr) + +(* Tactics grammar rules *) + +if !Options.v7 then +GEXTEND Gram + GLOBAL: tactic Vernac_.command tactic_arg; + +(* + GLOBAL: tactic_atom tactic_atom0 tactic_expr input_fun; +*) + input_fun: + [ [ l = base_ident -> Some l + | "()" -> None ] ] + ; + let_clause: + [ [ id = identref; "="; te = tactic_letarg -> LETCLAUSE (id, None, te) + | id = base_ident; ":"; c = Constr.constr; ":="; "Proof" -> + LETTOPCLAUSE (id, c) + | id = identref; ":"; c = constrarg; ":="; te = tactic_letarg -> + LETCLAUSE (id, Some (TacArg(ConstrMayEval c)), te) + | id = base_ident; ":"; c = Constr.constr -> + LETTOPCLAUSE (id, c) ] ] + ; + rec_clause: + [ [ name = identref; it = LIST1 input_fun; "->"; body = tactic_expr -> + (name,(it,body)) ] ] + ; + match_pattern: + [ [ id = Constr.constr_pattern; "["; pc = Constr.constr_pattern; "]" -> + let (_,s) = coerce_to_id id in Subterm (Some s, pc) + | "["; pc = Constr.constr_pattern; "]" -> Subterm (None,pc) + | pc = Constr.constr_pattern -> Term pc ] ] + ; + match_hyps: + [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) ] ] + ; + match_context_rule: + [ [ "["; largs = LIST0 match_hyps SEP ";"; "|-"; mp = match_pattern; "]"; + "->"; te = tactic_expr -> Pat (largs, mp, te) + | IDENT "_"; "->"; te = tactic_expr -> All te ] ] + ; + match_context_list: + [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] + ; + match_rule: + [ [ "["; mp = match_pattern; "]"; "->"; te = tactic_expr -> Pat ([],mp,te) + | IDENT "_"; "->"; te = tactic_expr -> All te ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] + ; + tactic_expr: + [ [ ta = tactic_expr5 -> ta ] ] + ; + tactic_expr5: + [ [ ta0 = tactic_expr5; ";"; ta1 = tactic_expr4 -> TacThen (ta0, ta1) + | ta = tactic_expr5; ";"; "["; lta = LIST0 tactic_expr SEP "|"; "]" -> + TacThens (ta, lta) + | y = tactic_expr4 -> y ] ] + ; + tactic_expr4: + [ [ ta = tactic_expr3 -> ta ] ] + ; + tactic_expr3: + [ [ IDENT "Try"; ta = tactic_expr3 -> TacTry ta + | IDENT "Do"; n = int_or_var; ta = tactic_expr3 -> TacDo (n,ta) + | IDENT "Repeat"; ta = tactic_expr3 -> TacRepeat ta + | IDENT "Progress"; ta = tactic_expr3 -> TacProgress ta + | IDENT "Info"; tc = tactic_expr3 -> TacInfo tc + | ta = tactic_expr2 -> ta ] ] + ; + tactic_expr2: + [ [ ta0 = tactic_atom; "Orelse"; ta1 = tactic_expr3 -> TacOrelse (ta0,ta1) + | ta = tactic_atom -> ta ] ] + ; + tactic_atom: + [ [ IDENT "Fun"; it = LIST1 input_fun ; "->"; body = tactic_expr -> + TacFun (it,body) + | IDENT "Rec"; rc = rec_clause -> + warning "'Rec f ...' is obsolete; use 'Rec f ... In f' instead"; + TacLetRecIn ([rc],TacArg (Reference (Libnames.Ident (fst rc)))) + | IDENT "Rec"; rc = rec_clause; rcl = LIST0 rec_clause SEP "And"; + [IDENT "In" | "in"]; body = tactic_expr -> TacLetRecIn (rc::rcl,body) + | IDENT "Let"; llc = LIST1 let_clause SEP "And"; IDENT "In"; + u = tactic_expr -> TacLetIn (make_letin_clause loc llc,u) + + | IDENT "Match"; IDENT "Context"; IDENT "With"; mrl = match_context_list + -> TacMatchContext (false,mrl) + | IDENT "Match"; IDENT "Reverse"; IDENT "Context"; IDENT "With"; mrl = match_context_list + -> TacMatchContext (true,mrl) + | IDENT "Match"; c = constrarg; IDENT "With"; mrl = match_list -> + TacMatch (TacArg(ConstrMayEval c),mrl) +(*To do: put Abstract in Refiner*) + | IDENT "Abstract"; tc = tactic_expr -> TacAbstract (tc,None) + | IDENT "Abstract"; tc = tactic_expr; "using"; s = base_ident -> + TacAbstract (tc,Some s) +(*End of To do*) + | IDENT "First" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacFirst l + | IDENT "Solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacSolve l + | IDENT "Idtac" ; s = [ s = STRING -> s | -> ""] -> TacId s + | IDENT "Fail"; n = [ n = int_or_var -> n | -> fail_default_value ]; + s = [ s = STRING -> s | -> ""] -> TacFail (n,s) + | st = simple_tactic -> TacAtom (loc,st) + | "("; a = tactic_expr; ")" -> a + | a = tactic_arg -> TacArg a + ] ] + ; + (* Tactic arguments *) + tactic_arg: + [ [ ta = tactic_arg1 -> ta ] ] + ; + tactic_letarg: + (* Cannot be merged with tactic_arg1, since then "In"/"And" are + parsed as lqualid! *) + [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr -> + ConstrMayEval (ConstrEval (rtc,c)) + | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" -> + ConstrMayEval (ConstrContext (id,c)) + | IDENT "Check"; c = Constr.constr -> + ConstrMayEval (ConstrTypeOf c) + | IDENT "FreshId"; s = OPT STRING -> TacFreshId s + | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat + | r = reference -> Reference r + | ta = tactic_arg0 -> ta ] ] + ; + tactic_arg1: + [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr -> + ConstrMayEval (ConstrEval (rtc,c)) + | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" -> + ConstrMayEval (ConstrContext (id,c)) + | IDENT "Check"; c = Constr.constr -> + ConstrMayEval (ConstrTypeOf c) + | IDENT "FreshId"; s = OPT STRING -> TacFreshId s + | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat + | r = reference; la = LIST1 tactic_arg0 -> TacCall (loc,r,la) + | r = reference -> Reference r + | ta = tactic_arg0 -> ta ] ] + ; + tactic_arg0: + [ [ "("; a = tactic_expr; ")" -> arg_of_expr a + | "()" -> TacVoid + | r = reference -> Reference r + | n = integer -> Integer n + | id = METAIDENT -> MetaIdArg (loc,id) + | "?" -> ConstrMayEval (ConstrTerm (CHole loc)) + | "?"; n = natural -> ConstrMayEval (ConstrTerm (CPatVar (loc,(false,Pattern.patvar_of_int n)))) + | "'"; c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ] + ; + + (* Definitions for tactics *) + deftok: + [ [ IDENT "Meta" + | IDENT "Tactic" ] ] + ; + tacdef_body: + [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr -> + (name, TacFun (it, body)) + | name = identref; ":="; body = tactic_expr -> + (name, body) ] ] + ; + tactic: + [ [ tac = tactic_expr -> tac ] ] + ; + Vernac_.command: + [ [ deftok; "Definition"; b = tacdef_body -> + VernacDeclareTacticDefinition (false, [b]) + | IDENT "Recursive"; deftok; "Definition"; + l = LIST1 tacdef_body SEP "And" -> + VernacDeclareTacticDefinition (true, l) ] ] + ; + END diff --git a/parsing/g_ltacnew.ml4 b/parsing/g_ltacnew.ml4 new file mode 100644 index 00000000..9c8d1675 --- /dev/null +++ b/parsing/g_ltacnew.ml4 @@ -0,0 +1,189 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* user_err_loc (loc, "", (str "Syntax Error")) + | LETCLAUSE (id,c,d) -> (id,c,d) + +let make_letin_clause loc = List.map (out_letin_clause loc) + +let arg_of_expr = function + TacArg a -> a + | e -> Tacexp (e:raw_tactic_expr) + +(* Tactics grammar rules *) + +let tactic_expr = Gram.Entry.create "tactic:tactic_expr" + +if not !Options.v7 then +GEXTEND Gram + GLOBAL: tactic Vernac_.command tactic_expr tactic_arg; + + tactic_expr: + [ "5" LEFTA + [ ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, ta1) + | ta = tactic_expr; ";"; "["; lta = LIST0 tactic_expr SEP "|"; "]" -> + TacThens (ta, lta) ] + | "4" + [ ] + | "3" RIGHTA + [ IDENT "try"; ta = tactic_expr -> TacTry ta + | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) + | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta + | IDENT "progress"; ta = tactic_expr -> TacProgress ta + | IDENT "info"; tc = tactic_expr -> TacInfo tc +(*To do: put Abstract in Refiner*) + | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) + | IDENT "abstract"; tc = NEXT; "using"; s = base_ident -> + TacAbstract (tc,Some s) ] +(*End of To do*) + | "2" RIGHTA + [ ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] + | "1" RIGHTA + [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr -> + TacFun (it,body) + | "let"; IDENT "rec"; rcl = LIST1 rec_clause SEP "with"; "in"; + body = tactic_expr -> TacLetRecIn (rcl,body) + | "let"; llc = LIST1 let_clause SEP "with"; "in"; + u = tactic_expr -> TacLetIn (make_letin_clause loc llc,u) + | "match"; IDENT "goal"; "with"; mrl = match_context_list; "end" -> + TacMatchContext (false,mrl) + | "match"; IDENT "reverse"; IDENT "goal"; "with"; + mrl = match_context_list; "end" -> + TacMatchContext (true,mrl) + | "match"; c = tactic_expr; "with"; mrl = match_list; "end" -> + TacMatch (c,mrl) + | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacFirst l + | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacSolve l + | IDENT "idtac"; s = [ s = STRING -> s | -> ""] -> TacId s + | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ]; + s = [ s = STRING -> s | -> ""] -> TacFail (n,s) + | st = simple_tactic -> TacAtom (loc,st) + | a = may_eval_arg -> TacArg(a) + | IDENT "constr"; ":"; c = Constr.constr -> + TacArg(ConstrMayEval(ConstrTerm c)) + | IDENT "ipattern"; ":"; ipat = simple_intropattern -> + TacArg(IntroPattern ipat) + | r = reference; la = LIST1 tactic_arg -> + TacArg(TacCall (loc,r,la)) + | r = reference -> TacArg (Reference r) ] + | "0" + [ "("; a = tactic_expr; ")" -> a + | a = tactic_atom -> TacArg a ] ] + ; + (* Tactic arguments *) + tactic_arg: + [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a + | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat + | a = may_eval_arg -> a + | a = tactic_atom -> a + | c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ] + ; + may_eval_arg: + [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> + ConstrMayEval (ConstrEval (rtc,c)) + | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> + ConstrMayEval (ConstrContext (id,c)) + | IDENT "type"; IDENT "of"; c = Constr.constr -> + ConstrMayEval (ConstrTypeOf c) + | IDENT "fresh"; s = OPT STRING -> + TacFreshId s ] ] + ; + tactic_atom: + [ [ id = METAIDENT -> MetaIdArg (loc,id) + | r = reference -> Reference r + | "()" -> TacVoid ] ] + ; + input_fun: + [ [ "_" -> None + | l = base_ident -> Some l ] ] + ; + let_clause: + [ [ id = identref; ":="; te = tactic_expr -> + LETCLAUSE (id, None, arg_of_expr te) + | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + LETCLAUSE (id, None, arg_of_expr (TacFun(args,te))) ] ] + ; + rec_clause: + [ [ name = identref; it = LIST1 input_fun; ":="; body = tactic_expr -> + (name,(it,body)) ] ] + ; + match_pattern: + [ [ IDENT "context"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + Subterm (oid, pc) + | pc = Constr.lconstr_pattern -> Term pc ] ] + ; + match_hyps: + [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) ] ] + ; + match_context_rule: + [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_context_list: + [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] + ; + + (* Definitions for tactics *) +(* + deftok: + [ [ IDENT "Meta" + | IDENT "Tactic" ] ] + ; +*) + tacdef_body: + [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr -> + (name, TacFun (it, body)) + | name = identref; ":="; body = tactic_expr -> + (name, body) ] ] + ; + tactic: + [ [ tac = tactic_expr -> tac ] ] + ; + Vernac_.command: + [ [ IDENT "Ltac"; + l = LIST1 tacdef_body SEP "with" -> + VernacDeclareTacticDefinition (true, l) ] ] + ; + END diff --git a/parsing/g_minicoq.ml4 b/parsing/g_minicoq.ml4 new file mode 100644 index 00000000..dd4ef517 --- /dev/null +++ b/parsing/g_minicoq.ml4 @@ -0,0 +1,175 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ()); Token.tparse = Lexer.tparse; + Token.text = Lexer.token_text} +;; + +type command = + | Definition of identifier * constr option * constr + | Parameter of identifier * constr + | Variable of identifier * constr + | Inductive of + (identifier * constr) list * + (identifier * constr * (identifier * constr) list) list + | Check of constr + +let gram = Grammar.create lexer + +let term = Grammar.Entry.create gram "term" +let name = Grammar.Entry.create gram "name" +let nametype = Grammar.Entry.create gram "nametype" +let inductive = Grammar.Entry.create gram "inductive" +let constructor = Grammar.Entry.create gram "constructor" +let command = Grammar.Entry.create gram "command" + +let path_of_string s = make_path [] (id_of_string s) + +EXTEND + name: + [ [ id = IDENT -> Name (id_of_string id) + | "_" -> Anonymous + ] ]; + nametype: + [ [ id = IDENT; ":"; t = term -> (id_of_string id, t) + ] ]; + term: + [ [ id = IDENT -> + mkVar (id_of_string id) + | IDENT "Rel"; n = INT -> + mkRel (int_of_string n) + | "Set" -> + mkSet + | "Prop" -> + mkProp + | "Type" -> + mkType (new_univ()) + | "Const"; id = IDENT -> + mkConst (path_of_string id, [||]) + | "Ind"; id = IDENT; n = INT -> + let n = int_of_string n in + mkMutInd ((path_of_string id, n), [||]) + | "Construct"; id = IDENT; n = INT; i = INT -> + let n = int_of_string n and i = int_of_string i in + mkMutConstruct (((path_of_string id, n), i), [||]) + | "["; na = name; ":"; t = term; "]"; c = term -> + mkLambda (na,t,c) + | "("; na = name; ":"; t = term; ")"; c = term -> + mkProd (na,t,c) + | c1 = term; "->"; c2 = term -> + mkArrow c1 c2 + | "("; id = IDENT; cl = LIST1 term; ")" -> + let c = mkVar (id_of_string id) in + mkApp (c, Array.of_list cl) + | "("; cl = LIST1 term; ")" -> + begin match cl with + | [c] -> c + | c::cl -> mkApp (c, Array.of_list cl) + end + | "("; c = term; "::"; t = term; ")" -> + mkCast (c, t) + | "<"; p = term; ">"; + IDENT "Case"; c = term; ":"; "Ind"; id = IDENT; i = INT; + "of"; bl = LIST0 term; "end" -> + let ind = (path_of_string id,int_of_string i) in + let nc = List.length bl in + let dummy_pats = Array.create nc RegularPat in + let dummy_ci = [||],(ind,[||],nc,None,dummy_pats) in + mkMutCase (dummy_ci, p, c, Array.of_list bl) + ] ]; + command: + [ [ "Definition"; id = IDENT; ":="; c = term; "." -> + Definition (id_of_string id, None, c) + | "Definition"; id = IDENT; ":"; t = term; ":="; c = term; "." -> + Definition (id_of_string id, Some t, c) + | "Parameter"; id = IDENT; ":"; t = term; "." -> + Parameter (id_of_string id, t) + | "Variable"; id = IDENT; ":"; t = term; "." -> + Variable (id_of_string id, t) + | "Inductive"; "["; params = LIST0 nametype SEP ";"; "]"; + inds = LIST1 inductive SEP "with" -> + Inductive (params, inds) + | IDENT "Check"; c = term; "." -> + Check c + | EOI -> raise End_of_file + ] ]; + inductive: + [ [ id = IDENT; ":"; ar = term; ":="; constrs = LIST0 constructor SEP "|" -> + (id_of_string id,ar,constrs) + ] ]; + constructor: + [ [ id = IDENT; ":"; c = term -> (id_of_string id,c) ] ]; +END + +(* Pretty-print. *) + +let print_univers = ref false +let print_casts = ref false + +let print_type u = + if !print_univers then (str "Type" ++ pr_uni u) + else (str "Type") + +let print_name = function + | Anonymous -> (str "_") + | Name id -> pr_id id + +let print_rel bv n = print_name (List.nth bv (pred n)) + +let rename bv = function + | Anonymous -> Anonymous + | Name id as na -> + let idl = + List.fold_left + (fun l n -> match n with Name x -> x::l | _ -> l) [] bv + in + if List.mem na bv then Name (next_ident_away id idl) else na + +let rec pp bv t = + match kind_of_term t with + | Sort (Prop Pos) -> (str "Set") + | Sort (Prop Null) -> (str "Prop") + | Sort (Type u) -> print_type u + | Lambda (na, t, c) -> + (str"[" ++ print_name na ++ str":" ++ pp bv t ++ str"]" ++ pp (na::bv) c) + | Prod (Anonymous, t, c) -> + (pp bv t ++ str"->" ++ pp (Anonymous::bv) c) + | Prod (na, t, c) -> + (str"(" ++ print_name na ++ str":" ++ pp bv t ++ str")" ++ pp (na::bv) c) + | Cast (c, t) -> + if !print_casts then + (str"(" ++ pp bv c ++ str"::" ++ pp bv t ++ str")") + else + pp bv c + | App(h, v) -> + (str"(" ++ pp bv h ++ spc () ++ + prvect_with_sep (fun () -> (spc ())) (pp bv) v ++ str")") + | Const (sp, _) -> + (str"Const " ++ pr_id (basename sp)) + | Ind ((sp,i), _) -> + (str"Ind " ++ pr_id (basename sp) ++ str" " ++ int i) + | Construct (((sp,i),j), _) -> + (str"Construct " ++ pr_id (basename sp) ++ str" " ++ int i ++ + str" " ++ int j) + | Var id -> pr_id id + | Rel n -> print_rel bv n + | _ -> (str"") + +let pr_term _ ctx = pp (fold_rel_context (fun _ (n,_,_) l -> n::l) ctx []) + diff --git a/parsing/g_minicoq.mli b/parsing/g_minicoq.mli new file mode 100644 index 00000000..e19b1163 --- /dev/null +++ b/parsing/g_minicoq.mli @@ -0,0 +1,31 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* env -> constr -> std_ppcmds diff --git a/parsing/g_module.ml4 b/parsing/g_module.ml4 new file mode 100644 index 00000000..0b542608 --- /dev/null +++ b/parsing/g_module.ml4 @@ -0,0 +1,47 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* CMEident qid + | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2) + | "("; me = module_expr; ")" -> me +(* ... *) + ] ] + ; + + with_declaration: + [ [ "Definition"; id = identref; ":="; c = Constr.constr -> + CWith_Definition (id,c) + | IDENT "Module"; id = identref; ":="; qid = qualid -> + CWith_Module (id,qid) + ] ] + ; + + module_type: + [ [ qid = qualid -> CMTEident qid +(* ... *) + | mty = module_type; "with"; decl = with_declaration -> + CMTEwith (mty,decl) ] ] + ; +END diff --git a/parsing/g_natsyntax.ml b/parsing/g_natsyntax.ml new file mode 100644 index 00000000..e43142ba --- /dev/null +++ b/parsing/g_natsyntax.ml @@ -0,0 +1,229 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* > *) +let nat_of_int n dloc = + let ast_O = set_loc dloc ast_O in + let ast_S = set_loc dloc ast_S in + let rec mk_nat n = + if n <= 0 then + ast_O + else + Node(dloc,"APPLIST", [ast_S; mk_nat (n-1)]) + in + mk_nat n + +let pat_nat_of_int n dloc = + let ast_O = set_loc dloc ast_O in + let ast_S = set_loc dloc ast_S in + let rec mk_nat n = + if n <= 0 then + ast_O + else + Node(dloc,"PATTCONSTRUCT", [ast_S; mk_nat (n-1)]) + in + mk_nat n + +let nat_of_string s dloc = + nat_of_int (int_of_string s) dloc + +let pat_nat_of_string s dloc = + pat_nat_of_int (int_of_string s) dloc + +exception Non_closed_number + +let rec int_of_nat_rec astS astO p = + match p with + | Node (_,"APPLIST", [b; a]) when alpha_eq(b,astS) -> + (int_of_nat_rec astS astO a)+1 + | a when alpha_eq(a,astO) -> 1 + (***** YES, 1, non 0 ... to print the successor of p *) + | _ -> raise Non_closed_number + +let int_of_nat p = + try + Some (int_of_nat_rec ast_S ast_O p) + with + Non_closed_number -> None + +let pr_S a = hov 0 (str "S" ++ brk (1,1) ++ a) + +let rec pr_external_S std_pr = function + | Node (l,"APPLIST", [b; a]) when alpha_eq (b,ast_S) -> + str"(" ++ pr_S (pr_external_S std_pr a) ++ str")" + | p -> std_pr p + +(* Declare the primitive printer *) + +(* Prints not p, but the SUCCESSOR of p !!!!! *) +let nat_printer std_pr p = + match (int_of_nat p) with + | Some i -> str "(" ++ str (string_of_int i) ++ str ")" + | None -> str "(" ++ pr_S (pr_external_S std_pr p) ++ str ")" + +let _ = Esyntax.Ppprim.add ("nat_printer", nat_printer) +(* +(* Declare the primitive parser *) + +let unat = create_univ_if_new "nat" + +let number = create_constr_entry unat "number" +let pat_number = create_constr_entry unat "pat_number" + +let _ = + Gram.extend number None + [None, None, + [[Gramext.Stoken ("INT", "")], + Gramext.action nat_of_string]] + +let _ = + Gram.extend pat_number None + [None, None, + [[Gramext.Stoken ("INT", "")], + Gramext.action pat_nat_of_string]] +*) + +(*i*) +open Rawterm +open Libnames +open Bignat +open Coqlib +open Symbols +open Pp +open Util +open Names +(*i*) + +(**********************************************************************) +(* Parsing via scopes *) +(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *) + +let nat_of_int dloc n = + match n with + | POS n -> + if less_than (of_string "5000") n & Options.is_verbose () then begin + warning ("You may experiment stack overflow and segmentation fault\ + \nwhile parsing numbers in nat greater than 5000"); + flush_all () + end; + let ref_O = RRef (dloc, glob_O) in + let ref_S = RRef (dloc, glob_S) in + let rec mk_nat acc n = + if is_nonzero n then + mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n) + else + acc + in + mk_nat ref_O n + | NEG n -> + user_err_loc (dloc, "nat_of_int", + str "Cannot interpret a negative number as a number of type nat") + +let pat_nat_of_int dloc n name = + match n with + | POS n -> + let rec mk_nat n name = + if is_nonzero n then + PatCstr (dloc,path_of_S,[mk_nat (sub_1 n) Anonymous],name) + else + PatCstr (dloc,path_of_O,[],name) + in + mk_nat n name + | NEG n -> + user_err_loc (dloc, "pat_nat_of_int", + str "Unable to interpret a negative number in type nat") + +(************************************************************************) +(* Printing via scopes *) + +exception Non_closed_number + +let rec int_of_nat = function + | RApp (_,RRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a) + | RRef (_,z) when z = glob_O -> zero + | _ -> raise Non_closed_number + +let uninterp_nat p = + try + Some (POS (int_of_nat p)) + with + Non_closed_number -> None + +let rec int_of_nat_pattern = function + | PatCstr (_,s,[a],_) when ConstructRef s = glob_S -> + add_1 (int_of_nat_pattern a) + | PatCstr (_,z,[],_) when ConstructRef z = glob_O -> zero + | _ -> raise Non_closed_number + +let uninterp_nat_pattern p = + try + Some (POS (int_of_nat_pattern p)) + with + Non_closed_number -> None + +(************************************************************************) +(* Declare the primitive parsers and printers *) + +let _ = + Symbols.declare_numeral_interpreter "nat_scope" + (glob_nat,["Coq";"Init";"Datatypes"]) + (nat_of_int,Some pat_nat_of_int) + ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, None) + +(************************************************************************) +(* Old ast printing *) + +open Coqast +open Ast +open Termast + +let _ = if !Options.v7 then +let ast_O = ast_of_ref glob_O in +let ast_S = ast_of_ref glob_S in + +let rec int_of_nat = function + | Node (_,"APPLIST", [b; a]) when alpha_eq(b,ast_S) -> (int_of_nat a) + 1 + | a when alpha_eq(a,ast_O) -> 0 + | _ -> raise Non_closed_number +in +(* Prints not p, but the SUCCESSOR of p !!!!! *) +let nat_printer_S p = + try + Some (int (int_of_nat p + 1)) + with + Non_closed_number -> None +in +let nat_printer_O _ = + Some (int 0) +in +(* Declare the primitive printers *) +let _ = + Esyntax.declare_primitive_printer "nat_printer_S" "nat_scope" nat_printer_S +in +let _ = + Esyntax.declare_primitive_printer "nat_printer_O" "nat_scope" nat_printer_O +in +() diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli new file mode 100644 index 00000000..1471aed2 --- /dev/null +++ b/parsing/g_natsyntax.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Slam(loc,Some id,b) + | Nmeta (_,s) -> Smetalam(loc,s,b) + | _ -> failwith "Slam expects a var or a metavar" +let local_append l id = l@[id] + +GEXTEND Gram + GLOBAL: ident natural integer bigint string preident ast + astlist qualid reference dirpath identref name base_ident var hyp; + + (* Compatibility: Prim.var is a synonym of Prim.ident *) + var: + [ [ id = ident -> id ] ] + ; + hyp: + [ [ id = ident -> id ] ] + ; + metaident: + [ [ s = METAIDENT -> Nmeta (loc,s) ] ] + ; + preident: + [ [ s = IDENT -> s ] ] + ; + base_ident: + [ [ s = IDENT -> local_id_of_string s ] ] + ; + name: + [ [ IDENT "_" -> (loc, Anonymous) + | id = base_ident -> (loc, Name id) ] ] + ; + identref: + [ [ id = base_ident -> (loc,id) ] ] + ; + ident: + [ [ id = base_ident -> id ] ] + ; + natural: + [ [ i = INT -> local_make_posint i ] ] + ; + bigint: + [ [ i = INT -> Bignat.POS (Bignat.of_string i) + | "-"; i = INT -> Bignat.NEG (Bignat.of_string i) ] ] + ; + integer: + [ [ i = INT -> local_make_posint i + | "-"; i = INT -> local_make_negint i ] ] + ; + field: + [ [ s = FIELD -> local_id_of_string s ] ] + ; + dirpath: + [ [ id = base_ident; l = LIST0 field -> + local_make_dirpath (local_append l id) ] ] + ; + fields: + [ [ id = field; (l,id') = fields -> (local_append l id,id') + | id = field -> ([],id) + ] ] + ; + basequalid: + [ [ id = base_ident; (l,id')=fields -> local_make_qualid (local_append l id) id' + | id = base_ident -> local_make_short_qualid id + ] ] + ; + qualid: + [ [ qid = basequalid -> loc, qid ] ] + ; + reference: + [ [ id = base_ident; (l,id') = fields -> + Qualid (loc, local_make_qualid (local_append l id) id') + | id = base_ident -> Ident (loc,id) + ] ] + ; + string: + [ [ s = STRING -> s ] ] + ; + astpath: + [ [ id = base_ident; (l,a) = fields -> + Path(loc, local_make_path (local_append l id) a) + | id = base_ident -> Nvar(loc, id) + ] ] + ; + (* ast *) + ast: + [ [ id = metaident -> id + | p = astpath -> p + | s = INT -> Num(loc, local_make_posint s) + | s = STRING -> Str(loc, s) + | "{"; s = METAIDENT; "}" -> Id(loc,s) + | "("; nname = IDENT; l = LIST0 ast; ")" -> Node(loc,nname,l) + | "("; METAIDENT "$LIST"; id = metaident; ")" -> Node(loc,"$LIST",[id]) + | "("; METAIDENT "$STR"; id = metaident; ")" -> Node(loc,"$STR",[id]) + | "("; METAIDENT "$VAR"; id = metaident; ")" -> Node(loc,"$VAR",[id]) + | "("; METAIDENT "$ID"; id = metaident; ")" -> Node(loc,"$ID",[id]) + | "("; METAIDENT "$ABSTRACT"; l = LIST0 ast;")"->Node(loc,"$ABSTRACT",l) + | "("; METAIDENT "$PATH"; id = metaident; ")" -> Node(loc,"$PATH",[id]) + | "("; METAIDENT "$NUM"; id = metaident; ")" -> Node(loc,"$NUM",[id]) + | "["; "<>"; "]"; b = ast -> Slam(loc,None,b) + | "["; a = ast; "]"; b = ast -> local_make_binding loc a b + +(* + | "["; ido = astidoption; "]"; b = ast -> Slam(loc,ido,b) + | "["; id = METAIDENT; "]"; b = ast -> Smetalam(loc,id,b) +*) + | "'"; a = ast -> Node(loc,"$QUOTE",[a]) ] ] + ; + astlist: + [ [ l = LIST0 ast -> l ] ] + ; +END diff --git a/parsing/g_primnew.ml4 b/parsing/g_primnew.ml4 new file mode 100644 index 00000000..c1875634 --- /dev/null +++ b/parsing/g_primnew.ml4 @@ -0,0 +1,84 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "; "<<"; ">>"; "'"] +let _ = + if not !Options.v7 then + List.iter (fun s -> Lexer.add_token("",s)) prim_kw + +open Prim + +open Nametab +let local_id_of_string = id_of_string +let local_make_dirpath = make_dirpath +let local_make_qualid l id' = make_qualid (local_make_dirpath l) id' +let local_make_short_qualid id = make_short_qualid id +let local_make_posint = int_of_string +let local_make_negint n = - int_of_string n +let local_make_path l a = encode_kn (local_make_dirpath l) a +let local_make_binding loc a b = + match a with + | Nvar (_,id) -> Slam(loc,Some id,b) + | Nmeta (_,s) -> Smetalam(loc,s,b) + | _ -> failwith "Slam expects a var or a metavar" +let local_append l id = l@[id] + +if not !Options.v7 then +GEXTEND Gram + GLOBAL: bigint qualid reference ne_string; + field: + [ [ s = FIELD -> local_id_of_string s ] ] + ; + fields: + [ [ id = field; (l,id') = fields -> (local_append l id,id') + | id = field -> ([],id) + ] ] + ; + basequalid: + [ [ id = base_ident; (l,id')=fields -> + local_make_qualid (local_append l id) id' + | id = base_ident -> local_make_short_qualid id + ] ] + ; + reference: + [ [ id = base_ident; (l,id') = fields -> + Qualid (loc, local_make_qualid (local_append l id) id') + | id = base_ident -> Ident (loc,id) + ] ] + ; + qualid: + [ [ qid = basequalid -> loc, qid ] ] + ; + ne_string: + [ [ s = STRING -> + if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string"); s + ] ] + ; + bigint: (* Negative numbers are dealt with specially *) + [ [ i = INT -> Bignat.POS (Bignat.of_string i) ] ] + ; +END diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 new file mode 100644 index 00000000..5262b785 --- /dev/null +++ b/parsing/g_proofs.ml4 @@ -0,0 +1,135 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tacexpr.ConclLocation () + | discard = [ IDENT "Discardable" -> true | -> false ]; "Hypothesis" + -> Tacexpr.HypLocation discard ] ] + ; + opt_hintbases: + [ [ -> [] + | ":"; l = LIST1 IDENT -> l ] ] + ; + command: + [ [ IDENT "Goal"; c = Constr.constr -> VernacGoal c + | "Proof" -> VernacProof (Tacexpr.TacId "") + | "Proof"; "with"; ta = tactic -> VernacProof ta + | IDENT "Abort" -> VernacAbort None + | IDENT "Abort"; IDENT "All" -> VernacAbortAll + | IDENT "Abort"; id = identref -> VernacAbort (Some id) + | IDENT "Admitted" -> VernacEndProof Admitted + | "Qed" -> VernacEndProof (Proved (true,None)) + | IDENT "Save" -> VernacEndProof (Proved (true,None)) + | IDENT "Defined" -> VernacEndProof (Proved (false,None)) + | IDENT "Defined"; id=identref -> + VernacEndProof (Proved (false,Some (id,None))) + | IDENT "Save"; tok = thm_token; id = identref -> + VernacEndProof (Proved (true,Some (id,Some tok))) + | IDENT "Save"; id = identref -> + VernacEndProof (Proved (true,Some (id,None))) + | IDENT "Suspend" -> VernacSuspend + | IDENT "Resume" -> VernacResume None + | IDENT "Resume"; id = identref -> VernacResume (Some id) + | IDENT "Restart" -> VernacRestart + | "Proof"; c = Constr.constr -> VernacExactProof c + | IDENT "Undo" -> VernacUndo 1 + | IDENT "Undo"; n = natural -> VernacUndo n + | IDENT "Focus" -> VernacFocus None + | IDENT "Focus"; n = natural -> VernacFocus (Some n) + | IDENT "Unfocus" -> VernacUnfocus + | IDENT "Show" -> VernacShow (ShowGoal None) + | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n)) + | IDENT "Show"; IDENT "Implicits"; n = natural -> + VernacShow (ShowGoalImplicitly (Some n)) + | IDENT "Show"; IDENT "Implicits" -> VernacShow (ShowGoalImplicitly None) + | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode + | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript + | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials + | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree + | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames + | IDENT "Show"; "Proof" -> VernacShow ShowProof + | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false) + | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true) + | IDENT "Explain"; "Proof"; l = LIST0 integer -> + VernacShow (ExplainProof l) + | IDENT "Explain"; "Proof"; IDENT "Tree"; l = LIST0 integer -> + VernacShow (ExplainTree l) + | IDENT "Go"; n = natural -> VernacGo (GoTo n) + | IDENT "Go"; IDENT "top" -> VernacGo GoTop + | IDENT "Go"; IDENT "prev" -> VernacGo GoPrev + | IDENT "Go"; IDENT "next" -> VernacGo GoNext + | IDENT "Guarded" -> VernacCheckGuard +(* Hints for Auto and EAuto *) + + | IDENT "HintDestruct"; + local = locality; + dloc = destruct_location; + id = base_ident; + hyptyp = Constr.constr_pattern; + pri = natural; + "["; tac = tactic; "]" -> + VernacHints(local,[],HintsDestruct (id,pri,dloc,hyptyp,tac)) + + | IDENT "Hint"; local = locality; hintname = base_ident; + dbnames = opt_hintbases; ":="; h = hint + -> VernacHints (local,dbnames, h hintname) + + | IDENT "Hints"; local = locality; + (dbnames,h) = hints -> VernacHints (local,dbnames, h) + + +(*This entry is not commented, only for debug*) + | IDENT "PrintConstr"; c = Constr.constr -> + VernacExtend ("PrintConstr", + [Genarg.in_gen Genarg.rawwit_constr c]) + ] ]; + + locality: + [ [ IDENT "Local" -> true | -> false ] ] + ; + hint: + [ [ IDENT "Resolve"; c = Constr.constr -> fun name -> HintsResolve [Some name, c] + | IDENT "Immediate"; c = Constr.constr -> fun name -> HintsImmediate [Some name, c] + | IDENT "Unfold"; qid = global -> fun name -> HintsUnfold [Some name,qid] + | IDENT "Constructors"; c = global -> fun n -> + HintsConstructors (Some n,[c]) + | IDENT "Extern"; n = natural; c = Constr.constr ; tac = tactic -> + fun name -> HintsExtern (Some name,n,c,tac) ] ] + ; + hints: + [ [ IDENT "Resolve"; l = LIST1 global; dbnames = opt_hintbases -> + (dbnames, + HintsResolve + (List.map (fun qid -> (None, CAppExpl(loc,(None,qid),[]))) l)) + | IDENT "Immediate"; l = LIST1 global; dbnames = opt_hintbases -> + (dbnames, + HintsImmediate + (List.map (fun qid-> (None, CAppExpl (loc,(None,qid),[]))) l)) + | IDENT "Unfold"; l = LIST1 global; dbnames = opt_hintbases -> + (dbnames, HintsUnfold (List.map (fun qid -> (None,qid)) l)) ] ] + ; + END diff --git a/parsing/g_proofsnew.ml4 b/parsing/g_proofsnew.ml4 new file mode 100644 index 00000000..04bf7a8b --- /dev/null +++ b/parsing/g_proofsnew.ml4 @@ -0,0 +1,126 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tacexpr.ConclLocation () + | discard = [ IDENT "Discardable" -> true | -> false ]; "Hypothesis" + -> Tacexpr.HypLocation discard ] ] + ; + opt_hintbases: + [ [ -> [] + | ":"; l = LIST1 IDENT -> l ] ] + ; + command: + [ [ IDENT "Goal"; c = Constr.lconstr -> VernacGoal c + | IDENT "Proof" -> VernacNop + | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta + | IDENT "Abort" -> VernacAbort None + | IDENT "Abort"; IDENT "All" -> VernacAbortAll + | IDENT "Abort"; id = identref -> VernacAbort (Some id) + | IDENT "Existential"; n = natural; c = constr_body -> + VernacSolveExistential (n,c) + | IDENT "Admitted" -> VernacEndProof Admitted + | IDENT "Qed" -> VernacEndProof (Proved (true,None)) + | IDENT "Save" -> VernacEndProof (Proved (true,None)) + | IDENT "Save"; tok = thm_token; id = identref -> + VernacEndProof (Proved (true,Some (id,Some tok))) + | IDENT "Save"; id = identref -> + VernacEndProof (Proved (true,Some (id,None))) + | IDENT "Defined" -> VernacEndProof (Proved (false,None)) + | IDENT "Defined"; id=identref -> + VernacEndProof (Proved (false,Some (id,None))) + | IDENT "Suspend" -> VernacSuspend + | IDENT "Resume" -> VernacResume None + | IDENT "Resume"; id = identref -> VernacResume (Some id) + | IDENT "Restart" -> VernacRestart + | IDENT "Proof"; c = Constr.lconstr -> VernacExactProof c + | IDENT "Undo" -> VernacUndo 1 + | IDENT "Undo"; n = natural -> VernacUndo n + | IDENT "Focus" -> VernacFocus None + | IDENT "Focus"; n = natural -> VernacFocus (Some n) + | IDENT "Unfocus" -> VernacUnfocus + | IDENT "Show" -> VernacShow (ShowGoal None) + | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n)) + | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> + VernacShow (ShowGoalImplicitly n) + | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode + | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript + | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials + | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree + | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames + | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof + | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false) + | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true) + | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer -> + VernacShow (ExplainProof l) + | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> + VernacShow (ExplainTree l) + | IDENT "Go"; n = natural -> VernacGo (GoTo n) + | IDENT "Go"; IDENT "top" -> VernacGo GoTop + | IDENT "Go"; IDENT "prev" -> VernacGo GoPrev + | IDENT "Go"; IDENT "next" -> VernacGo GoNext + | IDENT "Guarded" -> VernacCheckGuard +(* Hints for Auto and EAuto *) + | IDENT "Hint"; local = locality; h = hint; + dbnames = opt_hintbases -> + VernacHints (local,dbnames, h) + + +(*This entry is not commented, only for debug*) + | IDENT "PrintConstr"; c = Constr.constr -> + VernacExtend ("PrintConstr", + [Genarg.in_gen Genarg.rawwit_constr c]) + ] ]; + + locality: + [ [ IDENT "Local" -> true | -> false ] ] + ; + hint: + [ [ IDENT "Resolve"; lc = LIST1 Constr.constr -> + HintsResolve (List.map (fun c -> (None, c)) lc) + | IDENT "Immediate"; lc = LIST1 Constr.constr -> + HintsImmediate (List.map (fun c -> (None,c)) lc) + | IDENT "Unfold"; lqid = LIST1 global -> + HintsUnfold (List.map (fun g -> (None,g)) lqid) + | IDENT "Constructors"; lc = LIST1 global -> + HintsConstructors (None,lc) + | IDENT "Extern"; n = natural; c = Constr.constr_pattern ; "=>"; + tac = tactic -> + HintsExtern (None,n,c,tac) + | IDENT"Destruct"; + id = base_ident; ":="; + pri = natural; + dloc = destruct_location; + hyptyp = Constr.constr_pattern; + "=>"; tac = tactic -> + HintsDestruct(id,pri,dloc,hyptyp,tac) ] ] + ; + constr_body: + [ [ ":="; c = lconstr -> c + | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c,t) ] ] + ; +END diff --git a/parsing/g_rsyntax.ml b/parsing/g_rsyntax.ml new file mode 100644 index 00000000..8f5aad33 --- /dev/null +++ b/parsing/g_rsyntax.ml @@ -0,0 +1,332 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* = 2 + [| 2n+1 |] = 1 + 2 * [| n |] for n >= 2 + [| -n |] = - [| n |] for n >= 0 +*) + +let int_decomp n = +let div2 k = +let x = k mod 2 in +let y = k - x in (x,y/2) in +let rec list_ch m = +if m< 2 then [m] +else let (x1,x2) = div2 m in x1::(list_ch x2) +in list_ch n + +let _ = if !Options.v7 then +let r_of_int n dloc = + let (a0,a1,plus,mult,_,_) = get_r_sign dloc in + let list_ch = int_decomp n in + let a2 = mkAppC (plus, [a1; a1]) in + let rec mk_r l = + match l with + | [] -> failwith "Error r_of_int" + | [a] -> if a=1 then a1 else a0 + | [a;b] -> if a==1 then mkAppC (plus, [a1; a2]) else a2 + | a::l' -> if a=1 then mkAppC (plus, [a1; mkAppC (mult, [a2; mk_r l'])]) else mkAppC (mult, [a2; mk_r l']) + in mk_r list_ch +in +let r_of_string s dloc = + r_of_int (int_of_string s) dloc +in +let rsyntax_create name = + let e = + Pcoq.create_constr_entry (Pcoq.get_univ "rnatural") name in + Pcoq.Gram.Unsafe.clear_entry e; + e +in +let rnumber = rsyntax_create "rnumber" +in +let _ = + Gram.extend rnumber None + [None, None, + [[Gramext.Stoken ("INT", "")], + Gramext.action r_of_string]] +in () + +(**********************************************************************) +(* Old ast printing *) +(**********************************************************************) + +exception Non_closed_number + +let _ = if !Options.v7 then +let int_of_r p = + let (a0,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in + let rec int_of_r_rec p = + match p with + | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) & alpha_eq(c,a1) -> 2 + | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) -> + (match c with + | Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,mult) -> 1 + int_of_r_rec c + | Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) -> 3 + | _ -> raise Non_closed_number) + | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,mult) -> + (match a with + | Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) -> + (match c with + | g when alpha_eq(g,a1) -> raise Non_closed_number + | g when alpha_eq(g,a0) -> raise Non_closed_number + | _ -> 2 * int_of_r_rec c) + | _ -> raise Non_closed_number) + | a when alpha_eq(a,a0) -> 0 + | a when alpha_eq(a,a1) -> 1 + | _ -> raise Non_closed_number in + try + Some (int_of_r_rec p) + with + Non_closed_number -> None +in +let replace_plus p = + let (_,_,_,_,astnrplus,_) = get_r_sign_ast dummy_loc in + ope ("REXPR",[ope("APPLIST",[astnrplus;p])]) +in +let replace_mult p = + let (_,_,_,_,_,astnrmult) = get_r_sign_ast dummy_loc in + ope ("REXPR",[ope("APPLIST",[astnrmult;p])]) +in +let rec r_printer_odd std_pr p = + let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in + match (int_of_r (ope("APPLIST",[plus;a1;p]))) with + | Some i -> str (string_of_int i) + | None -> std_pr (replace_plus p) +in +let rec r_printer_odd_outside std_pr p = + let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in + match (int_of_r (ope("APPLIST",[plus;a1;p]))) with + | Some i -> str"``" ++ str (string_of_int i) ++ str"``" + | None -> std_pr (replace_plus p) +in +let rec r_printer_even std_pr p = + let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in + match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with + | Some i -> str (string_of_int i) + | None -> std_pr (replace_mult p) +in +let rec r_printer_even_outside std_pr p = + let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in + match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with + | Some i -> str"``" ++ str (string_of_int i) ++ str"``" + | None -> std_pr (replace_mult p) +in +let _ = Esyntax.Ppprim.add ("r_printer_odd", r_printer_odd) in +let _ = Esyntax.Ppprim.add ("r_printer_odd_outside", r_printer_odd_outside) in +let _ = Esyntax.Ppprim.add ("r_printer_even", r_printer_even) in +let _ = Esyntax.Ppprim.add ("r_printer_even_outside", r_printer_even_outside) +in () + +(**********************************************************************) +(* Parsing R via scopes *) +(**********************************************************************) + +open Libnames +open Rawterm +open Bignat + +let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) +let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"] + +(* TODO: temporary hack *) +let make_path dir id = Libnames.encode_kn dir (id_of_string id) + +let glob_R = ConstRef (make_path rdefinitions "R") +let glob_R1 = ConstRef (make_path rdefinitions "R1") +let glob_R0 = ConstRef (make_path rdefinitions "R0") +let glob_Ropp = ConstRef (make_path rdefinitions "Ropp") +let glob_Rplus = ConstRef (make_path rdefinitions "Rplus") +let glob_Rmult = ConstRef (make_path rdefinitions "Rmult") + +(* V7 *) +let r_of_posint dloc n = + let ref_R0 = RRef (dloc, glob_R0) in + let ref_R1 = RRef (dloc, glob_R1) in + let ref_Rplus = RRef (dloc, glob_Rplus) in + let ref_Rmult = RRef (dloc, glob_Rmult) in + let a2 = RApp(dloc, ref_Rplus, [ref_R1; ref_R1]) in + let list_ch = int_decomp n in + let rec mk_r l = + match l with + | [] -> failwith "Error r_of_posint" + | [a] -> if a=1 then ref_R1 else ref_R0 + | a::[b] -> if a==1 then RApp (dloc, ref_Rplus, [ref_R1; a2]) else a2 + | a::l' -> if a=1 then RApp (dloc, ref_Rplus, [ref_R1; RApp (dloc, ref_Rmult, [a2; mk_r l'])]) else RApp (dloc, ref_Rmult, [a2; mk_r l']) + in mk_r list_ch + +(* int_of_string o bigint_to_string : temporary hack ... *) +(* utiliser les bigint de caml ? *) +let r_of_int2 dloc z = + match z with + | NEG n -> RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (int_of_string (bigint_to_string (POS n)))]) + | POS n -> r_of_posint dloc (int_of_string (bigint_to_string z)) + +(* V8 *) +let two = mult_2 one +let three = add_1 two +let four = mult_2 two + +(* Unary representation of strictly positive numbers *) +let rec small_r dloc n = + if is_one n then RRef (dloc, glob_R1) + else RApp(dloc,RRef (dloc,glob_Rplus), + [RRef (dloc, glob_R1);small_r dloc (sub_1 n)]) + +let r_of_posint dloc n = + let r1 = RRef (dloc, glob_R1) in + let r2 = small_r dloc two in + let rec r_of_pos n = + if less_than n four then small_r dloc n + else + let (q,r) = div2_with_rest n in + let b = RApp(dloc,RRef(dloc,glob_Rmult),[r2;r_of_pos q]) in + if r then RApp(dloc,RRef(dloc,glob_Rplus),[r1;b]) else b in + if is_nonzero n then r_of_pos n else RRef(dloc,glob_R0) + +let r_of_int dloc z = + match z with + | NEG n -> RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc n]) + | POS n -> r_of_posint dloc n + +(**********************************************************************) +(* Printing R via scopes *) +(**********************************************************************) + +let bignat_of_r = +(* for numbers > 1 *) +let rec bignat_of_pos = function + (* 1+1 *) + | RApp (_,RRef (_,p), [RRef (_,o1); RRef (_,o2)]) + when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two + (* 1+(1+1) *) + | RApp (_,RRef (_,p1), [RRef (_,o1); + RApp(_,RRef (_,p2),[RRef(_,o2);RRef(_,o3)])]) + when p1 = glob_Rplus & p2 = glob_Rplus & + o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three + (* (1+1)*b *) + | RApp (_,RRef (_,p), [a; b]) when p = glob_Rmult -> + if bignat_of_pos a <> two then raise Non_closed_number; + mult_2 (bignat_of_pos b) + (* 1+(1+1)*b *) + | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])]) + when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 -> + if bignat_of_pos a <> two then raise Non_closed_number; + add_1 (mult_2 (bignat_of_pos b)) + | _ -> raise Non_closed_number +in +let bignat_of_r = function + | RRef (_,a) when a = glob_R0 -> zero + | RRef (_,a) when a = glob_R1 -> one + | r -> bignat_of_pos r +in +bignat_of_r + +let bigint_of_r = function + | RApp (_,RRef (_,o), [a]) when o = glob_Ropp -> NEG (bignat_of_r a) + | a -> POS (bignat_of_r a) + +let uninterp_r p = + try + Some (bigint_of_r p) + with Non_closed_number -> + None + +let _ = Symbols.declare_numeral_interpreter "R_scope" + (glob_R,["Coq";"Reals";"Rdefinitions"]) + ((if !Options.v7 then r_of_int2 else r_of_int),None) + ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0); + RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult);RRef(dummy_loc,glob_R1)], + uninterp_r, + None) + +(************************************************************************) +(* Old ast printers via scope *) + +let _ = if !Options.v7 then +let bignat_of_pos p = + let (_,one,plus,_,_,_) = get_r_sign_ast dummy_loc in + let rec transl = function + | Node (_,"APPLIST",[p; o; a]) when alpha_eq(p,plus) & alpha_eq(o,one) + -> add_1(transl a) + | a when alpha_eq(a,one) -> Bignat.one + | _ -> raise Non_closed_number + in transl p +in +let bignat_option_of_pos p = + try + Some (bignat_of_pos p) + with Non_closed_number -> + None +in +let r_printer_Rplus1 p = + match bignat_option_of_pos p with + | Some n -> Some (str (Bignat.to_string (add_1 n))) + | None -> None +in +let r_printer_Ropp p = + match bignat_option_of_pos p with + | Some n -> Some (str "-" ++ str (Bignat.to_string n)) + | None -> None +in +let r_printer_R1 _ = + Some (int 1) +in +let r_printer_R0 _ = + Some (int 0) +in +(* Declare pretty-printers for integers *) +let _ = + Esyntax.declare_primitive_printer "r_printer_Ropp" "R_scope" (r_printer_Ropp) +in let _ = + Esyntax.declare_primitive_printer "r_printer_Rplus1" "R_scope" (r_printer_Rplus1) +in let _ = + Esyntax.declare_primitive_printer "r_printer_R1" "R_scope" (r_printer_R1) +in let _ = + Esyntax.declare_primitive_printer "r_printer_R0" "R_scope" r_printer_R0 +in () diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 new file mode 100644 index 00000000..2e067215 --- /dev/null +++ b/parsing/g_tactic.ml4 @@ -0,0 +1,367 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Lexer.add_token ("",s)) tactic_kw + +(* Functions overloaded by quotifier *) + +let induction_arg_of_constr c = + try ElimOnIdent (Topconstr.constr_loc c,snd (coerce_to_id c)) + with _ -> ElimOnConstr c + +let local_compute = [FBeta;FIota;FDeltaBut [];FZeta] + +let error_oldelim _ = error "OldElim no longer supported" + +let join_to_constr loc c2 = (fst loc), snd (Topconstr.constr_loc c2) + +(* Auxiliary grammar rules *) + +if !Options.v7 then +GEXTEND Gram + GLOBAL: simple_tactic constrarg bindings constr_with_bindings + quantified_hypothesis red_expr int_or_var castedopenconstr + simple_intropattern; + + int_or_var: + [ [ n = integer -> Genarg.ArgArg n + | id = identref -> Genarg.ArgVar id ] ] + ; + autoarg_depth: + [ [ n = OPT natural -> n ] ] + ; + autoarg_adding: + [ [ IDENT "Adding" ; "["; l = LIST1 global; "]" -> l | -> [] ] ] + ; + autoarg_destructing: + [ [ IDENT "Destructing" -> true | -> false ] ] + ; + autoarg_usingTDB: + [ [ "Using"; "TDB" -> true | -> false ] ] + ; + autoargs: + [ [ a0 = autoarg_depth; l = autoarg_adding; + a2 = autoarg_destructing; a3 = autoarg_usingTDB -> (a0,l,a2,a3) ] ] + ; + (* Either an hypothesis or a ltac ref (variable or pattern patvar) *) + id_or_ltac_ref: + [ [ id = base_ident -> AI (loc,id) + | "?"; n = natural -> AI (loc,Pattern.patvar_of_int n) ] ] + ; + (* Either a global ref or a ltac ref (variable or pattern patvar) *) + global_or_ltac_ref: + [ [ qid = global -> qid + | "?"; n = natural -> Libnames.Ident (loc,Pattern.patvar_of_int n) ] ] + ; + (* An identifier or a quotation meta-variable *) + id_or_meta: + [ [ id = identref -> AI id + + (* This is used in quotations *) + | id = METAIDENT -> MetaId (loc,id) ] ] + ; + (* A number or a quotation meta-variable *) + num_or_meta: + [ [ n = integer -> AI n + | id = METAIDENT -> MetaId (loc,id) + ] ] + ; + constrarg: + [ [ IDENT "Inst"; id = identref; "["; c = constr; "]" -> + ConstrContext (id, c) + | IDENT "Eval"; rtc = Tactic.red_expr; "in"; c = constr -> + ConstrEval (rtc,c) + | IDENT "Check"; c = constr -> ConstrTypeOf c + | c = constr -> ConstrTerm c ] ] + ; + castedopenconstr: + [ [ c = constr -> c ] ] + ; + induction_arg: + [ [ n = natural -> ElimOnAnonHyp n + | c = constr -> induction_arg_of_constr c + ] ] + ; + quantified_hypothesis: + [ [ id = base_ident -> NamedHyp id + | n = natural -> AnonHyp n ] ] + ; + conversion: + [ [ nl = LIST1 integer; c1 = constr; "with"; c2 = constr -> + (Some (nl,c1), c2) + | c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2) + | c = constr -> (None, c) ] ] + ; + pattern_occ: + [ [ nl = LIST0 integer; c = constr -> (nl,c) ] ] + ; + intropatterns: + [ [ l = LIST0 simple_intropattern -> l ]] + ; + simple_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc + | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc] + | IDENT "_" -> IntroWildcard + | id = base_ident -> IntroIdentifier id + ] ] + ; + simple_binding: + [ [ id = base_ident; ":="; c = constr -> (loc, NamedHyp id, c) + | n = natural; ":="; c = constr -> (loc, AnonHyp n, c) ] ] + ; + bindings: + [ [ c1 = constr; ":="; c2 = constr; bl = LIST0 simple_binding -> + ExplicitBindings + ((join_to_constr loc c2,NamedHyp (snd(coerce_to_id c1)), c2) :: bl) + | n = natural; ":="; c = constr; bl = LIST0 simple_binding -> + ExplicitBindings ((join_to_constr loc c,AnonHyp n, c) :: bl) + | c1 = constr; bl = LIST0 constr -> + ImplicitBindings (c1 :: bl) ] ] + ; + constr_with_bindings: + [ [ c = constr; l = with_bindings -> (c, l) ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] + ; + unfold_occ: + [ [ nl = LIST0 integer; c = global_or_ltac_ref -> (nl,c) ] ] + ; + red_flag: + [ [ IDENT "Beta" -> FBeta + | IDENT "Delta" -> FDeltaBut [] + | IDENT "Iota" -> FIota + | IDENT "Zeta" -> FZeta + | IDENT "Delta"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FConst idl + | IDENT "Delta"; "-"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FDeltaBut idl + ] ] + ; + red_tactic: + [ [ IDENT "Red" -> Red false + | IDENT "Hnf" -> Hnf + | IDENT "Simpl"; po = OPT pattern_occ -> Simpl po + | IDENT "Cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) + | IDENT "Lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) + | IDENT "Compute" -> Cbv (make_red_flag [FBeta;FIota;FDeltaBut [];FZeta]) + | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul + | IDENT "Fold"; cl = LIST1 constr -> Fold cl + | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl ] ] + ; + (* This is [red_tactic] including possible extensions *) + red_expr: + [ [ IDENT "Red" -> Red false + | IDENT "Hnf" -> Hnf + | IDENT "Simpl"; po = OPT pattern_occ -> Simpl po + | IDENT "Cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) + | IDENT "Lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) + | IDENT "Compute" -> Cbv (make_red_flag [FBeta;FIota;FDeltaBut [];FZeta]) + | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul + | IDENT "Fold"; cl = LIST1 constr -> Fold cl + | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl + | s = IDENT; c = constr -> ExtraRedExpr (s,c) ] ] + ; + hypident: + [ [ id = id_or_meta -> id,[],(InHyp,ref None) + | "("; "Type"; "of"; id = id_or_meta; ")" -> + id,[],(InHypTypeOnly,ref None) + ] ] + ; + clause: + [ [ "in"; idl = LIST1 hypident -> + {onhyps=Some idl;onconcl=false; concl_occs=[]} + | -> {onhyps=Some[];onconcl=true;concl_occs=[]} ] ] + ; + simple_clause: + [ [ "in"; idl = LIST1 id_or_meta -> idl + | -> [] ] ] + ; + pattern_occ_hyp_tail_list: + [ [ pl = pattern_occ_hyp_list -> pl + | -> {onhyps=Some[];onconcl=false; concl_occs=[]} ] ] + ; + pattern_occ_hyp_list: + [ [ nl = LIST1 natural; IDENT "Goal" -> + {onhyps=Some[];onconcl=true;concl_occs=nl} + | nl = LIST1 natural; id = id_or_meta; cls = pattern_occ_hyp_tail_list + -> {cls with + onhyps=option_app(fun l -> (id,nl,(InHyp,ref None))::l) + cls.onhyps} + | IDENT "Goal" -> {onhyps=Some[];onconcl=true;concl_occs=[]} + | id = id_or_meta; cls = pattern_occ_hyp_tail_list -> + {cls with + onhyps=option_app(fun l -> (id,[],(InHyp,ref None))::l) + cls.onhyps} ] ] + ; + clause_pattern: + [ [ "in"; p = pattern_occ_hyp_list -> p + | -> {onhyps=None; onconcl=true; concl_occs=[] } ] ] + ; + fixdecl: + [ [ id = base_ident; "/"; n = natural; ":"; c = constr -> (id,n,c) ] ] + ; + cofixdecl: + [ [ id = base_ident; ":"; c = constr -> (id,c) ] ] + ; + hintbases: + [ [ "with"; "*" -> None + | "with"; l = LIST1 IDENT -> Some l + | -> Some [] ] ] + ; + eliminator: + [ [ "using"; el = constr_with_bindings -> el ] ] + ; + with_names: + [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ] + ; + simple_tactic: + [ [ + (* Basic tactics *) + IDENT "Intros"; IDENT "until"; id = quantified_hypothesis -> + TacIntrosUntil id + | IDENT "Intros"; pl = intropatterns -> TacIntroPattern pl + | IDENT "Intro"; id = base_ident; IDENT "after"; id2 = identref -> + TacIntroMove (Some id, Some id2) + | IDENT "Intro"; IDENT "after"; id2 = identref -> + TacIntroMove (None, Some id2) + | IDENT "Intro"; id = base_ident -> TacIntroMove (Some id,None) + | IDENT "Intro" -> TacIntroMove (None, None) + + | IDENT "Assumption" -> TacAssumption + | IDENT "Exact"; c = constr -> TacExact c + + | IDENT "Apply"; cl = constr_with_bindings -> TacApply cl + | IDENT "Elim"; cl = constr_with_bindings; el = OPT eliminator -> + TacElim (cl,el) + | IDENT "OldElim"; c = constr -> + (* TacOldElim c *) error_oldelim () + | IDENT "ElimType"; c = constr -> TacElimType c + | IDENT "Case"; cl = constr_with_bindings -> TacCase cl + | IDENT "CaseType"; c = constr -> TacCaseType c + | IDENT "Fix"; n = natural -> TacFix (None,n) + | IDENT "Fix"; id = base_ident; n = natural -> TacFix (Some id,n) + | IDENT "Fix"; id = base_ident; n = natural; "with"; fd = LIST0 fixdecl -> + TacMutualFix (id,n,fd) + | IDENT "Cofix" -> TacCofix None + | IDENT "Cofix"; id = base_ident -> TacCofix (Some id) + | IDENT "Cofix"; id = base_ident; "with"; fd = LIST0 cofixdecl -> + TacMutualCofix (id,fd) + + | IDENT "Cut"; c = constr -> TacCut c + | IDENT "Assert"; c = constr -> TacTrueCut (Names.Anonymous,c) + | IDENT "Assert"; c = constr; ":"; t = constr -> + TacTrueCut (Names.Name (snd(coerce_to_id c)),t) + | IDENT "Assert"; c = constr; ":="; b = constr -> + TacForward (false,Names.Name (snd (coerce_to_id c)),b) + | IDENT "Pose"; c = constr; ":="; b = constr -> + TacForward (true,Names.Name (snd(coerce_to_id c)),b) + | IDENT "Pose"; b = constr -> TacForward (true,Names.Anonymous,b) + | IDENT "Generalize"; lc = LIST1 constr -> TacGeneralize lc + | IDENT "Generalize"; IDENT "Dependent"; c = constr -> TacGeneralizeDep c + | IDENT "LetTac"; (_,na) = name; ":="; c = constr; p = clause_pattern + -> TacLetTac (na,c,p) + | IDENT "Instantiate"; n = natural; c = constr; cls = clause -> + TacInstantiate (n,c,cls) + | IDENT "Specialize"; n = OPT natural; lcb = constr_with_bindings -> + TacSpecialize (n,lcb) + | IDENT "LApply"; c = constr -> TacLApply c + + (* Derived basic tactics *) + | IDENT "Induction"; h = quantified_hypothesis -> TacSimpleInduction (h,ref []) + | IDENT "NewInduction"; c = induction_arg; el = OPT eliminator; + ids = with_names -> TacNewInduction (c,el,(ids,ref [])) + | IDENT "Double"; IDENT "Induction"; h1 = quantified_hypothesis; + h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2) + | IDENT "Destruct"; h = quantified_hypothesis -> TacSimpleDestruct h + | IDENT "NewDestruct"; c = induction_arg; el = OPT eliminator; + ids = with_names -> TacNewDestruct (c,el,(ids,ref [])) + | IDENT "Decompose"; IDENT "Record" ; c = constr -> TacDecomposeAnd c + | IDENT "Decompose"; IDENT "Sum"; c = constr -> TacDecomposeOr c + | IDENT "Decompose"; "["; l = LIST1 global_or_ltac_ref; "]"; c = constr + -> TacDecompose (l,c) + + (* Automation tactic *) + | IDENT "Trivial"; db = hintbases -> TacTrivial db + | IDENT "Auto"; n = OPT natural; db = hintbases -> TacAuto (n, db) + + | IDENT "AutoTDB"; n = OPT natural -> TacAutoTDB n + | IDENT "CDHyp"; id = identref -> TacDestructHyp (true,id) + | IDENT "DHyp"; id = identref -> TacDestructHyp (false,id) + | IDENT "DConcl" -> TacDestructConcl + | IDENT "SuperAuto"; l = autoargs -> TacSuperAuto l + | IDENT "Auto"; n = OPT natural; IDENT "Decomp"; p = OPT natural -> + TacDAuto (n, p) + + (* Context management *) + | IDENT "Clear"; l = LIST1 id_or_ltac_ref -> TacClear l + | IDENT "ClearBody"; l = LIST1 id_or_ltac_ref -> TacClearBody l + | IDENT "Move"; id1 = id_or_ltac_ref; IDENT "after"; + id2 = id_or_ltac_ref -> TacMove (true,id1,id2) + | IDENT "Rename"; id1 = id_or_ltac_ref; IDENT "into"; + id2 = id_or_ltac_ref -> TacRename (id1,id2) + + (* Constructors *) + | IDENT "Left"; bl = with_bindings -> TacLeft bl + | IDENT "Right"; bl = with_bindings -> TacRight bl + | IDENT "Split"; bl = with_bindings -> TacSplit (false,bl) + | IDENT "Exists"; bl = bindings -> TacSplit (true,bl) + | IDENT "Exists" -> TacSplit (true,NoBindings) + | IDENT "Constructor"; n = num_or_meta; l = with_bindings -> + TacConstructor (n,l) + | IDENT "Constructor"; t = OPT tactic -> TacAnyConstructor t + + (* Equivalence relations *) + | IDENT "Reflexivity" -> TacReflexivity + | IDENT "Symmetry"; cls = clause -> TacSymmetry cls + | IDENT "Transitivity"; c = constr -> TacTransitivity c + + (* Equality and inversion *) + | IDENT "Dependent"; k = + [ IDENT "Simple"; IDENT "Inversion" -> SimpleInversion + | IDENT "Inversion" -> FullInversion + | IDENT "Inversion_clear" -> FullInversionClear ]; + hyp = quantified_hypothesis; + ids = with_names; co = OPT ["with"; c = constr -> c] -> + TacInversion (DepInversion (k,co,ids),hyp) + | IDENT "Simple"; IDENT "Inversion"; + hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> + TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp) + | IDENT "Inversion"; + hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> + TacInversion (NonDepInversion (FullInversion, cl, ids), hyp) + | IDENT "Inversion_clear"; + hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> + TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp) + | IDENT "Inversion"; hyp = quantified_hypothesis; + "using"; c = constr; cl = simple_clause -> + TacInversion (InversionUsing (c,cl), hyp) + + (* Conversion *) + | r = red_tactic; cl = clause -> TacReduce (r, cl) + (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) + | IDENT "Change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl) + + ] ] + ; +END;; diff --git a/parsing/g_tacticnew.ml4 b/parsing/g_tacticnew.ml4 new file mode 100644 index 00000000..2070b40e --- /dev/null +++ b/parsing/g_tacticnew.ml4 @@ -0,0 +1,401 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "; "<-" ] +let _ = + if not !Options.v7 then + List.iter (fun s -> Lexer.add_token("",s)) tactic_kw + +(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) +(* admissible notation "(x t)" *) +let lpar_id_coloneq = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match Stream.npeek 1 strm with + | [("","(")] -> + (match Stream.npeek 2 strm with + | [_; ("IDENT",s)] -> + (match Stream.npeek 3 strm with + | [_; _; ("", ":=")] -> + Stream.junk strm; Stream.junk strm; Stream.junk strm; + Names.id_of_string s + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* idem for (x:=t) and (1:=t) *) +let test_lpar_idnum_coloneq = + Gram.Entry.of_parser "test_lpar_idnum_coloneq" + (fun strm -> + match Stream.npeek 1 strm with + | [("","(")] -> + (match Stream.npeek 2 strm with + | [_; (("IDENT"|"INT"),_)] -> + (match Stream.npeek 3 strm with + | [_; _; ("", ":=")] -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* idem for (x:t) *) +let lpar_id_colon = + Gram.Entry.of_parser "lpar_id_colon" + (fun strm -> + match Stream.npeek 1 strm with + | [("","(")] -> + (match Stream.npeek 2 strm with + | [_; ("IDENT",id)] -> + (match Stream.npeek 3 strm with + | [_; _; ("", ":")] -> + Stream.junk strm; Stream.junk strm; Stream.junk strm; + Names.id_of_string id + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +open Constr +open Prim +open Tactic + +let mk_fix_tac (loc,id,bl,ann,ty) = + let n = + match bl,ann with + [([_],_)], None -> 0 + | _, Some x -> + let ids = List.map snd (List.flatten (List.map fst bl)) in + (try list_index (snd x) ids + with Not_found -> error "no such fix variable") + | _ -> error "cannot guess decreasing argument of fix" in + (id,n,Topconstr.CProdN(loc,bl,ty)) + +let mk_cofix_tac (loc,id,bl,ann,ty) = + let _ = option_app (fun (aloc,_) -> + Util.user_err_loc + (aloc,"Constr:mk_cofix_tac", + Pp.str"Annotation forbidden in cofix expression")) ann in + (id,Topconstr.CProdN(loc,bl,ty)) + +(* Functions overloaded by quotifier *) +let induction_arg_of_constr c = + try ElimOnIdent (Topconstr.constr_loc c,snd(coerce_to_id c)) + with _ -> ElimOnConstr c + +let local_compute = [FBeta;FIota;FDeltaBut [];FZeta] + +let error_oldelim _ = error "OldElim no longer supported" + +let join_to_constr loc c2 = (fst loc), snd (Topconstr.constr_loc c2) + +(* Auxiliary grammar rules *) + +if not !Options.v7 then +GEXTEND Gram + GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis + bindings red_expr int_or_var castedopenconstr simple_intropattern; + + int_or_var: + [ [ n = integer -> Genarg.ArgArg n + | id = identref -> Genarg.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) ] ] + ; + (* A number or a quotation meta-variable *) + num_or_meta: + [ [ n = integer -> AI n + | id = METAIDENT -> MetaId (loc,id) + ] ] + ; + castedopenconstr: + [ [ c = constr -> c ] ] + ; + induction_arg: + [ [ n = natural -> ElimOnAnonHyp n + | c = constr -> induction_arg_of_constr c + ] ] + ; + quantified_hypothesis: + [ [ id = base_ident -> NamedHyp id + | n = natural -> AnonHyp n ] ] + ; + conversion: + [ [ c = constr -> (None, c) + | c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2) + | c1 = constr; "at"; nl = LIST1 integer; "with"; c2 = constr -> + (Some (nl,c1), c2) ] ] + ; + occurrences: + [ [ "at"; nl = LIST1 integer -> nl + | -> [] ] ] + ; + pattern_occ: + [ [ c = constr; nl = occurrences -> (nl,c) ] ] + ; + unfold_occ: + [ [ c = global; nl = occurrences -> (nl,c) ] ] + ; + intropatterns: + [ [ l = LIST0 simple_intropattern -> l ]] + ; + simple_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc + | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc] + | "_" -> IntroWildcard + | id = base_ident -> IntroIdentifier id + ] ] + ; + simple_binding: + [ [ "("; id = base_ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c) + | "("; n = natural; ":="; c = lconstr; ")" -> (loc, AnonHyp n, c) ] ] + ; + bindings: + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + ExplicitBindings bl + | bl = LIST1 constr -> ImplicitBindings bl ] ] + ; + constr_with_bindings: + [ [ c = constr; l = with_bindings -> (c, l) ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] + ; + red_flag: + [ [ IDENT "beta" -> FBeta + | IDENT "delta" -> FDeltaBut [] + | IDENT "iota" -> FIota + | IDENT "zeta" -> FZeta + | IDENT "delta"; "["; idl = LIST1 global; "]" -> FConst idl + | IDENT "delta"; "-"; "["; idl = LIST1 global; "]" -> FDeltaBut idl + ] ] + ; + red_tactic: + [ [ IDENT "red" -> Red false + | IDENT "hnf" -> Hnf + | IDENT "simpl"; po = OPT pattern_occ -> Simpl po + | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) + | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) + | IDENT "compute" -> compute + | 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 ] ] + ; + (* This is [red_tactic] including possible extensions *) + red_expr: + [ [ IDENT "red" -> Red false + | IDENT "hnf" -> Hnf + | IDENT "simpl"; po = OPT pattern_occ -> Simpl po + | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) + | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) + | IDENT "compute" -> compute + | IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul + | IDENT "fold"; cl = LIST1 constr -> Fold cl + | IDENT "pattern"; pl = LIST1 pattern_occ -> Pattern pl + | s = IDENT; c = constr -> ExtraRedExpr (s,c) ] ] + ; + hypident: + [ [ id = id_or_meta -> id,(InHyp,ref None) + | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> + id,(InHypTypeOnly,ref None) + | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> + id,(InHypValueOnly,ref None) + ] ] + ; + hypident_occ: + [ [ (id,l)=hypident; occs=occurrences -> (id,occs,l) ] ] + ; + clause: + [ [ "in"; "*"; occs=occurrences -> + {onhyps=None;onconcl=true;concl_occs=occs} + | "in"; "*"; "|-"; (b,occs)=concl_occ -> + {onhyps=None; onconcl=b; concl_occs=occs} + | "in"; hl=LIST0 hypident_occ SEP","; "|-"; (b,occs)=concl_occ -> + {onhyps=Some hl; onconcl=b; concl_occs=occs} + | "in"; hl=LIST0 hypident_occ SEP"," -> + {onhyps=Some hl; onconcl=false; concl_occs=[]} + | -> {onhyps=Some[];onconcl=true; concl_occs=[]} ] ] + ; + concl_occ: + [ [ "*"; occs = occurrences -> (true,occs) + | -> (false, []) ] ] + ; + simple_clause: + [ [ "in"; idl = LIST1 id_or_meta -> idl + | -> [] ] ] + ; + fixdecl: + [ [ "("; id = base_ident; bl=LIST0 Constr.binder; ann=fixannot; + ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ] + ; + fixannot: + [ [ "{"; IDENT "struct"; id=name; "}" -> Some id + | -> None ] ] + ; + hintbases: + [ [ "with"; "*" -> None + | "with"; l = LIST1 IDENT -> Some l + | -> Some [] ] ] + ; + eliminator: + [ [ "using"; el = constr_with_bindings -> el ] ] + ; + with_names: + [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ] + ; + simple_tactic: + [ [ + (* Basic tactics *) + IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> + TacIntrosUntil id + | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl + | IDENT "intro"; id = base_ident; IDENT "after"; id2 = identref -> + TacIntroMove (Some id, Some id2) + | IDENT "intro"; IDENT "after"; id2 = identref -> + TacIntroMove (None, Some id2) + | IDENT "intro"; id = base_ident -> TacIntroMove (Some id, None) + | IDENT "intro" -> TacIntroMove (None, None) + + | IDENT "assumption" -> TacAssumption + | IDENT "exact"; c = constr -> TacExact c + + | IDENT "apply"; cl = constr_with_bindings -> TacApply cl + | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator -> + TacElim (cl,el) + | IDENT "elimtype"; c = constr -> TacElimType c + | IDENT "case"; cl = constr_with_bindings -> TacCase cl + | IDENT "casetype"; c = constr -> TacCaseType c + | "fix"; n = natural -> TacFix (None,n) + | "fix"; id = base_ident; n = natural -> TacFix (Some id,n) + | "fix"; id = base_ident; n = natural; "with"; fd = LIST1 fixdecl -> + TacMutualFix (id,n,List.map mk_fix_tac fd) + | "cofix" -> TacCofix None + | "cofix"; id = base_ident -> TacCofix (Some id) + | "cofix"; id = base_ident; "with"; fd = LIST1 fixdecl -> + TacMutualCofix (id,List.map mk_cofix_tac fd) + + | IDENT "cut"; c = constr -> TacCut c + | IDENT "assert"; id = lpar_id_colon; t = lconstr; ")" -> + TacTrueCut (Names.Name id,t) + | IDENT "assert"; id = lpar_id_coloneq; b = lconstr; ")" -> + TacForward (false,Names.Name id,b) + | IDENT "assert"; c = constr -> TacTrueCut (Names.Anonymous,c) + | IDENT "pose"; id = lpar_id_coloneq; b = lconstr; ")" -> + TacForward (true,Names.Name id,b) + | IDENT "pose"; b = constr -> TacForward (true,Names.Anonymous,b) + | IDENT "generalize"; lc = LIST1 constr -> TacGeneralize lc + | IDENT "generalize"; IDENT "dependent"; c = constr -> + TacGeneralizeDep c + | IDENT "set"; id = lpar_id_coloneq; c = lconstr; ")"; + p = clause -> TacLetTac (Names.Name id,c,p) + | IDENT "set"; c = constr; p = clause -> + TacLetTac (Names.Anonymous,c,p) + | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")"; + cls = clause -> + TacInstantiate (n,c,cls) + + | IDENT "specialize"; n = OPT natural; lcb = constr_with_bindings -> + TacSpecialize (n,lcb) + | IDENT "lapply"; c = constr -> TacLApply c + + (* Derived basic tactics *) + | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis -> + TacSimpleInduction (h,ref []) + | IDENT "induction"; c = induction_arg; ids = with_names; + el = OPT eliminator -> TacNewInduction (c,el,(ids,ref [])) + | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis; + h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2) + | IDENT "simple"; IDENT"destruct"; h = quantified_hypothesis -> + TacSimpleDestruct h + | IDENT "destruct"; c = induction_arg; ids = with_names; + el = OPT eliminator -> TacNewDestruct (c,el,(ids,ref [])) + | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c + | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c + | IDENT "decompose"; "["; l = LIST1 global; "]"; c = constr + -> TacDecompose (l,c) + + (* Automation tactic *) + | IDENT "trivial"; db = hintbases -> TacTrivial db + | IDENT "auto"; n = OPT natural; db = hintbases -> TacAuto (n, db) + +(* Obsolete since V8.0 + | IDENT "autotdb"; n = OPT natural -> TacAutoTDB n + | IDENT "cdhyp"; id = identref -> TacDestructHyp (true,id) + | IDENT "dhyp"; id = identref -> TacDestructHyp (false,id) + | IDENT "dconcl" -> TacDestructConcl + | IDENT "superauto"; l = autoargs -> TacSuperAuto l +*) + | IDENT "auto"; n = OPT natural; IDENT "decomp"; p = OPT natural -> + TacDAuto (n, p) + + (* Context management *) + | IDENT "clear"; l = LIST1 id_or_meta -> TacClear l + | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l + | IDENT "move"; id1 = id_or_meta; IDENT "after"; id2 = id_or_meta -> + TacMove (true,id1,id2) + | IDENT "rename"; id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> + TacRename (id1,id2) + + (* Constructors *) + | IDENT "left"; bl = with_bindings -> TacLeft bl + | IDENT "right"; bl = with_bindings -> TacRight bl + | IDENT "split"; bl = with_bindings -> TacSplit (false,bl) + | "exists"; bl = bindings -> TacSplit (true,bl) + | "exists" -> TacSplit (true,NoBindings) + | IDENT "constructor"; n = num_or_meta; l = with_bindings -> + TacConstructor (n,l) + | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor t + + (* Equivalence relations *) + | IDENT "reflexivity" -> TacReflexivity + | IDENT "symmetry"; cls = clause -> TacSymmetry cls + | IDENT "transitivity"; c = constr -> TacTransitivity c + + (* Equality and inversion *) + | IDENT "dependent"; k = + [ IDENT "simple"; IDENT "inversion" -> SimpleInversion + | IDENT "inversion" -> FullInversion + | IDENT "inversion_clear" -> FullInversionClear ]; + hyp = quantified_hypothesis; + ids = with_names; co = OPT ["with"; c = constr -> c] -> + TacInversion (DepInversion (k,co,ids),hyp) + | IDENT "simple"; IDENT "inversion"; + hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> + TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp) + | IDENT "inversion"; + hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> + TacInversion (NonDepInversion (FullInversion, cl, ids), hyp) + | IDENT "inversion_clear"; + hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> + TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp) + | IDENT "inversion"; hyp = quantified_hypothesis; + "using"; c = constr; cl = simple_clause -> + TacInversion (InversionUsing (c,cl), hyp) + + (* Conversion *) + | r = red_tactic; cl = clause -> TacReduce (r, cl) + (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) + | IDENT "change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl) + ] ] + ; +END;; diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 new file mode 100644 index 00000000..e2eecf55 --- /dev/null +++ b/parsing/g_vernac.ml4 @@ -0,0 +1,524 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* b'e) !Pp.comments + +if !Options.v7 then +GEXTEND Gram + GLOBAL: vernac gallina_ext; + vernac: + (* 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 + | g = gallina_ext; "." -> g + | c = command; "." -> c + | c = syntax; "." -> c + | n = natural; ":"; tac = Tactic.tactic; "." -> VernacSolve (n,tac,true) + | n = natural; ":"; tac = Tactic.tactic; "!!" -> VernacSolve (n,tac,false) + | n = natural; ":"; v = check_command; "." -> v (Some n) + | "["; l = vernac_list_tail -> VernacList l + + (* For translation from V7 to V8 *) + | IDENT "V7only"; v = vernac -> + filter_com loc; VernacV7only v + | IDENT "V8only"; v = vernac -> VernacV8only v + +(* + (* This is for "Grammar vernac" rules *) + | id = METAIDENT -> VernacVar (Names.id_of_string id) +*) + ] ] + ; + + check_command: + [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = constr -> + fun g -> VernacCheckMayEval (Some r, g, c) + | IDENT "Check"; c = constr -> + fun g -> VernacCheckMayEval (None, g, c) ] ] + ; + vernac: FIRST + [ [ IDENT "Time"; v = vernac -> VernacTime v ] ] + ; + vernac: LAST + [ [ tac = Tactic.tactic; "." -> VernacSolve (1,tac,true) + | tac = Tactic.tactic; "!!" -> VernacSolve (1,tac,false) + | IDENT "Existential"; n = natural; c = constr_body -> + VernacSolveExistential (n,c) + ] ] + ; + constr_body: + [ [ ":="; c = constr; ":"; t = constr -> CCast(loc,c,t) + | ":"; t = constr; ":="; c = constr -> CCast(loc,c,t) + | ":="; c = constr -> c ] ] + ; + vernac_list_tail: + [ [ v = located_vernac; l = vernac_list_tail -> v :: l + | "]"; "." -> [] ] ] + ; + located_vernac: + [ [ v = vernac -> loc, v ] ] + ; +END + +let test_plurial_form = function + | [_,([_],_)] -> + Options.if_verbose warning + "Keywords Variables/Hypotheses/Parameters expect more than one assumption" + | _ -> () + +(* Gallina declarations *) +if !Options.v7 then +GEXTEND Gram + GLOBAL: gallina gallina_ext thm_token; + + thm_token: + [ [ "Theorem" -> Theorem + | IDENT "Lemma" -> Lemma + | IDENT "Fact" -> Fact + | IDENT "Remark" -> Remark ] ] + ; + def_token: + [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition) + | IDENT "Local" -> (fun _ _ -> ()), (Local, Definition) + | IDENT "SubClass" -> Class.add_subclass_hook, (Global, SubClass) + | IDENT "Local"; IDENT "SubClass" -> + Class.add_subclass_hook, (Local, SubClass) ] ] + ; + assumption_token: + [ [ "Hypothesis" -> (Local, Logical) + | "Variable" -> (Local, Definitional) + | "Axiom" -> (Global, Logical) + | "Parameter" -> (Global, Definitional) + | IDENT "Conjecture" -> (Global,Conjectural) ] ] + ; + assumptions_token: + [ [ IDENT "Hypotheses" -> (Local, Logical) + | IDENT "Variables" -> (Local, Definitional) + | IDENT "Parameters" -> (Global, Definitional) ] ] + ; + of_type_with_opt_coercion: + [ [ ":>" -> true + | ":"; ">" -> true + | ":" -> false ] ] + ; + params: + [ [ idl = LIST1 identref SEP ","; coe = of_type_with_opt_coercion; + c = constr -> (coe,(idl,c)) + ] ] + ; + ne_params_list: + [ [ ll = LIST1 params SEP ";" -> ll ] ] + ; + name_comma_list_tail: + [ [ ","; nal = LIST1 name SEP "," -> nal | -> [] ] ] + ; + ident_comma_list_tail: + [ [ ","; nal = LIST1 identref SEP "," -> nal | -> [] ] ] + ; + decl_notation: + [ [ "where"; ntn = STRING; ":="; c = constr; + scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] + ; + type_option: + [ [ ":"; c = constr -> c + | -> evar_constr loc ] ] + ; + opt_casted_constr: + [ [ c = constr; ":"; t = constr -> CCast(loc,c,t) + | c = constr -> c ] ] + ; + vardecls: + [ [ na = name; nal = name_comma_list_tail; c = type_option + -> LocalRawAssum (na::nal,c) + | na = name; "="; c = opt_casted_constr -> + LocalRawDef (na,c) + | na = name; ":="; c = opt_casted_constr -> + LocalRawDef (na,c) + ] ] + ; + binders: + [ [ "["; bl = LIST1 vardecls SEP ";"; "]" -> bl ] ] + ; + binders_list: + [ [ bls = LIST0 binders -> List.flatten bls ] ] + ; + reduce: + [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r + | -> None ] ] + ; + def_body: + [ [ bl = binders_list; ":="; red = reduce; c = constr; ":"; t = constr -> + DefineBody (bl, red, c, Some t) + | bl = binders_list; ":"; t = constr; ":="; red = reduce; c = constr -> + DefineBody (bl, red, c, Some t) + | bl = binders_list; ":="; red = reduce; c = constr -> + DefineBody (bl, red, c, None) + | bl = binders_list; ":"; t = constr -> + ProveBody (bl, t) ] ] + ; + gallina: + (* Definition, Theorem, Variable, Axiom, ... *) + [ [ thm = thm_token; id = identref; ":"; c = constr -> + VernacStartTheoremProof (thm, id, ([], c), false, (fun _ _ -> ())) + | (f,d) = def_token; id = identref; b = def_body -> + VernacDefinition (d, id, b, f) + | stre = assumption_token; bl = ne_params_list -> + VernacAssumption (stre, bl) + | stre = assumptions_token; bl = ne_params_list -> + test_plurial_form bl; + VernacAssumption (stre, bl) + ] ] + ; + (* Gallina inductive declarations *) + finite_token: + [ [ "Inductive" -> true + | "CoInductive" -> false ] ] + ; + record_token: + [ [ IDENT "Record" -> true | IDENT "Structure" -> false ] ] + ; + constructor: + [ [ idl = LIST1 identref SEP ","; coe = of_type_with_opt_coercion; + c = constr -> List.map (fun id -> (coe,(id,c))) idl ] ] + ; + constructor_list: + [ [ "|"; l = LIST1 constructor SEP "|" -> List.flatten l + | l = LIST1 constructor SEP "|" -> List.flatten l + | -> [] ] ] + ; + block_old_style: + [ [ ind = oneind_old_style; "with"; indl = block_old_style -> ind :: indl + | ind = oneind_old_style -> [ind] ] ] + ; + oneind_old_style: + [ [ id = identref; ":"; c = constr; ":="; lc = constructor_list -> + (id,c,lc) ] ] + ; + oneind: + [ [ id = identref; indpar = simple_binders_list; ":"; c = constr; + ":="; lc = constructor_list; ntn = OPT decl_notation -> + (id,ntn,indpar,c,lc) ] ] + ; + simple_binders_list: + [ [ bl = ne_simple_binders_list -> bl + | -> [] ] ] + ; + opt_coercion: + [ [ ">" -> true + | -> false ] ] + ; + onescheme: + [ [ id = identref; ":="; dep = dep; ind = global; IDENT "Sort"; + s = sort -> (id,dep,ind,s) ] ] + ; + schemes: + [ [ recl = LIST1 onescheme SEP "with" -> recl ] ] + ; + dep: + [ [ IDENT "Induction"; IDENT "for" -> true + | IDENT "Minimality"; IDENT "for" -> false ] ] + ; + onerec: + [ [ id = base_ident; bl = ne_fix_binders; ":"; type_ = constr; + ":="; def = constr; ntn = OPT decl_notation -> + let ni = List.length (List.flatten (List.map fst bl)) - 1 in + let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in + ((id, ni, bl, type_, def), ntn) ] ] + ; + specifrec: + [ [ l = LIST1 onerec SEP "with" -> l ] ] + ; + onecorec: + [ [ id = base_ident; ":"; c = constr; ":="; def = constr -> + (id,[],c,def) ] ] + ; + specifcorec: + [ [ l = LIST1 onecorec SEP "with" -> l ] ] + ; + record_field: + [ [ id = name; oc = of_type_with_opt_coercion; t = constr -> + (oc,AssumExpr (id,t)) + | id = name; oc = of_type_with_opt_coercion; t = constr; + ":="; b = constr -> + (oc,DefExpr (id,b,Some t)) + | id = name; ":="; b = constr -> + (false,DefExpr (id,b,None)) ] ] + ; + fields: + [ [ fs = LIST0 record_field SEP ";" -> fs ] ] + ; + simple_binders: + [ [ "["; bll = LIST1 vardecls SEP ";"; "]" -> bll ] ] + ; + ne_simple_binders_list: + [ [ bll = LIST1 simple_binders -> (List.flatten bll) ] ] + ; + fix_params: + [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c) + | idl = LIST1 name SEP "," -> (idl, evar_constr dummy_loc) + ] ] + ; + fix_binders: + [ [ "["; bll = LIST1 fix_params SEP ";"; "]" -> bll ] ] + ; + ne_fix_binders: + [ [ bll = LIST1 fix_binders -> List.flatten bll ] ] + ; + rec_constructor: + [ [ c = identref -> Some c + | -> None ] ] + ; + gallina_ext: + [ [ IDENT "Mutual"; bl = ne_simple_binders_list ; f = finite_token; + indl = block_old_style -> + let indl' = List.map (fun (id,ar,c) -> (id,None,bl,ar,c)) indl in + VernacInductive (f,indl') + | b = record_token; oc = opt_coercion; name = identref; + ps = simple_binders_list; ":"; + s = constr; ":="; c = rec_constructor; "{"; fs = fields; "}" -> + VernacRecord (b,(oc,name),ps,s,c,fs) + ] ] + ; + gallina: + [ [ IDENT "Mutual"; f = finite_token; indl = LIST1 oneind SEP "with" -> + VernacInductive (f,indl) + | f = finite_token; indl = LIST1 oneind SEP "with" -> + VernacInductive (f,indl) + | "Fixpoint"; recs = specifrec -> VernacFixpoint recs + | "CoFixpoint"; corecs = specifcorec -> VernacCoFixpoint corecs + | IDENT "Scheme"; l = schemes -> VernacScheme l + | f = finite_token; s = csort; id = identref; + indpar = simple_binders_list; ":="; lc = constructor_list -> + VernacInductive (f,[id,None,indpar,s,lc]) ] ] + ; + csort: + [ [ s = sort -> CSort (loc,s) ] ] + ; + gallina_ext: + [ [ +(* Sections *) + IDENT "Section"; id = identref -> VernacBeginSection id + | IDENT "Chapter"; id = identref -> VernacBeginSection id ] ] + ; + module_vardecls: + [ [ id = identref; idl = ident_comma_list_tail; ":"; + mty = Module.module_type -> (id::idl,mty) ] ] + ; + module_binders: + [ [ "["; bl = LIST1 module_vardecls SEP ";"; "]" -> bl ] ] + ; + module_binders_list: + [ [ bls = LIST0 module_binders -> List.flatten bls ] ] + ; + of_module_type: + [ [ ":"; mty = Module.module_type -> (mty, true) + | "<:"; mty = Module.module_type -> (mty, false) ] ] + ; + is_module_type: + [ [ ":="; mty = Module.module_type -> mty ] ] + ; + is_module_expr: + [ [ ":="; mexpr = Module.module_expr -> mexpr ] ] + ; + gallina_ext: + [ [ + (* Interactive module declaration *) + IDENT "Module"; id = identref; + bl = module_binders_list; mty_o = OPT of_module_type; + mexpr_o = OPT is_module_expr -> + VernacDefineModule (id, bl, mty_o, mexpr_o) + + | IDENT "Module"; "Type"; id = identref; + bl = module_binders_list; mty_o = OPT is_module_type -> + VernacDeclareModuleType (id, bl, mty_o) + + | IDENT "Declare"; IDENT "Module"; id = identref; + bl = module_binders_list; mty_o = OPT of_module_type; + mexpr_o = OPT is_module_expr -> + VernacDeclareModule (id, bl, mty_o, mexpr_o) + + (* This end a Section a Module or a Module Type *) + + | IDENT "End"; id = identref -> VernacEndSegment id + + +(* Transparent and Opaque *) + | IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l) + | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l) + +(* Canonical structure *) + | IDENT "Canonical"; IDENT "Structure"; qid = global -> + VernacCanonical qid + | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> + let s = Ast.coerce_global_to_id qid in + VernacDefinition + ((Global,CanonicalStructure),(dummy_loc,s),d,Recordobj.add_object_hook) + (* Rem: LOBJECT, OBJCOERCION, LOBJCOERCION have been removed + (they were unused and undocumented) *) + +(* Coercions *) + | IDENT "Coercion"; qid = global; d = def_body -> + let s = Ast.coerce_global_to_id qid in + VernacDefinition ((Global,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> + let s = Ast.coerce_global_to_id qid in + VernacDefinition ((Local,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; + ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> + VernacIdentityCoercion (Local, f, s, t) + | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; + s = class_rawexpr; ">->"; t = class_rawexpr -> + VernacIdentityCoercion (Global, f, s, t) + | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; + s = class_rawexpr; ">->"; t = class_rawexpr -> + VernacCoercion (Local, qid, s, t) + | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; + t = class_rawexpr -> + VernacCoercion (Global, qid, s, t) + | IDENT "Class"; IDENT "Local"; c = global -> + Pp.warning "Class is obsolete"; VernacNop + | IDENT "Class"; c = global -> + Pp.warning "Class is obsolete"; VernacNop + +(* Implicit *) +(* + | IDENT "Syntactic"; "Definition"; id = identref; ":="; c = constr; + n = OPT [ "|"; n = natural -> n ] -> + VernacSyntacticDefinition (id,c,n) +*) + | IDENT "Syntactic"; "Definition"; id = ident; ":="; c = constr; + n = OPT [ "|"; n = natural -> n ] -> + let c = match n with + | Some n -> + let l = list_tabulate (fun _ -> (CHole (loc),None)) n in + CApp (loc,(None,c),l) + | None -> c in + VernacSyntacticDefinition (id,c,false,true) + | IDENT "Implicits"; qid = global; "["; l = LIST0 natural; "]" -> + let l = List.map (fun n -> ExplByPos n) l in + VernacDeclareImplicits (qid,Some l) + | IDENT "Implicits"; qid = global -> VernacDeclareImplicits (qid,None) + + | IDENT "Implicit"; ["Variable"; "Type" | IDENT "Variables"; "Type"]; + idl = LIST1 identref SEP ","; ":"; c = constr -> VernacReserve (idl,c) + + (* For compatibility *) + | IDENT "Implicit"; IDENT "Arguments"; IDENT "On" -> + VernacSetOption + (Goptions.SecondaryTable ("Implicit","Arguments"), BoolValue true) + | IDENT "Implicit"; IDENT "Arguments"; IDENT "Off" -> + VernacSetOption + (Goptions.SecondaryTable ("Implicit","Arguments"), BoolValue false) + ] ] + ; +END + +(* Modules management *) +if !Options.v7 then +GEXTEND Gram + GLOBAL: command; + + export_token: + [ [ IDENT "Import" -> false + | IDENT "Export" -> true + | -> false ] ] + ; + specif_token: + [ [ IDENT "Implementation" -> Some false + | IDENT "Specification" -> Some true + | -> None ] ] + ; + command: + [ [ "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ]; + s = [ s = STRING -> s | s = IDENT -> s ] -> + VernacLoad (verbosely, s) +(* | "Compile"; + verbosely = + [ IDENT "Verbose" -> "Verbose" + | -> "" ]; + IDENT "Module"; + only_spec = + [ IDENT "Specification" -> "Specification" + | -> "" ]; + mname = [ s = STRING -> s | s = IDENT -> s ]; + fname = OPT [ s = STRING -> s | s = IDENT -> s ] -> ExtraVernac + let fname = match fname with Some s -> s | None -> mname in + <:ast< (CompileFile ($STR $verbosely) ($STR $only_spec) + ($STR $mname) ($STR $fname))>> +*) + | IDENT "Read"; IDENT "Module"; qidl = LIST1 global -> + VernacRequire (None, None, qidl) + | IDENT "Require"; export = export_token; specif = specif_token; + qidl = LIST1 global -> VernacRequire (Some export, specif, qidl) +(* | IDENT "Require"; export = export_token; specif = specif_token; + id = identref; filename = STRING -> + VernacRequireFrom (export, specif, id, filename) *) + | IDENT "Require"; export = export_token; specif = specif_token; + filename = STRING -> + VernacRequireFrom (Some export, specif, filename) + | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 STRING -> + VernacDeclareMLModule l + | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) + | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) + ] +] + ; +END + +if !Options.v7 then +GEXTEND Gram + GLOBAL: command; + + command: + [ [ + +(* State management *) + IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s + | IDENT "Write"; IDENT "State"; s = STRING -> VernacWriteState s + | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s + | IDENT "Restore"; IDENT "State"; s = STRING -> VernacRestoreState s + +(* Resetting *) + | IDENT "Reset"; id = identref -> VernacResetName id + | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial + | IDENT "Back" -> VernacBack 1 + | IDENT "Back"; n = natural -> VernacBack n + +(* Tactic Debugger *) + | IDENT "Debug"; IDENT "On" -> VernacDebug true + | IDENT "Debug"; IDENT "Off" -> VernacDebug false + + ] ]; + END +;; diff --git a/parsing/g_vernacnew.ml4 b/parsing/g_vernacnew.ml4 new file mode 100644 index 00000000..8a99a51e --- /dev/null +++ b/parsing/g_vernacnew.ml4 @@ -0,0 +1,729 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ->"; ":<"; "<:"; "where"; "at" ] +let _ = + if not !Options.v7 then + List.iter (fun s -> Lexer.add_token ("",s)) 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 class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" +let thm_token = Gram.Entry.create "vernac:thm_token" +let def_body = Gram.Entry.create "vernac:def_body" + +if not !Options.v7 then +GEXTEND Gram + GLOBAL: vernac gallina_ext; + vernac: + (* 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 + | g = gallina_ext; "." -> g + | c = command; "." -> c + | c = syntax; "." -> c + | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l + ] ] + ; + vernac: FIRST + [ [ IDENT "Time"; v = vernac -> VernacTime v ] ] + ; + vernac: LAST + [ [ gln = OPT[n=natural; ":" -> n]; + tac = subgoal_command -> tac gln ] ] + ; + subgoal_command: + [ [ c = check_command; "." -> c + | tac = Tactic.tactic; + use_dft_tac = [ "." -> false | "..." -> true ] -> + (fun g -> + let g = match g with Some gl -> gl | _ -> 1 in + VernacSolve(g,tac,use_dft_tac)) ] ] + ; + located_vernac: + [ [ v = vernac -> loc, v ] ] + ; +END + + +let test_plurial_form = function + | [(_,([_],_))] -> + Options.if_verbose warning + "Keywords Variables/Hypotheses/Parameters expect more than one assumption" + | _ -> () + +let no_coercion loc (c,x) = + if c then Util.user_err_loc + (loc,"no_coercion",Pp.str"no coercion allowed here"); + x + +(* Gallina declarations *) +if not !Options.v7 then +GEXTEND Gram + GLOBAL: gallina gallina_ext thm_token def_body; + + gallina: + (* Definition, Theorem, Variable, Axiom, ... *) + [ [ thm = thm_token; id = identref; (* bl = LIST0 binder; *) ":"; + c = lconstr -> + let bl = [] in + VernacStartTheoremProof (thm, id, (bl, c), false, (fun _ _ -> ())) + | (f,d) = def_token; id = identref; b = def_body -> + VernacDefinition (d, id, b, f) + | stre = assumption_token; bl = assum_list -> + VernacAssumption (stre, bl) + | stre = assumptions_token; bl = assum_list -> + test_plurial_form bl; + VernacAssumption (stre, bl) + (* Gallina inductive declarations *) + | f = finite_token; + indl = LIST1 inductive_definition SEP "with" -> + VernacInductive (f,indl) + | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + VernacFixpoint recs + | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> + VernacCoFixpoint corecs + | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l ] ] + ; + gallina_ext: + [ [ b = record_token; oc = opt_coercion; name = identref; + ps = LIST0 binder_let; ":"; + s = lconstr; ":="; cstr = OPT identref; "{"; + fs = LIST0 record_field SEP ";"; "}" -> + VernacRecord (b,(oc,name),ps,s,cstr,fs) +(* Non porté ? + | f = finite_token; s = csort; id = identref; + indpar = LIST0 simple_binder; ":="; lc = constructor_list -> + VernacInductive (f,[id,None,indpar,s,lc]) +*) + ] ] + ; + thm_token: + [ [ "Theorem" -> Theorem + | IDENT "Lemma" -> Lemma + | IDENT "Fact" -> Fact + | IDENT "Remark" -> Remark ] ] + ; + def_token: + [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition) + | IDENT "Let" -> (fun _ _ -> ()), (Local, Definition) + | IDENT "SubClass" -> Class.add_subclass_hook, (Global, SubClass) + | IDENT "Local"; IDENT "SubClass" -> + Class.add_subclass_hook, (Local, SubClass) ] ] + ; + assumption_token: + [ [ "Hypothesis" -> (Local, Logical) + | "Variable" -> (Local, Definitional) + | "Axiom" -> (Global, Logical) + | "Parameter" -> (Global, Definitional) + | IDENT "Conjecture" -> (Global, Conjectural) ] ] + ; + assumptions_token: + [ [ IDENT "Hypotheses" -> (Local, Logical) + | IDENT "Variables" -> (Local, Definitional) + | IDENT "Axioms" -> (Global, Logical) + | IDENT "Parameters" -> (Global, Definitional) ] ] + ; + finite_token: + [ [ "Inductive" -> true + | "CoInductive" -> false ] ] + ; + record_token: + [ [ IDENT "Record" -> true | IDENT "Structure" -> false ] ] + ; + (* Simple definitions *) + def_body: + [ [ bl = LIST0 binder_let; ":="; red = reduce; c = lconstr -> + (match c with + CCast(_,c,t) -> DefineBody (bl, red, c, Some t) + | _ -> DefineBody (bl, red, c, None)) + | bl = LIST0 binder_let; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> + DefineBody (bl, red, c, Some t) + | bl = LIST0 binder_let; ":"; t = lconstr -> + ProveBody (bl, t) ] ] + ; + reduce: + [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r + | -> None ] ] + ; + decl_notation: + [ [ OPT [ "where"; ntn = ne_string; ":="; c = constr; + scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] ] + ; + (* Inductives and records *) + inductive_definition: + [ [ id = identref; indpar = LIST0 binder_let; ":"; c = lconstr; + ":="; lc = constructor_list; ntn = decl_notation -> + (id,ntn,indpar,c,lc) ] ] + ; + constructor_list: + [ [ "|"; l = LIST1 constructor SEP "|" -> l + | l = LIST1 constructor SEP "|" -> l + | -> [] ] ] + ; +(* + csort: + [ [ s = sort -> CSort (loc,s) ] ] + ; +*) + opt_coercion: + [ [ ">" -> true + | -> false ] ] + ; + (* (co)-fixpoints *) + rec_definition: + [ [ id = base_ident; bl = LIST1 binder_let; + annot = OPT rec_annotation; type_ = type_cstr; + ":="; def = lconstr; ntn = decl_notation -> + let names = List.map snd (names_of_local_assums bl) in + let ni = + match annot with + Some id -> + (try list_index (Name id) names - 1 + with Not_found -> Util.user_err_loc + (loc,"Fixpoint", + Pp.str "No argument named " ++ Nameops.pr_id id)) + | None -> + if List.length names > 1 then + Util.user_err_loc + (loc,"Fixpoint", + Pp.str "the recursive argument needs to be specified"); + 0 in + ((id, ni, bl, type_, def),ntn) ] ] + ; + corec_definition: + [ [ id = base_ident; bl = LIST0 binder_let; c = type_cstr; ":="; + def = lconstr -> + (id,bl,c ,def) ] ] + ; + rec_annotation: + [ [ "{"; IDENT "struct"; id=IDENT; "}" -> id_of_string id ] ] + ; + type_cstr: + [ [ ":"; c=lconstr -> c + | -> CHole loc ] ] + ; + (* Inductive schemes *) + scheme: + [ [ id = identref; ":="; dep = dep_scheme; "for"; ind = global; + IDENT "Sort"; s = sort -> + (id,dep,ind,s) ] ] + ; + dep_scheme: + [ [ IDENT "Induction" -> true + | IDENT "Minimality" -> false ] ] + ; + (* Various Binders *) +(* + (* ... without coercions *) + binder_nodef: + [ [ b = binder_let -> + (match b with + LocalRawAssum(l,ty) -> (l,ty) + | LocalRawDef _ -> + Util.user_err_loc + (loc,"fix_param",Pp.str"defined binder not allowed here")) ] ] + ; +*) + (* ... with coercions *) + record_field: + [ [ id = name -> (false,AssumExpr(id,CHole loc)) + | id = name; oc = of_type_with_opt_coercion; t = lconstr -> + (oc,AssumExpr (id,t)) + | id = name; oc = of_type_with_opt_coercion; + t = lconstr; ":="; b = lconstr -> (oc,DefExpr (id,b,Some t)) + | id = name; ":="; b = lconstr -> + match b with + CCast(_,b,t) -> (false,DefExpr(id,b,Some t)) + | _ -> (false,DefExpr(id,b,None)) ] ] + ; + assum_list: + [ [ bl = LIST1 assum_coe -> bl | b = simple_assum_coe -> [b] ] ] + ; + assum_coe: + [ [ "("; a = simple_assum_coe; ")" -> a ] ] + ; + simple_assum_coe: + [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> + (oc,(idl,c)) ] ] + ; + constructor: + [ [ id = identref; l = LIST0 binder_let; + coe = of_type_with_opt_coercion; c = lconstr -> + (coe,(id,G_constrnew.mkCProdN loc l c)) + | id = identref; l = LIST0 binder_let -> + (false,(id,G_constrnew.mkCProdN loc l (CHole loc))) ] ] + ; + of_type_with_opt_coercion: + [ [ ":>" -> true + | ":"; ">" -> true + | ":" -> false ] ] + ; +END + + +(* Modules and Sections *) +if not !Options.v7 then +GEXTEND Gram + GLOBAL: gallina_ext module_expr module_type; + + gallina_ext: + [ [ (* Interactive module declaration *) + IDENT "Module"; id = identref; + bl = LIST0 module_binder; mty_o = OPT of_module_type; + mexpr_o = OPT is_module_expr -> + VernacDefineModule (id, bl, mty_o, mexpr_o) + + | IDENT "Module"; "Type"; id = identref; + bl = LIST0 module_binder; mty_o = OPT is_module_type -> + VernacDeclareModuleType (id, bl, mty_o) + + | IDENT "Declare"; IDENT "Module"; id = identref; + bl = LIST0 module_binder; mty_o = OPT of_module_type; + mexpr_o = OPT is_module_expr -> + VernacDeclareModule (id, bl, mty_o, mexpr_o) + (* Section beginning *) + | IDENT "Section"; id = identref -> VernacBeginSection id + | IDENT "Chapter"; id = identref -> VernacBeginSection id + + (* This end a Section a Module or a Module Type *) + | IDENT "End"; id = identref -> VernacEndSegment id + + (* Requiring an already compiled module *) + | IDENT "Require"; export = export_token; specif = specif_token; + qidl = LIST1 global -> + VernacRequire (export, specif, qidl) + | IDENT "Require"; export = export_token; specif = specif_token; + filename = ne_string -> + VernacRequireFrom (export, specif, filename) + | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) + | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) ] ] + ; + export_token: + [ [ IDENT "Import" -> Some false + | IDENT "Export" -> Some true + | -> None ] ] + ; + specif_token: + [ [ IDENT "Implementation" -> Some false + | IDENT "Specification" -> Some true + | -> None ] ] + ; + of_module_type: + [ [ ":"; mty = module_type -> (mty, true) + | "<:"; mty = module_type -> (mty, false) ] ] + ; + is_module_type: + [ [ ":="; mty = module_type -> mty ] ] + ; + is_module_expr: + [ [ ":="; mexpr = module_expr -> mexpr ] ] + ; + + (* Module binder *) + module_binder: + [ [ "("; idl = LIST1 identref; ":"; mty = module_type; ")" -> + (idl,mty) ] ] + ; + + (* Module expressions *) + module_expr: + [ [ qid = qualid -> CMEident qid + | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2) + | "("; me = module_expr; ")" -> me +(* ... *) + ] ] + ; + with_declaration: + [ [ "Definition"; id = identref; ":="; c = Constr.lconstr -> + CWith_Definition (id,c) + | IDENT "Module"; id = identref; ":="; qid = qualid -> + CWith_Module (id,qid) + ] ] + ; + module_type: + [ [ qid = qualid -> CMTEident qid +(* ... *) + | mty = module_type; "with"; decl = with_declaration -> + CMTEwith (mty,decl) ] ] + ; +END + +(* Extensions: implicits, coercions, etc. *) +if not !Options.v7 then +GEXTEND Gram + GLOBAL: gallina_ext; + + gallina_ext: + [ [ (* Transparent and Opaque *) + IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l) + | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l) + + (* Canonical structure *) + | IDENT "Canonical"; IDENT "Structure"; qid = global -> + VernacCanonical qid + | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> + let s = Ast.coerce_global_to_id qid in + VernacDefinition + ((Global,CanonicalStructure),(dummy_loc,s),d,Recordobj.add_object_hook) + + (* Coercions *) + | IDENT "Coercion"; qid = global; d = def_body -> + let s = Ast.coerce_global_to_id qid in + VernacDefinition ((Global,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> + let s = Ast.coerce_global_to_id qid in + VernacDefinition ((Local,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; + ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> + VernacIdentityCoercion (Local, f, s, t) + | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; + s = class_rawexpr; ">->"; t = class_rawexpr -> + VernacIdentityCoercion (Global, f, s, t) + | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; + s = class_rawexpr; ">->"; t = class_rawexpr -> + VernacCoercion (Local, qid, s, t) + | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; + t = class_rawexpr -> + VernacCoercion (Global, qid, s, t) + + (* Implicit *) + | IDENT "Implicit"; IDENT "Arguments"; qid = global; + pos = OPT [ "["; l = LIST0 ident; "]" -> l ] -> + let pos = option_app (List.map (fun id -> ExplByName id)) pos in + VernacDeclareImplicits (qid,pos) + + | IDENT "Implicit"; ["Type" | IDENT "Types"]; + idl = LIST1 identref; ":"; c = lconstr -> VernacReserve (idl,c) ] ] + ; +END + +if not !Options.v7 then +GEXTEND Gram + GLOBAL: command check_command class_rawexpr; + + command: + [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l + + (* System directory *) + | IDENT "Pwd" -> VernacChdir None + | IDENT "Cd" -> VernacChdir None + | IDENT "Cd"; dir = ne_string -> VernacChdir (Some dir) + + (* Toplevel control *) + | IDENT "Drop" -> VernacToplevelControl Drop + | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop + | IDENT "Quit" -> VernacToplevelControl Quit + + | IDENT "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ]; + s = [ s = ne_string -> s | s = IDENT -> s ] -> + VernacLoad (verbosely, s) + | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string -> + VernacDeclareMLModule l + + (* Dump of the universe graph - to file or to stdout *) + | IDENT "Dump"; IDENT "Universes"; fopt = OPT ne_string -> + VernacPrint (PrintUniverses fopt) + + | IDENT "Locate"; l = locatable -> VernacLocate l + + (* Managing load paths *) + | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> + VernacAddLoadPath (false, dir, alias) + | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; + alias = as_dirpath -> VernacAddLoadPath (true, dir, alias) + | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string -> + VernacRemoveLoadPath dir + + (* For compatibility *) + | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath -> + VernacAddLoadPath (false, dir, alias) + | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath -> + VernacAddLoadPath (true, dir, alias) + | IDENT "DelPath"; dir = ne_string -> + VernacRemoveLoadPath dir + + (* Type-Checking (pas dans le refman) *) + | "Type"; c = lconstr -> VernacGlobalCheck c + + (* Printing (careful factorization of entries) *) + | IDENT "Print"; p = printable -> VernacPrint p + | IDENT "Print"; qid = global -> VernacPrint (PrintName qid) + | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> + VernacPrint (PrintModuleType qid) + | IDENT "Print"; IDENT "Module"; qid = global -> + VernacPrint (PrintModule qid) + | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) + | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid) + + (* Searching the environment *) + | IDENT "Search"; qid = global; l = in_or_out_modules -> + VernacSearch (SearchHead qid, 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"; + sl = [ "["; l = LIST1 [ r = global -> SearchRef r + | s = ne_string -> SearchString s ]; "]" -> l + | qid = global -> [SearchRef qid] ]; + 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 *) + | "Set"; table = IDENT; field = IDENT; v = option_value -> + VernacSetOption (SecondaryTable (table,field),v) + | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> + VernacAddOption (SecondaryTable (table,field),lv) + | "Set"; table = IDENT; field = IDENT -> + VernacSetOption (SecondaryTable (table,field),BoolValue true) + | IDENT "Unset"; table = IDENT; field = IDENT -> + VernacUnsetOption (SecondaryTable (table,field)) + | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value -> + VernacRemoveOption (SecondaryTable (table,field),lv) + | "Set"; table = IDENT; value = option_value -> + VernacSetOption (PrimaryTable table, value) + | "Set"; table = IDENT -> + VernacSetOption (PrimaryTable table, BoolValue true) + | IDENT "Unset"; table = IDENT -> + VernacUnsetOption (PrimaryTable table) + + | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT -> + VernacPrintOption (SecondaryTable (table,field)) + | IDENT "Print"; IDENT "Table"; table = IDENT -> + VernacPrintOption (PrimaryTable table) + + | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value + -> VernacAddOption (SecondaryTable (table,field), v) + + (* Un value global ci-dessous va être caché par un field au dessus! *) + | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> + VernacAddOption (PrimaryTable table, v) + + | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value + -> VernacMemOption (SecondaryTable (table,field), v) + | IDENT "Test"; table = IDENT; field = IDENT -> + VernacPrintOption (SecondaryTable (table,field)) + | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value -> + VernacMemOption (PrimaryTable table, v) + | IDENT "Test"; table = IDENT -> + VernacPrintOption (PrimaryTable table) + + | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value + -> VernacRemoveOption (SecondaryTable (table,field), v) + | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> + VernacRemoveOption (PrimaryTable table, v) ] ] + ; + check_command: (* TODO: rapprocher Eval et Check *) + [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr -> + fun g -> VernacCheckMayEval (Some r, g, c) + | IDENT "Check"; c = lconstr -> + fun g -> VernacCheckMayEval (None, g, c) ] ] + ; + printable: + [ [ IDENT "Term"; qid = global -> PrintName qid + | IDENT "All" -> PrintFullContext + | IDENT "Section"; s = global -> PrintSectionContext s + | IDENT "Grammar"; ent = IDENT -> + (* This should be in "syntax" section but is here for factorization*) + PrintGrammar ("", ent) + | IDENT "LoadPath" -> PrintLoadPath + | IDENT "Modules" -> PrintModules + + | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath + | IDENT "ML"; IDENT "Modules" -> PrintMLModules + | IDENT "Graph" -> PrintGraph + | IDENT "Classes" -> PrintClasses + | IDENT "Coercions" -> PrintCoercions + | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr + -> PrintCoercionPaths (s,t) + | IDENT "Tables" -> PrintTables +(* Obsolete: was used for cooking V6.3 recipes ?? + | IDENT "Proof"; qid = global -> PrintOpaqueName qid +*) + | IDENT "Hint" -> PrintHintGoal + | IDENT "Hint"; qid = global -> PrintHint qid + | IDENT "Hint"; "*" -> PrintHintDb + | IDENT "HintDb"; s = IDENT -> PrintHintDbName s + | IDENT "Scopes" -> PrintScopes + | IDENT "Scope"; s = IDENT -> PrintScope s + | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s + | IDENT "Implicit"; qid = global -> PrintImplicit qid ] ] + ; + class_rawexpr: + [ [ IDENT "Funclass" -> FunClass + | IDENT "Sortclass" -> SortClass + | qid = global -> RefClass qid ] ] + ; + locatable: + [ [ qid = global -> LocateTerm qid + | IDENT "File"; f = ne_string -> LocateFile f + | IDENT "Library"; qid = global -> LocateLibrary qid + | s = ne_string -> LocateNotation s ] ] + ; + option_value: + [ [ n = integer -> IntValue n + | s = STRING -> StringValue s ] ] + ; + option_ref_value: + [ [ id = global -> QualidRefValue id + | s = STRING -> StringRefValue s ] ] + ; + as_dirpath: + [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ] + ; + in_or_out_modules: + [ [ IDENT "inside"; l = LIST1 global -> SearchInside l + | IDENT "outside"; l = LIST1 global -> SearchOutside l + | -> SearchOutside [] ] ] + ; + comment: + [ [ c = constr -> CommentConstr c + | s = STRING -> CommentString s + | n = natural -> CommentInt n ] ] + ; +END; + +if not !Options.v7 then +GEXTEND Gram + command: + [ [ +(* State management *) + IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s + | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s + | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s + | IDENT "Restore"; IDENT "State"; s = ne_string -> VernacRestoreState s + +(* Resetting *) + | IDENT "Reset"; id = identref -> VernacResetName id + | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial + | IDENT "Back" -> VernacBack 1 + | IDENT "Back"; n = natural -> VernacBack n + +(* Tactic Debugger *) + | IDENT "Debug"; IDENT "On" -> VernacDebug true + | IDENT "Debug"; IDENT "Off" -> VernacDebug false + + ] ]; + END +;; + +(* Grammar extensions *) + +if not !Options.v7 then +GEXTEND Gram + GLOBAL: syntax; + + syntax: + [ [ IDENT "Open"; local = locality; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (local,true,sc) + + | IDENT "Close"; local = locality; IDENT "Scope"; sc = IDENT -> + 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) + + | IDENT "Arguments"; IDENT "Scope"; qid = global; + "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl) + + | IDENT "Infix"; local = locality; + op = ne_string; ":="; p = global; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + sc = OPT [ ":"; sc = IDENT -> sc ] -> + VernacInfix (local,(op,modl),p,None,sc) + | IDENT "Notation"; local = locality; id = ident; ":="; c = constr; + b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] -> + VernacSyntacticDefinition (id,c,local,b) + | IDENT "Notation"; local = locality; s = ne_string; ":="; c = constr; + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + sc = OPT [ ":"; sc = IDENT -> sc ] -> + VernacNotation (local,c,Some(s,modl),None,sc) + + | IDENT "Tactic"; IDENT "Notation"; s = ne_string; + pil = LIST0 production_item; ":="; t = Tactic.tactic -> + VernacTacticGrammar ["",(s,pil),t] + + | IDENT "Reserved"; IDENT "Notation"; local = locality; s = ne_string; + l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] + -> VernacSyntaxExtension (local,Some(s,l),None) + + (* "Print" "Grammar" should be here but is in "command" entry in order + to factorize with other "Print"-based vernac entries *) + ] ] + ; + locality: + [ [ IDENT "Local" -> true | -> false ] ] + ; + level: + [ [ IDENT "level"; n = natural -> NumLevel n + | IDENT "next"; IDENT "level" -> NextLevel ] ] + ; + syntax_modifier: + [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) + | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; + lev = level -> SetItemLevel (x::l,lev) + | "at"; IDENT "level"; n = natural -> SetLevel n + | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA + | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA + | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA + | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) + | IDENT "only"; IDENT "parsing" -> SetOnlyParsing + | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s ] ] + ; + syntax_extension_type: + [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference + | IDENT "bigint" -> ETBigint + ] ] + ; + opt_scope: + [ [ "_" -> None | sc = IDENT -> Some sc ] ] + ; + production_item: + [[ s = ne_string -> VTerm s + | nt = IDENT; po = OPT [ "("; p = ident; ")" -> p ] -> + VNonTerm (loc,NtShort nt,po) ]] + ; +END + +(* Reinstall tactic and vernac extensions *) +let _ = + if not !Options.v7 then + Egrammar.reset_extend_grammars_v8() diff --git a/parsing/g_zsyntax.ml b/parsing/g_zsyntax.ml new file mode 100644 index 00000000..27eead96 --- /dev/null +++ b/parsing/g_zsyntax.ml @@ -0,0 +1,406 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mkAppC (xI, [pos_of q]) + | (q, false) -> mkAppC (xO, [pos_of q]) + | (_, true) -> xH + in + pos_of x + +let z_of_string pos_or_neg s dloc = + let ((xI,xO,xH),(aZERO,aPOS,aNEG)) = get_z_sign dloc in + let v = Bignat.of_string s in + if is_nonzero v then + if pos_or_neg then + mkAppC (aPOS, [pos_of_bignat xI xO xH v]) + else + mkAppC (aNEG, [pos_of_bignat xI xO xH v]) + else + aZERO + +(* Declare the primitive parser with Grammar and without the scope mechanism *) +let zsyntax_create name = + let e = + Pcoq.create_constr_entry (Pcoq.get_univ "znatural") name in + Pcoq.Gram.Unsafe.clear_entry e; + e + +let number = zsyntax_create "number" + +let negnumber = zsyntax_create "negnumber" + +let _ = + Gram.extend number None + [None, None, + [[Gramext.Stoken ("INT", "")], + Gramext.action (z_of_string true)]] + +let _ = + Gram.extend negnumber None + [None, None, + [[Gramext.Stoken ("INT", "")], + Gramext.action (z_of_string false)]] + +(**********************************************************************) +(* Old v7 ast printing *) + +open Coqlib + +exception Non_closed_number + +let get_z_sign_ast loc = + let ast_of_id id = + Termast.ast_of_ref + (reference_of_constr + (gen_constant_in_modules "Z-printer" zarith_base_modules id)) + in + ((ast_of_id "xI", + ast_of_id "xO", + ast_of_id "xH"), + (ast_of_id "ZERO", + ast_of_id "POS", + ast_of_id "NEG")) + +let _ = if !Options.v7 then +let rec bignat_of_pos c1 c2 c3 p = + match p with + | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c1) -> + mult_2 (bignat_of_pos c1 c2 c3 a) + | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c2) -> + add_1 (mult_2 (bignat_of_pos c1 c2 c3 a)) + | a when alpha_eq(a,c3) -> Bignat.one + | _ -> raise Non_closed_number +in +let bignat_option_of_pos xI xO xH p = + try + Some (bignat_of_pos xO xI xH p) + with Non_closed_number -> + None +in +let pr_pos a = hov 0 (str "POS" ++ brk (1,1) ++ a) in +let pr_neg a = hov 0 (str "NEG" ++ brk (1,1) ++ a) in + +let inside_printer posneg std_pr p = + let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in + match (bignat_option_of_pos xI xO xH p) with + | Some n -> + if posneg then + (str (Bignat.to_string n)) + else + (str "(-" ++ str (Bignat.to_string n) ++ str ")") + | None -> + let pr = if posneg then pr_pos else pr_neg in + str "(" ++ pr (std_pr (ope("ZEXPR",[p]))) ++ str ")" +in +let outside_zero_printer std_pr p = str "`0`" +in +let outside_printer posneg std_pr p = + let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in + match (bignat_option_of_pos xI xO xH p) with + | Some n -> + if posneg then + (str "`" ++ str (Bignat.to_string n) ++ str "`") + else + (str "`-" ++ str (Bignat.to_string n) ++ str "`") + | None -> + let pr = if posneg then pr_pos else pr_neg in + str "(" ++ pr (std_pr p) ++ str ")" +in +(* For printing with Syntax and without the scope mechanism *) +let _ = Esyntax.Ppprim.add ("positive_printer", (outside_printer true)) in +let _ = Esyntax.Ppprim.add ("negative_printer", (outside_printer false)) in +let _ = Esyntax.Ppprim.add ("positive_printer_inside", (inside_printer true))in +let _ = Esyntax.Ppprim.add ("negative_printer_inside", (inside_printer false)) +in () + +(**********************************************************************) +(* Parsing positive via scopes *) +(**********************************************************************) + +open Libnames +open Rawterm +let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) +let positive_module = ["Coq";"NArith";"BinPos"] + +(* TODO: temporary hack *) +let make_path dir id = Libnames.encode_kn dir id + +let positive_path = + make_path (make_dir positive_module) (id_of_string "positive") +let glob_positive = IndRef (positive_path,0) +let path_of_xI = ((positive_path,0),1) +let path_of_xO = ((positive_path,0),2) +let path_of_xH = ((positive_path,0),3) +let glob_xI = ConstructRef path_of_xI +let glob_xO = ConstructRef path_of_xO +let glob_xH = ConstructRef path_of_xH + +let pos_of_bignat dloc x = + let ref_xI = RRef (dloc, glob_xI) in + let ref_xH = RRef (dloc, glob_xH) in + let ref_xO = RRef (dloc, glob_xO) in + let rec pos_of x = + match div2_with_rest x with + | (q,false) -> RApp (dloc, ref_xO,[pos_of q]) + | (q,true) when is_nonzero q -> RApp (dloc,ref_xI,[pos_of q]) + | (q,true) -> ref_xH + in + pos_of x + +let interp_positive dloc = function + | POS n when is_nonzero n -> pos_of_bignat dloc n + | _ -> + user_err_loc (dloc, "interp_positive", + str "Only strictly positive numbers in type \"positive\"!") + +let rec pat_pos_of_bignat dloc x name = + match div2_with_rest x with + | (q,false) -> + PatCstr (dloc,path_of_xO,[pat_pos_of_bignat dloc q Anonymous],name) + | (q,true) when is_nonzero q -> + PatCstr (dloc,path_of_xI,[pat_pos_of_bignat dloc q Anonymous],name) + | (q,true) -> + PatCstr (dloc,path_of_xH,[],name) + +let pat_interp_positive dloc = function + | POS n -> pat_pos_of_bignat dloc n + | NEG n -> + user_err_loc (dloc, "interp_positive", + str "No negative number in type \"positive\"!") + +(**********************************************************************) +(* Printing positive via scopes *) +(**********************************************************************) + +let rec bignat_of_pos = function + | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a) + | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a)) + | RRef (_, a) when a = glob_xH -> Bignat.one + | _ -> raise Non_closed_number + +let uninterp_positive p = + try + Some (POS (bignat_of_pos p)) + with Non_closed_number -> + None + +(************************************************************************) +(* Declaring interpreters and uninterpreters for positive *) +(************************************************************************) + +let _ = Symbols.declare_numeral_interpreter "positive_scope" + (glob_positive,positive_module) + (interp_positive,Some pat_interp_positive) + ([RRef (dummy_loc, glob_xI); + RRef (dummy_loc, glob_xO); + RRef (dummy_loc, glob_xH)], + uninterp_positive, + None) + +(**********************************************************************) +(* Parsing N via scopes *) +(**********************************************************************) + +let binnat_module = ["Coq";"NArith";"BinNat"] +let n_path = make_path (make_dir binnat_module) + (id_of_string (if !Options.v7 then "entier" else "N")) +let glob_n = IndRef (n_path,0) +let path_of_N0 = ((n_path,0),1) +let path_of_Npos = ((n_path,0),2) +let glob_N0 = ConstructRef path_of_N0 +let glob_Npos = ConstructRef path_of_Npos + +let n_of_posint dloc pos_or_neg n = + if is_nonzero n then + RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n]) + else + RRef (dloc, glob_N0) + +let n_of_int dloc n = + match n with + | POS n -> n_of_posint dloc true n + | NEG n -> + user_err_loc (dloc, "", + str "No negative number in type N") + +let pat_n_of_binnat dloc n name = + if is_nonzero n then + PatCstr (dloc, path_of_Npos, [pat_pos_of_bignat dloc n Anonymous], name) + else + PatCstr (dloc, path_of_N0, [], name) + +let pat_n_of_int dloc n name = + match n with + | POS n -> pat_n_of_binnat dloc n name + | NEG n -> + user_err_loc (dloc, "", + str "No negative number in type N") + +(**********************************************************************) +(* Printing N via scopes *) +(**********************************************************************) + +let bignat_of_n = function + | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> POS (bignat_of_pos a) + | RRef (_, a) when a = glob_N0 -> POS (Bignat.zero) + | _ -> raise Non_closed_number + +let uninterp_n p = + try Some (bignat_of_n p) + with Non_closed_number -> None + +(************************************************************************) +(* Declaring interpreters and uninterpreters for N *) + +let _ = Symbols.declare_numeral_interpreter "N_scope" + (glob_n,binnat_module) + (n_of_int,Some pat_n_of_int) + ([RRef (dummy_loc, glob_N0); + RRef (dummy_loc, glob_Npos)], + uninterp_n, + None) + +(**********************************************************************) +(* Parsing Z via scopes *) +(**********************************************************************) + +let fast_integer_module = ["Coq";"ZArith";"BinInt"] +let z_path = make_path (make_dir fast_integer_module) (id_of_string "Z") +let glob_z = IndRef (z_path,0) +let path_of_ZERO = ((z_path,0),1) +let path_of_POS = ((z_path,0),2) +let path_of_NEG = ((z_path,0),3) +let glob_ZERO = ConstructRef path_of_ZERO +let glob_POS = ConstructRef path_of_POS +let glob_NEG = ConstructRef path_of_NEG + +let z_of_posint dloc pos_or_neg n = + if is_nonzero n then + let sgn = if pos_or_neg then glob_POS else glob_NEG in + RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n]) + else + RRef (dloc, glob_ZERO) + +let z_of_int dloc z = + match z with + | POS n -> z_of_posint dloc true n + | NEG n -> z_of_posint dloc false n + +let pat_z_of_posint dloc pos_or_neg n name = + if is_nonzero n then + let sgn = if pos_or_neg then path_of_POS else path_of_NEG in + PatCstr (dloc, sgn, [pat_pos_of_bignat dloc n Anonymous], name) + else + PatCstr (dloc, path_of_ZERO, [], name) + +let pat_z_of_int dloc n name = + match n with + | POS n -> pat_z_of_posint dloc true n name + | NEG n -> pat_z_of_posint dloc false n name + +(**********************************************************************) +(* Printing Z via scopes *) +(**********************************************************************) + +let bigint_of_z = function + | RApp (_, RRef (_,b),[a]) when b = glob_POS -> POS (bignat_of_pos a) + | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> NEG (bignat_of_pos a) + | RRef (_, a) when a = glob_ZERO -> POS (Bignat.zero) + | _ -> raise Non_closed_number + +let uninterp_z p = + try + Some (bigint_of_z p) + with Non_closed_number -> None + +(************************************************************************) +(* Declaring interpreters and uninterpreters for Z *) + +let _ = Symbols.declare_numeral_interpreter "Z_scope" + (glob_z,fast_integer_module) + (z_of_int,Some pat_z_of_int) + ([RRef (dummy_loc, glob_ZERO); + RRef (dummy_loc, glob_POS); + RRef (dummy_loc, glob_NEG)], + uninterp_z, + None) + +(************************************************************************) +(* Old V7 ast Printers *) + +open Esyntax + +let _ = if !Options.v7 then +let bignat_of_pos p = + let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in + let c1 = xO in + let c2 = xI in + let c3 = xH in + let rec transl = function + | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c1) -> mult_2(transl a) + | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c2) -> add_1(mult_2(transl a)) + | a when alpha_eq(a,c3) -> Bignat.one + | _ -> raise Non_closed_number + in transl p +in +let bignat_option_of_pos p = + try + Some (bignat_of_pos p) + with Non_closed_number -> + None +in +let z_printer posneg p = + match bignat_option_of_pos p with + | Some n -> + if posneg then + Some (str (Bignat.to_string n)) + else + Some (str "-" ++ str (Bignat.to_string n)) + | None -> None +in +let z_printer_ZERO _ = + Some (int 0) +in +(* Declare pretty-printers for integers *) +let _ = + declare_primitive_printer "z_printer_POS" "Z_scope" (z_printer true) in +let _ = + declare_primitive_printer "z_printer_NEG" "Z_scope" (z_printer false) in +let _ = + declare_primitive_printer "z_printer_ZERO" "Z_scope" z_printer_ZERO in +() diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli new file mode 100644 index 00000000..6a7aeb14 --- /dev/null +++ b/parsing/g_zsyntax.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None with + | Some tt' -> + CharMap.add c (insert tt' (i + 1)) (CharMap.remove c tt.branch) + | None -> + let tt' = {node = None; branch = CharMap.empty} in + CharMap.add c (insert tt' (i + 1)) tt.branch + in + { node = tt.node; branch = br } + in + insert ttree 0 + +(* Search a string in a dictionary: raises [Not_found] + if the word is not present. *) + +let ttree_find ttree str = + let rec proc_rec tt i = + if i == String.length str then + match tt.node with + | Some s -> s + | None -> raise Not_found + else + proc_rec (CharMap.find str.[i] tt.branch) (i+1) + in + proc_rec ttree 0 + +(* Lexer conventions on tokens *) + +type error = + | Illegal_character + | Unterminated_comment + | Unterminated_string + | Undefined_token + | Bad_token of string + +exception Error of error + +let bad_token str = raise (Error (Bad_token str)) + +let check_special_token str = + let rec loop_symb = parser + | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str + | [< _ = Stream.empty >] -> () + | [< '_ ; s >] -> loop_symb s + in + loop_symb (Stream.of_string str) + +let check_ident str = + let first_letter = function + (''' | '0'..'9') -> false + | _ -> true in + let rec loop_id = parser + | [< ' ('$' | 'a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_'); s >] -> + loop_id s + (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) + | [< ' ('\206' | '\207'); ' ('\128'..'\191'); s >] -> loop_id s + | [< ''\226'; 'c2; 'c3; s >] -> + (match c2, c3 with + (* utf8 letter-like unicode 2100-214F *) + | (('\132', '\128'..'\191') | ('\133', '\128'..'\143')) -> + loop_id s + (* utf8 symbols (see [parse_226_tail]) *) + | (('\134'..'\143' | '\152'..'\155' | '\159' + | '\164'..'\171'),_) -> + bad_token str + | _ -> (* default to iso 8859-1 "â" *) + if !Options.v7 then loop_id [< 'c2; 'c3; s >] + else bad_token str) + (* iso 8859-1 accentuated letters *) + | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255'); s >] -> + if !Options.v7 then loop_id s else bad_token str + | [< _ = Stream.empty >] -> () + | [< >] -> bad_token str + in + if String.length str > 0 && first_letter str.[0] then + loop_id (Stream.of_string str) + else + bad_token str + +let check_keyword str = + try check_special_token str + with Error _ -> check_ident str + +(* Keyword and symbol dictionary *) +let token_tree = ref empty_ttree + +let find_keyword s = ttree_find !token_tree s + +let is_keyword s = + try let _ = ttree_find !token_tree s in true with Not_found -> false + +let add_keyword str = + check_keyword str; + token_tree := ttree_add !token_tree str + +(* Adding a new token (keyword or special token). *) +let add_token (con, str) = match con with + | "" -> add_keyword str + | "METAIDENT" | "IDENT" | "FIELD" | "INT" | "STRING" | "EOI" + -> () + | _ -> + raise (Token.Error ("\ +the constructor \"" ^ con ^ "\" is not recognized by Lexer")) + + +(* Freeze and unfreeze the state of the lexer *) +type frozen_t = ttree + +let freeze () = !token_tree + +let unfreeze tt = + token_tree := tt + +let init () = + unfreeze empty_ttree + +let _ = init() + +(* Errors occuring while lexing (explained as "Lexer error: ...") *) +let err loc str = Stdpp.raise_with_loc (Util.make_loc loc) (Error str) + +(* The string buffering machinery *) + +let buff = ref (String.create 80) + +let store len x = + if len >= String.length !buff then + buff := !buff ^ String.create (String.length !buff); + !buff.[len] <- x; + succ len + +let mstore len s = + let rec add_rec len i = + if i == String.length s then len else add_rec (store len s.[i]) (succ i) + in + add_rec len 0 + +let get_buff len = String.sub !buff 0 len + + +(* The classical lexer: idents, numbers, quoted strings, comments *) + +let rec ident_tail len strm = + if !Options.v7 then + match strm with parser + | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' | '@' as c); s >] -> + ident_tail (store len c) s + (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) + | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] -> + ident_tail (store (store len c1) c2) s + (* iso 8859-1 accentuated letters *) + | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c); s >] -> + ident_tail (store len c) s + | [< >] -> len + else + match strm with parser + | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] -> + ident_tail (store len c) s + (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) + | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] -> + ident_tail (store (store len c1) c2) s + | [< >] -> len + + +let rec number len = parser + | [< ' ('0'..'9' as c); s >] -> number (store len c) s + | [< >] -> len + +let escape len c = store len c + +let rec string_v8 bp len = parser + | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] -> + if esc then string_v8 bp (store len '"') s else len + | [< 'c; s >] -> string_v8 bp (store len c) s + | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string + +let rec string_v7 bp len = parser + | [< ''"' >] -> len + | [< ''\\'; c = (parser [< ' ('"' | '\\' as c) >] -> c | [< >] -> '\\'); s >] + -> string_v7 bp (escape len c) s + | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string + | [< 'c; s >] -> string_v7 bp (store len c) s + +let string bp len s = + if !Options.v7 then string_v7 bp len s else string_v8 bp len s + +(* 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 comment translation *) +let comment_begin = ref None +let comm_loc bp = if !comment_begin=None then comment_begin := Some bp + +let current = Buffer.create 8192 +let between_com = ref true + +type com_state = int option * string * bool +let restore_com_state (o,s,b) = + comment_begin := o; + Buffer.clear current; Buffer.add_string current s; + between_com := b +let dflt_com = (None,"",true) +let com_state () = + let s = (!comment_begin, Buffer.contents current, !between_com) in + restore_com_state dflt_com; s + +let real_push_char c = Buffer.add_char current c + +(* Add a char if it is between two commands, if it is a newline or + if the last char is not a space itself. *) +let push_char c = + if + !between_com || List.mem c ['\n';'\r'] || + (List.mem c [' ';'\t']&& + (Buffer.length current = 0 || + not (let s = Buffer.contents current in + List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r']))) + then + real_push_char c + +let push_string s = Buffer.add_string current s + +let null_comment s = + let rec null i = + i<0 || (List.mem s.[i] [' ';'\t';'\n';'\r'] && null (i-1)) in + null (String.length s - 1) + +let comment_stop ep = + let current_s = Buffer.contents current in + if !Options.xml_export && Buffer.length current > 0 && + (!between_com || not(null_comment current_s)) then + !xml_output_comment current_s; + (if Options.do_translate() && 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); + ep-1 in + Pp.comments := ((bp,ep),current_s) :: !Pp.comments); + Buffer.clear current; + comment_begin := None; + between_com := false + +(* Does not unescape!!! *) +let rec comm_string bp = parser + | [< ''"' >] -> push_string "\"" + | [< ''\\'; _ = + (parser [< ' ('"' | '\\' as c) >] -> + if c='"' then real_push_char c; + real_push_char c + | [< >] -> real_push_char '\\'); s >] + -> comm_string bp s + | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string + | [< 'c; s >] -> real_push_char c; comm_string bp s + +let rec comment bp = parser bp2 + | [< ''('; + _ = (parser + | [< ''*'; s >] -> push_string "(*"; comment bp s + | [< >] -> push_string "(" ); + s >] -> comment bp s + | [< ''*'; + _ = parser + | [< '')' >] ep -> push_string "*)"; + | [< s >] -> real_push_char '*'; comment bp s >] -> () + | [< ''"'; s >] -> + if Options.do_translate() then (push_string"\"";comm_string bp2 s) + else ignore (string bp2 0 s); + comment bp s + | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment + | [< '_ as z; s >] ep -> real_push_char z; comment bp s + +(* Parse a special token, using the [token_tree] *) + +let progress_special c = function + | None -> None + | Some tt -> try Some (CharMap.find c tt.branch) with Not_found -> None + +let rec special tt cs = match tt with + | None -> None + | Some tt -> + match + match Stream.peek cs with + | Some c -> + (try Some (CharMap.find c tt.branch) with Not_found -> None) + | None -> None + with + | Some _ as tt' -> Stream.junk cs; special tt' cs + | None -> tt.node + +let process_chars bp c cs = + let t = + try special (Some (CharMap.find c !token_tree.branch)) cs + with Not_found -> !token_tree.node + in + let ep = Stream.count cs in + match t with + | Some t -> (("", t), (bp, ep)) + | None -> err (bp, ep) Undefined_token + +type token_226_tail = + | TokSymbol of string option + | TokIdent of string + +let parse_226_tail tk = parser + | [< ''\132' as c2; ' ('\128'..'\191' as c3); + (* utf8 letter-like unicode 2100-214F *) + len = ident_tail (store (store (store 0 '\226') c2) c3) >] -> + TokIdent (get_buff len) + | [< ''\133' as c2; ' ('\128'..'\143' as c3); + (* utf8 letter-like unicode 2100-214F *) + len = ident_tail (store (store (store 0 '\226') c2) c3) >] -> + TokIdent (get_buff len) + | [< ' ('\134'..'\143' | '\152'..'\155' | '\159' + | '\164'..'\171' as c2); 'c3; + (* utf8 arrows A unicode 2190-21FF *) + (* utf8 mathematical operators unicode 2200-22FF *) + (* utf8 miscellaneous technical unicode 2300-23FF *) + (* utf8 miscellaneous symbols unicode 2600-26FF *) + (* utf8 Miscellaneous Mathematical Symbols-A unicode 27C0-27DF *) + (* utf8 Supplemental Arrows-A unicode 27E0-27FF *) + (* utf8 Supplemental Arrows-B unicode 2900-297F *) + (* utf8 Miscellaneous Mathematical Symbols-B unicode 2980-29FF *) + (* utf8 mathematical operators unicode 2A00-2AFF *) + t = special (progress_special c3 (progress_special c2 + (progress_special '\226' tk))) >] -> + TokSymbol t + | [< len = ident_tail (store 0 '\226') >] -> + TokIdent (get_buff len) + + +(* Parse what follows a dot *) +let parse_after_dot bp c strm = + if !Options.v7 then + match strm with parser + | [< ' ('_' | 'a'..'z' | 'A'..'Z' as c); + len = ident_tail (store 0 c) >] -> + ("FIELD", get_buff len) + (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) + | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); + len = ident_tail (store (store 0 c1) c2) >] -> + ("FIELD", get_buff len) + (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) + | [< ''\226' as c1; t = parse_226_tail + (progress_special '.' (Some !token_tree)) >] ep -> + (match t with + | TokSymbol (Some t) -> ("", t) + | TokSymbol None -> err (bp, ep) Undefined_token + | TokIdent t -> ("FIELD", t)) + (* iso 8859-1 accentuated letters *) + | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c); + len = ident_tail (store 0 c) >] -> + ("FIELD", get_buff len) + | [< (t,_) = process_chars bp c >] -> t + else + match strm with parser + | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); + len = ident_tail (store 0 c) >] -> + ("FIELD", get_buff len) + (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) + | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); + len = ident_tail (store (store 0 c1) c2) >] -> + ("FIELD", get_buff len) + (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) + | [< ''\226' as c1; t = parse_226_tail + (progress_special '.' (Some !token_tree)) >] ep -> + (match t with + | TokSymbol (Some t) -> ("", t) + | TokSymbol None -> err (bp, ep) Undefined_token + | TokIdent t -> ("FIELD", t)) + | [< (t,_) = process_chars bp c >] -> t + + +(* Parse a token in a char stream *) + +let rec next_token = parser bp + | [< '' ' | '\t' | '\n' |'\r' as c; s >] ep -> + comm_loc bp; push_char c; next_token s + | [< ''$'; len = ident_tail (store 0 '$') >] ep -> + comment_stop bp; + (("METAIDENT", get_buff len), (bp,ep)) + | [< ''.' as c; t = parse_after_dot bp c >] ep -> + comment_stop bp; + if !Options.v7 & t=("",".") then between_com := true; + (t, (bp,ep)) + | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); + len = ident_tail (store 0 c) >] ep -> + let id = get_buff len in + comment_stop bp; + (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep) + (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) + | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); + len = ident_tail (store (store 0 c1) c2) >] ep -> + let id = get_buff len in + comment_stop bp; + (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep) + (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) + | [< ''\226' as c1; t = parse_226_tail (Some !token_tree) >] ep -> + comment_stop bp; + (match t with + | TokSymbol (Some t) -> ("", t), (bp, ep) + | TokSymbol None -> err (bp, ep) Undefined_token + | TokIdent id -> + (try ("", find_keyword id) with Not_found -> ("IDENT", id)), + (bp, ep)) + (* iso 8859-1 accentuated letters *) + | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c) ; s >] -> + if !Options.v7 then + begin + match s with parser + [< len = ident_tail (store 0 c) >] ep -> + let id = get_buff len in + comment_stop bp; + (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep) + end + else + begin + match s with parser + [< t = process_chars bp c >] -> comment_stop bp; t + end + | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep -> + comment_stop bp; + (("INT", get_buff len), (bp, ep)) + | [< ''\"'; len = string bp 0 >] ep -> + comment_stop bp; + (("STRING", get_buff len), (bp, ep)) + | [< ' ('(' as c); + t = parser + | [< ''*'; s >] -> + comm_loc bp; + push_string "(*"; + comment bp s; + next_token s + | [< t = process_chars bp c >] -> comment_stop bp; t >] -> + t + | [< 'c; t = process_chars bp c >] -> comment_stop bp; t + | [< _ = Stream.empty >] -> comment_stop bp; (("EOI", ""), (bp, bp + 1)) + +(* Location table system for creating tables associating a token count + to its location in a char stream (the source) *) + +let locerr () = invalid_arg "Lexer: location function" + +let tsz = 256 (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *) + +let loct_create () = ref [| [| |] |] + +let loct_func loct i = + match + if i < 0 || i/tsz >= Array.length !loct then None + else if !loct.(i/tsz) = [| |] then None + else !loct.(i/tsz).(i mod tsz) + with + | Some loc -> Util.make_loc loc + | _ -> locerr () + +let loct_add loct i loc = + while i/tsz >= Array.length !loct do + let new_tmax = Array.length !loct * 2 in + let new_loct = Array.make new_tmax [| |] in + Array.blit !loct 0 new_loct 0 (Array.length !loct); + loct := new_loct; + done; + if !loct.(i/tsz) = [| |] then !loct.(i/tsz) <- Array.make tsz None; + !loct.(i/tsz).(i mod tsz) <- Some loc + +let current_location_table = ref (ref [| [| |] |]) + +let location_function n = + loct_func !current_location_table n + +let func cs = + let loct = loct_create () in + let ts = + Stream.from + (fun i -> + let (tok, loc) = next_token cs in + loct_add loct i loc; Some tok) + in + current_location_table := loct; + (ts, loct_func loct) + +type location_table = (int * int) option array array ref +let location_table () = !current_location_table +let restore_location_table t = current_location_table := t + +(* Names of tokens, for this lexer, used in Grammar error messages *) + +let token_text = function + | ("", t) -> "'" ^ t ^ "'" + | ("IDENT", "") -> "identifier" + | ("IDENT", t) -> "'" ^ t ^ "'" + | ("INT", "") -> "integer" + | ("INT", s) -> "'" ^ s ^ "'" + | ("STRING", "") -> "string" + | ("EOI", "") -> "end of input" + | (con, "") -> con + | (con, prm) -> con ^ " \"" ^ prm ^ "\"" + +let tparse (p_con, p_prm) = + None + (*i was + if p_prm = "" then + (parser [< '(con, prm) when con = p_con >] -> prm) + else + (parser [< '(con, prm) when con = p_con && prm = p_prm >] -> prm) + i*) diff --git a/parsing/lexer.mli b/parsing/lexer.mli new file mode 100644 index 00000000..133bca65 --- /dev/null +++ b/parsing/lexer.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit +val is_keyword : string -> bool + +val func : char Stream.t -> (string * string) Stream.t * (int -> loc) +val location_function : int -> loc + +(* for coqdoc *) +type location_table +val location_table : unit -> location_table +val restore_location_table : location_table -> unit + +val check_ident : string -> unit +val check_keyword : string -> unit + +val tparse : string * string -> ((string * string) Stream.t -> string) option + +val token_text : string * string -> string + +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 diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 new file mode 100644 index 00000000..cda482af --- /dev/null +++ b/parsing/pcoq.ml4 @@ -0,0 +1,803 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ()); + Token.tparse = Lexer.tparse; + Token.text = Lexer.token_text } + +module L = + struct + let lexer = lexer + end + +(* The parser of Coq *) + +module G = Grammar.Make(L) + +let grammar_delete e rls = + List.iter + (fun (_,_,lev) -> + List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) + (List.rev rls) + +(* grammar_object is the superclass of all grammar entry *) +module type Gramobj = +sig + type grammar_object + val weaken_entry : 'a G.Entry.e -> grammar_object G.Entry.e +end + +module Gramobj : Gramobj = +struct + type grammar_object = Obj.t + let weaken_entry e = Obj.magic e +end + +type grammar_object = Gramobj.grammar_object +type typed_entry = entry_type * grammar_object G.Entry.e +let in_typed_entry t e = (t,Gramobj.weaken_entry e) +let type_of_typed_entry (t,e) = t +let object_of_typed_entry (t,e) = e +let weaken_entry x = Gramobj.weaken_entry x + +module type Gramtypes = +sig + open Decl_kinds + val inGramObj : 'a raw_abstract_argument_type -> 'a G.Entry.e -> typed_entry + val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.Entry.e +end + +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"; + (* downcast from grammar_object *) + Obj.magic (object_of_typed_entry o) +end + +open Gramtypes + +type ext_kind = + | ByGrammar of + grammar_object G.Entry.e * Gramext.position option * + (string option * Gramext.g_assoc option * + (Token.t Gramext.g_symbol list * Gramext.g_action) list) list + | ByGEXTEND of (unit -> unit) * (unit -> unit) + +let camlp4_state = ref [] + +(* The apparent parser of Coq; encapsulate G to keep track of the + extensions. *) +module Gram = + struct + include G + let extend e pos rls = + camlp4_state := + (ByGEXTEND ((fun () -> grammar_delete e rls), + (fun () -> G.extend e pos rls))) + :: !camlp4_state; + G.extend e pos rls + let delete_rule e pil = + errorlabstrm "Pcoq.delete_rule" (str "GDELETE_RULE forbidden.") + end + + +let camlp4_verbosity silent f x = + let a = !Gramext.warning_verbose in + Gramext.warning_verbose := silent; + f x; + Gramext.warning_verbose := a + +(* This extension command is used by the Grammar constr *) + +let grammar_extend te pos rls = + camlp4_state := ByGrammar (Gramobj.weaken_entry te,pos,rls) :: !camlp4_state; + camlp4_verbosity (Options.is_verbose ()) (G.extend te pos) rls + +(* n is the number of extended entries (not the number of Grammar commands!) + to remove. *) +let rec remove_grammars n = + if n>0 then + (match !camlp4_state with + | [] -> anomaly "Pcoq.remove_grammars: too many rules to remove" + | ByGrammar(g,_,rls)::t -> + grammar_delete g rls; + camlp4_state := t; + remove_grammars (n-1) + | ByGEXTEND (undo,redo)::t -> + undo(); + camlp4_state := t; + remove_grammars n; + redo(); + camlp4_state := ByGEXTEND (undo,redo) :: !camlp4_state) + +(* An entry that checks we reached the end of the input. *) +let eoi_entry en = + let e = Gram.Entry.create ((Gram.Entry.name en) ^ "_eoi") in + GEXTEND Gram + e: [ [ x = en; EOI -> x ] ] + ; + END; + e + +let map_entry f en = + let e = Gram.Entry.create ((Gram.Entry.name en) ^ "_map") in + GEXTEND Gram + e: [ [ x = en -> f x ] ] + ; + END; + e + +(* Parse a string, does NOT check if the entire string was read + (use eoi_entry) *) + +let parse_string f x = + let strm = Stream.of_string x in Gram.Entry.parse f (Gram.parsable strm) + +type gram_universe = (string, typed_entry) Hashtbl.t + +let trace = ref false + +(* The univ_tab is not part of the state. It contains all the grammar that + exist or have existed before in the session. *) + +let univ_tab = (Hashtbl.create 7 : (string, string * gram_universe) Hashtbl.t) + +let create_univ s = + let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u + +let uprim = create_univ "prim" +let uconstr = create_univ "constr" +let umodule = create_univ "module" +let utactic = create_univ "tactic" +let uvernac = create_univ "vernac" + +let create_univ_if_new s = + (* compatibilite *) + let s = if s = "command" then (warning "'command' grammar universe is obsolete; use name 'constr' instead"; "constr") else s in + try + Hashtbl.find univ_tab s + with Not_found -> + if !trace then begin + Printf.eprintf "[Creating univ %s]\n" s; flush stderr; () + end; + let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u + +let get_univ = create_univ_if_new + +let get_entry (u, utab) s = + try + Hashtbl.find utab s + with Not_found -> + errorlabstrm "Pcoq.get_entry" + (str "unknown grammar entry " ++ str u ++ str ":" ++ str s) + +let new_entry etyp (u, utab) s = + let ename = u ^ ":" ^ s in + let e = in_typed_entry etyp (Gram.Entry.create ename) in + Hashtbl.add utab s e; e + +let entry_type (u, utab) s = + try + let e = Hashtbl.find utab s in + Some (type_of_typed_entry e) + with Not_found -> None + +let get_entry_type (u,n) = type_of_typed_entry (get_entry (get_univ u) n) + +let create_entry_if_new (u, utab) s etyp = + try + if type_of_typed_entry (Hashtbl.find utab s) <> etyp then + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type") + with Not_found -> + if !trace then begin + Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; () + end; + let _ = new_entry etyp (u, utab) s in () + +let create_entry (u, utab) s etyp = + try + let e = Hashtbl.find utab s in + if type_of_typed_entry e <> etyp then + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); + e + with Not_found -> + if !trace then begin + Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; () + end; + new_entry etyp (u, utab) s + +let create_constr_entry u s = + outGramObj rawwit_constr (create_entry u s ConstrArgType) + +let create_generic_entry s wit = + let (u,utab) = utactic in + let etyp = unquote wit in + try + let e = Hashtbl.find utab s in + if type_of_typed_entry e <> etyp then + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); + outGramObj wit e + with Not_found -> + if !trace then begin + Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; () + end; + let e = Gram.Entry.create s in + Hashtbl.add utab s (inGramObj wit e); e + +let get_generic_entry s = + let (u,utab) = utactic in + try + object_of_typed_entry (Hashtbl.find utab s) + with Not_found -> + error ("unknown grammar entry "^u^":"^s) + +let get_generic_entry_type (u,utab) s = + try type_of_typed_entry (Hashtbl.find utab s) + with Not_found -> + error ("unknown grammar entry "^u^":"^s) + +let force_entry_type (u, utab) s etyp = + try + let entry = Hashtbl.find utab s in + let extyp = type_of_typed_entry entry in + if etyp = extyp then + entry + else begin + prerr_endline + ("Grammar entry " ^ u ^ ":" ^ s ^ + " redefined with another type;\n older entry hidden."); + Hashtbl.remove utab s; + new_entry etyp (u, utab) s + end + with Not_found -> + new_entry etyp (u, utab) s + +(* [make_gen_entry] builds entries extensible by giving its name (a string) *) +(* For entries extensible only via the ML name, Gram.Entry.create is enough *) + +let make_gen_entry (u,univ) rawwit s = + let e = Gram.Entry.create (u ^ ":" ^ s) in + Hashtbl.add univ s (inGramObj rawwit e); e + +(* Grammar entries *) + +module Prim = + struct + let gec_gen x = make_gen_entry uprim x + + (* Entries that can be refered via the string -> Gram.Entry.e 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 bigint = Gram.Entry.create "Prim.bigint" + let string = gec_gen rawwit_string "string" + let reference = make_gen_entry uprim rawwit_ref "reference" + + (* parsed like ident but interpreted as a term *) + let hyp = gec_gen rawwit_ident "hyp" + + (* synonym of hyp/ident (before semantics split) for v7 compatibility *) + let var = gec_gen rawwit_ident "var" + + let name = Gram.Entry.create "Prim.name" + let identref = Gram.Entry.create "Prim.identref" + + (* A synonym of ident - maybe ident will be located one day *) + let base_ident = Gram.Entry.create "Prim.base_ident" + + let qualid = Gram.Entry.create "Prim.qualid" + let dirpath = Gram.Entry.create "Prim.dirpath" + + let ne_string = Gram.Entry.create "Prim.ne_string" + + (* For old ast printer *) + let astpat = Gram.Entry.create "Prim.astpat" + let ast = Gram.Entry.create "Prim.ast" + let astlist = Gram.Entry.create "Prim.astlist" + let ast_eoi = eoi_entry ast + let astact = Gram.Entry.create "Prim.astact" + end + + +module Constr = + struct + let gec_constr = make_gen_entry uconstr rawwit_constr + let gec_constr_list = make_gen_entry uconstr (wit_list0 rawwit_constr) + + (* Entries that can be refered via the string -> Gram.Entry.e table *) + let constr = gec_constr "constr" + let operconstr = gec_constr "operconstr" + let constr_eoi = eoi_entry constr + let lconstr = gec_constr "lconstr" + let binder_constr = create_constr_entry uconstr "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 pattern = Gram.Entry.create "constr:pattern" + let annot = Gram.Entry.create "constr:annot" + let constr_pattern = gec_constr "constr_pattern" + let lconstr_pattern = gec_constr "lconstr_pattern" + let binder = Gram.Entry.create "constr:binder" + let binder_let = Gram.Entry.create "constr:binder_let" + end + +module Module = + struct + let module_expr = Gram.Entry.create "module_expr" + let module_type = Gram.Entry.create "module_type" + end + +module Tactic = + struct + (* Main entry for extensions *) + let simple_tactic = Gram.Entry.create "tactic:simple_tactic" + + (* Entries that can be refered via the string -> Gram.Entry.e table *) + (* Typically for tactic user extensions *) + let castedopenconstr = + make_gen_entry utactic rawwit_casted_open_constr "castedopenconstr" + let constr_with_bindings = + make_gen_entry utactic rawwit_constr_with_bindings "constr_with_bindings" + let bindings = + make_gen_entry utactic rawwit_bindings "bindings" + let constrarg = make_gen_entry utactic rawwit_constr_may_eval "constrarg" + 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" + let simple_intropattern = + make_gen_entry utactic rawwit_intro_pattern "simple_intropattern" + + (* Main entries for ltac *) + let tactic_arg = Gram.Entry.create "tactic:tactic_arg" + let tactic = make_gen_entry utactic rawwit_tactic "tactic" + + (* Main entry for quotations *) + let tactic_eoi = eoi_entry tactic + end + + +module Vernac_ = + struct + let gec_vernac s = Gram.Entry.create ("vernac:" ^ s) + + (* The different kinds of vernacular commands *) + let gallina = gec_vernac "gallina" + let gallina_ext = gec_vernac "gallina_ext" + let command = gec_vernac "command" + let syntax = gec_vernac "syntax_command" + let vernac = gec_vernac "Vernac_.vernac" + + let vernac_eoi = eoi_entry vernac + end + + +(* Prim is not re-initialized *) +let reset_all_grammars () = + let f = Gram.Unsafe.clear_entry in + List.iter f + [Constr.constr;Constr.operconstr;Constr.lconstr;Constr.annot; + Constr.constr_pattern;Constr.lconstr_pattern]; + f Constr.ident; f Constr.global; f Constr.sort; f Constr.pattern; + f Module.module_expr; f Module.module_type; + f Tactic.simple_tactic; + f Tactic.castedopenconstr; + f Tactic.constr_with_bindings; + f Tactic.bindings; + f Tactic.constrarg; + f Tactic.quantified_hypothesis; + f Tactic.int_or_var; + f Tactic.red_expr; + f Tactic.tactic_arg; + f Tactic.tactic; + f Vernac_.gallina; + f Vernac_.gallina_ext; + f Vernac_.command; + f Vernac_.syntax; + f Vernac_.vernac; + Lexer.init() + +let main_entry = Gram.Entry.create "vernac" + +GEXTEND Gram + main_entry: + [ [ a = Vernac_.vernac -> Some (loc,a) | EOI -> None ] ] + ; +END + +(* Quotations *) + +open Prim +open Constr +open Tactic +open Vernac_ + +(* current file and toplevel/vernac.ml *) +let globalizer = ref (fun x -> failwith "No globalizer") +let set_globalizer f = globalizer := f + +let define_ast_quotation default s (e:Coqast.t G.Entry.e) = + (if default then + GEXTEND Gram + ast: [ [ "<<"; c = e; ">>" -> c ] ]; + (* Uncomment this to keep compatibility with old grammar syntax + constr: [ [ "<<"; c = e; ">>" -> c ] ]; + vernac: [ [ "<<"; c = e; ">>" -> c ] ]; + tactic: [ [ "<<"; c = e; ">>" -> c ] ]; + *) + END); + (GEXTEND Gram + GLOBAL: ast constr command tactic; + ast: + [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; + (* Uncomment this to keep compatibility with old grammar syntax + constr: + [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; + command: + [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; + tactic: + [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; + *) + END) + +(* +let _ = define_ast_quotation false "ast" ast in () +*) + +let dynconstr = Gram.Entry.create "Constr.dynconstr" +let dyncasespattern = Gram.Entry.create "Constr.dyncasespattern" + +GEXTEND Gram + dynconstr: + [ [ a = Constr.constr -> ConstrNode a + (* For compatibility *) + | "<<"; a = Constr.lconstr; ">>" -> ConstrNode a ] ] + ; + dyncasespattern: [ [ a = Constr.pattern -> CasesPatternNode a ] ]; +END + +(**********************************************************************) +(* The following is to dynamically set the parser in Grammar actions *) +(* and Syntax pattern, according to the universe of the rule defined *) + +type parser_type = + | ConstrParser + | CasesPatternParser + +let default_action_parser_ref = ref dynconstr + +let get_default_action_parser () = !default_action_parser_ref + +let entry_type_of_parser = function + | ConstrParser -> Some ConstrArgType + | CasesPatternParser -> failwith "entry_type_of_parser: cases_pattern, TODO" + +let parser_type_from_name = function + | "constr" -> ConstrParser + | "cases_pattern" -> CasesPatternParser + | "tactic" -> assert false + | "vernac" -> error "No longer supported" + | s -> ConstrParser + +let set_default_action_parser = function + | ConstrParser -> default_action_parser_ref := dynconstr + | CasesPatternParser -> default_action_parser_ref := dyncasespattern + +let default_action_parser = + Gram.Entry.of_parser "default_action_parser" + (fun strm -> Gram.Entry.parse_token (get_default_action_parser ()) strm) + +(**********************************************************************) +(* This determines (depending on the associativity of the current + level and on the expected associativity) if a reference to constr_n is + a reference to the current level (to be translated into "SELF" on the + left border and into "constr LEVEL n" elsewhere), to the level below + (to be translated into "NEXT") or to an below wrt associativity (to be + translated in camlp4 into "constr" without level) or to another level + (to be translated into "constr LEVEL n") *) + +let assoc_level = function + | Some Gramext.LeftA when !Options.v7 -> "L" + | _ -> "" + +let constr_level = function + | n,assoc -> (string_of_int n)^(assoc_level assoc) + +let constr_level2 = function + | n,assoc -> (string_of_int n)^(assoc_level (Some assoc)) + +let default_levels_v7 = + [10,Gramext.RightA; + 9,Gramext.RightA; + 8,Gramext.RightA; + 1,Gramext.RightA; + 0,Gramext.RightA] + +let default_levels_v8 = + [200,Gramext.RightA; + 100,Gramext.RightA; + 99,Gramext.RightA; + 90,Gramext.RightA; + 10,Gramext.RightA; + 9,Gramext.RightA; + 1,Gramext.LeftA; + 0,Gramext.RightA] + +let default_pattern_levels_v8 = + [10,Gramext.LeftA; + 0,Gramext.RightA] + +let level_stack = + ref + [if !Options.v7 then (default_levels_v7, default_levels_v7) + else (default_levels_v8, default_pattern_levels_v8)] + +(* 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 *) +exception Found of Gramext.g_assoc + +open Ppextend + +let admissible_assoc = function + | Gramext.LeftA, Some (Gramext.RightA | Gramext.NonA) -> false + | Gramext.RightA, Some Gramext.LeftA -> false + | _ -> true + +let create_assoc = function + | None -> Gramext.RightA + | Some a -> a + +let error_level_assoc p current expected = + let pr_assoc = function + | Gramext.LeftA -> str "left" + | Gramext.RightA -> str "right" + | Gramext.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 find_position forpat other assoc lev = + let default = if !Options.v7 then Some (10,Gramext.RightA) else None in + let ccurrent,pcurrent as current = List.hd !level_stack in + match lev with + | None -> + level_stack := current :: !level_stack; + None, (if other then assoc else None), None + | Some n -> + if !Options.v7 & n = 8 & assoc = Some Gramext.LeftA then + error "Left associativity not allowed at level 8"; + let after = ref default in + let rec add_level q = function + | (p,_ as pa)::l when p > n -> pa :: add_level (Some pa) l + | (p,a as pa)::l as l' when p = n -> + if admissible_assoc (a,assoc) then raise (Found a); + (* No duplication of levels in v8 *) + if not !Options.v7 then error_level_assoc p a (out_some assoc); + (* Maybe this was (p,Left) and p occurs a second time *) + if a = Gramext.LeftA then + match l with + | (p,a)::_ as l' when p = n -> raise (Found a) + | _ -> after := Some pa; pa::(n,create_assoc assoc)::l + else + (* This was not (p,LeftA) hence assoc is RightA *) + (after := q; (n,create_assoc assoc)::l') + | l -> + after := q; (n,create_assoc assoc)::l + in + try + (* Create the entry *) + let updated = + if forpat then (ccurrent, add_level default pcurrent) + else (add_level default ccurrent, pcurrent) in + level_stack := updated:: !level_stack; + let assoc = create_assoc assoc in + (if !after = None then Some Gramext.First + else Some (Gramext.After (constr_level2 (out_some !after)))), + Some assoc, Some (constr_level2 (n,assoc)) + with + Found a -> + level_stack := current :: !level_stack; + (* Just inherit the existing associativity and name (None) *) + Some (Gramext.Level (constr_level2 (n,a))), None, None + +let remove_levels n = + level_stack := list_skipn n !level_stack + +(* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *) +let camlp4_assoc = function + | Some Gramext.NonA | Some Gramext.RightA -> Gramext.RightA + | None | Some Gramext.LeftA -> Gramext.LeftA + +(* [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 + the result is + + None = SELF + Some None = NEXT + Some (Some (n,cur)) = constr LEVEL n + s.t. if [cur] is set then [n] is the same as the [from] level *) +let adjust_level assoc from = function +(* Associativity is None means force the level *) + | (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 (false,Some (Gramext.NonA|Gramext.LeftA))) -> + Some None + (* If RightA on the right-hand side, set to the explicit (current) level *) + | (NumLevel n,BorderProd (false,Some Gramext.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 (true,Some Gramext.NonA)) -> None + (* If the expected assoc is the current one, set to SELF *) + | (NumLevel n,BorderProd (true,Some a)) when a = camlp4_assoc assoc -> + None + (* Otherwise, force the level, n or n-1, according to expected assoc *) + | (NumLevel n,BorderProd (true,Some a)) -> + if a = Gramext.LeftA then Some (Some (n,true)) else Some None + (* 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)) + | _ -> Some (Some (n,false)) + +(* + (* If NonA on the right-hand side, set to NEXT *) + | (n,BorderProd (false,Some Gramext.NonA)) -> Some None + (* If NonA on the left-hand side, adopt the current assoc ?? *) + | (n,BorderProd (true,Some Gramext.NonA)) -> None + (* Associativity is None means force the level *) + | (n,BorderProd (_,None)) -> Some (Some (n,true)) + (* If left assoc at a left level, set NEXT on the right *) + | (n,BorderProd (false,Some (Gramext.LeftA as a))) + when Gramext.LeftA = camlp4_assoc assoc -> Some None + (* If right or none assoc expected is the current assoc, set explicit + level on the right side *) + | (n,BorderProd (false,Some a)) when a = camlp4_assoc assoc -> + Some (Some (n,true)) + (* If the expected assoc is the current one, SELF on the left sides *) + | (n,BorderProd (true,Some a)) when a = camlp4_assoc assoc -> None + (* Otherwise, force the level, n or n-1, according to expected assoc *) + | (n,BorderProd (left,Some a)) -> + if (left & a = Gramext.LeftA) or ((not left) & a = Gramext.RightA) + then Some (Some (n,true)) else Some (Some (n-1,false)) +(* | (8,InternalProd) -> None (* Or (Some 8) for factorization ? *)*) + | (n,InternalProd) -> + match from with + | ETConstr (p,()) when p = n+1 -> Some None + | ETConstr (p,()) -> Some (Some (n,n=p)) + | _ -> Some (Some (n,false)) +*) + +let compute_entry allow_create adjust forpat = function + | ETConstr (n,q) -> + (if forpat then weaken_entry Constr.pattern + else weaken_entry Constr.operconstr), + (if forpat & !Options.v7 then None else adjust (n,q)), false + | ETIdent -> weaken_entry Constr.ident, None, false + | ETBigint -> weaken_entry Prim.bigint, None, false + | ETReference -> weaken_entry Constr.global, None, false + | ETPattern -> weaken_entry Constr.pattern, None, false + | ETOther ("constr","annot") -> + weaken_entry Constr.annot, None, false + | ETConstrList _ -> error "List of entries cannot be registered" + | ETOther (u,n) -> + let u = get_univ u in + let e = + try get_entry u n + with e when allow_create -> create_entry u n ConstrArgType in + object_of_typed_entry e, None, true + +(* This computes the name of the level where to add a new rule *) +let get_constr_entry forpat en = + match en with + ETConstr(200,()) when not !Options.v7 & not forpat -> + snd (get_entry (get_univ "constr") "binder_constr"), + None, + false + | _ -> compute_entry true (fun (n,()) -> Some n) forpat en + +(* This computes the name to give to a production knowing the name and + associativity of the level where it must be added *) +let get_constr_production_entry ass from forpat en = + (* first 2 cases to help factorisation *) + match en with + | ETConstr (NumLevel 10,q) when !Options.v7 & not forpat -> + weaken_entry Constr.lconstr, None, false +(* + | ETConstr (8,q) when !Options.v7 -> + weaken_entry Constr.constr, None, false +*) + | _ -> compute_entry false (adjust_level ass from) forpat en + +let constr_prod_level assoc cur lev = + if !Options.v7 then + if cur then constr_level (lev,assoc) else + match lev with + | 4 when !Options.v7 -> "4L" + | n -> string_of_int n + else + (* No duplication L/R of levels in v8 *) + constr_level (lev,assoc) + +let is_self from e = + match from, e with + ETConstr(n,()), ETConstr(NumLevel n', + BorderProd(false, _ (* Some(Gramext.NonA|Gramext.LeftA) *))) -> false + | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(true,_)) -> n=n' + | (ETIdent,ETIdent | ETReference, ETReference | ETBigint,ETBigint + | ETPattern, ETPattern) -> true + | ETOther(s1,s2), ETOther(s1',s2') -> s1=s1' & s2=s2' + | _ -> false + +let is_binder_level from e = + match from, e with + ETConstr(200,()), ETConstr(NumLevel 200,_) -> not !Options.v7 + | _ -> false + +let rec symbol_of_production assoc from forpat typ = + if is_binder_level from typ then + let eobj = snd (get_entry (get_univ "constr") "operconstr") in + Gramext.Snterml (Gram.Entry.obj eobj,"200") + else if is_self from typ then Gramext.Sself + else + match typ with + | ETConstrList (typ',[]) -> + Gramext.Slist1 (symbol_of_production assoc from forpat (ETConstr typ')) + | ETConstrList (typ',tkl) -> + Gramext.Slist1sep + (symbol_of_production assoc from forpat (ETConstr typ'), + Gramext.srules + [List.map (fun x -> Gramext.Stoken x) tkl, + List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl + (Gramext.action (fun loc -> ()))]) + | _ -> + match get_constr_production_entry assoc from forpat typ with + | (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj) + | (eobj,Some None,_) -> Gramext.Snext + | (eobj,Some (Some (lev,cur)),_) -> + Gramext.Snterml (Gram.Entry.obj eobj,constr_prod_level assoc cur lev) + + diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli new file mode 100644 index 00000000..5c6c8354 --- /dev/null +++ b/parsing/pcoq.mli @@ -0,0 +1,192 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Extend.entry_type +val object_of_typed_entry : typed_entry -> grammar_object Gram.Entry.e +val weaken_entry : 'a Gram.Entry.e -> grammar_object Gram.Entry.e + +val get_constr_entry : + bool -> constr_entry -> grammar_object Gram.Entry.e * int option * bool + +val symbol_of_production : Gramext.g_assoc option -> constr_entry -> + bool -> constr_production_entry -> Token.t Gramext.g_symbol + +val grammar_extend : + 'a Gram.Entry.e -> Gramext.position option -> + (string option * Gramext.g_assoc option * + (Token.t Gramext.g_symbol list * Gramext.g_action) list) list + -> unit + +val remove_grammars : int -> unit + +val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit + +(* Parse a string *) + +val parse_string : 'a Gram.Entry.e -> string -> 'a +val eoi_entry : 'a Gram.Entry.e -> 'a Gram.Entry.e +val map_entry : ('a -> 'b) -> 'a Gram.Entry.e -> 'b Gram.Entry.e + +(* Entry types *) + +(* Table of Coq's grammar entries *) + +type gram_universe + +val create_univ_if_new : string -> string * gram_universe +val get_univ : string -> string * gram_universe +val get_entry : string * gram_universe -> string -> typed_entry + +val entry_type : string * gram_universe -> string -> entry_type option + +val get_entry_type : string * string -> entry_type +val create_entry_if_new : + string * gram_universe -> string -> entry_type -> unit +val create_entry : + string * gram_universe -> string -> entry_type -> typed_entry +val force_entry_type : + string * gram_universe -> string -> entry_type -> typed_entry + +val create_constr_entry : + string * gram_universe -> string -> constr_expr Gram.Entry.e +val create_generic_entry : string -> ('a, constr_expr,raw_tactic_expr) abstract_argument_type -> 'a Gram.Entry.e +val get_generic_entry : string -> grammar_object Gram.Entry.e +val get_generic_entry_type : string * gram_universe -> string -> Genarg.argument_type + +type parser_type = + | ConstrParser + | CasesPatternParser + +val entry_type_of_parser : parser_type -> entry_type option +val parser_type_from_name : string -> parser_type + +(* Quotations in ast parser *) +val define_ast_quotation : bool -> string -> (Coqast.t Gram.Entry.e) -> unit +val set_globalizer : (constr_expr -> Coqast.t) -> unit + +(* The default parser for actions in grammar rules *) + +val default_action_parser : dynamic_grammar Gram.Entry.e +val set_default_action_parser : parser_type -> unit + +(* The main entry: reads an optional vernac command *) + +val main_entry : (loc * vernac_expr) option Gram.Entry.e + +(* Initial state of the grammar *) + +module Prim : + sig + open Util + open Names + open Libnames + val preident : string Gram.Entry.e + val ident : identifier Gram.Entry.e + val name : name located Gram.Entry.e + val identref : identifier located Gram.Entry.e + val base_ident : identifier Gram.Entry.e + val natural : int Gram.Entry.e + val bigint : Bignat.bigint Gram.Entry.e + val integer : int Gram.Entry.e + val string : string Gram.Entry.e + val qualid : qualid located Gram.Entry.e + val reference : reference Gram.Entry.e + val dirpath : dir_path Gram.Entry.e + val ne_string : string Gram.Entry.e + val hyp : identifier Gram.Entry.e + (* v7 only entries *) + val astpat: typed_ast Gram.Entry.e + val ast : Coqast.t Gram.Entry.e + val astlist : Coqast.t list Gram.Entry.e + val ast_eoi : Coqast.t Gram.Entry.e + val var : identifier Gram.Entry.e + end + +module Constr : + sig + val constr : constr_expr Gram.Entry.e + val constr_eoi : constr_expr Gram.Entry.e + val lconstr : constr_expr Gram.Entry.e + val binder_constr : constr_expr Gram.Entry.e + val operconstr : constr_expr Gram.Entry.e + val ident : identifier Gram.Entry.e + val global : reference Gram.Entry.e + val sort : rawsort Gram.Entry.e + val pattern : cases_pattern_expr Gram.Entry.e + val annot : constr_expr Gram.Entry.e + val constr_pattern : constr_expr Gram.Entry.e + val lconstr_pattern : constr_expr Gram.Entry.e + val binder : (name located list * constr_expr) Gram.Entry.e + val binder_let : local_binder Gram.Entry.e + end + +module Module : + sig + val module_expr : module_ast Gram.Entry.e + val module_type : module_type_ast Gram.Entry.e + end + +module Tactic : + sig + open Rawterm + val castedopenconstr : constr_expr Gram.Entry.e + val constr_with_bindings : constr_expr with_bindings Gram.Entry.e + val bindings : constr_expr bindings Gram.Entry.e + val constrarg : (constr_expr,reference) may_eval Gram.Entry.e + val quantified_hypothesis : quantified_hypothesis Gram.Entry.e + val int_or_var : int or_var Gram.Entry.e + val red_expr : raw_red_expr Gram.Entry.e + val simple_tactic : raw_atomic_tactic_expr Gram.Entry.e + val simple_intropattern : Genarg.intro_pattern_expr Gram.Entry.e + val tactic_arg : raw_tactic_arg Gram.Entry.e + val tactic : raw_tactic_expr Gram.Entry.e + val tactic_eoi : raw_tactic_expr Gram.Entry.e + end + +module Vernac_ : + sig + open Decl_kinds + val gallina : vernac_expr Gram.Entry.e + val gallina_ext : vernac_expr Gram.Entry.e + val command : vernac_expr Gram.Entry.e + val syntax : vernac_expr Gram.Entry.e + val vernac : vernac_expr Gram.Entry.e + val vernac_eoi : vernac_expr Gram.Entry.e + end + +val reset_all_grammars : unit -> unit + +(* Registering/resetting the level of an entry *) + +val find_position : + bool -> bool -> Gramext.g_assoc option -> int option -> + Gramext.position option * Gramext.g_assoc option * string option + +val remove_levels : int -> unit diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml new file mode 100644 index 00000000..6a5242e8 --- /dev/null +++ b/parsing/ppconstr.ml @@ -0,0 +1,388 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* child <= parent + | L -> child < parent + | Prec n -> child <= n + | Any -> true + +let env_assoc_value v env = + try List.nth env (v-1) + with Not_found -> anomaly "Inconsistent environment for pretty-print rule" + +let decode_constrlist_value = function + | CAppExpl (_,_,l) -> l + | CApp (_,_,l) -> List.map fst l + | _ -> anomaly "Ill-formed list argument of notation" + +let decode_patlist_value = function + | CPatCstr (_,_,l) -> l + | _ -> anomaly "Ill-formed list argument of notation" + +open Symbols + +let rec print_hunk n decode pr env = function + | UnpMetaVar (e,prec) -> pr (n,prec) (env_assoc_value e env) + | UnpListMetaVar (e,prec,sl) -> + prlist_with_sep (fun () -> prlist (print_hunk n decode pr env) sl) + (pr (n,prec)) (decode (env_assoc_value e env)) + | UnpTerminal s -> str s + | UnpBox (b,sub) -> ppcmd_of_box b (prlist (print_hunk n decode pr env) sub) + | UnpCut cut -> ppcmd_of_cut cut + +let pr_notation_gen decode pr s env = + let unpl, level = find_notation_printing_rule s in + prlist (print_hunk level decode pr env) unpl, level + +let pr_notation = pr_notation_gen decode_constrlist_value +let pr_patnotation = pr_notation_gen decode_patlist_value + +let pr_delimiters key strm = + let left = "'"^key^":" and right = "'" in + let lspace = + if is_letter (left.[String.length left -1]) then str " " else mt () in + let rspace = + let c = right.[0] in + if is_letter c or is_digit c or c = '\'' then str " " else mt () in + str left ++ lspace ++ strm ++ rspace ++ str right + +open Rawterm + +let pr_opt pr = function + | None -> mt () + | Some x -> spc () ++ pr x + +let pr_universe u = str "" + +let pr_sort = function + | RProp Term.Null -> str "Prop" + | RProp Term.Pos -> str "Set" + | RType u -> str "Type" ++ pr_opt pr_universe u + +let pr_explicitation = function + | None -> mt () + | Some (_,ExplByPos n) -> int n ++ str "!" + | Some (_,ExplByName n) -> anomaly "Argument made explicit by name" + +let pr_expl_args pr (a,expl) = + pr_explicitation expl ++ pr (lapp,L) a + +let pr_opt_type pr = function + | CHole _ -> mt () + | t -> str ":" ++ pr ltop t + +let pr_tight_coma () = str "," ++ cut () + +let pr_name = function + | Anonymous -> str "_" + | Name id -> pr_id id + +let pr_located pr (loc,x) = pr x + +let pr_let_binder pr x a = + hov 0 (hov 0 (pr_name x ++ brk(0,1) ++ str ":=") ++ brk(0,1) ++ pr ltop a) + +let pr_binder pr (nal,t) = + hov 0 ( + prlist_with_sep pr_tight_coma (pr_located pr_name) nal ++ + pr_opt_type pr t) + +let pr_binders pr bl = + hv 0 (prlist_with_sep pr_semicolon (pr_binder pr) bl) + +let pr_local_binder pr = function + LocalRawAssum(nal,t) -> pr_binder pr (nal,t) + | LocalRawDef((_,na),t) -> pr_let_binder pr na t + +let pr_local_binders pr bl = + hv 0 (prlist_with_sep pr_semicolon (pr_local_binder pr) bl) + +let pr_global vars ref = pr_global_env vars ref + +let rec pr_lambda_tail pr bll = function + | CLambdaN (_,bl,a) -> + pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_binders pr bl) a + | CLetIn (_,x,a,b) -> + pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_let_binder pr (snd x) a) b + | a -> + bll, pr ltop a + +let rec pr_prod_tail pr bll = function + | CProdN (_,bl,a) -> + pr_prod_tail pr (bll ++ pr_semicolon () ++ pr_binders pr bl) a + | a -> bll, pr ltop a + +let pr_recursive_decl pr id binders t c = + pr_id id ++ binders ++ + brk (1,2) ++ str ": " ++ pr ltop t ++ str " :=" ++ + brk (1,2) ++ pr ltop c + +let split_lambda = function + | CLambdaN (loc,[[na],t],c) -> (na,t,c) + | CLambdaN (loc,([na],t)::bl,c) -> (na,t,CLambdaN(loc,bl,c)) + | CLambdaN (loc,(na::nal,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,t)::bl,c)) + | _ -> anomaly "ill-formed fixpoint body" + +let split_product = function + | CArrow (loc,t,c) -> ((loc,Anonymous),t,c) + | CProdN (loc,[[na],t],c) -> (na,t,c) + | CProdN (loc,([na],t)::bl,c) -> (na,t,CProdN(loc,bl,c)) + | CProdN (loc,(na::nal,t)::bl,c) -> (na,t,CProdN(loc,(nal,t)::bl,c)) + | _ -> anomaly "ill-formed fixpoint body" + +let concat_binder na t = function + | [] -> [[na],t] + | (nal,u)::bl' as bl -> if t=u then (na::nal,t)::bl' else ([na],t)::bl + +let rec split_fix n typ def = + if n = 0 then ([],typ,def) + else + let (na,_,def) = split_lambda def in + let (_,t,typ) = split_product typ in + let (bl,typ,def) = split_fix (n-1) typ def in + (concat_binder na t bl,typ,def) + +let pr_fixdecl pr (id,n,bl,t,c) = + pr_recursive_decl pr id + (brk (1,2) ++ str "[" ++ pr_local_binders pr bl ++ str "]") t c + +let pr_cofixdecl pr (id,bl,t,c) = + let b = + if bl=[] then mt() else + brk(1,2) ++ str"[" ++ pr_local_binders pr bl ++ str "]" in + pr_recursive_decl pr id b t c + +let pr_recursive fix pr_decl id = function + | [] -> anomaly "(co)fixpoint with no definition" + | d1::dl -> + hov 0 ( + str fix ++ spc () ++ pr_id id ++ brk (1,2) ++ str "{" ++ + (v 0 ( + (hov 0 (pr_decl d1)) ++ + (prlist (fun fix -> fnl () ++ hov 0 (str "with" ++ pr_decl fix)) + dl))) ++ + str "}") + +let pr_fix pr = pr_recursive "Fix" (pr_fixdecl pr) +let pr_cofix pr = pr_recursive "CoFix" (pr_cofixdecl pr) + +let rec pr_arrow pr = function + | CArrow (_,a,b) -> pr (larrow,L) a ++ cut () ++ str "->" ++ pr_arrow pr b + | a -> pr (larrow,E) a + +let pr_annotation pr = function + | None -> mt () + | Some t -> str "<" ++ pr ltop t ++ str ">" ++ brk (0,2) + +let rec pr_cases_pattern _inh = function + | CPatAlias (_,p,x) -> + pr_cases_pattern _inh p ++ spc () ++ str "as" ++ spc () ++ pr_id x + | CPatCstr (_,c,[]) -> pr_reference c + | CPatCstr (_,c,pl) -> + hov 0 ( + str "(" ++ pr_reference c ++ spc () ++ + prlist_with_sep spc (pr_cases_pattern _inh) pl ++ str ")") + | CPatAtom (_,Some c) -> pr_reference c + | CPatAtom (_,None) -> str "_" + | CPatNotation (_,"( _ )",[p]) -> + str"("++ pr_cases_pattern _inh p ++ str")" + | CPatNotation (_,s,env) -> fst (pr_patnotation pr_cases_pattern s env) + | CPatNumeral (_,n) -> Bignat.pr_bigint n + | CPatDelimiters (_,key,p) -> pr_delimiters key (pr_cases_pattern _inh p) + +let pr_cases_pattern = pr_cases_pattern (0,E) (* level unused *) + +let pr_eqn pr (_,patl,rhs) = + hov 0 ( + prlist_with_sep spc pr_cases_pattern patl ++ spc () ++ + str "=>" ++ + brk (1,1) ++ pr ltop rhs) ++ spc () + +let pr_cases pr (po,_) tml eqns = + hov 0 ( + pr_annotation pr po ++ + hv 0 ( + hv 0 ( + str "Cases" ++ brk (1,2) ++ + prlist_with_sep spc (fun (tm,_) -> pr ltop tm) tml ++ spc() ++ str "of") ++ brk(1,2) ++ + prlist_with_sep (fun () -> str "| ") (pr_eqn pr) eqns ++ + str "end")) + +let pr_proj pr pr_app a f l = + hov 0 (pr (latom,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")") + +let pr_explapp pr f l = + hov 0 ( + str "!" ++ pr_reference f ++ + prlist (fun a -> brk (1,1) ++ pr (lapp,L) a) l) + +let pr_app pr a l = + hov 0 ( + pr (lapp,L) a ++ + prlist (fun a -> brk (1,1) ++ pr_expl_args pr a) l) + +let rec pr inherited a = + let (strm,prec) = match a with + | CRef r -> pr_reference r, latom + | CFix (_,id,fix) -> pr_fix pr (snd id) fix, latom + | CCoFix (_,id,cofix) -> pr_cofix pr (snd id) cofix, latom + | CArrow _ -> hv 0 (pr_arrow pr a), larrow + | CProdN (_,bl,a) -> + let bll, a = pr_prod_tail pr (mt()) a in + hv 1 ( + hv 1 (str "(" ++ pr_binders pr bl ++ bll ++ str ")") ++ + brk (0,1) ++ a), lprod + | CLambdaN (_,bl,a) -> + let bll, a = pr_lambda_tail pr (mt()) a in + hv 1 ( + hv 1 (str "[" ++ pr_binders pr bl ++ bll ++ str "]") ++ + brk (0,1) ++ a), llambda + | CLetIn (_,x,a,b) -> + let bll, b = pr_lambda_tail pr (mt()) b in + hv 1 ( + hv 1 (str "[" ++ pr_let_binder pr (snd x) a ++ bll ++ str "]") ++ + brk (0,1) ++ b), lletin + | CAppExpl (_,((* V7 don't know about projections *)_,f),l) -> + pr_explapp pr f l, lapp + | CApp (_,(_,a),l) -> + pr_app pr a l, lapp + | CCases (_,po,tml,eqns) -> + pr_cases pr po tml eqns, lcases + | COrderedCase (_,IfStyle,po,c,[b1;b2]) -> + (* On force les parenthèses autour d'un "if" sous-terme (même si le + parsing est lui plus tolérant) *) + hov 0 ( + pr_annotation pr po ++ + hv 0 ( + str "if " ++ pr ltop c ++ spc () ++ + hov 0 (str "then" ++ brk (1,1) ++ pr ltop b1) ++ spc () ++ + hov 0 (str "else" ++ brk (1,1) ++ pr ltop b2))), lif + | CLetTuple _ | CIf _ -> + error "Let tuple not supported in v7" + + | COrderedCase (_,(MatchStyle|RegularStyle as style),po,c,bl) -> + hov 0 ( + hov 0 ( + pr_annotation pr po ++ + hov 0 ( + str (if style=RegularStyle then "Case" else "Match") ++ + brk (1,1) ++ pr ltop c ++ spc () ++ + str (if style=RegularStyle then "of" else "with") ++ + brk (1,3) ++ + fnl () ++ hov 0 (prlist (fun b -> pr ltop b ++ fnl ()) bl) ++ + str "end"))), lcases + | COrderedCase (_,_,_,_,_) -> + anomaly "malformed if or destructuring let" + | CHole _ -> str "?", latom +(* + | CEvar (_,n) -> str "?" ++ int n, latom +*) + | CEvar (_,n) -> str (Evd.string_of_existential n), latom + | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom + | CSort (_,s) -> pr_sort s, latom + | CCast (_,a,b) -> + hv 0 (pr (lcast,L) a ++ cut () ++ str "::" ++ pr (lcast,E) b), lcast + | CNotation (_,"( _ )",[t]) -> + str"("++ pr (max_int,E) t ++ str")", latom + | CNotation (_,s,env) -> pr_notation pr s env + | CNumeral (_,p) -> Bignat.pr_bigint p, latom + | CDelimiters (_,sc,a) -> pr_delimiters sc (pr ltop a), latom + | CDynamic _ -> str "", latom + in + if prec_less prec inherited then strm + else str"(" ++ strm ++ str")" + +let pr_constr = pr ltop + +let pr_pattern = pr_constr + +let pr_qualid qid = str (string_of_qualid qid) + +open Rawterm + +let pr_arg pr x = spc () ++ pr x + +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_occurrences prc (nl,c) = prlist (fun n -> int n ++ spc ()) nl ++ prc c + +let pr_red_expr (pr_constr,pr_ref) = function + | Red false -> str "Red" + | Hnf -> str "Hnf" + | Simpl o -> str "Simpl" ++ pr_opt (pr_occurrences pr_constr) o + | Cbv f -> + if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then + str "Compute" + else + hov 1 (str "Cbv" ++ spc () ++ pr_red_flag pr_ref f) + | Lazy f -> + hov 1 (str "Lazy" ++ spc () ++ pr_red_flag pr_ref f) + | Unfold l -> + hov 1 (str "Unfold" ++ + prlist (fun (nl,qid) -> + prlist (pr_arg int) nl ++ spc () ++ pr_ref qid) l) + | Fold l -> hov 1 (str "Fold" ++ prlist (pr_arg pr_constr) l) + | Pattern l -> hov 1 (str "Pattern " ++ prlist (pr_occurrences pr_constr) l) + | Red true -> error "Shouldn't be accessible from user" + | ExtraRedExpr (s,c) -> + hov 1 (str s ++ pr_arg pr_constr c) + +let rec pr_may_eval pr pr2 = function + | ConstrEval (r,c) -> + hov 0 + (str "Eval" ++ brk (1,1) ++ pr_red_expr (pr,pr2) r ++ + spc () ++ str "in" ++ brk (1,1) ++ pr c) + | ConstrContext ((_,id),c) -> + hov 0 + (str "Inst " ++ brk (1,1) ++ pr_id id ++ spc () ++ + str "[" ++ pr c ++ str "]") + | ConstrTypeOf c -> hov 0 (str "Check " ++ brk (1,1) ++ pr c) + | ConstrTerm c -> pr c + +let pr_rawconstr c = pr_constr (Constrextern.extern_rawconstr Idset.empty c) diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli new file mode 100644 index 00000000..d238b371 --- /dev/null +++ b/parsing/ppconstr.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr_expr -> constr_expr -> + (name located list * constr_expr) list * constr_expr * constr_expr + +val pr_global : Idset.t -> global_reference -> std_ppcmds + +val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds +val pr_name : name -> std_ppcmds +val pr_qualid : qualid -> std_ppcmds +val pr_red_expr : + ('a -> std_ppcmds) * ('b -> std_ppcmds) -> + ('a,'b) red_expr_gen -> std_ppcmds +val pr_occurrences : ('a -> std_ppcmds) -> 'a occurrences -> std_ppcmds + +val pr_sort : rawsort -> std_ppcmds +val pr_pattern : Tacexpr.pattern_expr -> std_ppcmds +val pr_constr : constr_expr -> std_ppcmds +val pr_cases_pattern : cases_pattern_expr -> std_ppcmds +val pr_may_eval : ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('a,'b) may_eval -> std_ppcmds +val pr_rawconstr : rawconstr -> std_ppcmds diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml new file mode 100644 index 00000000..95e134ae --- /dev/null +++ b/parsing/pptactic.ml @@ -0,0 +1,758 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds) -> (raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds +type 'a glob_extra_genarg_printer = + (rawconstr_and_expr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds +type 'a extra_genarg_printer = + (Term.constr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +let genarg_pprule_v7 = ref Stringmap.empty +let genarg_pprule = ref Stringmap.empty + +let declare_extra_genarg_pprule for_v8 (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 prtac x = f prc prtac (out_gen rawwit x) in + let g prc prtac x = g prc prtac (out_gen globwit x) in + let h prc prtac x = h prc prtac (out_gen wit x) in + genarg_pprule_v7 := Stringmap.add s (f,g,h) !genarg_pprule_v7; + if for_v8 then + 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_located pr (loc,x) = pr x + +let pr_ltac_constant sp = pr_qualid (Nametab.shortest_qualid_of_tactic sp) + +let pr_evaluable_reference = function + | EvalVarRef id -> pr_id id + | EvalConstRef sp -> pr_global (Libnames.ConstRef sp) + +let pr_inductive ind = pr_global (Libnames.IndRef ind) + +let pr_quantified_hypothesis = function + | AnonHyp n -> int n + | NamedHyp id -> pr_id id + +let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h + +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 -> if Options.do_translate () or not !Options.v7 then + str"(" ++ pr_binding prlc b ++ str")" + else + pr_binding prc b) + 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 -> if Options.do_translate () or not !Options.v7 then + str"(" ++ pr_binding prlc b ++ str")" + else + pr_binding prc b) + l + | NoBindings -> mt () + +let pr_with_bindings prc prlc (c,bl) = + if Options.do_translate () then + (* translator calls pr_with_bindings on rawconstr: we cast it! *) + let bl' = Ppconstrnew.translate_with_bindings (fst (Obj.magic c) : rawconstr) bl in + prc c ++ hv 0 (pr_bindings prc prlc bl') + else + 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 pr_with_names = function + | None -> mt () + | Some ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat) + +let pr_hyp_location pr_id = function + | id, _, (InHyp,_) -> spc () ++ pr_id id + | id, _, (InHypTypeOnly,_) -> + spc () ++ str "(Type of " ++ pr_id id ++ str ")" + | id, _, _ -> error "Unsupported hyp location in v7" + +let pr_clause pr_id = function + | [] -> mt () + | l -> spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l) + + +let pr_clauses pr_id cls = + match cls with + { onhyps = Some l; onconcl = false } -> + spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l) + | { onhyps = Some []; onconcl = true } -> mt() + | _ -> error "this clause has both hypothesis and conclusion" + +let pr_simple_clause pr_id = function + | [] -> mt () + | l -> spc () ++ + hov 0 (str "in" ++ spc () ++ prlist_with_sep spc pr_id l) + +let pr_clause_pattern pr_id cls = + pr_opt + (prlist (fun (id,occs,_) -> + prlist (pr_arg int) occs ++ spc () ++ pr_id id)) cls.onhyps ++ + if cls.onconcl then + prlist (pr_arg int) cls.concl_occs ++ spc() ++ str"Goal" + else mt() + +let pr_subterms pr occl = + hov 0 (pr_occurrences pr occl ++ spc () ++ str "with") + +let pr_induction_arg prc = function + | ElimOnConstr c -> prc c + | ElimOnIdent (_,id) -> 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_match_pattern pr_pat = function + | Term a -> pr_pat a + | Subterm (None,a) -> str "[" ++ pr_pat a ++ str "]" + | Subterm (Some id,a) -> pr_id id ++ str "[" ++ pr_pat a ++ str "]" + +let pr_match_hyps pr_pat = function + | Hyp ((_,na),mp) -> pr_name na ++ str ":" ++ pr_match_pattern pr_pat mp + +let pr_match_rule m pr_pat pr = function + | Pat ([],mp,t) when m -> + str "[" ++ pr_match_pattern pr_pat mp ++ str "]" + ++ spc () ++ str "->" ++ brk (1,2) ++ pr t + | Pat (rl,mp,t) -> + str "[" ++ prlist_with_sep pr_semicolon + (pr_match_hyps pr_pat) rl ++ spc () ++ + str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ str "]" ++ + spc () ++ str "->" ++ brk (1,2) ++ pr t + | All t -> str "_" ++ spc () ++ str "->" ++ brk (1,2) ++ pr t + +let pr_funvar = function + | None -> spc () ++ str "()" + | Some id -> spc () ++ pr_id id + +let pr_let_clause k pr = function + | ((_,id),None,t) -> hv 0(str k ++ pr_id id ++ str " =" ++ brk (1,1) ++ pr t) + | ((_,id),Some c,t) -> str "TODO(LETCLAUSE)" + +let pr_let_clauses pr = function + | hd::tl -> + hv 0 + (pr_let_clause "Let " pr hd ++ + prlist (fun t -> spc () ++ pr_let_clause "And " pr t) tl) + | [] -> anomaly "LetIn must declare at least one binding" + +let pr_rec_clause pr ((_,id),(l,t)) = + pr_id id ++ prlist pr_funvar l ++ str "->" ++ spc () ++ pr t + +let pr_rec_clauses pr l = + prlist_with_sep (fun () -> fnl () ++ str "And ") (pr_rec_clause pr) l + +let pr_hintbases = function + | None -> spc () ++ str "with *" + | Some [] -> mt () + | Some l -> + spc () ++ str "with" ++ hv 0 (prlist (fun s -> spc () ++ str s) l) + +let pr_autoarg_adding = function + | [] -> mt () + | l -> + spc () ++ str "Adding [" ++ + hv 0 (prlist_with_sep spc pr_reference l) ++ str "]" + +let pr_autoarg_destructing = function + | true -> spc () ++ str "Destructing" + | false -> mt () + +let pr_autoarg_usingTDB = function + | true -> spc () ++ str "Using TDB" + | false -> mt () + +let rec pr_raw_generic prc prlc prtac prref x = + match Genarg.genarg_tag x with + | BoolArgType -> pr_arg str (if out_gen rawwit_bool x then "true" else "false") + | IntArgType -> pr_arg int (out_gen rawwit_int x) + | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen rawwit_int_or_var x) + | StringArgType -> spc () ++ str "\"" ++ str (out_gen rawwit_string x) ++ str "\"" + | PreIdentArgType -> pr_arg str (out_gen rawwit_pre_ident x) + | IntroPatternArgType -> pr_arg pr_intro_pattern + (out_gen rawwit_intro_pattern x) + | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen rawwit_ident x)) + | HypArgType -> pr_arg + (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen rawwit_var x) + | RefArgType -> pr_arg prref (out_gen rawwit_ref x) + | SortArgType -> pr_arg pr_sort (out_gen rawwit_sort x) + | ConstrArgType -> pr_arg prc (out_gen rawwit_constr x) + | ConstrMayEvalArgType -> + pr_arg (pr_may_eval prc prref) + (out_gen rawwit_constr_may_eval x) + | QuantHypArgType -> + pr_arg pr_quantified_hypothesis (out_gen rawwit_quant_hyp x) + | RedExprArgType -> + pr_arg (pr_red_expr + (prc,prref)) (out_gen rawwit_red_expr x) + | TacticArgType -> pr_arg prtac (out_gen rawwit_tactic x) + | CastedOpenConstrArgType -> + pr_arg prc (out_gen rawwit_casted_open_constr x) + | ConstrWithBindingsArgType -> + pr_arg (pr_with_bindings prc prlc) (out_gen rawwit_constr_with_bindings x) + | BindingsArgType -> + pr_arg (pr_bindings_no_with prc prlc) (out_gen rawwit_bindings x) + | List0ArgType _ -> + hov 0 (fold_list0 (fun x a -> pr_raw_generic prc prlc prtac prref x ++ a) x (mt())) + | List1ArgType _ -> + hov 0 (fold_list1 (fun x a -> pr_raw_generic prc prlc prtac prref x ++ a) x (mt())) + | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prref) (mt()) x) + | PairArgType _ -> + hov 0 + (fold_pair + (fun a b -> pr_raw_generic prc prlc prtac prref a ++ spc () ++ + pr_raw_generic prc prlc prtac prref b) + x) + | ExtraArgType s -> + let tab = + if Options.do_translate() or not !Options.v7 then !genarg_pprule + else !genarg_pprule_v7 in + try pi1 (Stringmap.find s tab) prc prtac x + with Not_found -> str " [no printer for " ++ str s ++ str "] " + + +let rec pr_glob_generic prc prlc prtac x = + match Genarg.genarg_tag x with + | BoolArgType -> pr_arg str (if out_gen globwit_bool x then "true" else "false") + | IntArgType -> pr_arg int (out_gen globwit_int x) + | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen globwit_int_or_var x) + | StringArgType -> spc () ++ str "\"" ++ str (out_gen globwit_string x) ++ str "\"" + | PreIdentArgType -> pr_arg str (out_gen globwit_pre_ident x) + | IntroPatternArgType -> + pr_arg pr_intro_pattern (out_gen globwit_intro_pattern x) + | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen globwit_ident x)) + | HypArgType -> pr_arg (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen globwit_var x) + | RefArgType -> pr_arg (pr_or_var (pr_located pr_global)) (out_gen globwit_ref x) + | SortArgType -> pr_arg pr_sort (out_gen globwit_sort x) + | ConstrArgType -> pr_arg prc (out_gen globwit_constr x) + | ConstrMayEvalArgType -> + pr_arg (pr_may_eval prc + (pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_constr_may_eval x) + | QuantHypArgType -> + pr_arg pr_quantified_hypothesis (out_gen globwit_quant_hyp x) + | RedExprArgType -> + pr_arg (pr_red_expr + (prc,pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_red_expr x) + | TacticArgType -> pr_arg prtac (out_gen globwit_tactic x) + | CastedOpenConstrArgType -> + pr_arg prc (out_gen globwit_casted_open_constr x) + | ConstrWithBindingsArgType -> + pr_arg (pr_with_bindings prc prlc) (out_gen globwit_constr_with_bindings x) + | BindingsArgType -> + pr_arg (pr_bindings_no_with prc prlc) (out_gen globwit_bindings x) + | List0ArgType _ -> + hov 0 (fold_list0 (fun x a -> pr_glob_generic prc prlc prtac x ++ a) x (mt())) + | List1ArgType _ -> + hov 0 (fold_list1 (fun x a -> pr_glob_generic prc prlc prtac x ++ a) x (mt())) + | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac) (mt()) x) + | PairArgType _ -> + hov 0 + (fold_pair + (fun a b -> pr_glob_generic prc prlc prtac a ++ spc () ++ + pr_glob_generic prc prlc prtac b) + x) + | ExtraArgType s -> + let tab = + if Options.do_translate() or not !Options.v7 then !genarg_pprule + else !genarg_pprule_v7 in + try pi2 (Stringmap.find s tab) prc prtac x + with Not_found -> str " [no printer for " ++ str s ++ str "] " + +open Closure + +let rec pr_generic prc prlc prtac x = + match Genarg.genarg_tag x with + | BoolArgType -> pr_arg str (if out_gen wit_bool x then "true" else "false") + | IntArgType -> pr_arg int (out_gen wit_int x) + | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen wit_int_or_var x) + | StringArgType -> spc () ++ str "\"" ++ str (out_gen wit_string x) ++ str "\"" + | PreIdentArgType -> pr_arg str (out_gen wit_pre_ident x) + | IntroPatternArgType -> + pr_arg pr_intro_pattern (out_gen wit_intro_pattern x) + | IdentArgType -> pr_arg pr_id (Constrextern.v7_to_v8_id (out_gen wit_ident x)) + | HypArgType -> pr_arg prc (out_gen wit_var x) + | RefArgType -> pr_arg pr_global (out_gen wit_ref x) + | SortArgType -> pr_arg prc (Term.mkSort (out_gen wit_sort x)) + | ConstrArgType -> pr_arg prc (out_gen wit_constr x) + | ConstrMayEvalArgType -> + pr_arg prc (out_gen wit_constr_may_eval x) + | QuantHypArgType -> + pr_arg pr_quantified_hypothesis (out_gen wit_quant_hyp x) + | RedExprArgType -> + pr_arg (pr_red_expr (prc,pr_evaluable_reference)) (out_gen wit_red_expr x) + | TacticArgType -> pr_arg prtac (out_gen wit_tactic x) + | CastedOpenConstrArgType -> + pr_arg prc (snd (out_gen wit_casted_open_constr x)) + | ConstrWithBindingsArgType -> + pr_arg (pr_with_bindings prc prlc) (out_gen wit_constr_with_bindings x) + | BindingsArgType -> + pr_arg (pr_bindings_no_with prc prlc) (out_gen wit_bindings x) + | List0ArgType _ -> + hov 0 (fold_list0 (fun x a -> pr_generic prc prlc prtac x ++ a) x (mt())) + | List1ArgType _ -> + hov 0 (fold_list1 (fun x a -> pr_generic prc prlc prtac x ++ a) x (mt())) + | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac) (mt()) x) + | PairArgType _ -> + hov 0 + (fold_pair + (fun a b -> pr_generic prc prlc prtac a ++ spc () ++ + pr_generic prc prlc prtac b) + x) + | ExtraArgType s -> + let tab = + if Options.do_translate() or not !Options.v7 then !genarg_pprule + else !genarg_pprule_v7 in + try pi3 (Stringmap.find s tab) prc prtac x + with Not_found -> str " [no printer for " ++ str s ++ str "]" + +let rec pr_tacarg_using_rule pr_gen = function + | Some s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al) + | None :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule pr_gen (l,al) + | [], [] -> mt () + | _ -> failwith "Inconsistent arguments of extended tactic" + +let pr_extend_gen prgen s l = + let tab = + if Options.do_translate() or not !Options.v7 then prtac_tab + else prtac_tab_v7 + in + try + let tags = List.map genarg_tag l in + (* Hack pour les syntaxes changeant non uniformément en passant a la V8 *) + let s = + let n = String.length s in + if Options.do_translate() & n > 2 & String.sub s (n-2) 2 = "v7" + then String.sub s 0 (n-2) ^ "v8" + else s in + let (s,pl) = Hashtbl.find tab (s,tags) in + str s ++ pr_tacarg_using_rule prgen (pl,l) + with Not_found -> + str s ++ prlist prgen l ++ str " (* Generic printer *)" + +let make_pr_tac (pr_tac,pr_tac0,pr_constr,pr_pat,pr_cst,pr_ind,pr_ref,pr_ident,pr_extend) = + +let pr_bindings = pr_bindings pr_constr pr_constr in +let pr_bindings_no_with = pr_bindings_no_with pr_constr pr_constr in +let pr_with_bindings = pr_with_bindings pr_constr pr_constr in +let pr_eliminator cb = str "using" ++ pr_arg (pr_with_bindings) cb in +let pr_constrarg c = spc () ++ pr_constr c in +let pr_intarg n = spc () ++ int n in + + (* Printing tactics as arguments *) +let rec pr_atom0 = function + | TacIntroPattern [] -> str "Intros" + | TacIntroMove (None,None) -> str "Intro" + | TacAssumption -> str "Assumption" + | TacAnyConstructor None -> str "Constructor" + | TacTrivial (Some []) -> str "Trivial" + | TacAuto (None,Some []) -> str "Auto" + | TacAutoTDB None -> str "AutoTDB" + | TacDestructConcl -> str "DConcl" + | TacReflexivity -> str "Reflexivity" + | t -> str "(" ++ pr_atom1 t ++ str ")" + + (* Main tactic printer *) +and pr_atom1 = function + | TacExtend (_,s,l) -> pr_extend pr_constr pr_constr pr_tac s l + | TacAlias (_,s,l,_) -> + pr_extend pr_constr pr_constr pr_tac 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,None) as t -> pr_atom0 t + | TacIntroMove (Some id1,None) -> str "Intro " ++ pr_id id1 + | TacIntroMove (ido1,Some (_,id2)) -> + hov 1 + (str "Intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++ pr_id id2) + | TacAssumption as t -> pr_atom0 t + | TacExact c -> hov 1 (str "Exact" ++ pr_arg pr_constr c) + | TacApply cb -> hov 1 (str "Apply" ++ spc () ++ pr_with_bindings cb) + | TacElim (cb,cbo) -> + hov 1 (str "Elim" ++ pr_arg pr_with_bindings cb ++ + pr_opt pr_eliminator cbo) + | TacElimType c -> hov 1 (str "ElimType" ++ pr_arg pr_constr c) + | TacCase cb -> hov 1 (str "Case" ++ spc () ++ pr_with_bindings cb) + | TacCaseType c -> hov 1 (str "CaseType" ++ pr_arg pr_constr c) + | TacFix (ido,n) -> hov 1 (str "Fix" ++ pr_opt pr_id ido ++ pr_intarg n) + | TacMutualFix (id,n,l) -> + hov 1 (str "Fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc () ++ + hov 0 (str "with" ++ brk (1,1) ++ + prlist_with_sep spc + (fun (id,n,c) -> + spc () ++ pr_id id ++ pr_intarg n ++ pr_arg pr_constr c) + l)) + | TacCofix ido -> hov 1 (str "Cofix" ++ pr_opt pr_id ido) + | TacMutualCofix (id,l) -> + hov 1 (str "Cofix" ++ spc () ++ pr_id id ++ spc () ++ + hov 0 (str "with" ++ brk (1,1) ++ + prlist (fun (id,c) -> spc () ++ pr_id id ++ pr_arg pr_constr c) + l)) + | TacCut c -> hov 1 (str "Cut" ++ pr_arg pr_constr c) + | TacTrueCut (Anonymous,c) -> + hov 1 (str "Assert" ++ pr_arg pr_constr c) + | TacTrueCut (Name id,c) -> + hov 1 (str "Assert" ++ spc () ++ pr_id id ++ str ":" ++ pr_constr c) + | TacForward (false,na,c) -> + hov 1 (str "Assert" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c) + | TacForward (true,na,c) -> + hov 1 (str "Pose" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c) + | TacGeneralize l -> + hov 1 (str "Generalize" ++ spc () ++ prlist_with_sep spc pr_constr l) + | TacGeneralizeDep c -> + hov 1 (str "Generalize" ++ spc () ++ str "Dependent" ++ spc () ++ + pr_constr c) + | TacLetTac (na,c,cl) -> + let pcl = match cl with + {onhyps=None;onconcl=true;concl_occs=[]} -> mt() + | _ -> pr_clauses pr_ident cl in + hov 1 (str "LetTac" ++ spc () ++ pr_name na ++ str ":=" ++ + pr_constr c ++ pcl) + | TacInstantiate (n,c,cls) -> + hov 1 (str "Instantiate" ++ pr_arg int n ++ pr_arg pr_constr c ++ + pr_clauses pr_ident cls) + (* Derived basic tactics *) + | TacSimpleInduction (h,_) -> + hov 1 (str "Induction" ++ pr_arg pr_quantified_hypothesis h) + | TacNewInduction (h,e,(ids,_)) -> + hov 1 (str "NewInduction" ++ spc () ++ pr_induction_arg pr_constr h ++ + pr_opt pr_eliminator e ++ pr_with_names ids) + | TacSimpleDestruct h -> + hov 1 (str "Destruct" ++ pr_arg pr_quantified_hypothesis h) + | TacNewDestruct (h,e,(ids,_)) -> + hov 1 (str "NewDestruct" ++ spc () ++ pr_induction_arg pr_constr h ++ + pr_opt pr_eliminator e ++ pr_with_names ids) + | 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_arg pr_constr c) + | TacDecomposeOr c -> + hov 1 (str "Decompose Sum" ++ pr_arg pr_constr c) + | TacDecompose (l,c) -> + hov 1 (str "Decompose" ++ spc () ++ + hov 0 (str "[" ++ prlist_with_sep spc pr_ind l + ++ str "]" ++ pr_arg pr_constr c)) + | TacSpecialize (n,c) -> + hov 1 (str "Specialize" ++ pr_opt int n ++ pr_with_bindings c) + | TacLApply c -> + hov 1 (str "LApply" ++ pr_constr c) + + (* Automation tactics *) + | TacTrivial (Some []) as x -> pr_atom0 x + | TacTrivial db -> hov 0 (str "Trivial" ++ pr_hintbases db) + | TacAuto (None,Some []) as x -> pr_atom0 x + | TacAuto (n,db) -> hov 0 (str "Auto" ++ pr_opt int n ++ pr_hintbases db) + | TacAutoTDB None as x -> pr_atom0 x + | TacAutoTDB (Some n) -> hov 0 (str "AutoTDB" ++ spc () ++ int n) + | TacDestructHyp (true,(_,id)) -> hov 0 (str "CDHyp" ++ spc () ++ pr_id id) + | TacDestructHyp (false,(_,id)) -> hov 0 (str "DHyp" ++ spc () ++ pr_id id) + | TacDestructConcl as x -> pr_atom0 x + | TacSuperAuto (n,l,b1,b2) -> + hov 1 (str "SuperAuto" ++ pr_opt int n ++ pr_autoarg_adding l ++ + pr_autoarg_destructing b1 ++ pr_autoarg_usingTDB b2) + | TacDAuto (n,p) -> + hov 1 (str "Auto" ++ pr_opt int n ++ str "Decomp" ++ pr_opt int p) + + (* Context management *) + | TacClear l -> + hov 1 (str "Clear" ++ spc () ++ 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 ++ spc () ++ + str "after" ++ brk (1,1) ++ pr_ident id2) + | TacRename (id1,id2) -> + hov 1 + (str "Rename" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ + str "into" ++ brk (1,1) ++ pr_ident id2) + + (* Constructors *) + | TacLeft l -> hov 1 (str "Left" ++ pr_bindings l) + | TacRight l -> hov 1 (str "Right" ++ pr_bindings l) + | TacSplit (_,l) -> hov 1 (str "Split" ++ pr_bindings l) + | TacAnyConstructor (Some t) -> + hov 1 (str "Constructor" ++ pr_arg pr_tac0 t) + | TacAnyConstructor None as t -> pr_atom0 t + | TacConstructor (n,l) -> + hov 1 (str "Constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings l) + + (* Conversion *) + | TacReduce (r,h) -> + hov 1 (pr_red_expr (pr_constr,pr_cst) r ++ pr_clauses pr_ident h) + | TacChange (occl,c,h) -> + hov 1 (str "Change" ++ pr_opt (pr_subterms pr_constr) occl ++ + brk (1,1) ++ pr_constr c ++ pr_clauses pr_ident h) + + (* Equivalence relations *) + | TacReflexivity as x -> pr_atom0 x + | TacSymmetry cls -> str "Symmetry " ++ pr_clauses pr_ident cls + | TacTransitivity c -> str "Transitivity" ++ pr_arg pr_constr c + + (* Equality and inversion *) + | TacInversion (DepInversion (k,c,ids),hyp) -> + hov 1 (str "Dependent " ++ pr_induction_kind k ++ + pr_quantified_hypothesis hyp ++ + pr_with_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_names ids ++ pr_simple_clause pr_ident cl) + | TacInversion (InversionUsing (c,cl),hyp) -> + hov 1 (str "Inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ + str "using" ++ spc () ++ pr_constr c ++ + pr_simple_clause pr_ident cl) + +and pr_tactic_seq_body tl = + hv 0 (str "[ " ++ + prlist_with_sep (fun () -> spc () ++ str "| ") prtac tl ++ str " ]") + + (* Strictly closed atomic tactic expressions *) +and pr0 = function + | TacFirst tl -> str "First" ++ spc () ++ pr_tactic_seq_body tl + | TacSolve tl -> str "Solve" ++ spc () ++ pr_tactic_seq_body tl + | TacId "" -> str "Idtac" + | TacFail (ArgArg 0,"") -> str "Fail" + | TacAtom (_,t) -> pr_atom0 t + | TacArg c -> pr_tacarg c + | t -> str "(" ++ prtac t ++ str ")" + + (* Semi-closed atomic tactic expressions *) +and pr1 = function + | TacAtom (_,t) -> pr_atom1 t + | TacId s -> str "Idtac \"" ++ str s ++ str "\"" + | TacFail (ArgArg 0,s) -> str "Fail \"" ++ str s ++ str "\"" + | TacFail (n,"") -> str "Fail " ++ pr_or_var int n + | TacFail (n,s) -> str "Fail " ++ pr_or_var int n ++ str " \"" ++ str s ++ str "\"" + | t -> pr0 t + + (* Orelse tactic expressions (printed as if parsed associating on the right + though the semantics is purely associative) *) +and pr2 = function + | TacOrelse (t1,t2) -> + hov 1 (pr1 t1 ++ str " Orelse" ++ brk (1,1) ++ pr3 t2) + | t -> pr1 t + + (* Non closed prefix tactic expressions *) +and pr3 = function + | TacTry t -> hov 1 (str "Try" ++ spc () ++ pr3 t) + | TacDo (n,t) -> hov 1 (str "Do " ++ pr_or_var int n ++ spc () ++ pr3 t) + | TacRepeat t -> hov 1 (str "Repeat" ++ spc () ++ pr3 t) + | TacProgress t -> hov 1 (str "Progress" ++ spc () ++ pr3 t) + | TacInfo t -> hov 1 (str "Info" ++ spc () ++ pr3 t) + | t -> pr2 t + +and pr4 = function + | t -> pr3 t + + (* THEN and THENS tactic expressions (printed as if parsed + associating on the left though the semantics is purely associative) *) +and pr5 = function + | TacThens (t,tl) -> + hov 1 (pr5 t ++ str ";" ++ spc () ++ pr_tactic_seq_body tl) + | TacThen (t1,t2) -> + hov 1 (pr5 t1 ++ str ";" ++ spc () ++ pr4 t2) + | t -> pr4 t + + (* Ltac tactic expressions *) +and pr6 = function + |(TacAtom _ + | TacThen _ + | TacThens _ + | TacFirst _ + | TacSolve _ + | TacTry _ + | TacOrelse _ + | TacDo _ + | TacRepeat _ + | TacProgress _ + | TacId _ + | TacFail _ + | TacInfo _) as t -> pr5 t + + | TacAbstract (t,None) -> str "Abstract " ++ pr6 t + | TacAbstract (t,Some s) -> + hov 0 + (str "Abstract " ++ pr6 t ++ spc () ++ str "using" ++ spc () ++ pr_id s) + | TacLetRecIn (l,t) -> + hv 0 + (str "Rec " ++ pr_rec_clauses prtac l ++ + spc () ++ str "In" ++ fnl () ++ prtac t) + | TacLetIn (llc,u) -> + v 0 + (hv 0 (pr_let_clauses pr_tacarg0 llc ++ spc () ++ str "In") ++ fnl () ++ prtac u) + | TacMatch (t,lrul) -> + hov 0 (str "Match" ++ spc () ++ pr6 t ++ spc() + ++ str "With" + ++ prlist + (fun r -> fnl () ++ str "|" ++ spc () ++ + pr_match_rule true pr_pat prtac r) + lrul) + | TacMatchContext (lr,lrul) -> + hov 0 ( + str (if lr then "Match Reverse Context With" else "Match Context With") + ++ prlist + (fun r -> fnl () ++ str "|" ++ spc () ++ + pr_match_rule false pr_pat prtac r) + lrul) + | TacFun (lvar,body) -> + hov 0 (str "Fun" ++ + prlist pr_funvar lvar ++ spc () ++ str "->" ++ spc () ++ prtac body) + + | TacArg c -> pr_tacarg c + +and pr_tacarg0 = function + | TacDynamic (_,t) -> str ("") + | MetaIdArg (_,s) -> str ("$" ^ s) + | IntroPattern ipat -> pr_intro_pattern ipat + | TacVoid -> str "()" + | Reference r -> pr_ref r + | ConstrMayEval (ConstrTerm c) -> str "'" ++ pr_constr c + | ConstrMayEval c -> pr_may_eval pr_constr pr_cst c + | Integer n -> int n + | TacFreshId sopt -> str "FreshId" ++ pr_opt qstring sopt + | (TacCall _ | Tacexp _) as t -> str "(" ++ pr_tacarg1 t ++ str ")" + +and pr_tacarg1 = function + | TacCall (_,f,l) -> + hov 0 (pr_ref f ++ spc () ++ prlist_with_sep spc pr_tacarg0 l) + | Tacexp t -> pr_tac t + | t -> pr_tacarg0 t + +and pr_tacarg x = pr_tacarg1 x + +and prtac x = pr6 x + +in (prtac,pr0,pr_match_rule false pr_pat pr_tac) + +let pr_raw_extend prc prlc prtac = + pr_extend_gen (pr_raw_generic prc prlc prtac Ppconstrnew.pr_reference) +let pr_glob_extend prc prlc prtac = + pr_extend_gen (pr_glob_generic prc prlc prtac) +let pr_extend prc prlc prtac = + pr_extend_gen (pr_generic prc prlc prtac) + +let pr_and_constr_expr pr (c,_) = pr c + +let rec glob_printers = + (pr_glob_tactic, + pr_glob_tactic0, + pr_and_constr_expr Printer.pr_rawterm, + Printer.pr_pattern, + pr_or_var (pr_and_short_name pr_evaluable_reference), + pr_or_var pr_inductive, + pr_or_var (pr_located pr_ltac_constant), + pr_located pr_id, + pr_glob_extend) + +and pr_glob_tactic (t:glob_tactic_expr) = pi1 (make_pr_tac glob_printers) t + +and pr_glob_tactic0 t = pi2 (make_pr_tac glob_printers) t + +and pr_glob_match_context t = pi3 (make_pr_tac glob_printers) t + +let (pr_tactic,_,_) = + make_pr_tac + (pr_glob_tactic, + pr_glob_tactic0, + Printer.prterm, + Printer.pr_pattern, + pr_evaluable_reference, + pr_inductive, + pr_ltac_constant, + pr_id, + pr_extend) diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli new file mode 100644 index 00000000..a80ec6fb --- /dev/null +++ b/parsing/pptactic.mli @@ -0,0 +1,84 @@ +(************************************************************************) +(* 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_located : ('a -> std_ppcmds) -> 'a Util.located -> std_ppcmds + +type 'a raw_extra_genarg_printer = + (constr_expr -> std_ppcmds) -> (raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a glob_extra_genarg_printer = + (rawconstr_and_expr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a extra_genarg_printer = + (Term.constr -> std_ppcmds) -> (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 : + bool -> + ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) -> + ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) -> + ('b closed_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 : bool -> string -> + argument_type list * (string * grammar_terminals) -> unit + +val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds + +val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('a,'b) match_rule -> std_ppcmds + +val pr_glob_tactic : glob_tactic_expr -> std_ppcmds + +val pr_tactic : Proof_type.tactic_expr -> std_ppcmds + +val pr_glob_generic: + (rawconstr_and_expr -> std_ppcmds) -> + (rawconstr_and_expr -> std_ppcmds) -> + (glob_tactic_expr -> std_ppcmds) -> + glob_generic_argument -> std_ppcmds + +val pr_raw_generic : + (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (raw_tactic_expr -> std_ppcmds) -> + (Libnames.reference -> std_ppcmds) -> + (constr_expr, raw_tactic_expr) generic_argument -> + std_ppcmds + +val pr_raw_extend: + (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> + (raw_tactic_expr -> std_ppcmds) -> string -> + raw_generic_argument list -> std_ppcmds + +val pr_glob_extend: + (rawconstr_and_expr -> std_ppcmds) -> (rawconstr_and_expr -> std_ppcmds) -> + (glob_tactic_expr -> std_ppcmds) -> string -> + glob_generic_argument list -> std_ppcmds + +val pr_extend : + (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> + (glob_tactic_expr -> std_ppcmds) -> string -> closed_generic_argument list -> std_ppcmds diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml new file mode 100644 index 00000000..169eff94 --- /dev/null +++ b/parsing/prettyp.ml @@ -0,0 +1,605 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mt () + | [i] -> str"Position [" ++ int i ++ str"] is implicit" ++ fnl() + | l -> + str"Positions [" ++ + prlist_with_sep (fun () -> str "; ") int l ++ + str"] are implicit" ++ fnl() + +let print_impl_args_by_name = function + | [] -> mt () + | [i] -> str"Argument " ++ pr_id (name_of_implicit i) ++ str" is implicit" ++ + fnl() + | l -> + str"Arguments " ++ + prlist_with_sep (fun () -> str ", ") + (fun imp -> pr_id (name_of_implicit imp)) l ++ + str" are implicit" ++ fnl() + +let print_impl_args l = + if !Options.v7 then print_impl_args_by_pos (positions_of_implicits l) + else print_impl_args_by_name (List.filter is_status_implicit l) + +(*********************) +(** Printing Scopes *) + +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 () ++ prtype typ) ++ fnl () + +let print_argument_scopes = function + | [Some sc] -> str"Argument scope is [" ++ str sc ++ str"]" ++ fnl() + | l when not (List.for_all ((=) None) l) -> + hov 2 (str"Argument scopes are" ++ spc() ++ + str "[" ++ + prlist_with_sep spc (function Some sc -> str sc | None -> str "_") l ++ + str "]") ++ fnl() + | _ -> mt() + +let need_expansion impl ref = + let typ = Global.type_of_global ref in + let ctx = fst (decompose_prod_assum typ) in + let nprods = List.length (List.filter (fun (_,b,_) -> b=None) ctx) in + impl <> [] & let _,lastimpl = list_chop nprods impl in + List.filter is_status_implicit lastimpl <> [] + +let print_name_infos ref = + let impl = implicits_of_global ref in + let scopes = Symbols.find_arguments_scope ref in + let type_for_implicit = + if need_expansion impl ref then + (* Need to reduce since implicits are computed with products flattened *) + str "Expanded type for implicit arguments" ++ fnl () ++ + print_ref true ref ++ fnl() + else mt() in + (if (List.filter is_status_implicit impl<>[]) + or not (List.for_all ((=) None) scopes) + then fnl() + else mt()) + ++ type_for_implicit + ++ print_impl_args impl ++ print_argument_scopes scopes + +let print_id_args_data test pr id l = + if List.exists test l then + str"For " ++ pr_id id ++ str": " ++ pr l + else + mt() + +let print_args_data_of_inductive_ids get test pr sp mipv = + prvecti + (fun i mip -> + print_id_args_data test pr mip.mind_typename (get (IndRef (sp,i))) ++ + prvecti + (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 is_status_implicit print_impl_args + +let print_inductive_argument_scopes = + print_args_data_of_inductive_ids + Symbols.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 * kernel_name + | 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_syntactic_definition 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_sp (Nametab.sp_of_global ref) + | Syntactic kn -> + str (if !Options.v7 then "Syntactic Definition" else "Notation") ++ + spc () ++ pr_sp (Nametab.sp_of_syntactic_definition 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_sp (Nametab.full_name_modtype qid) + | Undefined qid -> + pr_qualid qid ++ str " is 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 + | SyntacticDef kn -> Syntactic kn, N.shortest_qualid_of_syndef kn in + match List.map expand (N.extended_locate_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 "(visible as " ++ pr_qualid oqid ++ str")" + else + mt ()))) l + +(******************************************) +(**** Printing declarations and judgments *) + +let print_typed_value_in_env env (trm,typ) = + (prterm_env env trm ++ fnl () ++ + str " : " ++ prtype_env env typ ++ fnl ()) + +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) + +(* To be improved; the type should be used to provide the types in the + abstractions. This should be done recursively inside prterm, 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 = prterm body in + let ptyp = prtype typ in + (str "*** [" ++ str name ++ str " " ++ + hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++ + str ":" ++ brk (1,2) ++ ptyp) ++ + str "]" ++ fnl ()) + +let print_named_assum name typ = + (str "*** [" ++ str name ++ str " : " ++ prtype typ ++ str "]" ++ fnl ()) + +let 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 print_params env params = + if List.length params = 0 then + (mt ()) + else + if !Options.v7 then + (str "[" ++ pr_rel_context env params ++ str "]" ++ brk(1,2)) + 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 " : " ++ prterm_env envpar c) + (Array.to_list (array_map2 (fun n t -> (n,t)) names types)) + in + hv 0 (str " " ++ pc) + +let build_inductive sp tyi = + let (mib,mip) = Global.lookup_inductive (sp,tyi) in + let params = mip.mind_params_ctxt in + let args = extended_rel_list 0 params in + let env = Global.env() in + let arity = hnf_prod_applist env mip.mind_user_arity args in + let cstrtypes = arities_of_constructors env (sp,tyi) in + let cstrtypes = + Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in + let cstrnames = mip.mind_consnames in + (IndRef (sp,tyi), params, arity, cstrnames, cstrtypes) + +let print_one_inductive (sp,tyi) = + let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in + let env = Global.env () in + let envpar = push_rel_context params env in + hov 0 ( + pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ print_params env params ++ + str ": " ++ prterm_env envpar arity ++ str " :=") ++ + brk(0,2) ++ print_constructors envpar cstrnames cstrtypes + +let pr_mutual_inductive finite indl = + hov 0 ( + str (if finite then "Inductive " else "CoInductive ") ++ + prlist_with_sep (fun () -> fnl () ++ str" with ") + print_one_inductive indl) ++ + fnl () + +let print_mutual sp = + let (mib,mip) = Global.lookup_inductive (sp,0) in + let mipv = mib.mind_packets in + let names = list_tabulate (fun x -> (sp,x)) (Array.length mipv) in + pr_mutual_inductive mib.mind_finite names ++ + print_inductive_implicit_args sp mipv ++ + print_inductive_argument_scopes sp mipv + +let print_section_variable sp = + let d = get_variable sp in + print_named_decl d ++ + print_name_infos (VarRef sp) + +let print_body = function + | Some lc -> prterm (Declarations.force lc) + | None -> (str"") + +let print_typed_body (val_0,typ) = + (print_body val_0 ++ fnl () ++ str " : " ++ prtype typ ++ fnl ()) + +let print_constant with_values sep sp = + let cb = Global.lookup_constant sp in + let val_0 = cb.const_body in + let typ = cb.const_type in + hov 0 ( + match val_0 with + | None -> + str"*** [ " ++ + print_basename sp ++ str " : " ++ cut () ++ prtype typ ++ + str" ]" ++ fnl () + | _ -> + print_basename sp ++ str sep ++ cut () ++ + (if with_values then print_typed_body (val_0,typ) else prtype typ) ++ + fnl ()) + +let print_constant_with_infos sp = + print_constant true " = " sp ++ print_name_infos (ConstRef sp) + +let print_inductive sp = (print_mutual sp) + +let print_syntactic_def sep kn = + let qid = Nametab.shortest_qualid_of_syndef kn in + let c = Syntax_def.search_syntactic_definition dummy_loc kn in + (str (if !Options.v7 then "Syntactic Definition " else "Notation ") + ++ pr_qualid qid ++ str sep ++ + Constrextern.without_symbols pr_rawterm c ++ fnl ()) + +let print_leaf_entry with_values sep ((sp,kn as oname),lobj) = + let tag = object_tag lobj in + match (oname,tag) with + | (_,"VARIABLE") -> + Some (print_section_variable (basename sp)) + | (_,"CONSTANT") -> + Some (print_constant with_values sep kn) + | (_,"INDUCTIVE") -> + Some (print_inductive kn) + | (_,"MODULE") -> + let (mp,_,l) = repr_kn kn in + Some (print_module with_values (MPdot (mp,l))) + | (_,"MODULE TYPE") -> + Some (print_modtype kn) + | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| + "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None + (* To deal with forgotten cases... *) + | (_,s) -> None +(* + | (_,s) -> + (str(string_of_path sp) ++ str" : " ++ + str"Unrecognized object " ++ str s ++ fnl ()) +*) + +let rec print_library_entry with_values ent = + let sep = if with_values then " = " else " : " in + let pr_name (sp,_) = pr_id (basename sp) in + match ent with + | (oname,Lib.Leaf lobj) -> + print_leaf_entry with_values sep (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.OpenedModtype _) -> + Some (str " >>>>>>> Module Type " ++ pr_name oname) + | (_,Lib.FrozenState _) -> + None + +let print_context with_values = + let rec prec n = function + | h::rest when n = None or out_some n > 0 -> + (match print_library_entry with_values h with + | None -> prec n rest + | Some pp -> prec (option_app ((+) (-1)) n) rest ++ pp ++ fnl ()) + | _ -> mt () + in + prec + +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) + +(* 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 *) + +let list_filter_vec f vec = + let rec frec n lf = + if n < 0 then lf + else if f vec.(n) then + frec (n-1) (vec.(n)::lf) + else + frec (n-1) lf + in + frec (Array.length vec -1) [] + +(* 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 (_,_,ctxt)) as hd)::rest -> + error "Cannot print the contents of a closed section" + | [] -> [] + | 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_eval red_fun env {uj_val=trm;uj_type=typ} = + let ntrm = red_fun env Evd.empty trm in + (str " = " ++ print_judgment env {uj_val = ntrm; uj_type = typ}) + +let print_name ref = + match locate_any_name ref with + | 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 -> + try + let sp = Nametab.locate_obj qid in + let (oname,lobj) = + let (oname,entry) = + List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None) + in + match entry with + | Lib.Leaf obj -> (oname,obj) + | _ -> raise Not_found + in + match print_leaf_entry true " = " (oname,lobj) with + | None -> mt () + | Some pp -> pp ++ fnl() + with Not_found -> + errorlabstrm + "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object") + +let print_opaque_name qid = + let sigma = Evd.empty in + let env = Global.env () in + let sign = Global.named_context () in + match global qid with + | ConstRef cst -> + let cb = Global.lookup_constant cst in + if cb.const_body <> None then + print_constant_with_infos cst + else + error "not a defined constant" + | IndRef (sp,_) -> + print_mutual sp + | ConstructRef cstr -> + let ty = Inductive.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 ref = + let sigma = Evd.empty in + let k = locate_any_name ref in + begin match k with + | Term ref -> print_ref false ref ++ print_name_infos ref + | Syntactic kn -> print_syntactic_def " := " kn + | Dir _ | ModuleType _ | Undefined _ -> mt () end + ++ + hov 0 (str "Expands to: " ++ pr_located_qualid k) + +let print_impargs ref = + let ref = Nametab.global ref in + let impl = implicits_of_global ref in + let has_impl = List.filter is_status_implicit impl <> [] in + (* Need to reduce since implicits are computed with products flattened *) + print_ref (need_expansion impl ref) ref ++ fnl() ++ + (if has_impl then print_impl_args impl + else (str "No implicit arguments" ++ fnl ())) + +let print_local_context () = + let env = Lib.contents_after None in + let rec print_var_rec = function + | [] -> (mt ()) + | (oname,Lib.Leaf lobj)::rest -> + if "VARIABLE" = object_tag lobj then + let d = get_variable (basename (fst oname)) in + (print_var_rec rest ++ + print_named_decl d) + else + print_var_rec rest + | _::rest -> print_var_rec rest + + and print_last_const = function + | (oname,Lib.Leaf lobj)::rest -> + (match object_tag lobj with + | "CONSTANT" -> + let kn = snd oname in + let {const_body=val_0;const_type=typ} = + Global.lookup_constant kn in + (print_last_const rest ++ + print_basename kn ++str" = " ++ + print_typed_body (val_0,typ)) + | "INDUCTIVE" -> + let kn = snd oname in + (print_last_const rest ++print_mutual kn ++ fnl ()) + | "VARIABLE" -> (mt ()) + | _ -> print_last_const rest) + | _ -> (mt ()) + in + (print_var_rec env ++ print_last_const env) + +let unfold_head_fconst = + let rec unfrec k = match kind_of_term k with + | Const cst -> constant_value (Global.env ()) cst + | Lambda (na,t,b) -> mkLambda (na,t,unfrec b) + | App (f,v) -> appvect (unfrec f,v) + | _ -> k + in + unfrec + +(* 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 = prterm (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) = + (str"[" ++ + 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 _ -> + errorlabstrm "index_of_class" (pr_class cl ++ str" is 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 (i,j) + with _ -> + errorlabstrm "index_cl_of_id" + (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt) + in + print_path ((i,j),p) + +(*************************************************************************) diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli new file mode 100644 index 00000000..c8471330 --- /dev/null +++ b/parsing/prettyp.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Termops.names_context + +val print_closed_sections : bool ref +val print_impl_args : Impargs.implicits_list -> std_ppcmds +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_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 -> unsafe_judgment -> std_ppcmds +(* This function is exported for the graphical user-interface pcoq *) +val build_inductive : mutual_inductive -> int -> + global_reference * rel_context * types * identifier array * types array +val print_mutual : mutual_inductive -> std_ppcmds +val print_name : reference -> std_ppcmds +val print_opaque_name : reference -> std_ppcmds +val print_local_context : unit -> std_ppcmds +val print_about : reference -> std_ppcmds +val print_impargs : reference -> std_ppcmds + +(*i +val print_extracted_name : identifier -> std_ppcmds +val print_extraction : unit -> std_ppcmds +val print_extracted_vars : unit -> std_ppcmds +i*) + +(* 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 inspect : int -> std_ppcmds + +(* Locate *) +val print_located_qualid : reference -> std_ppcmds diff --git a/parsing/printer.ml b/parsing/printer.ml new file mode 100644 index 00000000..dfacc764 --- /dev/null +++ b/parsing/printer.ml @@ -0,0 +1,249 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (* May happen in debug *) + (str ("CONST("^(string_of_kn kn)^")")) + +let global_var_name id = + try pr_global Idset.empty (VarRef id) + with Not_found -> (* May happen in debug *) + (str ("SECVAR("^(string_of_id id)^")")) + +let global_ind_name (kn,tyi) = + try pr_global Idset.empty (IndRef (kn,tyi)) + with Not_found -> (* May happen in debug *) + (str ("IND("^(string_of_kn kn)^","^(string_of_int tyi)^")")) + +let global_constr_name ((kn,tyi),i) = + try pr_global Idset.empty (ConstructRef ((kn,tyi),i)) + with Not_found -> (* May happen in debug *) + (str ("CONSTRUCT("^(string_of_kn kn)^","^(string_of_int tyi) + ^","^(string_of_int i)^")")) + +let globpr gt = match gt with + | Nvar(_,s) -> (pr_id s) + | Node(_,"EVAR", [Num (_,ev)]) -> (str ("?" ^ (string_of_int ev))) + | Node(_,"CONST",[Path(_,sl)]) -> + global_const_name (section_path sl) + | Node(_,"SECVAR",[Nvar(_,s)]) -> + global_var_name s + | Node(_,"MUTIND",[Path(_,sl); Num(_,tyi)]) -> + global_ind_name (section_path sl, tyi) + | Node(_,"MUTCONSTRUCT",[Path(_,sl); Num(_,tyi); Num(_,i)]) -> + global_constr_name ((section_path sl, tyi), i) + | Dynamic(_,d) -> + if (Dyn.tag d) = "constr" then (str"") + else dfltpr gt + | gt -> dfltpr gt + + +let wrap_exception = function + Anomaly (s1,s2) -> + warning ("Anomaly ("^s1^")"); pp s2; + str"" + | Failure _ | UserError _ | Not_found -> + str"" + | s -> raise s + +let gentermpr_fail gt = + let prec = + if !Options.v7 then constr_initial_prec_v7 else constr_initial_prec in + Esyntax.genprint globpr constr_syntax_universe prec gt + +let gentermpr gt = + try gentermpr_fail gt + with s -> wrap_exception s + +(**********************************************************************) +(* Generic printing: choose old or new printers *) + +(* [at_top] means ids of env must be avoided in bound variables *) +let gentermpr_core at_top env t = + if !Options.v7 then gentermpr (Termast.ast_of_constr at_top env t) + else Ppconstrnew.pr_lconstr (Constrextern.extern_constr at_top env t) +let pr_cases_pattern t = + if !Options.v7 then gentermpr (Termast.ast_of_cases_pattern t) + else Ppconstrnew.pr_cases_pattern + (Constrextern.extern_cases_pattern Idset.empty t) +let pr_pattern_env tenv env t = + if !Options.v7 then gentermpr (Termast.ast_of_pattern tenv env t) + else Ppconstrnew.pr_constr + (Constrextern.extern_pattern tenv env t) + +(**********************************************************************) +(* Derived printers *) + +let prterm_env_at_top env = gentermpr_core true env +let prterm_env env = gentermpr_core false env +let prtype_env env typ = prterm_env env typ +let prjudge_env env j = + (prterm_env env j.uj_val, prterm_env env j.uj_type) + +(* NB do not remove the eta-redexes! Global.env() has side-effects... *) +let prterm t = prterm_env (Global.env()) t +let prtype t = prtype_env (Global.env()) t +let prjudge j = prjudge_env (Global.env()) j + +let pr_constant env cst = prterm_env env (mkConst cst) +let pr_existential env ev = prterm_env env (mkEvar ev) +let pr_inductive env ind = prterm_env env (mkInd ind) +let pr_constructor env cstr = prterm_env env (mkConstruct cstr) +let pr_global = pr_global Idset.empty + +let pr_rawterm t = + if !Options.v7 then gentermpr (Termast.ast_of_rawconstr t) + else Ppconstrnew.pr_lconstr (Constrextern.extern_rawconstr Idset.empty t) + +open Pattern +let pr_ref_label = function (* On triche sur le contexte *) + | ConstNode sp -> pr_constant (Global.env()) sp + | IndNode sp -> pr_inductive (Global.env()) sp + | CstrNode sp -> pr_constructor (Global.env()) sp + | VarNode id -> pr_id id + +let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t + +let pr_var_decl env (id,c,typ) = + let pbody = match c with + | None -> (mt ()) + | Some c -> + (* Force evaluation *) + let pb = prterm_env env c in + (str" := " ++ pb ++ cut () ) in + let pt = prtype_env 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 = prterm_env env c in + (str":=" ++ spc () ++ pb ++ spc ()) in + let ptyp = prtype_env 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 = + hv 0 (fold_named_context + (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d) + env ~init:(mt ())) + +let pr_rel_context env rel_context = + let rec prec env = function + | [] -> (mt ()) + | [b] -> + if !Options.v7 then pr_rel_decl env b + else str "(" ++ pr_rel_decl env b ++ str")" + | b::rest -> + let pb = pr_rel_decl env b in + let penvtl = prec (push_rel b env) rest in + if !Options.v7 then + (pb ++ str";" ++ spc () ++ penvtl) + else + (str "(" ++ pb ++ str")" ++ spc () ++ penvtl) + in + hov 0 (prec env (List.rev rel_context)) + +(* 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 (String.make 1 (Char.chr 253))) ++ + 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 (String.make 1 (Char.chr 253))) ++ + pnat)) + env ~init:(mt ()) + in + (sign_env ++ db_env) + +let pr_context_of env = match Options.print_hyps_limit () with + | None -> hv 0 (pr_context_unlimited env) + | Some n -> hv 0 (pr_context_limit n env) diff --git a/parsing/printer.mli b/parsing/printer.mli new file mode 100644 index 00000000..b4cd87b0 --- /dev/null +++ b/parsing/printer.mli @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds +*) + +val prterm_env : env -> constr -> std_ppcmds +val prterm_env_at_top : env -> constr -> std_ppcmds +val prterm : constr -> std_ppcmds +val prtype_env : env -> types -> std_ppcmds +val prtype : types -> std_ppcmds +val prjudge_env : + env -> Environ.unsafe_judgment -> std_ppcmds * std_ppcmds +val prjudge : Environ.unsafe_judgment -> std_ppcmds * std_ppcmds + +val pr_rawterm : Rawterm.rawconstr -> std_ppcmds +val pr_cases_pattern : Rawterm.cases_pattern -> 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_global : global_reference -> std_ppcmds +val pr_ref_label : constr_label -> std_ppcmds +val pr_pattern : constr_pattern -> std_ppcmds +val pr_pattern_env : env -> names_context -> constr_pattern -> std_ppcmds + +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_of : env -> std_ppcmds +val pr_rel_context : env -> rel_context -> std_ppcmds +val pr_context_of : env -> std_ppcmds + +val emacs_str : string -> string + diff --git a/parsing/printmod.ml b/parsing/printmod.ml new file mode 100644 index 00000000..aaf4a662 --- /dev/null +++ b/parsing/printmod.ml @@ -0,0 +1,133 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* pr_id (List.assoc mbid locals) + | MPdot(mp,l) -> + print_local_modpath locals mp ++ str "." ++ pr_lab l + | MPself _ | 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 -> + let (mp,_,l) = repr_kn kn in + print_local_modpath locals mp ++ str"." ++ pr_lab l + +let rec flatten_app mexpr l = match mexpr with + | MEBapply (mexpr,marg,_) -> flatten_app mexpr (marg::l) + | mexpr -> mexpr::l + +let rec print_module name locals with_body mb = + let body = match mb.mod_equiv, with_body, mb.mod_expr with + | None, false, _ + | None, true, None -> mt() + | None, true, Some mexpr -> + spc () ++ str ":= " ++ print_modexpr locals mexpr + | Some mp, _, _ -> str " == " ++ print_modpath locals mp + in + hv 2 (str "Module " ++ name ++ spc () ++ str": " ++ + print_modtype locals mb.mod_type ++ body) + +and print_modtype locals mty = match mty with + | MTBident kn -> print_kn locals kn + | MTBfunsig (mbid,mtb1,mtb2) -> +(* let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env + in *) + let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in + hov 2 (str "Funsig" ++ spc () ++ str "(" ++ + pr_id (id_of_mbid mbid) ++ str " : " ++ print_modtype locals mtb1 ++ + str ")" ++ spc() ++ print_modtype locals' mtb2) + | MTBsig (msid,sign) -> + hv 2 (str "Sig" ++ spc () ++ print_sig locals msid sign ++ brk (1,-2) ++ str "End") + +and print_sig locals msid sign = + let print_spec (l,spec) = (match spec with + | SPBconst {const_body=Some _; const_opaque=false} -> str "Definition " + | SPBconst {const_body=None} + | SPBconst {const_opaque=true} -> str "Parameter " + | SPBmind _ -> str "Inductive " + | SPBmodule _ -> str "Module " + | SPBmodtype _ -> str "Module Type ") ++ str (string_of_label l) + in + prlist_with_sep spc print_spec sign + +and print_struct locals msid struc = + let print_body (l,body) = (match body with + | SEBconst {const_body=Some _; const_opaque=false} -> str "Definition " + | SEBconst {const_body=Some _; const_opaque=true} -> str "Theorem " + | SEBconst {const_body=None} -> str "Parameter " + | SEBmind _ -> str "Inductive " + | SEBmodule _ -> str "Module " + | SEBmodtype _ -> str "Module Type ") ++ str (string_of_label l) + in + prlist_with_sep spc print_body struc + +and print_modexpr locals mexpr = match mexpr with + | MEBident mp -> print_modpath locals mp + | MEBfunctor (mbid,mty,mexpr) -> +(* let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env + in *) + let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in + hov 2 (str "Functor" ++ spc() ++ str"[" ++ pr_id(id_of_mbid mbid) ++ + str ":" ++ print_modtype locals mty ++ + str "]" ++ spc () ++ print_modexpr locals' mexpr) + | MEBstruct (msid, struc) -> + hv 2 (str "Struct" ++ spc () ++ print_struct locals msid struc ++ brk (1,-2) ++ str "End") + | MEBapply (mexpr,marg,_) -> + let lapp = flatten_app mexpr [marg] in + hov 3 (str"(" ++ prlist_with_sep spc (print_modexpr locals) lapp ++ str")") + + + +let rec printable_body dir = + let dir = dirpath_prefix 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 + + +let print_module with_body mp = + let name = print_modpath [] mp in + print_module name [] with_body (Global.lookup_module mp) ++ fnl () + +let print_modtype kn = + let name = print_kn [] kn in + str "Module Type " ++ name ++ str " = " ++ + print_modtype [] (Global.lookup_modtype kn) ++ fnl () diff --git a/parsing/printmod.mli b/parsing/printmod.mli new file mode 100644 index 00000000..2df0581c --- /dev/null +++ b/parsing/printmod.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool + +val print_module : bool -> module_path -> std_ppcmds + +val print_modtype : kernel_name -> std_ppcmds diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 new file mode 100644 index 00000000..aa0fce9d --- /dev/null +++ b/parsing/q_coqast.ml4 @@ -0,0 +1,567 @@ +(************************************************************************) +(* 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 = + let e = + let loc = unloc loc in + let loc = make_loc (1, snd loc - fst loc) in <:expr< $lid:purge_str x$ >> + in + <:expr< $anti:e$ >> + +(* [mlexpr_of_ast] contributes to translate g_*.ml4 files into g_*.ppo *) +(* This is where $id's (and macros) in ast are translated in ML variables *) +(* which will bind their actual ast value *) + +let rec mlexpr_of_ast = function + | Coqast.Nmeta (loc, id) -> anti loc id + | Coqast.Id (loc, id) when is_meta id -> <:expr< Coqast.Id loc $anti loc id$ >> + | Coqast.Node (_, "$VAR", [Coqast.Nmeta (loc, x)]) -> + <:expr< let s = $anti loc x$ in + if String.length s > 0 && String.sub s 0 1 = "$" then + failwith "Wrong ast: $VAR should not be bound to a meta variable" + else + Coqast.Nvar loc (Names.id_of_string s) >> + | Coqast.Node (_, "$PATH", [Coqast.Nmeta (loc, x)]) -> + <:expr< Coqast.Path loc $anti loc x$ >> + | Coqast.Node (_, "$ID", [Coqast.Nmeta (loc, x)]) -> + <:expr< Coqast.Id loc $anti loc x$ >> + | Coqast.Node (_, "$STR", [Coqast.Nmeta (loc, x)]) -> + <:expr< Coqast.Str loc $anti loc x$ >> +(* Obsolète + | Coqast.Node _ "$SLAM" [Coqast.Nmeta loc idl; y] -> + <:expr< + List.fold_right (Pcoq.slam_ast loc) $anti loc idl$ $mlexpr_of_ast y$ >> +*) + | Coqast.Node (loc, "$ABSTRACT", [Coqast.Str (_, s); x; y]) -> + let x = mlexpr_of_ast x in + let y = mlexpr_of_ast y in + <:expr< Ast.abstract_binders_ast loc $str:s$ $x$ $y$ >> + | Coqast.Node (loc, nn, al) -> + let e = expr_list_of_ast_list al in + <:expr< Coqast.Node loc $str:nn$ $e$ >> + | Coqast.Nvar (loc, id) -> + <:expr< Coqast.Nvar loc (Names.id_of_string $str:Names.string_of_id id$) >> + | Coqast.Slam (loc, None, a) -> + <:expr< Coqast.Slam loc None $mlexpr_of_ast a$ >> + | Coqast.Smetalam (loc, s, a) -> + <:expr< + match $anti loc s$ with + [ Coqast.Nvar _ id -> Coqast.Slam loc (Some id) $mlexpr_of_ast a$ + | Coqast.Nmeta _ s -> Coqast.Smetalam loc s $mlexpr_of_ast a$ + | _ -> failwith "Slam expects a var or a metavar" ] >> + | Coqast.Slam (loc, Some s, a) -> + let se = <:expr< Names.id_of_string $str:Names.string_of_id s$ >> in + <:expr< Coqast.Slam loc (Some $se$) $mlexpr_of_ast a$ >> + | Coqast.Num (loc, i) -> <:expr< Coqast.Num loc $int:string_of_int i$ >> + | Coqast.Id (loc, id) -> <:expr< Coqast.Id loc $str:id$ >> + | Coqast.Str (loc, str) -> <:expr< Coqast.Str loc $str:str$ >> + | Coqast.Path (loc, kn) -> + let l,a = Libnames.decode_kn kn in + let mlexpr_of_modid id = + <:expr< Names.id_of_string $str:string_of_id id$ >> in + let e = List.map mlexpr_of_modid (repr_dirpath l) in + let e = expr_list_of_var_list e in + <:expr< Coqast.Path loc (Libnames.encode_kn (Names.make_dirpath $e$) + (Names.id_of_string $str:Names.string_of_id a$)) >> + | Coqast.Dynamic (_, _) -> + failwith "Q_Coqast: dynamic: not implemented" + +and expr_list_of_ast_list al = + List.fold_right + (fun a e2 -> match a with + | (Coqast.Node (_, "$LIST", [Coqast.Nmeta (locv, pv)])) -> + let e1 = anti locv pv in + let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in + if e2 = (let loc = dummy_loc in <:expr< [] >>) + then <:expr< $e1$ >> + else <:expr< ( $lid:"@"$ $e1$ $e2$) >> + | _ -> + let e1 = mlexpr_of_ast a in + let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in + <:expr< [$e1$ :: $e2$] >> ) + al (let loc = dummy_loc in <:expr< [] >>) + +and expr_list_of_var_list sl = + let loc = dummy_loc in + List.fold_right + (fun e1 e2 -> + let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in + <:expr< [$e1$ :: $e2$] >>) + sl <:expr< [] >> + +(* 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_intro_pattern = function + | Genarg.IntroOrAndPattern _ -> failwith "mlexpr_of_intro_pattern: TODO" + | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >> + | Genarg.IntroIdentifier id -> + <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >> + +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 + | Rawterm.AnonHyp n -> <:expr< Rawterm.AnonHyp $mlexpr_of_int n$ >> + | Rawterm.NamedHyp id -> <:expr< Rawterm.NamedHyp $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_or_var f = function + | Genarg.ArgArg x -> <:expr< Genarg.ArgArg $f x$ >> + | Genarg.ArgVar id -> <:expr< Genarg.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_list mlexpr_of_int + +let mlexpr_of_hyp_location = function + | id, occs, (Tacexpr.InHyp,_) -> + <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHyp, ref None)) >> + | id, occs, (Tacexpr.InHypTypeOnly,_) -> + <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypTypeOnly, ref None)) >> + | id, occs, (Tacexpr.InHypValueOnly,_) -> + <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypValueOnly,ref None)) >> + +let mlexpr_of_clause cl = + <:expr< {Tacexpr.onhyps= + $mlexpr_of_option (mlexpr_of_list mlexpr_of_hyp_location) + cl.Tacexpr.onhyps$; + Tacexpr.onconcl= $mlexpr_of_bool cl.Tacexpr.onconcl$; + Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >> + +(* +let mlexpr_of_red_mode = function + | Closure.UNIFORM -> <:expr< Closure.UNIFORM >> + | Closure.SIMPL -> <:expr< Closure.SIMPL >> + | Closure.WITHBACK -> <:expr< Closure.WITHBACK >> +*) + +let mlexpr_of_red_flags { + Rawterm.rBeta = bb; + Rawterm.rIota = bi; + Rawterm.rZeta = bz; + Rawterm.rDelta = bd; + Rawterm.rConst = l +} = <:expr< { + Rawterm.rBeta = $mlexpr_of_bool bb$; + Rawterm.rIota = $mlexpr_of_bool bi$; + Rawterm.rZeta = $mlexpr_of_bool bz$; + Rawterm.rDelta = $mlexpr_of_bool bd$; + Rawterm.rConst = $mlexpr_of_list mlexpr_of_reference l$ +} >> + +let mlexpr_of_explicitation = function + | Topconstr.ExplByName id -> <:expr< Topconstr.ExplByName $mlexpr_of_ident id$ >> + | Topconstr.ExplByPos n -> <:expr< Topconstr.ExplByPos $mlexpr_of_int n$ >> + +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_pair (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> + | Topconstr.CLambdaN (loc,l,a) -> <:expr< Topconstr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_pair (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) 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.COrderedCase (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" + | Topconstr.CHole loc -> <:expr< Topconstr.CHole $dloc$ >> + | Topconstr.CNotation(_,ntn,l) -> + <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$ + $mlexpr_of_list mlexpr_of_constr l$ >> + | 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_pair (mlexpr_of_list mlexpr_of_int) mlexpr_of_constr + +let mlexpr_of_red_expr = function + | Rawterm.Red b -> <:expr< Rawterm.Red $mlexpr_of_bool b$ >> + | Rawterm.Hnf -> <:expr< Rawterm.Hnf >> + | Rawterm.Simpl o -> <:expr< Rawterm.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >> + | Rawterm.Cbv f -> + <:expr< Rawterm.Cbv $mlexpr_of_red_flags f$ >> + | Rawterm.Lazy f -> + <:expr< Rawterm.Lazy $mlexpr_of_red_flags f$ >> + | Rawterm.Unfold l -> + let f1 = mlexpr_of_list mlexpr_of_int in + let f2 = mlexpr_of_reference in + let f = mlexpr_of_list (mlexpr_of_pair f1 f2) in + <:expr< Rawterm.Unfold $f l$ >> + | Rawterm.Fold l -> + <:expr< Rawterm.Fold $mlexpr_of_list mlexpr_of_constr l$ >> + | Rawterm.Pattern l -> + let f = mlexpr_of_list mlexpr_of_occ_constr in + <:expr< Rawterm.Pattern $f l$ >> + | Rawterm.ExtraRedExpr (s,c) -> + let l = mlexpr_of_constr c in + <:expr< Rawterm.ExtraRedExpr $mlexpr_of_string s$ $l$ >> + +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 -> <:expr< Genarg.IdentArgType >> + | Genarg.HypArgType -> <:expr< Genarg.HypArgType >> + | Genarg.StringArgType -> <:expr< Genarg.StringArgType >> + | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >> + | Genarg.CastedOpenConstrArgType -> <:expr< Genarg.CastedOpenConstrArgType >> + | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >> + | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >> + | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >> + | Genarg.TacticArgType -> <:expr< Genarg.TacticArgType >> + | 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 + | Rawterm.ConstrEval (r,c) -> + <:expr< Rawterm.ConstrEval $mlexpr_of_red_expr r$ $f c$ >> + | Rawterm.ConstrContext ((loc,id),c) -> + let id = mlexpr_of_ident id in + <:expr< Rawterm.ConstrContext (loc,$id$) $f c$ >> + | Rawterm.ConstrTypeOf c -> + <:expr< Rawterm.ConstrTypeOf $mlexpr_of_constr c$ >> + | Rawterm.ConstrTerm c -> + <:expr< Rawterm.ConstrTerm $mlexpr_of_constr c$ >> + +let mlexpr_of_binding_kind = function + | Rawterm.ExplicitBindings l -> + let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in + <:expr< Rawterm.ExplicitBindings $l$ >> + | Rawterm.ImplicitBindings l -> + let l = mlexpr_of_list mlexpr_of_constr l in + <:expr< Rawterm.ImplicitBindings $l$ >> + | Rawterm.NoBindings -> + <:expr< Rawterm.NoBindings >> + +let mlexpr_of_induction_arg = function + | Tacexpr.ElimOnConstr c -> + <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr 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_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_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 (ido,t) -> + <:expr< Tacexpr.Subterm $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$ >> + +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 rec mlexpr_of_atomic_tactic = function + (* Basic tactics *) + | Tacexpr.TacIntroPattern pl -> + let pl = mlexpr_of_list 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_option (mlexpr_of_located mlexpr_of_ident) idopt' in + <:expr< Tacexpr.TacIntroMove $idopt$ $idopt'$ >> + | Tacexpr.TacAssumption -> + <:expr< Tacexpr.TacAssumption >> + | Tacexpr.TacExact c -> + <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >> + | Tacexpr.TacApply cb -> + <:expr< Tacexpr.TacApply $mlexpr_of_constr_with_binding cb$ >> + | Tacexpr.TacElim (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 $cb$ $cbo$ >> + | Tacexpr.TacElimType c -> + <:expr< Tacexpr.TacElimType $mlexpr_of_constr c$ >> + | Tacexpr.TacCase cb -> + let cb = mlexpr_of_constr_with_binding cb in + <:expr< Tacexpr.TacCase $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 (id,n,l) -> + 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 $id$ $n$ $l$ >> + | Tacexpr.TacCofix ido -> + let ido = mlexpr_of_ident_option ido in + <:expr< Tacexpr.TacCofix $ido$ >> + | Tacexpr.TacMutualCofix (id,l) -> + 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 $id$ $l$ >> + + | Tacexpr.TacCut c -> + <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >> + | Tacexpr.TacTrueCut (na,c) -> + let na = mlexpr_of_name na in + <:expr< Tacexpr.TacTrueCut $na$ $mlexpr_of_constr c$ >> + | Tacexpr.TacForward (b,na,c) -> + <:expr< Tacexpr.TacForward $mlexpr_of_bool b$ $mlexpr_of_name na$ $mlexpr_of_constr c$ >> + | Tacexpr.TacGeneralize cl -> + <:expr< Tacexpr.TacGeneralize $mlexpr_of_list mlexpr_of_constr cl$ >> + | Tacexpr.TacGeneralizeDep c -> + <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >> + | Tacexpr.TacLetTac (na,c,cl) -> + let na = mlexpr_of_name na in + let cl = mlexpr_of_clause_pattern cl in + <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$ >> + + (* Derived basic tactics *) + | Tacexpr.TacSimpleInduction (h,_) -> + <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$,ref []) >> + | Tacexpr.TacNewInduction (c,cbo,ids) -> + let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in + let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in + <:expr< Tacexpr.TacNewInduction $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref [])>> + | Tacexpr.TacSimpleDestruct h -> + <:expr< Tacexpr.TacSimpleDestruct $mlexpr_of_quantified_hypothesis h$ >> + | Tacexpr.TacNewDestruct (c,cbo,ids) -> + let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in + let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in + <:expr< Tacexpr.TacNewDestruct $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref []) >> + + (* Context management *) + | Tacexpr.TacClear l -> + let l = mlexpr_of_list (mlexpr_of_hyp) l in + <:expr< Tacexpr.TacClear $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_hyp id2$ >> + + (* Constructors *) + | Tacexpr.TacLeft l -> + <:expr< Tacexpr.TacLeft $mlexpr_of_binding_kind l$>> + | Tacexpr.TacRight l -> + <:expr< Tacexpr.TacRight $mlexpr_of_binding_kind l$>> + | Tacexpr.TacSplit (b,l) -> + <:expr< Tacexpr.TacSplit + ($mlexpr_of_bool b$,$mlexpr_of_binding_kind l$)>> + | Tacexpr.TacAnyConstructor t -> + <:expr< Tacexpr.TacAnyConstructor $mlexpr_of_option mlexpr_of_tactic t$>> + | Tacexpr.TacConstructor (n,l) -> + let n = mlexpr_of_or_metaid mlexpr_of_int n in + <:expr< Tacexpr.TacConstructor $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 (occl,c,cl) -> + let l = mlexpr_of_clause cl in + let g = mlexpr_of_option mlexpr_of_occ_constr in + <:expr< Tacexpr.TacChange $g occl$ $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_constr c$ >> + + (* Automation tactics *) + | Tacexpr.TacAuto (n,l) -> + let n = mlexpr_of_option mlexpr_of_int n in + let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in + <:expr< Tacexpr.TacAuto $n$ $l$ >> +(* + | Tacexpr.TacTrivial l -> + let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in + <:expr< Tacexpr.TacTrivial $l$ >> +*) + +(* + | Tacexpr.TacExtend (s,l) -> + let l = mlexpr_of_list mlexpr_of_tactic_arg l in + let $dloc$ = MLast.loc_of_expr l in + <:expr< Tacexpr.TacExtend $mlexpr_of_string s$ $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.TacRepeat t -> + <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >> + | Tacexpr.TacProgress t -> + <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >> + | Tacexpr.TacId s -> <:expr< Tacexpr.TacId $str:s$ >> + | Tacexpr.TacFail (n,s) -> <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $str:s$ >> +(* + | 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 (l,t) -> + let f = + mlexpr_of_triple + (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_ident) + (mlexpr_of_option mlexpr_of_tactic) + mlexpr_of_tactic_arg in + <:expr< Tacexpr.TacLetIn $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >> + | Tacexpr.TacMatch (t,l) -> + <:expr< Tacexpr.TacMatch + $mlexpr_of_tactic t$ + $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> + | Tacexpr.TacMatchContext (lr,l) -> + <:expr< Tacexpr.TacMatchContext + $mlexpr_of_bool lr$ + $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> +(* + | Tacexpr.TacFun of $dloc$ * tactic_fun_ast + | Tacexpr.TacFunRec of $dloc$ * identifier * tactic_fun_ast +*) +(* + | Tacexpr.TacArg (Tacexpr.AstTacArg (Coqast.Nmeta $dloc$ id)) -> anti loc id +*) + | Tacexpr.TacArg (Tacexpr.MetaIdArg (_,id)) -> anti loc id + | Tacexpr.TacArg t -> + <:expr< Tacexpr.TacArg $mlexpr_of_tactic_arg t$ >> + | _ -> failwith "Quotation of tactic expressions: TODO" + +and mlexpr_of_tactic_arg = function + | Tacexpr.MetaIdArg (loc,id) -> 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" + +let f e = + let ee s = + mlexpr_of_ast (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 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.add "vernac" (f Pcoq.Vernac_.vernac_eoi);*) +(* Quotation.add "ast" (f Pcoq.Prim.ast_eoi);*) + Quotation.default := "constr" diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4 new file mode 100644 index 00000000..b3f5393c --- /dev/null +++ b/parsing/q_util.ml4 @@ -0,0 +1,68 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* > -> <:patt< $patt_of_expr e1$.$patt_of_expr e2$ >> + | <:expr< $e1$ $e2$ >> -> <:patt< $patt_of_expr e1$ $patt_of_expr e2$ >> + | <:expr< loc >> -> <:patt< _ >> + | <:expr< $lid:s$ >> -> <:patt< $lid:s$ >> + | <:expr< $uid:s$ >> -> <:patt< $uid:s$ >> + | <:expr< $str:s$ >> -> <:patt< $str:s$ >> + | <:expr< $anti:e$ >> -> <:patt< $anti:patt_of_expr e$ >> + | _ -> not_impl "patt_of_expr" e + +let mlexpr_of_list f l = + List.fold_right + (fun e1 e2 -> + let e1 = f e1 in + let loc = (fst (MLast.loc_of_expr e1), snd (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 = (fst (MLast.loc_of_expr e1), snd (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 = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e3)) in + <:expr< ($e1$, $e2$, $e3$) >> + +(* 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$ >> diff --git a/parsing/q_util.mli b/parsing/q_util.mli new file mode 100644 index 00000000..a2c22bc3 --- /dev/null +++ b/parsing/q_util.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* MLast.patt + +val mlexpr_of_list : ('a -> 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_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 + diff --git a/parsing/search.ml b/parsing/search.ml new file mode 100644 index 00000000..a3d6e000 --- /dev/null +++ b/parsing/search.ml @@ -0,0 +1,224 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* head_const d + | LetIn (_,_,_,d) -> head_const d + | App (f,_) -> head_const f + | Cast (d,_) -> head_const d + | _ -> c + +(* General search, restricted to head constant if [only_head] *) + +let gen_crible refopt (fn : global_reference -> env -> constr -> unit) = + let env = Global.env () in + let imported = Library.opened_libraries() in + let crible_rec (sp,_) lobj = match object_tag lobj with + | "VARIABLE" -> + (try + let (idc,_,typ) = get_variable (basename sp) in + if refopt = None + || head_const typ = constr_of_reference (out_some refopt) + then + fn (VarRef idc) env typ + with Not_found -> (* we are in a section *) ()) + | "CONSTANT" -> + let kn = locate_constant (qualid_of_sp sp) in + let {const_type=typ} = Global.lookup_constant kn in + if refopt = None + || head_const typ = constr_of_reference (out_some refopt) + then + fn (ConstRef kn) env typ + | "INDUCTIVE" -> + let kn = locate_mind (qualid_of_sp sp) in + let mib = Global.lookup_mind kn in + (match refopt with + | Some (IndRef ((kn',tyi) as ind)) when kn=kn' -> + print_constructors ind fn env + (Array.length (mib.mind_packets.(tyi).mind_user_lc)) + | Some _ -> () + | _ -> + Array.iteri + (fun i mip -> print_constructors (kn,i) fn env + (Array.length mip.mind_user_lc)) mib.mind_packets) + | _ -> () + in + try + Declaremods.iter_all_segments false crible_rec + with Not_found -> + () + +let crible ref = gen_crible (Some ref) + +(* Fine Search. By Yves Bertot. *) + +exception No_section_path + +let rec head c = + let c = strip_outer_cast c in + match kind_of_term c with + | Prod (_,_,c) -> head c + | LetIn (_,_,_,c) -> head c + | _ -> c + +let constr_to_section_path c = match kind_of_term c with + | Const sp -> sp + | _ -> raise No_section_path + +let xor a b = (a or b) & (not (a & b)) + +let plain_display ref a c = + let pc = prterm_env a c in + let pr = pr_global ref in + msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ()) + +let filter_by_module (module_list:dir_path list) (accept:bool) + (ref:global_reference) _ _ = + try + let sp = sp_of_global ref in + let sl = dirpath sp in + let rec filter_aux = function + | m :: tl -> (not (is_dirpath_prefix_of m sl)) && (filter_aux tl) + | [] -> true + in + xor accept (filter_aux module_list) + with No_section_path -> + false + +let gref_eq = + IndRef (Libnames.encode_kn Coqlib.logic_module (id_of_string "eq"), 0) +let gref_eqT = + IndRef (Libnames.encode_kn Coqlib.logic_type_module (id_of_string "eqT"), 0) + +let mk_rewrite_pattern1 eq pattern = + PApp (PRef eq, [| PMeta None; pattern; PMeta None |]) + +let mk_rewrite_pattern2 eq pattern = + PApp (PRef eq, [| PMeta None; PMeta None; pattern |]) + +let pattern_filter pat _ a c = + try + try + is_matching pat (head c) + with _ -> + is_matching + pat (head (Typing.type_of (Global.env()) Evd.empty c)) + with UserError _ -> + false + +let filtered_search filter_function display_function ref = + crible ref + (fun s a c -> if filter_function s a c then display_function s a c) + +let rec id_from_pattern = function + | PRef gr -> gr +(* should be appear as a PRef (VarRef sp) !! + | PVar id -> Nametab.locate (make_qualid [] (string_of_id id)) + *) + | PApp (p,_) -> id_from_pattern p + | _ -> error "the pattern is not simple enough" + +let raw_pattern_search extra_filter display_function pat = + let name = id_from_pattern pat in + filtered_search + (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c) + display_function name + +let raw_search_rewrite extra_filter display_function pattern = + filtered_search + (fun s a c -> + ((pattern_filter (mk_rewrite_pattern1 gref_eq pattern) s a c) || + (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c)) + && extra_filter s a c) + display_function gref_eq +(* + ; + filtered_search + (fun s a c -> + ((pattern_filter (mk_rewrite_pattern1 gref_eqT pattern) s a c) || + (pattern_filter (mk_rewrite_pattern2 gref_eqT pattern) s a c)) + && extra_filter s a c) + display_function gref_eqT +*) + +let text_pattern_search extra_filter = + raw_pattern_search extra_filter plain_display + +let text_search_rewrite extra_filter = + raw_search_rewrite extra_filter plain_display + +let filter_by_module_from_list = function + | [], _ -> (fun _ _ _ -> true) + | l, outside -> filter_by_module l (not outside) + +let search_by_head ref inout = + filtered_search (filter_by_module_from_list inout) plain_display ref + +let search_rewrite pat inout = + text_search_rewrite (filter_by_module_from_list inout) pat + +let search_pattern pat inout = + text_pattern_search (filter_by_module_from_list inout) pat + + +let gen_filtered_search filter_function display_function = + gen_crible None + (fun s a c -> if filter_function s a c then display_function s a c) + +(** SearchAbout *) + +let name_of_reference ref = string_of_id (id_of_global ref) + +type glob_search_about_item = + | GlobSearchRef of global_reference + | GlobSearchString of string + +let search_about_item (itemref,typ) = function + | GlobSearchRef ref -> Termops.occur_term (constr_of_reference ref) typ + | GlobSearchString s -> string_string_contains (name_of_reference itemref) s + +let raw_search_about filter_modules display_function l = + let filter ref' env typ = + filter_modules ref' env typ && + List.for_all (search_about_item (ref',typ)) l + in + gen_filtered_search filter display_function + +let search_about ref inout = + raw_search_about (filter_by_module_from_list inout) plain_display ref diff --git a/parsing/search.mli b/parsing/search.mli new file mode 100644 index 00000000..62ba865d --- /dev/null +++ b/parsing/search.mli @@ -0,0 +1,49 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* dir_path list * bool -> unit +val search_rewrite : constr_pattern -> dir_path list * bool -> unit +val search_pattern : constr_pattern -> dir_path list * bool -> unit +val search_about : glob_search_about_item list -> dir_path list * bool -> unit + +(* The filtering function that is by standard search facilities. + It can be passed as argument to the raw search functions. + It is used in pcoq. *) + +val filter_by_module_from_list : + dir_path list * bool -> global_reference -> env -> 'a -> bool + +(* raw search functions can be used for various extensions. + They are also used for pcoq. *) +val gen_filtered_search : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> unit +val filtered_search : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> global_reference -> unit +val raw_pattern_search : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> constr_pattern -> unit +val raw_search_rewrite : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> constr_pattern -> unit +val raw_search_about : (global_reference -> env -> constr -> bool) -> + (global_reference -> env -> constr -> unit) -> + glob_search_about_item list -> unit diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 new file mode 100644 index 00000000..bbacd013 --- /dev/null +++ b/parsing/tacextend.ml4 @@ -0,0 +1,283 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* > + +type grammar_tactic_production_expr = + | TacTerm of string + | TacNonTerm of Util.loc * Genarg.argument_type * MLast.expr * string option + +let rec make_patt = function + | [] -> <:patt< [] >> + | TacNonTerm(loc',_,_,Some p)::l -> + <:patt< [ $lid:p$ :: $make_patt l$ ] >> + | _::l -> make_patt l + +let rec make_when loc = function + | [] -> <:expr< True >> + | TacNonTerm(loc',t,_,Some p)::l -> + 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 + | TacNonTerm(loc,t,_,Some p)::l -> + 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 + let v = + (* Special case for tactics which must be stored in algebraic + form to avoid marshalling closures and to be reprinted *) + if t = TacticArgType then + <:expr< ($v$, Tacinterp.eval_tactic $v$) >> + else v in + <:expr< let $lid:p$ = $v$ in $e$ >> + | _::l -> make_let e l + +let add_clause s (_,pt,e) l = + let p = make_patt pt in + let w = Some (make_when (MLast.loc_of_expr e) pt) in + (p, w, make_let e pt)::l + +let rec extract_signature = function + | [] -> [] + | TacNonTerm (_,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_clauses s l = + check_unicity s l; + let default = + (<:patt< _ >>,None,<:expr< failwith "Tactic extension: cannot occur" >>) in + List.fold_right (add_clause s) l [default] + +let rec make_args = function + | [] -> <:expr< [] >> + | TacNonTerm(loc,t,_,Some p)::l -> + <: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 + | TacNonTerm(loc,TacticArgType,_,Some p)::l -> + let loc = join_loc loc (MLast.loc_of_expr e) in + let e = make_eval_tactic e l in + (* Special case for tactics which must be stored in algebraic + form to avoid marshalling closures and to be reprinted *) + <:expr< let $lid:p$ = ($lid:p$,Tacinterp.eval_tactic $lid:p$) in $e$ >> + | _::l -> make_eval_tactic e l + +let rec make_fun e = function + | [] -> e + | TacNonTerm(loc,_,_,Some p)::l -> + <:expr< fun $lid:p$ -> $make_fun e l$ >> + | _::l -> make_fun e l + +let mlexpr_of_grammar_production = function + | TacTerm s -> + <:expr< Egrammar.TacTerm $mlexpr_of_string s$ >> + | TacNonTerm (loc,nt,g,sopt) -> + <:expr< Egrammar.TacNonTerm $default_loc$ ($g$,$mlexpr_of_argtype loc nt$) $mlexpr_of_option mlexpr_of_string sopt$ >> + +let mlexpr_terminals_of_grammar_production = function + | TacTerm s -> <:expr< Some $mlexpr_of_string s$ >> + | TacNonTerm (loc,nt,g,sopt) -> <:expr< None >> + +let mlexpr_of_semi_clause = + mlexpr_of_pair mlexpr_of_string (mlexpr_of_list mlexpr_of_grammar_production) + +let mlexpr_of_clause = + mlexpr_of_list (fun (a,b,c) -> mlexpr_of_semi_clause (a,b)) + +let rec make_tags loc = function + | [] -> <:expr< [] >> + | TacNonTerm(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 (s,pt,e) = + let loc = MLast.loc_of_expr e in + let prods = mlexpr_of_list mlexpr_terminals_of_grammar_production pt in + <:expr< ($make_tags loc pt$, ($str:s$, $prods$)) >> + +let make_printing_rule = mlexpr_of_list make_one_printing_rule + +let new_tac_ext (s,cl) = + (String.lowercase s, List.map + (fun (s,l,e) -> + (String.lowercase s, List.map + (function TacTerm s -> TacTerm (String.lowercase s) + | t -> t) l, + e)) + cl) + +let declare_tactic_v7 loc s cl = + let pp = make_printing_rule 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 = let s = "h_"^s in s.[2] <- Char.lowercase s.[2]; 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 se = mlexpr_of_string s in + <:str_item< + declare + open Pcoq; + Egrammar.extend_tactic_grammar $se$ $gl$; + List.iter (Pptactic.declare_extra_tactic_pprule False $se$) $pp$; + end + >> + +let rec contains_epsilon = function + | List0ArgType _ -> true + | List1ArgType t -> contains_epsilon t + | OptArgType _ -> true + | PairArgType(t1,t2) -> contains_epsilon t1 && contains_epsilon t2 + | ExtraArgType("hintbases") -> true + | _ -> false +let is_atomic = + List.for_all + (function + TacTerm _ -> false + | TacNonTerm(_,t,_,_) -> contains_epsilon t) + +let declare_tactic loc s cl = + let (s',cl') = new_tac_ext (s,cl) in + let pp' = make_printing_rule cl' in + let gl' = mlexpr_of_clause cl' in + let se' = mlexpr_of_string s' in + let pp = make_printing_rule 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 se = mlexpr_of_string s in + let atomic_tactics = + mlexpr_of_list (fun (s,_,_) -> mlexpr_of_string s) + (List.filter (fun (_,al,_) -> is_atomic al) cl') in + <:str_item< + declare + open Pcoq; + declare $list:hidden$ end; + try + let _=Refiner.add_tactic $se'$ (fun [ $list:make_clauses s' cl'$ ]) in + List.iter + (fun s -> Tacinterp.add_primitive_tactic s + (Tacexpr.TacAtom($default_loc$, + Tacexpr.TacExtend($default_loc$,s,[])))) + $atomic_tactics$ + with e -> Pp.pp (Cerrors.explain_exn e); + if Options.v7.val then Egrammar.extend_tactic_grammar $se'$ $gl$ + else Egrammar.extend_tactic_grammar $se'$ $gl'$; + List.iter (Pptactic.declare_extra_tactic_pprule True $se'$) $pp'$; + List.iter (Pptactic.declare_extra_tactic_pprule False $se'$) $pp$; + end + >> + +open Vernacexpr +open Pcoq + +let rec interp_entry_name loc s = + let l = String.length s in + if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in + List1ArgType t, <:expr< Gramext.Slist1 $g$ >> + else if l > 5 & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in + List0ArgType t, <:expr< Gramext.Slist0 $g$ >> + else if l > 4 & String.sub s (l-4) 4 = "_opt" then + let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in + OptArgType t, <:expr< Gramext.Sopt $g$ >> + else + + let t, se = + match Pcoq.entry_type (Pcoq.get_univ "prim") s with + | Some _ as x -> x, <:expr< Prim. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "constr") s with + | Some _ as x -> x, <:expr< Constr. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "tactic") s with + | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> + | None -> None, <:expr< $lid:s$ >> in + let t = + match t with + | Some t -> t + | None -> +(* Pp.warning_with Pp_control.err_ft + ("Unknown primitive grammar entry: "^s);*) + ExtraArgType s + in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> + +open Pcaml + +EXTEND + GLOBAL: str_item; + str_item: + [ [ "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ]; + OPT "|"; l = LIST1 tacrule SEP "|"; + "END" -> + declare_tactic loc s l + | "V7"; "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ]; + OPT "|"; l = LIST1 tacrule SEP "|"; + "END" -> + declare_tactic_v7 loc s l ] ] + ; + tacrule: + [ [ "["; s = STRING; l = LIST0 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]" + -> + if s = "" then Util.user_err_loc (loc,"",Pp.str "Tactic name is empty"); + (s,l,e) + ] ] + ; + tacargs: + [ [ e = LIDENT; "("; s = LIDENT; ")" -> + let t, g = interp_entry_name loc e in + TacNonTerm (loc, t, g, Some s) + | s = STRING -> + TacTerm s + ] ] + ; + END + diff --git a/parsing/termast.ml b/parsing/termast.ml new file mode 100644 index 00000000..47e45d42 --- /dev/null +++ b/parsing/termast.ml @@ -0,0 +1,503 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* o := old; raise e + +let with_arguments f = with_option print_arguments f +let with_casts f = with_option print_casts f +let with_implicits f = with_option print_implicits f +let with_coercions f = with_option print_coercions f +let with_universes f = with_option print_universes f +*) +(**********************************************************************) +(* conversion of references *) + +let ids_of_ctxt ctxt = + Array.to_list + (Array.map + (function c -> match kind_of_term c with + | Var id -> id + | _ -> + error + "Termast: arbitrary substitution of references not yet implemented") + ctxt) + +let ast_of_ident id = nvar id + +let ast_of_name = function + | Name id -> nvar id + | Anonymous -> nvar wildcard + +let idopt_of_name = function + | Name id -> Some id + | Anonymous -> None + +let ast_of_binders bl = + List.map (fun (nal,isdef,ty) -> + if isdef then ope("LETBINDER",ty::List.map ast_of_name nal) + else ope("BINDER",ty::List.map ast_of_name nal)) bl + +let ast_type_of_binder bl t = + List.fold_right (fun (nal,isdef,ty) ast -> + if isdef then + ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)]) + else + ope("PROD",[ty;List.fold_right + (fun na ast -> slam(idopt_of_name na,ast)) nal ast])) + bl t + +let ast_body_of_binder bl t = + List.fold_right (fun (nal,isdef,ty) ast -> + if isdef then + ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)]) + else + ope("LAMBDA",[ty;List.fold_right + (fun na ast -> slam(idopt_of_name na,ast)) nal ast])) + bl t + +let ast_of_constant_ref sp = + ope("CONST", [path_section dummy_loc sp]) + +let ast_of_existential_ref ev = +(* + let ev = + try int_of_string (string_of_id ev) + with _ -> warning "cannot find existential variable number"; 0 in +*) + ope("EVAR", [num ev]) + +let ast_of_constructor_ref ((sp,tyi),n) = + ope("MUTCONSTRUCT",[path_section dummy_loc sp; num tyi; num n]) + +let ast_of_inductive_ref (sp,tyi) = + ope("MUTIND", [path_section dummy_loc sp; num tyi]) + +let ast_of_section_variable_ref s = + ope("SECVAR", [nvar s]) + +let ast_of_qualid p = + let dir, s = repr_qualid p in + let args = List.map nvar ((List.rev(repr_dirpath dir))@[s]) in + ope ("QUALID", args) + +let ast_of_ref = function + | ConstRef sp -> ast_of_constant_ref sp + | IndRef sp -> ast_of_inductive_ref sp + | ConstructRef sp -> ast_of_constructor_ref sp + | VarRef id -> ast_of_section_variable_ref id + +(**********************************************************************) +(* conversion of patterns *) + +let rec ast_of_cases_pattern = function (* loc is thrown away for printing *) + | PatVar (loc,Name id) -> nvar id + | PatVar (loc,Anonymous) -> nvar wildcard + | PatCstr(loc,cstrsp,args,Name id) -> + let args = List.map ast_of_cases_pattern args in + ope("PATTAS", + [nvar id; + ope("PATTCONSTRUCT", (ast_of_constructor_ref cstrsp)::args)]) + | PatCstr(loc,cstrsp,args,Anonymous) -> + ope("PATTCONSTRUCT", + (ast_of_constructor_ref cstrsp) + :: List.map ast_of_cases_pattern args) + +let ast_dependent na aty = + match na with + | Name id -> occur_var_ast id aty + | Anonymous -> false + +let decompose_binder = function + | RProd(_,na,ty,c) -> Some (BProd,na,ty,c) + | RLambda(_,na,ty,c) -> Some (BLambda,na,ty,c) + | RLetIn(_,na,b,c) -> Some (BLetIn,na,b,c) + | _ -> None + +(* Implicit args indexes are in ascending order *) +let explicitize impl args = + let n = List.length args in + let rec exprec q = function + | a::args, imp::impl when is_status_implicit imp -> + let tail = exprec (q+1) (args,impl) in + let visible = + (!print_implicits & !print_implicits_explicit_args) + or not (is_inferable_implicit false n imp) in + if visible then ope("EXPL", [num q; a]) :: tail else tail + | a::args, _::impl -> a :: exprec (q+1) (args,impl) + | args, [] -> args (* In case of polymorphism *) + | [], _ -> [] + in exprec 1 (args,impl) + +let rec skip_coercion dest_ref (f,args as app) = + if !print_coercions then app + else + try + match dest_ref f with + | Some r -> + (match Classops.hide_coercion r with + | Some n -> + if n >= List.length args then app + else (* We skip a coercion *) + let fargs = list_skipn n args in + skip_coercion dest_ref (List.hd fargs,List.tl fargs) + | None -> app) + | None -> app + with Not_found -> app + +let ast_of_app impl f args = + if !print_implicits & not !print_implicits_explicit_args then + ope("APPLISTEXPL", f::args) + else + let args = explicitize impl args in + if args = [] then f else ope("APPLIST", f::args) + +let rec ast_of_raw = function + | RRef (_,ref) -> ast_of_ref ref + | RVar (_,id) -> ast_of_ident id + | REvar (_,n,_) -> (* we drop args *) ast_of_existential_ref n + | RPatVar (_,(_,n)) -> ope("META",[ast_of_ident n]) + | RApp (_,f,args) -> + let (f,args) = + skip_coercion (function RRef(_,r) -> Some r | _ -> None) (f,args) in + let astf = ast_of_raw f in + let astargs = List.map ast_of_raw args in + (match f with + | RRef (_,ref) -> ast_of_app (implicits_of_global ref) astf astargs + | _ -> ast_of_app [] astf astargs) + + | RProd (_,Anonymous,t,c) -> + (* Anonymous product are never factorized *) + ope("ARROW",[ast_of_raw t; slam(None,ast_of_raw c)]) + + | RLetIn (_,na,t,c) -> + ope("LETIN",[ast_of_raw t; slam(idopt_of_name na,ast_of_raw c)]) + + | RProd (_,na,t,c) -> + let (n,a) = factorize_binder 1 BProd na (ast_of_raw t) c in + (* PROD et PRODLIST doivent être distingués à cause du cas *) + (* non dépendant, pour isoler l'implication; peut-être un *) + (* constructeur ARROW serait-il plus justifié ? *) + let tag = if n=1 then "PROD" else "PRODLIST" in + ope(tag,[ast_of_raw t;a]) + + | RLambda (_,na,t,c) -> + let (n,a) = factorize_binder 1 BLambda na (ast_of_raw t) c in + (* LAMBDA et LAMBDALIST se comportent pareil ... Non ! *) + (* Pour compatibilité des theories, il faut LAMBDALIST partout *) + ope("LAMBDALIST",[ast_of_raw t;a]) + + | RCases (_,(typopt,_),tml,eqns) -> + let pred = ast_of_rawopt typopt in + let tag = "CASES" in + let asttomatch = + ope("TOMATCH", List.map (fun (tm,_) -> ast_of_raw tm) tml) in + let asteqns = List.map ast_of_eqn eqns in + ope(tag,pred::asttomatch::asteqns) + + | ROrderedCase (_,LetStyle,typopt,tm,[|bv|],_) -> + let nvar' = function Anonymous -> nvar wildcard | Name id -> nvar id in + let rec f l = function + | RLambda (_,na,RHole _,c) -> f (nvar' na :: l) c + | RLetIn (_,na,RHole _,c) -> f (nvar' na :: l) c + | c -> List.rev l, ast_of_raw c in + let l,c = f [] bv in + let eqn = ope ("EQN", [c;ope ("PATTCONSTRUCT",(nvar wildcard)::l)]) in + ope ("FORCELET",[(ast_of_rawopt typopt);(ast_of_raw tm);eqn]) + + | ROrderedCase (_,st,typopt,tm,bv,_) -> + let tag = match st with + | IfStyle -> "FORCEIF" + | RegularStyle -> "CASE" + | MatchStyle | LetStyle -> "MATCH" + in + + (* warning "Old Case syntax"; *) + ope(tag,(ast_of_rawopt typopt) + ::(ast_of_raw tm) + ::(Array.to_list (Array.map ast_of_raw bv))) + + | RLetTuple _ | RIf _ -> + error "Let tuple not supported in v7" + + | RRec (_,fk,idv,blv,tyv,bv) -> + let alfi = Array.map ast_of_ident idv in + (match fk with + | RFix (nv,n) -> + let rec split_lambda binds = function + | (0, t) -> (List.rev binds,ast_of_raw t) + | (n, RLetIn (_,na,b,c)) -> + let bind = ope("LETBINDER",[ast_of_raw b;ast_of_name na]) in + split_lambda (bind::binds) (n,c) + | (n, RLambda (_,na,t,b)) -> + let bind = ope("BINDER",[ast_of_raw t;ast_of_name na]) in + split_lambda (bind::binds) (n-1,b) + | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint body" in + let rec split_product = function + | (0, t) -> ast_of_raw t + | (n, RLetIn (_,na,_,c)) -> split_product (n,c) + | (n, RProd (_,na,t,b)) -> split_product (n-1,b) + | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint type" in + let listdecl = + Array.mapi + (fun i fi -> + if List.length blv.(i) >= nv.(i)+1 then + let (oldfixp,factb) = list_chop (nv.(i)+1) blv.(i) in + let bl = factorize_local_binder oldfixp in + let factb = factorize_local_binder factb in + let asttyp = ast_type_of_binder factb + (ast_of_raw tyv.(i)) in + let astdef = ast_body_of_binder factb + (ast_of_raw bv.(i)) in + ope("FDECL",[fi;ope("BINDERS",ast_of_binders bl); + asttyp; astdef]) + else + let n = nv.(i)+1 - List.length blv.(i) in + let (lparams,astdef) = + split_lambda [] (n,bv.(i)) in + let bl = factorize_local_binder blv.(i) in + let lparams = ast_of_binders bl @ lparams in + let asttyp = split_product (n,tyv.(i)) in + ope("FDECL", + [fi; ope ("BINDERS",lparams); + asttyp; astdef])) + alfi + in + ope("FIX", alfi.(n)::(Array.to_list listdecl)) + | RCoFix n -> + let listdecl = + Array.mapi + (fun i fi -> + let bl = factorize_local_binder blv.(i) in + let asttyp = ast_type_of_binder bl (ast_of_raw tyv.(i)) in + let astdef = ast_body_of_binder bl (ast_of_raw bv.(i)) in + ope("CFDECL",[fi; asttyp; astdef])) + alfi + in + ope("COFIX", alfi.(n)::(Array.to_list listdecl))) + + | RSort (_,s) -> + (match s with + | RProp Null -> ope("PROP",[]) + | RProp Pos -> ope("SET",[]) + | RType (Some u) when !print_universes -> ope("TYPE",[ide(Univ.string_of_univ u)]) + | RType _ -> ope("TYPE",[])) + | RHole _ -> ope("ISEVAR",[]) + | RCast (_,c,t) -> ope("CAST",[ast_of_raw c;ast_of_raw t]) + | RDynamic (loc,d) -> Dynamic (loc,d) + +and ast_of_eqn (_,ids,pl,c) = + ope("EQN", (ast_of_raw c)::(List.map ast_of_cases_pattern pl)) + +and ast_of_rawopt = function + | None -> (string "SYNTH") + | Some p -> ast_of_raw p + +and factorize_binder n oper na aty c = + let (p,body) = match decompose_binder c with + | Some (oper',na',ty',c') + when (oper = oper') & (aty = ast_of_raw ty') + & not (ast_dependent na aty) (* To avoid na in ty' escapes scope *) + & not (na' = Anonymous & oper = BProd) + -> factorize_binder (n+1) oper na' aty c' + | _ -> (n,ast_of_raw c) + in + (p,slam(idopt_of_name na, body)) + +and factorize_local_binder = function + [] -> [] + | (na,Some bd,ty)::l -> + ([na],true,ast_of_raw bd) :: factorize_local_binder l + | (na,None,ty)::l -> + let ty = ast_of_raw ty in + (match factorize_local_binder l with + (lna,false,ty') :: l when ty=ty' -> + (na::lna,false,ty') :: l + | l -> ([na],false,ty) :: l) + + +let ast_of_rawconstr = ast_of_raw + +(******************************************************************) +(* Main translation function from constr -> ast *) + +let ast_of_constr at_top env t = + let t' = + if !print_casts then t + else Reductionops.local_strong strip_outer_cast t in + let avoid = if at_top then ids_of_context env else [] in + ast_of_raw + (Detyping.detype (at_top,env) avoid (names_of_rel_context env) t') + +let ast_of_constant env sp = + let a = ast_of_constant_ref sp in + a + +let ast_of_existential env (ev,ids) = + let a = ast_of_existential_ref ev in + if !print_arguments or !print_evar_arguments then + ope("INSTANCE",a::(array_map_to_list (ast_of_constr false env) ids)) + else a + +let ast_of_constructor env cstr_sp = + let a = ast_of_constructor_ref cstr_sp in + a + +let ast_of_inductive env ind_sp = + let a = ast_of_inductive_ref ind_sp in + a + +let decompose_binder_pattern = function + | PProd(na,ty,c) -> Some (BProd,na,ty,c) + | PLambda(na,ty,c) -> Some (BLambda,na,ty,c) + | PLetIn(na,b,c) -> Some (BLetIn,na,b,c) + | _ -> None + +let rec ast_of_pattern tenv env = function + | PRef ref -> ast_of_ref ref + + | PVar id -> ast_of_ident id + + | PEvar (n,_) -> ast_of_existential_ref n + + | PRel n -> + (try match lookup_name_of_rel n env with + | Name id -> ast_of_ident id + | Anonymous -> + anomaly "ast_of_pattern: index to an anonymous variable" + with Not_found -> + nvar (id_of_string ("[REL "^(string_of_int n)^"]"))) + + | PApp (f,args) -> + let (f,args) = + skip_coercion (function PRef r -> Some r | _ -> None) + (f,Array.to_list args) in + let astf = ast_of_pattern tenv env f in + let astargs = List.map (ast_of_pattern tenv env) args in + (match f with + | PRef ref -> ast_of_app (implicits_of_global ref) astf astargs + | _ -> ast_of_app [] astf astargs) + + | PSoApp (n,args) -> + ope("SOAPP",(ope ("META",[ast_of_ident n])):: + (List.map (ast_of_pattern tenv env) args)) + + | PLetIn (na,b,c) -> + let c' = ast_of_pattern tenv (add_name na env) c in + ope("LETIN",[ast_of_pattern tenv env b;slam(idopt_of_name na,c')]) + + | PProd (Anonymous,t,c) -> + ope("PROD",[ast_of_pattern tenv env t; + slam(None,ast_of_pattern tenv env c)]) + | PProd (na,t,c) -> + let env' = add_name na env in + let (n,a) = + factorize_binder_pattern tenv env' 1 BProd na + (ast_of_pattern tenv env t) c in + (* PROD et PRODLIST doivent être distingués à cause du cas *) + (* non dépendant, pour isoler l'implication; peut-être un *) + (* constructeur ARROW serait-il plus justifié ? *) + let tag = if n=1 then "PROD" else "PRODLIST" in + ope(tag,[ast_of_pattern tenv env t;a]) + | PLambda (na,t,c) -> + let env' = add_name na env in + let (n,a) = + factorize_binder_pattern tenv env' 1 BLambda na + (ast_of_pattern tenv env t) c in + (* LAMBDA et LAMBDALIST se comportent pareil *) + let tag = if n=1 then "LAMBDA" else "LAMBDALIST" in + ope(tag,[ast_of_pattern tenv env t;a]) + + | PCase (st,typopt,tm,bv) -> + warning "Old Case syntax"; + ope("MUTCASE",(ast_of_patopt tenv env typopt) + ::(ast_of_pattern tenv env tm) + ::(Array.to_list (Array.map (ast_of_pattern tenv env) bv))) + + | PSort s -> + (match s with + | RProp Null -> ope("PROP",[]) + | RProp Pos -> ope("SET",[]) + | RType _ -> ope("TYPE",[])) + + | PMeta (Some n) -> ope("META",[ast_of_ident n]) + | PMeta None -> ope("ISEVAR",[]) + | PFix f -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkFix f)) + | PCoFix c -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkCoFix c)) + +and ast_of_patopt tenv env = function + | None -> (string "SYNTH") + | Some p -> ast_of_pattern tenv env p + +and factorize_binder_pattern tenv env n oper na aty c = + let (p,body) = match decompose_binder_pattern c with + | Some (oper',na',ty',c') + when (oper = oper') & (aty = ast_of_pattern tenv env ty') + & not (na' = Anonymous & oper = BProd) + -> + factorize_binder_pattern tenv (add_name na' env) (n+1) oper na' aty c' + | _ -> (n,ast_of_pattern tenv env c) + in + (p,slam(idopt_of_name na, body)) diff --git a/parsing/termast.mli b/parsing/termast.mli new file mode 100644 index 00000000..c66e8f0f --- /dev/null +++ b/parsing/termast.mli @@ -0,0 +1,55 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Coqast.t +val ast_of_rawconstr : rawconstr -> Coqast.t +val ast_of_pattern : env -> names_context -> constr_pattern -> Coqast.t + +(* If [b=true] in [ast_of_constr b env c] then the variables in the first + level of quantification clashing with the variables in [env] are renamed *) + +val ast_of_constr : bool -> env -> constr -> Coqast.t + +val ast_of_constant : env -> constant -> Coqast.t +val ast_of_existential : env -> existential -> Coqast.t +val ast_of_constructor : env -> constructor -> Coqast.t +val ast_of_inductive : env -> inductive -> Coqast.t +val ast_of_ref : global_reference -> Coqast.t +val ast_of_qualid : qualid -> Coqast.t + +(*i Now in constrextern.mli +val print_implicits : bool ref +val print_casts : bool ref +val print_arguments : bool ref +val print_evar_arguments : bool ref +val print_coercions : bool ref +val print_universes : bool ref + +val with_casts : ('a -> 'b) -> 'a -> 'b +val with_implicits : ('a -> 'b) -> 'a -> 'b +val with_arguments : ('a -> 'b) -> 'a -> 'b +val with_coercions : ('a -> 'b) -> 'a -> 'b +val with_universes : ('a -> 'b) -> 'a -> 'b +i*) diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 new file mode 100644 index 00000000..bdc1ea66 --- /dev/null +++ b/parsing/vernacextend.ml4 @@ -0,0 +1,162 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* > + +type grammar_tactic_production_expr = + | VernacTerm of string + | VernacNonTerm of Util.loc * Genarg.argument_type * MLast.expr * string option +let rec make_patt = function + | [] -> <:patt< [] >> + | VernacNonTerm(_,_,_,Some p)::l -> + <:patt< [ $lid:p$ :: $make_patt l$ ] >> + | _::l -> make_patt l + +let rec make_when loc = function + | [] -> <:expr< True >> + | VernacNonTerm(loc',t,_,Some p)::l -> + 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 + | VernacNonTerm(loc,t,_,Some p)::l -> + 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 add_clause s (_,pt,e) l = + let p = make_patt pt in + let w = Some (make_when (MLast.loc_of_expr e) pt) in + (p, w, make_let e pt)::l + +let rec extract_signature = function + | [] -> [] + | VernacNonTerm (_,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 entry "^s^" have the same\n"^ + "non-terminals in the same order: put them in distinct vernac entries") + +let make_clauses s l = + check_unicity s l; + let default = + (<:patt< _ >>,None,<:expr< failwith "Vernac extension: cannot occur" >>) in + List.fold_right (add_clause s) l [default] + +let rec make_fun e = function + | [] -> e + | VernacNonTerm(loc,_,_,Some p)::l -> + <:expr< fun $lid:p$ -> $make_fun e l$ >> + | _::l -> make_fun e l + +let mlexpr_of_grammar_production = function + | VernacTerm s -> + <:expr< Egrammar.TacTerm $mlexpr_of_string s$ >> + | VernacNonTerm (loc,nt,g,sopt) -> + <:expr< Egrammar.TacNonTerm $default_loc$ ($g$,$mlexpr_of_argtype loc nt$) $mlexpr_of_option mlexpr_of_string sopt$ >> + +let mlexpr_of_clause = + mlexpr_of_list + (fun (a,b,c) -> + (mlexpr_of_pair + mlexpr_of_string + (mlexpr_of_list mlexpr_of_grammar_production) + (a,b))) + +let declare_command loc s cl = + let gl = mlexpr_of_clause cl in + let icl = make_clauses s cl in + <:str_item< + declare + open Pcoq; + try Vernacinterp.vinterp_add $mlexpr_of_string s$ (fun [ $list:icl$ ]) + with e -> Pp.pp (Cerrors.explain_exn e); + Egrammar.extend_vernac_command_grammar $mlexpr_of_string s$ $gl$; + end + >> + +open Vernacexpr +open Pcoq + +let rec interp_entry_name loc s = + let l = String.length s in + if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in + List1ArgType t, <:expr< Gramext.Slist1 $g$ >> + else if l > 5 & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in + List0ArgType t, <:expr< Gramext.Slist0 $g$ >> + else if l > 4 & String.sub s (l-4) 4 = "_opt" then + let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in + OptArgType t, <:expr< Gramext.Sopt $g$ >> + else + let t, se = + match Pcoq.entry_type (Pcoq.get_univ "prim") s with + | Some _ as x -> x, <:expr< Prim. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "constr") s with + | Some _ as x -> x, <:expr< Constr. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "tactic") s with + | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> + | None -> None, <:expr< $lid:s$ >> in + let t = + match t with + | Some t -> t + | None -> +(* Pp.warning_with Pp_control.err_ft + ("Unknown primitive grammar entry: "^s);*) + ExtraArgType s + in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> + +open Pcaml + +EXTEND + GLOBAL: str_item; + str_item: + [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT; + OPT "|"; l = LIST1 rule SEP "|"; + "END" -> + declare_command loc s l ] ] + ; + rule: + [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]" + -> + if s = "" then Util.user_err_loc (loc,"",Pp.str "Command name is empty"); + (s,l,<:expr< fun () -> $e$ >>) + ] ] + ; + args: + [ [ e = LIDENT; "("; s = LIDENT; ")" -> + let t, g = interp_entry_name loc e in + VernacNonTerm (loc, t, g, Some s) + | s = STRING -> + VernacTerm s + ] ] + ; + END +;; -- cgit v1.2.3