From 297b0cb44bbe8ec7304ca635c566815167266d4a Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 24 Jun 2015 11:28:44 +0200 Subject: Revert commit 18796b6aea453bdeef1ad12ce80eeb220bf01e67, close 3080 This reverts 18796b6aea453bdeef1ad12ce80eeb220bf01e67 (Slight change in the semantics of arguments scopes: scopes can no longer be bound to Funclass or Sortclass (this does not seem to be useful)). It is useful to have function_scope for, e.g., function composition. This allows users to, e.g., automatically interpret ∘ as morphism composition when expecting a morphism of categories, as functor composition when expecting a functor, and as function composition when expecting a function. Additionally, it is nicer to have fewer special cases in the OCaml code, and give more things a uniform syntax. (The scope type_scope should not be special-cased; this change is coming up next.) Also explicitly define [function_scope] in theories/Init/Notations.v. This closes bug #3080, Build a [function_scope] like [type_scope], or allow [Bind Scope ... with Sortclass] and [Bind Scope ... with Funclass] We now mention Funclass and Sortclass in the documentation of [Bind Scope] again. --- parsing/g_vernac.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index fe9c582408..5a6dfa547c 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1048,7 +1048,7 @@ GEXTEND Gram VernacDelimiters (sc, None) | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; - refl = LIST1 smart_global -> VernacBindScope (sc,refl) + refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) | IDENT "Infix"; local = obsolete_locality; op = ne_lstring; ":="; p = constr; -- cgit v1.2.3 From 2bc88f9a536c3db3c2d4a38a8a0da0500b895c7b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Sep 2015 18:35:48 +0200 Subject: Univs: Add universe binding lists to definitions ... lemmas and inductives to control which universes are bound and where in universe polymorphic definitions. Names stay outside the kernel. --- parsing/g_vernac.ml4 | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 11f78c708c..63850713f2 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -196,9 +196,9 @@ GEXTEND Gram gallina: (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr; + [ [ thm = thm_token; id = pidentref; bl = binders; ":"; c = lconstr; l = LIST0 - [ "with"; id = identref; bl = binders; ":"; c = lconstr -> + [ "with"; id = pidentref; bl = binders; ":"; c = lconstr -> (Some id,(bl,c,None)) ] -> VernacStartTheoremProof (thm, (Some id,(bl,c,None))::l, false) | stre = assumption_token; nl = inline; bl = assum_list -> @@ -206,10 +206,10 @@ GEXTEND Gram | stre = assumptions_token; nl = inline; bl = assum_list -> test_plurial_form bl; VernacAssumption (stre, nl, bl) - | d = def_token; id = identref; b = def_body -> + | d = def_token; id = pidentref; b = def_body -> VernacDefinition (d, id, b) | IDENT "Let"; id = identref; b = def_body -> - VernacDefinition ((Some Discharge, Definition), id, b) + VernacDefinition ((Some Discharge, Definition), (id, None), b) (* Gallina inductive declarations *) | priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> @@ -268,6 +268,9 @@ GEXTEND Gram | IDENT "Inline" -> DefaultInline | -> NoInline] ] ; + pidentref: + [ [ i = identref; l = OPT [ "@{" ; l = LIST1 identref; "}" -> l ] -> (i,l) ] ] + ; univ_constraint: [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; r = identref -> (l, ord, r) ] ] @@ -312,7 +315,7 @@ GEXTEND Gram | -> RecordDecl (None, []) ] ] ; inductive_definition: - [ [ oc = opt_coercion; id = identref; indpar = binders; + [ [ oc = opt_coercion; id = pidentref; indpar = binders; c = OPT [ ":"; c = lconstr -> c ]; lc=opt_constructors_or_fields; ntn = decl_notation -> (((oc,id),indpar,c,lc),ntn) ] ] @@ -338,14 +341,14 @@ GEXTEND Gram ; (* (co)-fixpoints *) rec_definition: - [ [ id = identref; + [ [ id = pidentref; bl = binders_fixannot; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> let bl, annot = bl in ((id,annot,bl,ty,def),ntn) ] ] ; corec_definition: - [ [ id = identref; bl = binders; ty = type_cstr; + [ [ id = pidentref; bl = binders; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> ((id,bl,ty,def),ntn) ] ] ; @@ -605,15 +608,15 @@ GEXTEND Gram d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition - ((Some Global,CanonicalStructure),(Loc.ghost,s),d) + ((Some Global,CanonicalStructure),((Loc.ghost,s),None),d) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((None,Coercion),(Loc.ghost,s),d) + VernacDefinition ((None,Coercion),((Loc.ghost,s),None),d) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((Some Decl_kinds.Local,Coercion),(Loc.ghost,s),d) + VernacDefinition ((Some Decl_kinds.Local,Coercion),((Loc.ghost,s),None),d) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (true, f, s, t) -- cgit v1.2.3 From d37aab528dca587127b9f9944e1521e4fc3d9cc7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 7 Oct 2015 13:11:52 +0200 Subject: Univs: add Strict Universe Declaration option (on by default) This option disallows "declare at first use" semantics for universe variables (in @{}), forcing the declaration of _all_ universes appearing in a definition when introducing it with syntax Definition/Inductive foo@{i j k} .. The bound universes at the end of a definition/inductive must be exactly those ones, no extras allowed currently. Test-suite files using the old semantics just disable the option. --- parsing/g_constr.ml4 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'parsing') diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index e47e3fb1e6..9fe3022341 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -153,12 +153,12 @@ GEXTEND Gram [ [ "Set" -> GSet | "Prop" -> GProp | "Type" -> GType [] - | "Type"; "@{"; u = universe; "}" -> GType (List.map Id.to_string u) + | "Type"; "@{"; u = universe; "}" -> GType (List.map (fun (loc,x) -> (loc, Id.to_string x)) u) ] ] ; universe: - [ [ IDENT "max"; "("; ids = LIST1 ident SEP ","; ")" -> ids - | id = ident -> [id] + [ [ IDENT "max"; "("; ids = LIST1 identref SEP ","; ")" -> ids + | id = identref -> [id] ] ] ; lconstr: @@ -302,7 +302,7 @@ GEXTEND Gram [ [ "Set" -> GSet | "Prop" -> GProp | "Type" -> GType None - | id = ident -> GType (Some (Id.to_string id)) + | id = identref -> GType (Some (fst id, Id.to_string (snd id))) ] ] ; fix_constr: -- cgit v1.2.3 From 8a7f111ad5ce35e183016a2a968d19f29b7622c5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 7 Oct 2015 14:32:30 +0200 Subject: Record fields accept an optional final semicolon separator. There is no such thing as the OPTSEP macro in Camlp4 so I had to expand it by hand. --- parsing/g_constr.ml4 | 22 +++++++++++++++++++--- parsing/g_vernac.ml4 | 11 +++++++++-- 2 files changed, 28 insertions(+), 5 deletions(-) (limited to 'parsing') diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 9fe3022341..e2e6795f73 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -224,11 +224,20 @@ GEXTEND Gram ] ] ; record_declaration: - [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (!@loc, None, fs) + [ [ fs = record_fields -> CRecord (!@loc, None, fs) (* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) (* CRecord (!@loc, Some c, fs) *) ] ] ; + + record_fields: + [ [ f = record_field_declaration; ";"; fs = record_fields -> f :: fs + | f = record_field_declaration; ";" -> [f] + | f = record_field_declaration -> [f] + | -> [] + ] ] + ; + record_field_declaration: [ [ id = global; params = LIST0 identref; ":="; c = lconstr -> (id, abstract_constr_expr c (binders_of_lidents params)) ] ] @@ -356,9 +365,16 @@ GEXTEND Gram [ [ pll = LIST1 mult_pattern SEP "|"; "=>"; rhs = lconstr -> (!@loc,pll,rhs) ] ] ; - recordpattern: + record_pattern: [ [ id = global; ":="; pat = pattern -> (id, pat) ] ] ; + record_patterns: + [ [ p = record_pattern; ";"; ps = record_patterns -> p :: ps + | p = record_pattern; ";" -> [p] + | p = record_pattern-> [p] + | -> [] + ] ] + ; pattern: [ "200" RIGHTA [ ] | "100" RIGHTA @@ -382,7 +398,7 @@ GEXTEND Gram [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ] | "0" [ r = Prim.reference -> CPatAtom (!@loc,Some r) - | "{|"; pat = LIST0 recordpattern SEP ";" ; "|}" -> CPatRecord (!@loc, pat) + | "{|"; pat = record_patterns; "|}" -> CPatRecord (!@loc, pat) | "_" -> CPatAtom (!@loc,None) | "("; p = pattern LEVEL "200"; ")" -> (match p with diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 63850713f2..e9915fceb3 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -325,9 +325,9 @@ GEXTEND Gram | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> Constructors ((c id)::l) | id = identref ; c = constructor_type -> Constructors [ c id ] - | cstr = identref; "{"; fs = LIST0 record_field SEP ";"; "}" -> + | cstr = identref; "{"; fs = record_fields; "}" -> RecordDecl (Some cstr,fs) - | "{";fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (None,fs) + | "{";fs = record_fields; "}" -> RecordDecl (None,fs) | -> Constructors [] ] ] ; (* @@ -389,6 +389,13 @@ GEXTEND Gram [ [ bd = record_binder; pri = OPT [ "|"; n = natural -> n ]; ntn = decl_notation -> (bd,pri),ntn ] ] ; + record_fields: + [ [ f = record_field; ";"; fs = record_fields -> f :: fs + | f = record_field; ";" -> [f] + | f = record_field -> [f] + | -> [] + ] ] + ; record_binder_body: [ [ l = binders; oc = of_type_with_opt_coercion; t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN (!@loc) l t)) -- cgit v1.2.3 From 9ea8867a0fa8f2a52df102732fdc1a931c659826 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 30 Sep 2015 22:12:25 +0200 Subject: Proof using: let-in policy, optional auto-clear, forward closure* - "Proof using p*" means: use p and any section var about p. - Simplify the grammar/parser for proof using . - Section variables with a body (let-in) are pulled in automatically since they are safe to be used (add no extra quantification) - automatic clear of "unused" section variables made optional: Set Proof Using Clear Unused. since clearing section hypotheses does not "always work" (e.g. hint databases are not really cleaned) - term_typing: trigger a "suggest proof using" message also for Let theorems. --- parsing/g_proofs.ml4 | 8 ++++---- parsing/g_vernac.ml4 | 50 ++++++++++++++++++++++++++++++++------------------ 2 files changed, 36 insertions(+), 22 deletions(-) (limited to 'parsing') diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 1e254c16ba..7f5459bfa6 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -37,12 +37,12 @@ GEXTEND Gram command: [ [ IDENT "Goal"; c = lconstr -> VernacGoal c | IDENT "Proof" -> - VernacProof (None,hint_proof_using G_vernac.section_subset_descr None) + VernacProof (None,hint_proof_using G_vernac.section_subset_expr None) | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn | IDENT "Proof"; "with"; ta = tactic; - l = OPT [ "using"; l = G_vernac.section_subset_descr -> l ] -> - VernacProof (Some ta,hint_proof_using G_vernac.section_subset_descr l) - | IDENT "Proof"; "using"; l = G_vernac.section_subset_descr; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> + VernacProof (Some ta,hint_proof_using G_vernac.section_subset_expr l) + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; ta = OPT [ "with"; ta = tactic -> ta ] -> VernacProof (ta,Some l) | IDENT "Proof"; c = lconstr -> VernacExactProof c diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index e9915fceb3..fc0a4c8c31 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -46,7 +46,7 @@ let record_field = Gram.entry_create "vernac:record_field" let of_type_with_opt_coercion = Gram.entry_create "vernac:of_type_with_opt_coercion" let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" -let section_subset_descr = Gram.entry_create "vernac:section_subset_descr" +let section_subset_expr = Gram.entry_create "vernac:section_subset_expr" let command_entry = ref noedit_mode let set_command_entry e = command_entry := e @@ -447,20 +447,24 @@ GEXTEND Gram ; END -let only_identrefs = - Gram.Entry.of_parser "test_only_identrefs" +let only_starredidentrefs = + Gram.Entry.of_parser "test_only_starredidentrefs" (fun strm -> let rec aux n = match get_tok (Util.stream_nth n strm) with | KEYWORD "." -> () | KEYWORD ")" -> () - | IDENT _ -> aux (n+1) + | (IDENT _ | KEYWORD "Type" | KEYWORD "*") -> aux (n+1) | _ -> raise Stream.Failure in aux 0) +let starredidentreflist_to_expr l = + match l with + | [] -> SsEmpty + | x :: xs -> List.fold_right (fun i acc -> SsUnion(i,acc)) xs x (* Modules and Sections *) GEXTEND Gram - GLOBAL: gallina_ext module_expr module_type section_subset_descr; + GLOBAL: gallina_ext module_expr module_type section_subset_expr; gallina_ext: [ [ (* Interactive module declaration *) @@ -483,7 +487,7 @@ GEXTEND Gram | IDENT "End"; id = identref -> VernacEndSegment id (* Naming a set of section hyps *) - | IDENT "Collection"; id = identref; ":="; expr = section_subset_descr -> + | IDENT "Collection"; id = identref; ":="; expr = section_subset_expr -> VernacNameSectionHypSet (id, expr) (* Requiring an already compiled module *) @@ -574,22 +578,32 @@ GEXTEND Gram CMwith (!@loc,mty,decl) ] ] ; - section_subset_descr: - [ [ IDENT "All" -> SsAll - | "Type" -> SsType - | only_identrefs; l = LIST0 identref -> SsExpr (SsSet l) - | e = section_subset_expr -> SsExpr e ] ] - ; + (* Proof using *) section_subset_expr: + [ [ only_starredidentrefs; l = LIST0 starredidentref -> + starredidentreflist_to_expr l + | e = ssexpr -> e ]] + ; + starredidentref: + [ [ i = identref -> SsSingl i + | i = identref; "*" -> SsFwdClose(SsSingl i) + | "Type" -> SsSingl (!@loc, Id.of_string "Type") + | "Type"; "*" -> SsFwdClose (SsSingl (!@loc, Id.of_string "Type")) ]] + ; + ssexpr: [ "35" - [ "-"; e = section_subset_expr -> SsCompl e ] + [ "-"; e = ssexpr -> SsCompl e ] | "50" - [ e1 = section_subset_expr; "-"; e2 = section_subset_expr->SsSubstr(e1,e2) - | e1 = section_subset_expr; "+"; e2 = section_subset_expr->SsUnion(e1,e2)] + [ e1 = ssexpr; "-"; e2 = ssexpr->SsSubstr(e1,e2) + | e1 = ssexpr; "+"; e2 = ssexpr->SsUnion(e1,e2)] | "0" - [ i = identref -> SsSet [i] - | "("; only_identrefs; l = LIST0 identref; ")"-> SsSet l - | "("; e = section_subset_expr; ")"-> e ] ] + [ i = starredidentref -> i + | "("; only_starredidentrefs; l = LIST0 starredidentref; ")"-> + starredidentreflist_to_expr l + | "("; only_starredidentrefs; l = LIST0 starredidentref; ")"; "*" -> + SsFwdClose(starredidentreflist_to_expr l) + | "("; e = ssexpr; ")"-> e + | "("; e = ssexpr; ")"; "*" -> SsFwdClose e ] ] ; END -- cgit v1.2.3 From 33d153a01f2814c6e5486c07257667254b91fa0c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 7 Oct 2015 15:08:27 +0200 Subject: Axioms now support the universe binding syntax. We artificially restrict the syntax though, because it is unclear of what the semantics of several axioms in a row is, in particular about the resolution of remaining evars. --- parsing/g_vernac.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index fc0a4c8c31..3bd190bb8a 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -420,7 +420,7 @@ GEXTEND Gram [ [ "("; a = simple_assum_coe; ")" -> a ] ] ; simple_assum_coe: - [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> + [ [ idl = LIST1 pidentref; oc = of_type_with_opt_coercion; c = lconstr -> (not (Option.is_empty oc),(idl,c)) ] ] ; -- cgit v1.2.3 From dbdef043ea143f871a3710bae36dfc45fd815835 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 8 Oct 2015 13:47:05 +0200 Subject: Allowing empty bound universe variables. --- parsing/g_vernac.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 3bd190bb8a..1f9f57f698 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -269,7 +269,7 @@ GEXTEND Gram | -> NoInline] ] ; pidentref: - [ [ i = identref; l = OPT [ "@{" ; l = LIST1 identref; "}" -> l ] -> (i,l) ] ] + [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] ; univ_constraint: [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; -- cgit v1.2.3 From ed95f122f3c68becc09c653471dc2982b346d343 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 13 Oct 2015 18:30:47 +0200 Subject: Fix some typos. --- parsing/lexer.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 8e83929619..c6d5f3b925 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -70,7 +70,7 @@ let ttree_remove ttree str = remove ttree 0 -(* Errors occuring while lexing (explained as "Lexer error: ...") *) +(* Errors occurring while lexing (explained as "Lexer error: ...") *) module Error = struct -- cgit v1.2.3 From f617aeef08441e83b13f839ce767b840fddbcf7d Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 14 Oct 2015 10:39:55 +0200 Subject: Fix some typos. --- parsing/pcoq.ml4 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 797b031fe4..2e47e07a36 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -298,7 +298,7 @@ module Prim = struct let gec_gen x = make_gen_entry uprim x - (* Entries that can be refered via the string -> Gram.entry table *) + (* Entries that can be referred via the string -> Gram.entry table *) (* Typically for tactic or vernac extensions *) let preident = gec_gen (rawwit wit_pre_ident) "preident" let ident = gec_gen (rawwit wit_ident) "ident" @@ -334,7 +334,7 @@ module Constr = struct let gec_constr = make_gen_entry uconstr (rawwit wit_constr) - (* Entries that can be refered via the string -> Gram.entry table *) + (* Entries that can be referred via the string -> Gram.entry table *) let constr = gec_constr "constr" let operconstr = gec_constr "operconstr" let constr_eoi = eoi_entry constr @@ -367,7 +367,7 @@ module Tactic = (* Main entry for extensions *) let simple_tactic = Gram.entry_create "tactic:simple_tactic" - (* Entries that can be refered via the string -> Gram.entry table *) + (* Entries that can be referred via the string -> Gram.entry table *) (* Typically for tactic user extensions *) let open_constr = make_gen_entry utactic (rawwit wit_open_constr) "open_constr" -- cgit v1.2.3 From 426ba79b270299f64a4498187adad717760d11bc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 12:50:38 +0200 Subject: Expliciting some uses of Compat module. --- parsing/lexer.ml4 | 11 +++++------ parsing/pcoq.mli | 3 +-- 2 files changed, 6 insertions(+), 8 deletions(-) (limited to 'parsing') diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index c6d5f3b925..23bd74da95 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -8,7 +8,6 @@ open Pp open Util -open Compat open Tok (* Dictionaries: trees annotated with string options, each node being a map @@ -565,7 +564,7 @@ let loct_add loct i loc = Hashtbl.add loct i loc let current_location_table = ref (loct_create ()) -type location_table = (int, CompatLoc.t) Hashtbl.t +type location_table = (int, Compat.CompatLoc.t) Hashtbl.t let location_table () = !current_location_table let restore_location_table t = current_location_table := t @@ -602,7 +601,7 @@ let func cs = Stream.from (fun i -> let (tok, loc) = next_token cs in - loct_add loct i (make_loc loc); Some tok) + loct_add loct i (Compat.make_loc loc); Some tok) in current_location_table := loct; (ts, loct_func loct) @@ -622,10 +621,10 @@ ELSE (* official camlp4 for ocaml >= 3.10 *) module M_ = Camlp4.ErrorHandler.Register (Error) -module Loc = CompatLoc +module Loc = Compat.CompatLoc module Token = struct include Tok (* Cf. tok.ml *) - module Loc = CompatLoc + module Loc = Compat.CompatLoc module Error = Camlp4.Struct.EmptyError module Filter = struct type token_filter = (Tok.t * Loc.t) Stream.t -> (Tok.t * Loc.t) Stream.t @@ -643,7 +642,7 @@ let mk () _init_loc(*FIXME*) cs = let rec self = parser i [< (tok, loc) = next_token; s >] -> - let loc = make_loc loc in + let loc = Compat.make_loc loc in loct_add loct i loc; [< '(tok, loc); self s >] | [< >] -> [< >] diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 2146ad964f..6e9cf263f2 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -14,13 +14,12 @@ open Genarg open Constrexpr open Tacexpr open Libnames -open Compat open Misctypes open Genredexpr (** The parser of Coq *) -module Gram : GrammarSig +module Gram : Compat.GrammarSig (** The parser of Coq is built from three kinds of rule declarations: -- cgit v1.2.3 From 0935b4565a8c1760570d0037b8b4cff745c3885c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 14:55:12 +0200 Subject: Removing the dependencies of Pcoq in IFDEF macros. --- parsing/compat.ml4 | 71 ++++++++++++++++++++++++++++++++++++++++ parsing/pcoq.ml4 | 95 ++++++++++++++++++++---------------------------------- 2 files changed, 106 insertions(+), 60 deletions(-) (limited to 'parsing') diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index eba1d2b8f0..4208fd364e 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -238,6 +238,69 @@ end END +(** Some definitions are grammar-specific in Camlp4, so we use a functor to + depend on it while taking a dummy argument in Camlp5. *) + +module GramextMake (G : GrammarSig) : +sig + val stoken : Tok.t -> G.symbol + val sself : G.symbol + val snext : G.symbol + val slist0 : G.symbol -> G.symbol + val slist0sep : G.symbol * G.symbol -> G.symbol + val slist1 : G.symbol -> G.symbol + val slist1sep : G.symbol * G.symbol -> G.symbol + val sopt : G.symbol -> G.symbol + val snterml : G.internal_entry * string -> G.symbol + val snterm : G.internal_entry -> G.symbol + val snterml_level : G.symbol -> string +end = +struct + +IFDEF CAMLP5 THEN + let stoken tok = + let pattern = match tok with + | Tok.KEYWORD s -> "", s + | Tok.IDENT s -> "IDENT", s + | Tok.METAIDENT s -> "METAIDENT", s + | Tok.PATTERNIDENT s -> "PATTERNIDENT", s + | Tok.FIELD s -> "FIELD", s + | Tok.INT s -> "INT", s + | Tok.STRING s -> "STRING", s + | Tok.LEFTQMARK -> "LEFTQMARK", "" + | Tok.BULLET s -> "BULLET", s + | Tok.EOI -> "EOI", "" + in + Gramext.Stoken pattern +ELSE + module Gramext = G + let stoken tok = match tok with + | Tok.KEYWORD s -> Gramext.Skeyword s + | tok -> Gramext.Stoken ((=) tok, G.Token.to_string tok) +END + +IFDEF CAMLP5_6_00 THEN + let slist0sep (x, y) = Gramext.Slist0sep (x, y, false) + let slist1sep (x, y) = Gramext.Slist1sep (x, y, false) +ELSE + let slist0sep (x, y) = Gramext.Slist0sep (x, y) + let slist1sep (x, y) = Gramext.Slist1sep (x, y) +END + + let snterml (x, y) = Gramext.Snterml (x, y) + let snterm x = Gramext.Snterm x + let sself = Gramext.Sself + let snext = Gramext.Snext + let slist0 x = Gramext.Slist0 x + let slist1 x = Gramext.Slist1 x + let sopt x = Gramext.Sopt x + + let snterml_level = function + | Gramext.Snterml (_, l) -> l + | _ -> failwith "snterml_level" + +end + (** Misc functional adjustments *) @@ -323,3 +386,11 @@ let qualified_name loc path name = let path = List.fold_right fold path (Ast.IdLid (loc, name)) in Ast.ExId (loc, path) END + +IFDEF CAMLP5 THEN +let warning_verbose = Gramext.warning_verbose +ELSE +(* TODO: this is a workaround, since there isn't such + [warning_verbose] in new camlp4. *) +let warning_verbose = ref true +END diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 2e47e07a36..ff50eb5c70 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -20,37 +20,11 @@ open Tok (* necessary for camlp4 *) module G = GrammarMake (Lexer) -(* TODO: this is a workaround, since there isn't such - [warning_verbose] in new camlp4. In camlp5, this ref - gets hidden by [Gramext.warning_verbose] *) -let warning_verbose = ref true - -IFDEF CAMLP5 THEN -open Gramext -ELSE -open PcamlSig.Grammar -open G -END - -(** Compatibility with Camlp5 6.x *) - -IFDEF CAMLP5_6_00 THEN -let slist0sep x y = Slist0sep (x, y, false) -let slist1sep x y = Slist1sep (x, y, false) -ELSE -let slist0sep x y = Slist0sep (x, y) -let slist1sep x y = Slist1sep (x, y) -END - -let gram_token_of_token tok = -IFDEF CAMLP5 THEN - Stoken (Tok.to_pattern tok) -ELSE - match tok with - | KEYWORD s -> Skeyword s - | tok -> Stoken ((=) tok, to_string tok) -END +let warning_verbose = Compat.warning_verbose +module Symbols = GramextMake(G) + +let gram_token_of_token = Symbols.stoken let gram_token_of_string s = gram_token_of_token (Lexer.terminal s) let camlp4_verbosity silent f x = @@ -158,7 +132,10 @@ let grammar_delete e reinit (pos,rls) = (List.rev rls); match reinit with | Some (a,ext) -> - let lev = match pos with Some (Level n) -> n | _ -> assert false in + let lev = match Option.map Compat.to_coq_position pos with + | Some (Level n) -> n + | _ -> assert false + in maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]]) | None -> () @@ -679,56 +656,56 @@ let make_sep_rules tkl = let rec symbol_of_constr_prod_entry_key assoc from forpat typ = if is_binder_level from typ then if forpat then - Snterml (Gram.Entry.obj Constr.pattern,"200") + Symbols.snterml (Gram.Entry.obj Constr.pattern,"200") else - Snterml (Gram.Entry.obj Constr.operconstr,"200") + Symbols.snterml (Gram.Entry.obj Constr.operconstr,"200") else if is_self from typ then - Sself + Symbols.sself else match typ with | ETConstrList (typ',[]) -> - Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) + Symbols.slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) | ETConstrList (typ',tkl) -> - slist1sep - (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) - (make_sep_rules tkl) + Symbols.slist1sep + (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'), + make_sep_rules tkl) | ETBinderList (false,[]) -> - Slist1 + Symbols.slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) | ETBinderList (false,tkl) -> - slist1sep - (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) - (make_sep_rules tkl) + Symbols.slist1sep + (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false), + make_sep_rules tkl) | _ -> match interp_constr_prod_entry_key assoc from forpat typ with - | (eobj,None,_) -> Snterm (Gram.Entry.obj eobj) - | (eobj,Some None,_) -> Snext + | (eobj,None,_) -> Symbols.snterm (Gram.Entry.obj eobj) + | (eobj,Some None,_) -> Symbols.snext | (eobj,Some (Some (lev,cur)),_) -> - Snterml (Gram.Entry.obj eobj,constr_level lev) + Symbols.snterml (Gram.Entry.obj eobj,constr_level lev) (** Binding general entry keys to symbol *) let rec symbol_of_prod_entry_key = function - | Alist1 s -> Slist1 (symbol_of_prod_entry_key s) + | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> - slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string sep) - | Alist0 s -> Slist0 (symbol_of_prod_entry_key s) + Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) + | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s) | Alist0sep (s,sep) -> - slist0sep (symbol_of_prod_entry_key s) (gram_token_of_string sep) - | Aopt s -> Sopt (symbol_of_prod_entry_key s) + Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep) + | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) | Amodifiers s -> Gram.srules' [([], Gram.action (fun _loc -> [])); ([gram_token_of_string "("; - slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string ","); + Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ","); gram_token_of_string ")"], Gram.action (fun _ l _ _loc -> l))] - | Aself -> Sself - | Anext -> Snext - | Atactic 5 -> Snterm (Gram.Entry.obj Tactic.binder_tactic) + | Aself -> Symbols.sself + | Anext -> Symbols.snext + | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) | Atactic n -> - Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) + Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) | Agram s -> let e = try @@ -742,14 +719,12 @@ let rec symbol_of_prod_entry_key = function with Not_found -> Errors.anomaly (str "Unregistered grammar entry: " ++ str s) in - Snterm (Gram.Entry.obj (object_of_typed_entry e)) + Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) | Aentry (u,s) -> let e = get_entry (get_univ u) s in - Snterm (Gram.Entry.obj (object_of_typed_entry e)) + Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) -let level_of_snterml = function - | Snterml (_,l) -> int_of_string l - | _ -> failwith "level_of_snterml" +let level_of_snterml e = int_of_string (Symbols.snterml_level e) (**********************************************************************) (* Interpret entry names of the form "ne_constr_list" as entry keys *) -- cgit v1.2.3 From 9d9b91f683cb698e7d6cdf97dc60cc89735a6597 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 17:19:16 +0200 Subject: Expanding the grammar extensions of Pcoq. --- parsing/pcoq.ml4 | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index ff50eb5c70..48dc1372ce 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -192,22 +192,22 @@ let rec remove_grammars n = redo(); camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state) +let make_rule r = [None, None, r] + (** 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; + let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in + let act = Gram.action (fun _ x loc -> x) in + maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); 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; + let symbs = [Symbols.snterm (Gram.Entry.obj en)] in + let act = Gram.action (fun x loc -> f x) in + maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); e (* Parse a string, does NOT check if the entire string was read @@ -397,11 +397,14 @@ module Vernac_ = (* Main vernac entry *) let main_entry = Gram.entry_create "vernac" - GEXTEND Gram - main_entry: - [ [ a = vernac -> Some (!@loc, a) | EOI -> None ] ] - ; - END + let () = + let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in + let act_eoi = Gram.action (fun _ loc -> None) in + let rule = [ + ([ Symbols.stoken Tok.EOI ], act_eoi); + ([ Symbols.snterm (Gram.Entry.obj vernac) ], act_vernac ); + ] in + maybe_uncurry (Gram.extend main_entry) (None, make_rule rule) end -- cgit v1.2.3 From 513344627bbdf4d822ca93156d2e2943408ec50d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 17:42:00 +0200 Subject: Turn Pcoq into a regular ML file. --- parsing/pcoq.ml | 814 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ parsing/pcoq.ml4 | 814 ------------------------------------------------------- 2 files changed, 814 insertions(+), 814 deletions(-) create mode 100644 parsing/pcoq.ml delete mode 100644 parsing/pcoq.ml4 (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml new file mode 100644 index 0000000000..48dc1372ce --- /dev/null +++ b/parsing/pcoq.ml @@ -0,0 +1,814 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* grammar_object G.entry +end + +module Gramobj : Gramobj = +struct + type grammar_object = Obj.t + let weaken_entry e = Obj.magic e +end + +(** Grammar entries with associated types *) + +type entry_type = argument_type +type grammar_object = Gramobj.grammar_object +type typed_entry = argument_type * grammar_object G.entry +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 + val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry + val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry +end + +module Gramtypes : Gramtypes = +struct + let inGramObj rawwit = in_typed_entry (unquote rawwit) + let outGramObj (a:'a raw_abstract_argument_type) o = + if not (argument_type_eq (type_of_typed_entry o) (unquote a)) + then anomaly ~label:"outGramObj" (str "wrong type"); + (* downcast from grammar_object *) + Obj.magic (object_of_typed_entry o) +end + +open Gramtypes + +(** Grammar extensions *) + +(** NB: [extend_statment = + gram_position option * single_extend_statment list] + and [single_extend_statment = + string option * gram_assoc option * production_rule list] + and [production_rule = symbol list * action] + + In [single_extend_statement], first two parameters are name and + assoc iff a level is created *) + +(** Type of reinitialization data *) +type gram_reinit = gram_assoc * gram_position + +type ext_kind = + | ByGrammar of + grammar_object G.entry + * gram_reinit option (** for reinitialization if ever needed *) + * G.extend_statment + | ByEXTEND of (unit -> unit) * (unit -> unit) + +(** The list of extensions *) + +let camlp4_state = ref [] + +(** Deletion *) + +let grammar_delete e reinit (pos,rls) = + List.iter + (fun (n,ass,lev) -> + List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) + (List.rev rls); + match reinit with + | Some (a,ext) -> + let lev = match Option.map Compat.to_coq_position pos with + | Some (Level n) -> n + | _ -> assert false + in + maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]]) + | None -> () + +(** The apparent parser of Coq; encapsulate G to keep track + of the extensions. *) + +module Gram = + struct + include G + let extend e = + maybe_curry + (fun ext -> + camlp4_state := + (ByEXTEND ((fun () -> grammar_delete e None ext), + (fun () -> maybe_uncurry (G.extend e) ext))) + :: !camlp4_state; + maybe_uncurry (G.extend e) ext) + let delete_rule e pil = + (* spiwack: if you use load an ML module which contains GDELETE_RULE + in a section, God kills a kitty. As it would corrupt remove_grammars. + There does not seem to be a good way to undo a delete rule. As deleting + takes fewer arguments than extending. The production rule isn't returned + by delete_rule. If we could retrieve the necessary information, then + ByEXTEND provides just the framework we need to allow this in section. + I'm not entirely sure it makes sense, but at least it would be more correct. + *) + G.delete_rule e pil + end + +(** This extension command is used by the Grammar constr *) + +let grammar_extend e reinit ext = + camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state; + camlp4_verbose (maybe_uncurry (G.extend e)) ext + +(** Remove extensions + + [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 ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove") + | ByGrammar(g,reinit,ext)::t -> + let f (a,b) = (of_coq_assoc a, of_coq_position b) in + grammar_delete g (Option.map f reinit) ext; + camlp4_state := t; + remove_grammars (n-1) + | ByEXTEND (undo,redo)::t -> + undo(); + camlp4_state := t; + remove_grammars n; + redo(); + camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state) + +let make_rule r = [None, None, r] + +(** 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 + let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in + let act = Gram.action (fun _ x loc -> x) in + maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); + e + +let map_entry f en = + let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in + let symbs = [Symbols.snterm (Gram.Entry.obj en)] in + let act = Gram.action (fun x loc -> f x) in + maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); + 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 * (string, typed_entry) Hashtbl.t + +let trace = ref false + +(* The univ_tab is not part of the state. It contains all the grammars that + exist or have existed before in the session. *) + +let univ_tab = (Hashtbl.create 7 : (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 utactic = create_univ "tactic" +let uvernac = create_univ "vernac" + +let get_univ s = + try + Hashtbl.find univ_tab s + with Not_found -> + anomaly (Pp.str ("Unknown grammar universe: "^s)) + +let get_entry (u, utab) s = Hashtbl.find utab s + +let new_entry etyp (u, utab) s = + if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr); + let ename = u ^ ":" ^ s in + let e = in_typed_entry etyp (Gram.entry_create ename) in + Hashtbl.add utab s e; e + +let create_entry (u, utab) s etyp = + try + let e = Hashtbl.find utab s in + if not (argument_type_eq (type_of_typed_entry e) etyp) then + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); + e + with Not_found -> + new_entry etyp (u, utab) s + +let create_constr_entry s = + outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) + +let create_generic_entry s wit = + outGramObj wit (create_entry utactic s (unquote wit)) + +(* [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 + +(* Initial grammar entries *) + +module Prim = + struct + let gec_gen x = make_gen_entry uprim x + + (* Entries that can be referred via the string -> Gram.entry table *) + (* Typically for tactic or vernac extensions *) + let preident = gec_gen (rawwit wit_pre_ident) "preident" + let ident = gec_gen (rawwit wit_ident) "ident" + let natural = gec_gen (rawwit wit_int) "natural" + let integer = gec_gen (rawwit wit_int) "integer" + let bigint = Gram.entry_create "Prim.bigint" + let string = gec_gen (rawwit wit_string) "string" + let reference = make_gen_entry uprim (rawwit wit_ref) "reference" + let by_notation = Gram.entry_create "by_notation" + let smart_global = Gram.entry_create "smart_global" + + (* parsed like ident but interpreted as a term *) + let var = gec_gen (rawwit wit_var) "var" + + let name = Gram.entry_create "Prim.name" + let identref = Gram.entry_create "Prim.identref" + let pattern_ident = Gram.entry_create "pattern_ident" + let pattern_identref = Gram.entry_create "pattern_identref" + + (* A synonym of ident - maybe ident will be located one day *) + let base_ident = Gram.entry_create "Prim.base_ident" + + let qualid = Gram.entry_create "Prim.qualid" + let fullyqualid = Gram.entry_create "Prim.fullyqualid" + let dirpath = Gram.entry_create "Prim.dirpath" + + let ne_string = Gram.entry_create "Prim.ne_string" + let ne_lstring = Gram.entry_create "Prim.ne_lstring" + + end + +module Constr = + struct + let gec_constr = make_gen_entry uconstr (rawwit wit_constr) + + (* Entries that can be referred via the string -> Gram.entry 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 "binder_constr" + let ident = make_gen_entry uconstr (rawwit wit_ident) "ident" + let global = make_gen_entry uconstr (rawwit wit_ref) "global" + let sort = make_gen_entry uconstr (rawwit wit_sort) "sort" + let pattern = Gram.entry_create "constr:pattern" + let constr_pattern = gec_constr "constr_pattern" + let lconstr_pattern = gec_constr "lconstr_pattern" + let closed_binder = Gram.entry_create "constr:closed_binder" + let binder = Gram.entry_create "constr:binder" + let binders = Gram.entry_create "constr:binders" + let open_binders = Gram.entry_create "constr:open_binders" + let binders_fixannot = Gram.entry_create "constr:binders_fixannot" + let typeclass_constraint = Gram.entry_create "constr:typeclass_constraint" + let record_declaration = Gram.entry_create "constr:record_declaration" + let appl_arg = Gram.entry_create "constr:appl_arg" + 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 referred via the string -> Gram.entry table *) + (* Typically for tactic user extensions *) + let open_constr = + make_gen_entry utactic (rawwit wit_open_constr) "open_constr" + let constr_with_bindings = + make_gen_entry utactic (rawwit wit_constr_with_bindings) "constr_with_bindings" + let bindings = + make_gen_entry utactic (rawwit wit_bindings) "bindings" + let hypident = Gram.entry_create "hypident" + let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" + let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" + let uconstr = + make_gen_entry utactic (rawwit wit_uconstr) "uconstr" + let quantified_hypothesis = + make_gen_entry utactic (rawwit wit_quant_hyp) "quantified_hypothesis" + let int_or_var = make_gen_entry utactic (rawwit wit_int_or_var) "int_or_var" + let red_expr = make_gen_entry utactic (rawwit wit_red_expr) "red_expr" + let simple_intropattern = + make_gen_entry utactic (rawwit wit_intro_pattern) "simple_intropattern" + let clause_dft_concl = + make_gen_entry utactic (rawwit wit_clause_dft_concl) "clause" + + + (* Main entries for ltac *) + let tactic_arg = Gram.entry_create "tactic:tactic_arg" + let tactic_expr = Gram.entry_create "tactic:tactic_expr" + let binder_tactic = Gram.entry_create "tactic:binder_tactic" + + let tactic = make_gen_entry utactic (rawwit wit_tactic) "tactic" + + (* Main entry for quotations *) + let tactic_eoi = eoi_entry tactic + + (* For Ltac definition *) + let tacdef_body = Gram.entry_create "tactic:tacdef_body" + + end + +module Vernac_ = + 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 + let rec_definition = gec_vernac "Vernac.rec_definition" + (* Main vernac entry *) + let main_entry = Gram.entry_create "vernac" + + let () = + let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in + let act_eoi = Gram.action (fun _ loc -> None) in + let rule = [ + ([ Symbols.stoken Tok.EOI ], act_eoi); + ([ Symbols.snterm (Gram.Entry.obj vernac) ], act_vernac ); + ] in + maybe_uncurry (Gram.extend main_entry) (None, make_rule rule) + + end + +let main_entry = Vernac_.main_entry + +(**********************************************************************) +(* 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") + + The boolean is true if the entry was existing _and_ empty; this to + circumvent a weakness of camlp4/camlp5 whose undo mechanism is not the + converse of the extension mechanism *) + +let constr_level = string_of_int + +let default_levels = + [200,Extend.RightA,false; + 100,Extend.RightA,false; + 99,Extend.RightA,true; + 10,Extend.RightA,false; + 9,Extend.RightA,false; + 8,Extend.RightA,true; + 1,Extend.LeftA,false; + 0,Extend.RightA,false] + +let default_pattern_levels = + [200,Extend.RightA,true; + 100,Extend.RightA,false; + 99,Extend.RightA,true; + 11,Extend.LeftA,false; + 10,Extend.RightA,false; + 1,Extend.LeftA,false; + 0,Extend.RightA,false] + +let level_stack = + ref [(default_levels, default_pattern_levels)] + +(* 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 *) + +let admissible_assoc = function + | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false + | Extend.RightA, Some Extend.LeftA -> false + | _ -> true + +let create_assoc = function + | None -> Extend.RightA + | Some a -> a + +let error_level_assoc p current expected = + let pr_assoc = function + | Extend.LeftA -> str "left" + | Extend.RightA -> str "right" + | Extend.NonA -> str "non" in + errorlabstrm "" + (str "Level " ++ int p ++ str " is already declared " ++ + pr_assoc current ++ str " associative while it is now expected to be " ++ + pr_assoc expected ++ str " associative.") + +let create_pos = function + | None -> Extend.First + | Some lev -> Extend.After (constr_level lev) + +let find_position_gen forpat ensure assoc lev = + let ccurrent,pcurrent as current = List.hd !level_stack in + match lev with + | None -> + level_stack := current :: !level_stack; + None, None, None, None + | Some n -> + let after = ref None in + let init = ref None in + let rec add_level q = function + | (p,_,_ as pa)::l when p > n -> pa :: add_level (Some p) l + | (p,a,reinit)::l when Int.equal p n -> + if reinit then + let a' = create_assoc assoc in + (init := Some (a',create_pos q); (p,a',false)::l) + else if admissible_assoc (a,assoc) then + raise Exit + else + error_level_assoc p a (Option.get assoc) + | l -> after := q; (n,create_assoc assoc,ensure)::l + in + try + let updated = + if forpat then (ccurrent, add_level None pcurrent) + else (add_level None ccurrent, pcurrent) in + level_stack := updated:: !level_stack; + let assoc = create_assoc assoc in + begin match !init with + | None -> + (* Create the entry *) + Some (create_pos !after), Some assoc, Some (constr_level n), None + | _ -> + (* The reinit flag has been updated *) + Some (Extend.Level (constr_level n)), None, None, !init + end + with + (* Nothing has changed *) + Exit -> + level_stack := current :: !level_stack; + (* Just inherit the existing associativity and name (None) *) + Some (Extend.Level (constr_level n)), None, None, None + +let remove_levels n = + level_stack := List.skipn n !level_stack + +let rec list_mem_assoc_triple x = function + | [] -> false + | (a,b,c) :: l -> Int.equal a x || list_mem_assoc_triple x l + +let register_empty_levels forpat levels = + let filter n = + try + let levels = (if forpat then snd else fst) (List.hd !level_stack) in + if not (list_mem_assoc_triple n levels) then + Some (find_position_gen forpat true None (Some n)) + else None + with Failure _ -> None + in + List.map_filter filter levels + +let find_position forpat assoc level = + find_position_gen forpat false assoc level + +(* Synchronise the stack of level updates *) +let synchronize_level_positions () = + let _ = find_position true None None in () + +(**********************************************************************) +(* Binding constr entry keys to entries *) + +(* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *) +let camlp4_assoc = function + | Some Extend.NonA | Some Extend.RightA -> Extend.RightA + | None | Some Extend.LeftA -> Extend.LeftA + +let assoc_eq al ar = match al, ar with +| Extend.NonA, Extend.NonA +| Extend.RightA, Extend.RightA +| Extend.LeftA, Extend.LeftA -> true +| _, _ -> false + +(* [adjust_level assoc from prod] where [assoc] and [from] are the name + and associativity of the level where to add the rule; the meaning of + 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 (Right,Some (Extend.NonA|Extend.LeftA))) -> + Some None + (* If RightA on the right-hand side, set to the explicit (current) level *) + | (NumLevel n,BorderProd (Right,Some Extend.RightA)) -> + Some (Some (n,true)) +(* Compute production name on the left side *) + (* If NonA on the left-hand side, adopt the current assoc ?? *) + | (NumLevel n,BorderProd (Left,Some Extend.NonA)) -> None + (* If the expected assoc is the current one, set to SELF *) + | (NumLevel n,BorderProd (Left,Some a)) when assoc_eq a (camlp4_assoc assoc) -> + None + (* Otherwise, force the level, n or n-1, according to expected assoc *) + | (NumLevel n,BorderProd (Left,Some a)) -> + begin match a with + | Extend.LeftA -> Some (Some (n, true)) + | _ -> Some None + end + (* None means NEXT *) + | (NextLevel,_) -> Some None +(* Compute production name elsewhere *) + | (NumLevel n,InternalProd) -> + match from with + | ETConstr (p,()) when Int.equal p (n + 1) -> Some None + | ETConstr (p,()) -> Some (Some (n, Int.equal n p)) + | _ -> Some (Some (n,false)) + +let compute_entry allow_create adjust forpat = function + | ETConstr (n,q) -> + (if forpat then weaken_entry Constr.pattern + else weaken_entry Constr.operconstr), + adjust (n,q), false + | ETName -> weaken_entry Prim.name, None, false + | ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList") + | ETBinder false -> weaken_entry Constr.binder, None, false + | ETBinderList (true,tkl) -> + let () = match tkl with [] -> () | _ -> assert false in + weaken_entry Constr.open_binders, None, false + | ETBinderList (false,_) -> anomaly (Pp.str "List of entries cannot be registered.") + | ETBigint -> weaken_entry Prim.bigint, None, false + | ETReference -> weaken_entry Constr.global, None, false + | ETPattern -> weaken_entry Constr.pattern, None, false + | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") + | ETOther (u,n) -> + let u = get_univ u in + let e = + try get_entry u n + with Not_found 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 interp_constr_entry_key forpat = function + | ETConstr(200,()) when not forpat -> + weaken_entry Constr.binder_constr, None + | e -> + let (e,level,_) = compute_entry true (fun (n,()) -> Some n) forpat e in + (e, level) + +(* This computes the name to give to a production knowing the name and + associativity of the level where it must be added *) +let interp_constr_prod_entry_key ass from forpat en = + compute_entry false (adjust_level ass from) forpat en + +(**********************************************************************) +(* Binding constr entry keys to symbols *) + +let is_self from e = + match from, e with + ETConstr(n,()), ETConstr(NumLevel n', + BorderProd(Right, _ (* Some(NonA|LeftA) *))) -> false + | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> Int.equal n n' + | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint + | ETPattern, ETPattern) -> true + | ETOther(s1,s2), ETOther(s1',s2') -> + String.equal s1 s1' && String.equal s2 s2' + | _ -> false + +let is_binder_level from e = + match from, e with + ETConstr(200,()), + ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true + | _ -> false + +let make_sep_rules tkl = + Gram.srules' + [List.map gram_token_of_token tkl, + List.fold_right (fun _ v -> Gram.action (fun _ -> v)) tkl + (Gram.action (fun loc -> ()))] + +let rec symbol_of_constr_prod_entry_key assoc from forpat typ = + if is_binder_level from typ then + if forpat then + Symbols.snterml (Gram.Entry.obj Constr.pattern,"200") + else + Symbols.snterml (Gram.Entry.obj Constr.operconstr,"200") + else if is_self from typ then + Symbols.sself + else + match typ with + | ETConstrList (typ',[]) -> + Symbols.slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) + | ETConstrList (typ',tkl) -> + Symbols.slist1sep + (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'), + make_sep_rules tkl) + | ETBinderList (false,[]) -> + Symbols.slist1 + (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) + | ETBinderList (false,tkl) -> + Symbols.slist1sep + (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false), + make_sep_rules tkl) + + | _ -> + match interp_constr_prod_entry_key assoc from forpat typ with + | (eobj,None,_) -> Symbols.snterm (Gram.Entry.obj eobj) + | (eobj,Some None,_) -> Symbols.snext + | (eobj,Some (Some (lev,cur)),_) -> + Symbols.snterml (Gram.Entry.obj eobj,constr_level lev) + +(** Binding general entry keys to symbol *) + +let rec symbol_of_prod_entry_key = function + | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) + | Alist1sep (s,sep) -> + Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) + | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s) + | Alist0sep (s,sep) -> + Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep) + | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) + | Amodifiers s -> + Gram.srules' + [([], Gram.action (fun _loc -> [])); + ([gram_token_of_string "("; + Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ","); + gram_token_of_string ")"], + Gram.action (fun _ l _ _loc -> l))] + | Aself -> Symbols.sself + | Anext -> Symbols.snext + | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) + | Atactic n -> + Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) + | Agram s -> + let e = + try + (** ppedrot: we should always generate Agram entries which have already + been registered, so this should not fail. *) + let (u, s) = match String.split ':' s with + | u :: s :: [] -> (u, s) + | _ -> raise Not_found + in + get_entry (get_univ u) s + with Not_found -> + Errors.anomaly (str "Unregistered grammar entry: " ++ str s) + in + Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) + | Aentry (u,s) -> + let e = get_entry (get_univ u) s in + Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) + +let level_of_snterml e = int_of_string (Symbols.snterml_level e) + +(**********************************************************************) +(* Interpret entry names of the form "ne_constr_list" as entry keys *) + +let coincide s pat off = + let len = String.length pat in + let break = ref true in + let i = ref 0 in + while !break && !i < len do + let c = Char.code s.[off + !i] in + let d = Char.code pat.[!i] in + break := Int.equal c d; + incr i + done; + !break + +let tactic_level s = + if Int.equal (String.length s) 7 && coincide s "tactic" 0 then + let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48) + else None + else None + +let type_of_entry u s = + type_of_typed_entry (get_entry u s) + +let rec interp_entry_name static up_level s sep = + let l = String.length s in + if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then + let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in + ListArgType t, Alist1 g + else if l > 12 && coincide s "ne_" 0 && + coincide s "_list_sep" (l-9) then + let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in + ListArgType t, Alist1sep (g,sep) + else if l > 5 && coincide s "_list" (l-5) then + let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in + ListArgType t, Alist0 g + else if l > 9 && coincide s "_list_sep" (l-9) then + let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in + ListArgType t, Alist0sep (g,sep) + else if l > 4 && coincide s "_opt" (l-4) then + let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in + OptArgType t, Aopt g + else if l > 5 && coincide s "_mods" (l-5) then + let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in + ListArgType t, Amodifiers g + else + let s = match s with "hyp" -> "var" | _ -> s in + let check_lvl n = match up_level with + | None -> false + | Some m -> Int.equal m n + && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) + && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) + in + let t, se = + match tactic_level s with + | Some n -> + (** Quite ad-hoc *) + let t = unquote (rawwit wit_tactic) in + let se = + if check_lvl n then Aself + else if check_lvl (n + 1) then Anext + else Atactic n + in + (Some t, se) + | None -> + try Some (type_of_entry uprim s), Aentry ("prim",s) with Not_found -> + try Some (type_of_entry uconstr s), Aentry ("constr",s) with Not_found -> + try Some (type_of_entry utactic s), Aentry ("tactic",s) with Not_found -> + if static then + error ("Unknown entry "^s^".") + else + None, Aentry ("",s) in + let t = + match t with + | Some t -> t + | None -> ExtraArgType s in + t, se + +let list_entry_names () = + let add_entry key (entry, _) accu = (key, entry) :: accu in + let ans = Hashtbl.fold add_entry (snd uprim) [] in + let ans = Hashtbl.fold add_entry (snd uconstr) ans in + Hashtbl.fold add_entry (snd utactic) ans diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 deleted file mode 100644 index 48dc1372ce..0000000000 --- a/parsing/pcoq.ml4 +++ /dev/null @@ -1,814 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* grammar_object G.entry -end - -module Gramobj : Gramobj = -struct - type grammar_object = Obj.t - let weaken_entry e = Obj.magic e -end - -(** Grammar entries with associated types *) - -type entry_type = argument_type -type grammar_object = Gramobj.grammar_object -type typed_entry = argument_type * grammar_object G.entry -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 - val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry - val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry -end - -module Gramtypes : Gramtypes = -struct - let inGramObj rawwit = in_typed_entry (unquote rawwit) - let outGramObj (a:'a raw_abstract_argument_type) o = - if not (argument_type_eq (type_of_typed_entry o) (unquote a)) - then anomaly ~label:"outGramObj" (str "wrong type"); - (* downcast from grammar_object *) - Obj.magic (object_of_typed_entry o) -end - -open Gramtypes - -(** Grammar extensions *) - -(** NB: [extend_statment = - gram_position option * single_extend_statment list] - and [single_extend_statment = - string option * gram_assoc option * production_rule list] - and [production_rule = symbol list * action] - - In [single_extend_statement], first two parameters are name and - assoc iff a level is created *) - -(** Type of reinitialization data *) -type gram_reinit = gram_assoc * gram_position - -type ext_kind = - | ByGrammar of - grammar_object G.entry - * gram_reinit option (** for reinitialization if ever needed *) - * G.extend_statment - | ByEXTEND of (unit -> unit) * (unit -> unit) - -(** The list of extensions *) - -let camlp4_state = ref [] - -(** Deletion *) - -let grammar_delete e reinit (pos,rls) = - List.iter - (fun (n,ass,lev) -> - List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) - (List.rev rls); - match reinit with - | Some (a,ext) -> - let lev = match Option.map Compat.to_coq_position pos with - | Some (Level n) -> n - | _ -> assert false - in - maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]]) - | None -> () - -(** The apparent parser of Coq; encapsulate G to keep track - of the extensions. *) - -module Gram = - struct - include G - let extend e = - maybe_curry - (fun ext -> - camlp4_state := - (ByEXTEND ((fun () -> grammar_delete e None ext), - (fun () -> maybe_uncurry (G.extend e) ext))) - :: !camlp4_state; - maybe_uncurry (G.extend e) ext) - let delete_rule e pil = - (* spiwack: if you use load an ML module which contains GDELETE_RULE - in a section, God kills a kitty. As it would corrupt remove_grammars. - There does not seem to be a good way to undo a delete rule. As deleting - takes fewer arguments than extending. The production rule isn't returned - by delete_rule. If we could retrieve the necessary information, then - ByEXTEND provides just the framework we need to allow this in section. - I'm not entirely sure it makes sense, but at least it would be more correct. - *) - G.delete_rule e pil - end - -(** This extension command is used by the Grammar constr *) - -let grammar_extend e reinit ext = - camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state; - camlp4_verbose (maybe_uncurry (G.extend e)) ext - -(** Remove extensions - - [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 ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove") - | ByGrammar(g,reinit,ext)::t -> - let f (a,b) = (of_coq_assoc a, of_coq_position b) in - grammar_delete g (Option.map f reinit) ext; - camlp4_state := t; - remove_grammars (n-1) - | ByEXTEND (undo,redo)::t -> - undo(); - camlp4_state := t; - remove_grammars n; - redo(); - camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state) - -let make_rule r = [None, None, r] - -(** 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 - let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in - let act = Gram.action (fun _ x loc -> x) in - maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); - e - -let map_entry f en = - let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in - let symbs = [Symbols.snterm (Gram.Entry.obj en)] in - let act = Gram.action (fun x loc -> f x) in - maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); - 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 * (string, typed_entry) Hashtbl.t - -let trace = ref false - -(* The univ_tab is not part of the state. It contains all the grammars that - exist or have existed before in the session. *) - -let univ_tab = (Hashtbl.create 7 : (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 utactic = create_univ "tactic" -let uvernac = create_univ "vernac" - -let get_univ s = - try - Hashtbl.find univ_tab s - with Not_found -> - anomaly (Pp.str ("Unknown grammar universe: "^s)) - -let get_entry (u, utab) s = Hashtbl.find utab s - -let new_entry etyp (u, utab) s = - if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr); - let ename = u ^ ":" ^ s in - let e = in_typed_entry etyp (Gram.entry_create ename) in - Hashtbl.add utab s e; e - -let create_entry (u, utab) s etyp = - try - let e = Hashtbl.find utab s in - if not (argument_type_eq (type_of_typed_entry e) etyp) then - failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - e - with Not_found -> - new_entry etyp (u, utab) s - -let create_constr_entry s = - outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) - -let create_generic_entry s wit = - outGramObj wit (create_entry utactic s (unquote wit)) - -(* [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 - -(* Initial grammar entries *) - -module Prim = - struct - let gec_gen x = make_gen_entry uprim x - - (* Entries that can be referred via the string -> Gram.entry table *) - (* Typically for tactic or vernac extensions *) - let preident = gec_gen (rawwit wit_pre_ident) "preident" - let ident = gec_gen (rawwit wit_ident) "ident" - let natural = gec_gen (rawwit wit_int) "natural" - let integer = gec_gen (rawwit wit_int) "integer" - let bigint = Gram.entry_create "Prim.bigint" - let string = gec_gen (rawwit wit_string) "string" - let reference = make_gen_entry uprim (rawwit wit_ref) "reference" - let by_notation = Gram.entry_create "by_notation" - let smart_global = Gram.entry_create "smart_global" - - (* parsed like ident but interpreted as a term *) - let var = gec_gen (rawwit wit_var) "var" - - let name = Gram.entry_create "Prim.name" - let identref = Gram.entry_create "Prim.identref" - let pattern_ident = Gram.entry_create "pattern_ident" - let pattern_identref = Gram.entry_create "pattern_identref" - - (* A synonym of ident - maybe ident will be located one day *) - let base_ident = Gram.entry_create "Prim.base_ident" - - let qualid = Gram.entry_create "Prim.qualid" - let fullyqualid = Gram.entry_create "Prim.fullyqualid" - let dirpath = Gram.entry_create "Prim.dirpath" - - let ne_string = Gram.entry_create "Prim.ne_string" - let ne_lstring = Gram.entry_create "Prim.ne_lstring" - - end - -module Constr = - struct - let gec_constr = make_gen_entry uconstr (rawwit wit_constr) - - (* Entries that can be referred via the string -> Gram.entry 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 "binder_constr" - let ident = make_gen_entry uconstr (rawwit wit_ident) "ident" - let global = make_gen_entry uconstr (rawwit wit_ref) "global" - let sort = make_gen_entry uconstr (rawwit wit_sort) "sort" - let pattern = Gram.entry_create "constr:pattern" - let constr_pattern = gec_constr "constr_pattern" - let lconstr_pattern = gec_constr "lconstr_pattern" - let closed_binder = Gram.entry_create "constr:closed_binder" - let binder = Gram.entry_create "constr:binder" - let binders = Gram.entry_create "constr:binders" - let open_binders = Gram.entry_create "constr:open_binders" - let binders_fixannot = Gram.entry_create "constr:binders_fixannot" - let typeclass_constraint = Gram.entry_create "constr:typeclass_constraint" - let record_declaration = Gram.entry_create "constr:record_declaration" - let appl_arg = Gram.entry_create "constr:appl_arg" - 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 referred via the string -> Gram.entry table *) - (* Typically for tactic user extensions *) - let open_constr = - make_gen_entry utactic (rawwit wit_open_constr) "open_constr" - let constr_with_bindings = - make_gen_entry utactic (rawwit wit_constr_with_bindings) "constr_with_bindings" - let bindings = - make_gen_entry utactic (rawwit wit_bindings) "bindings" - let hypident = Gram.entry_create "hypident" - let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" - let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" - let uconstr = - make_gen_entry utactic (rawwit wit_uconstr) "uconstr" - let quantified_hypothesis = - make_gen_entry utactic (rawwit wit_quant_hyp) "quantified_hypothesis" - let int_or_var = make_gen_entry utactic (rawwit wit_int_or_var) "int_or_var" - let red_expr = make_gen_entry utactic (rawwit wit_red_expr) "red_expr" - let simple_intropattern = - make_gen_entry utactic (rawwit wit_intro_pattern) "simple_intropattern" - let clause_dft_concl = - make_gen_entry utactic (rawwit wit_clause_dft_concl) "clause" - - - (* Main entries for ltac *) - let tactic_arg = Gram.entry_create "tactic:tactic_arg" - let tactic_expr = Gram.entry_create "tactic:tactic_expr" - let binder_tactic = Gram.entry_create "tactic:binder_tactic" - - let tactic = make_gen_entry utactic (rawwit wit_tactic) "tactic" - - (* Main entry for quotations *) - let tactic_eoi = eoi_entry tactic - - (* For Ltac definition *) - let tacdef_body = Gram.entry_create "tactic:tacdef_body" - - end - -module Vernac_ = - 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 - let rec_definition = gec_vernac "Vernac.rec_definition" - (* Main vernac entry *) - let main_entry = Gram.entry_create "vernac" - - let () = - let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in - let act_eoi = Gram.action (fun _ loc -> None) in - let rule = [ - ([ Symbols.stoken Tok.EOI ], act_eoi); - ([ Symbols.snterm (Gram.Entry.obj vernac) ], act_vernac ); - ] in - maybe_uncurry (Gram.extend main_entry) (None, make_rule rule) - - end - -let main_entry = Vernac_.main_entry - -(**********************************************************************) -(* 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") - - The boolean is true if the entry was existing _and_ empty; this to - circumvent a weakness of camlp4/camlp5 whose undo mechanism is not the - converse of the extension mechanism *) - -let constr_level = string_of_int - -let default_levels = - [200,Extend.RightA,false; - 100,Extend.RightA,false; - 99,Extend.RightA,true; - 10,Extend.RightA,false; - 9,Extend.RightA,false; - 8,Extend.RightA,true; - 1,Extend.LeftA,false; - 0,Extend.RightA,false] - -let default_pattern_levels = - [200,Extend.RightA,true; - 100,Extend.RightA,false; - 99,Extend.RightA,true; - 11,Extend.LeftA,false; - 10,Extend.RightA,false; - 1,Extend.LeftA,false; - 0,Extend.RightA,false] - -let level_stack = - ref [(default_levels, default_pattern_levels)] - -(* 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 *) - -let admissible_assoc = function - | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false - | Extend.RightA, Some Extend.LeftA -> false - | _ -> true - -let create_assoc = function - | None -> Extend.RightA - | Some a -> a - -let error_level_assoc p current expected = - let pr_assoc = function - | Extend.LeftA -> str "left" - | Extend.RightA -> str "right" - | Extend.NonA -> str "non" in - errorlabstrm "" - (str "Level " ++ int p ++ str " is already declared " ++ - pr_assoc current ++ str " associative while it is now expected to be " ++ - pr_assoc expected ++ str " associative.") - -let create_pos = function - | None -> Extend.First - | Some lev -> Extend.After (constr_level lev) - -let find_position_gen forpat ensure assoc lev = - let ccurrent,pcurrent as current = List.hd !level_stack in - match lev with - | None -> - level_stack := current :: !level_stack; - None, None, None, None - | Some n -> - let after = ref None in - let init = ref None in - let rec add_level q = function - | (p,_,_ as pa)::l when p > n -> pa :: add_level (Some p) l - | (p,a,reinit)::l when Int.equal p n -> - if reinit then - let a' = create_assoc assoc in - (init := Some (a',create_pos q); (p,a',false)::l) - else if admissible_assoc (a,assoc) then - raise Exit - else - error_level_assoc p a (Option.get assoc) - | l -> after := q; (n,create_assoc assoc,ensure)::l - in - try - let updated = - if forpat then (ccurrent, add_level None pcurrent) - else (add_level None ccurrent, pcurrent) in - level_stack := updated:: !level_stack; - let assoc = create_assoc assoc in - begin match !init with - | None -> - (* Create the entry *) - Some (create_pos !after), Some assoc, Some (constr_level n), None - | _ -> - (* The reinit flag has been updated *) - Some (Extend.Level (constr_level n)), None, None, !init - end - with - (* Nothing has changed *) - Exit -> - level_stack := current :: !level_stack; - (* Just inherit the existing associativity and name (None) *) - Some (Extend.Level (constr_level n)), None, None, None - -let remove_levels n = - level_stack := List.skipn n !level_stack - -let rec list_mem_assoc_triple x = function - | [] -> false - | (a,b,c) :: l -> Int.equal a x || list_mem_assoc_triple x l - -let register_empty_levels forpat levels = - let filter n = - try - let levels = (if forpat then snd else fst) (List.hd !level_stack) in - if not (list_mem_assoc_triple n levels) then - Some (find_position_gen forpat true None (Some n)) - else None - with Failure _ -> None - in - List.map_filter filter levels - -let find_position forpat assoc level = - find_position_gen forpat false assoc level - -(* Synchronise the stack of level updates *) -let synchronize_level_positions () = - let _ = find_position true None None in () - -(**********************************************************************) -(* Binding constr entry keys to entries *) - -(* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *) -let camlp4_assoc = function - | Some Extend.NonA | Some Extend.RightA -> Extend.RightA - | None | Some Extend.LeftA -> Extend.LeftA - -let assoc_eq al ar = match al, ar with -| Extend.NonA, Extend.NonA -| Extend.RightA, Extend.RightA -| Extend.LeftA, Extend.LeftA -> true -| _, _ -> false - -(* [adjust_level assoc from prod] where [assoc] and [from] are the name - and associativity of the level where to add the rule; the meaning of - 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 (Right,Some (Extend.NonA|Extend.LeftA))) -> - Some None - (* If RightA on the right-hand side, set to the explicit (current) level *) - | (NumLevel n,BorderProd (Right,Some Extend.RightA)) -> - Some (Some (n,true)) -(* Compute production name on the left side *) - (* If NonA on the left-hand side, adopt the current assoc ?? *) - | (NumLevel n,BorderProd (Left,Some Extend.NonA)) -> None - (* If the expected assoc is the current one, set to SELF *) - | (NumLevel n,BorderProd (Left,Some a)) when assoc_eq a (camlp4_assoc assoc) -> - None - (* Otherwise, force the level, n or n-1, according to expected assoc *) - | (NumLevel n,BorderProd (Left,Some a)) -> - begin match a with - | Extend.LeftA -> Some (Some (n, true)) - | _ -> Some None - end - (* None means NEXT *) - | (NextLevel,_) -> Some None -(* Compute production name elsewhere *) - | (NumLevel n,InternalProd) -> - match from with - | ETConstr (p,()) when Int.equal p (n + 1) -> Some None - | ETConstr (p,()) -> Some (Some (n, Int.equal n p)) - | _ -> Some (Some (n,false)) - -let compute_entry allow_create adjust forpat = function - | ETConstr (n,q) -> - (if forpat then weaken_entry Constr.pattern - else weaken_entry Constr.operconstr), - adjust (n,q), false - | ETName -> weaken_entry Prim.name, None, false - | ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList") - | ETBinder false -> weaken_entry Constr.binder, None, false - | ETBinderList (true,tkl) -> - let () = match tkl with [] -> () | _ -> assert false in - weaken_entry Constr.open_binders, None, false - | ETBinderList (false,_) -> anomaly (Pp.str "List of entries cannot be registered.") - | ETBigint -> weaken_entry Prim.bigint, None, false - | ETReference -> weaken_entry Constr.global, None, false - | ETPattern -> weaken_entry Constr.pattern, None, false - | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") - | ETOther (u,n) -> - let u = get_univ u in - let e = - try get_entry u n - with Not_found 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 interp_constr_entry_key forpat = function - | ETConstr(200,()) when not forpat -> - weaken_entry Constr.binder_constr, None - | e -> - let (e,level,_) = compute_entry true (fun (n,()) -> Some n) forpat e in - (e, level) - -(* This computes the name to give to a production knowing the name and - associativity of the level where it must be added *) -let interp_constr_prod_entry_key ass from forpat en = - compute_entry false (adjust_level ass from) forpat en - -(**********************************************************************) -(* Binding constr entry keys to symbols *) - -let is_self from e = - match from, e with - ETConstr(n,()), ETConstr(NumLevel n', - BorderProd(Right, _ (* Some(NonA|LeftA) *))) -> false - | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> Int.equal n n' - | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint - | ETPattern, ETPattern) -> true - | ETOther(s1,s2), ETOther(s1',s2') -> - String.equal s1 s1' && String.equal s2 s2' - | _ -> false - -let is_binder_level from e = - match from, e with - ETConstr(200,()), - ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true - | _ -> false - -let make_sep_rules tkl = - Gram.srules' - [List.map gram_token_of_token tkl, - List.fold_right (fun _ v -> Gram.action (fun _ -> v)) tkl - (Gram.action (fun loc -> ()))] - -let rec symbol_of_constr_prod_entry_key assoc from forpat typ = - if is_binder_level from typ then - if forpat then - Symbols.snterml (Gram.Entry.obj Constr.pattern,"200") - else - Symbols.snterml (Gram.Entry.obj Constr.operconstr,"200") - else if is_self from typ then - Symbols.sself - else - match typ with - | ETConstrList (typ',[]) -> - Symbols.slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) - | ETConstrList (typ',tkl) -> - Symbols.slist1sep - (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'), - make_sep_rules tkl) - | ETBinderList (false,[]) -> - Symbols.slist1 - (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) - | ETBinderList (false,tkl) -> - Symbols.slist1sep - (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false), - make_sep_rules tkl) - - | _ -> - match interp_constr_prod_entry_key assoc from forpat typ with - | (eobj,None,_) -> Symbols.snterm (Gram.Entry.obj eobj) - | (eobj,Some None,_) -> Symbols.snext - | (eobj,Some (Some (lev,cur)),_) -> - Symbols.snterml (Gram.Entry.obj eobj,constr_level lev) - -(** Binding general entry keys to symbol *) - -let rec symbol_of_prod_entry_key = function - | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) - | Alist1sep (s,sep) -> - Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) - | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s) - | Alist0sep (s,sep) -> - Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep) - | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) - | Amodifiers s -> - Gram.srules' - [([], Gram.action (fun _loc -> [])); - ([gram_token_of_string "("; - Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ","); - gram_token_of_string ")"], - Gram.action (fun _ l _ _loc -> l))] - | Aself -> Symbols.sself - | Anext -> Symbols.snext - | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) - | Atactic n -> - Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) - | Agram s -> - let e = - try - (** ppedrot: we should always generate Agram entries which have already - been registered, so this should not fail. *) - let (u, s) = match String.split ':' s with - | u :: s :: [] -> (u, s) - | _ -> raise Not_found - in - get_entry (get_univ u) s - with Not_found -> - Errors.anomaly (str "Unregistered grammar entry: " ++ str s) - in - Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) - | Aentry (u,s) -> - let e = get_entry (get_univ u) s in - Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) - -let level_of_snterml e = int_of_string (Symbols.snterml_level e) - -(**********************************************************************) -(* Interpret entry names of the form "ne_constr_list" as entry keys *) - -let coincide s pat off = - let len = String.length pat in - let break = ref true in - let i = ref 0 in - while !break && !i < len do - let c = Char.code s.[off + !i] in - let d = Char.code pat.[!i] in - break := Int.equal c d; - incr i - done; - !break - -let tactic_level s = - if Int.equal (String.length s) 7 && coincide s "tactic" 0 then - let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48) - else None - else None - -let type_of_entry u s = - type_of_typed_entry (get_entry u s) - -let rec interp_entry_name static up_level s sep = - let l = String.length s in - if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - ListArgType t, Alist1 g - else if l > 12 && coincide s "ne_" 0 && - coincide s "_list_sep" (l-9) then - let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - ListArgType t, Alist1sep (g,sep) - else if l > 5 && coincide s "_list" (l-5) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - ListArgType t, Alist0 g - else if l > 9 && coincide s "_list_sep" (l-9) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - ListArgType t, Alist0sep (g,sep) - else if l > 4 && coincide s "_opt" (l-4) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in - OptArgType t, Aopt g - else if l > 5 && coincide s "_mods" (l-5) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - ListArgType t, Amodifiers g - else - let s = match s with "hyp" -> "var" | _ -> s in - let check_lvl n = match up_level with - | None -> false - | Some m -> Int.equal m n - && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) - && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) - in - let t, se = - match tactic_level s with - | Some n -> - (** Quite ad-hoc *) - let t = unquote (rawwit wit_tactic) in - let se = - if check_lvl n then Aself - else if check_lvl (n + 1) then Anext - else Atactic n - in - (Some t, se) - | None -> - try Some (type_of_entry uprim s), Aentry ("prim",s) with Not_found -> - try Some (type_of_entry uconstr s), Aentry ("constr",s) with Not_found -> - try Some (type_of_entry utactic s), Aentry ("tactic",s) with Not_found -> - if static then - error ("Unknown entry "^s^".") - else - None, Aentry ("",s) in - let t = - match t with - | Some t -> t - | None -> ExtraArgType s in - t, se - -let list_entry_names () = - let add_entry key (entry, _) accu = (key, entry) :: accu in - let ans = Hashtbl.fold add_entry (snd uprim) [] in - let ans = Hashtbl.fold add_entry (snd uconstr) ans in - Hashtbl.fold add_entry (snd utactic) ans -- cgit v1.2.3 From 1b2a1f0229b485496497ebd1ddbbc561825d61e6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 17:52:41 +0200 Subject: Pcoq.prod_entry_key now uses a GADT to statically enforce typedness. --- parsing/egramml.ml | 4 +-- parsing/egramml.mli | 4 +-- parsing/pcoq.ml | 70 +++++++++++++++++++++++++++-------------------------- parsing/pcoq.mli | 30 ++++++++++++----------- 4 files changed, 56 insertions(+), 52 deletions(-) (limited to 'parsing') diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 8fe03b3632..8f07087085 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -30,8 +30,8 @@ let make_generic_action type grammar_prod_item = | GramTerminal of string - | GramNonTerminal of - Loc.t * argument_type * prod_entry_key * Id.t option + | GramNonTerminal : + Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> grammar_prod_item let make_prod_item = function | GramTerminal s -> (gram_token_of_string s, None) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 9ebb5b83b5..60ec6a05a8 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -13,8 +13,8 @@ type grammar_prod_item = | GramTerminal of string - | GramNonTerminal of Loc.t * Genarg.argument_type * - Pcoq.prod_entry_key * Names.Id.t option + | GramNonTerminal : Loc.t * Genarg.argument_type * + ('s, 'a) Pcoq.entry_key * Names.Id.t option -> grammar_prod_item val extend_vernac_command_grammar : Vernacexpr.extend_name -> Vernacexpr.vernac_expr Pcoq.Gram.entry option -> diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 48dc1372ce..63662a9561 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -36,26 +36,6 @@ let camlp4_verbosity silent f x = let camlp4_verbose f x = camlp4_verbosity (Flags.is_verbose ()) f x -(** General entry keys *) - -(** This intermediate abstract representation of entries can - both be reified into mlexpr for the ML extensions and - dynamically interpreted as entries for the Coq level extensions -*) - -type prod_entry_key = - | Alist1 of prod_entry_key - | Alist1sep of prod_entry_key * string - | Alist0 of prod_entry_key - | Alist0sep of prod_entry_key * string - | Aopt of prod_entry_key - | Amodifiers of prod_entry_key - | Aself - | Anext - | Atactic of int - | Agram of string - | Aentry of string * string - (** [grammar_object] is the superclass of all grammar entries *) module type Gramobj = @@ -80,6 +60,28 @@ let type_of_typed_entry (t,e) = t let object_of_typed_entry (t,e) = e let weaken_entry x = Gramobj.weaken_entry x +(** General entry keys *) + +(** This intermediate abstract representation of entries can + both be reified into mlexpr for the ML extensions and + dynamically interpreted as entries for the Coq level extensions +*) + +type ('self, _) entry_key = +| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key +| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Aself : ('self, 'self) entry_key +| Anext : ('self, 'self) entry_key +| Atactic : int -> ('self, Tacexpr.raw_tactic_expr) entry_key +| Agram : string -> ('self, 'a) entry_key +| Aentry : string * string -> ('self, 'a) entry_key + +type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name + module type Gramtypes = sig val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry @@ -689,7 +691,7 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = (** Binding general entry keys to symbol *) -let rec symbol_of_prod_entry_key = function +let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) @@ -756,24 +758,24 @@ let type_of_entry u s = let rec interp_entry_name static up_level s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - ListArgType t, Alist1 g + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in + EntryName (ListArgType t, Alist1 g) else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then - let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - ListArgType t, Alist1sep (g,sep) + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in + EntryName (ListArgType t, Alist1sep (g,sep)) else if l > 5 && coincide s "_list" (l-5) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - ListArgType t, Alist0 g + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in + EntryName (ListArgType t, Alist0 g) else if l > 9 && coincide s "_list_sep" (l-9) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - ListArgType t, Alist0sep (g,sep) + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in + EntryName (ListArgType t, Alist0sep (g,sep)) else if l > 4 && coincide s "_opt" (l-4) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in - OptArgType t, Aopt g + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in + EntryName (OptArgType t, Aopt g) else if l > 5 && coincide s "_mods" (l-5) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - ListArgType t, Amodifiers g + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in + EntryName (ListArgType t, Amodifiers g) else let s = match s with "hyp" -> "var" | _ -> s in let check_lvl n = match up_level with @@ -805,7 +807,7 @@ let rec interp_entry_name static up_level s sep = match t with | Some t -> t | None -> ExtraArgType s in - t, se + EntryName (t, se) let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 6e9cf263f2..cdffbcba50 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -264,28 +264,30 @@ val symbol_of_constr_prod_entry_key : gram_assoc option -> dynamically interpreted as entries for the Coq level extensions *) -type prod_entry_key = - | Alist1 of prod_entry_key - | Alist1sep of prod_entry_key * string - | Alist0 of prod_entry_key - | Alist0sep of prod_entry_key * string - | Aopt of prod_entry_key - | Amodifiers of prod_entry_key - | Aself - | Anext - | Atactic of int - | Agram of string - | Aentry of string * string +type ('self, _) entry_key = +| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key +| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Aself : ('self, 'self) entry_key +| Anext : ('self, 'self) entry_key +| Atactic : int -> ('self, raw_tactic_expr) entry_key +| Agram : string -> ('self, 'a) entry_key +| Aentry : string * string -> ('self, 'a) entry_key (** Binding general entry keys to symbols *) val symbol_of_prod_entry_key : - prod_entry_key -> Gram.symbol + ('self, 'a) entry_key -> Gram.symbol + +type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name (** Interpret entry names of the form "ne_constr_list" as entry keys *) val interp_entry_name : bool (** true to fail on unknown entry *) -> - int option -> string -> string -> entry_type * prod_entry_key + int option -> string -> string -> entry_name (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * entry_type) list -- cgit v1.2.3 From 06e10609b3bb04c3f42a2211c9f782f130ffd7dd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 24 Oct 2015 23:58:28 +0200 Subject: Getting rid of the Agram entry. --- parsing/egramcoq.ml | 2 +- parsing/pcoq.ml | 21 +++++---------------- parsing/pcoq.mli | 5 +++-- 3 files changed, 9 insertions(+), 19 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index d9eb5d4126..fba754eaaf 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -378,7 +378,7 @@ let create_ltac_quotation name cast wit e = let rule = [ gram_token_of_string name; gram_token_of_string ":"; - symbol_of_prod_entry_key (Agram (Gram.Entry.name e)); + symbol_of_prod_entry_key (Aentry (name_of_entry e)); ] in let action v _ _ loc = let loc = !@loc in diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 63662a9561..b1692e9e2b 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -77,8 +77,7 @@ type ('self, _) entry_key = | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key | Atactic : int -> ('self, Tacexpr.raw_tactic_expr) entry_key -| Agram : string -> ('self, 'a) entry_key -| Aentry : string * string -> ('self, 'a) entry_key +| Aentry : (string * string) -> ('self, 'a) entry_key type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name @@ -711,20 +710,6 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) | Atactic n -> Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) - | Agram s -> - let e = - try - (** ppedrot: we should always generate Agram entries which have already - been registered, so this should not fail. *) - let (u, s) = match String.split ':' s with - | u :: s :: [] -> (u, s) - | _ -> raise Not_found - in - get_entry (get_univ u) s - with Not_found -> - Errors.anomaly (str "Unregistered grammar entry: " ++ str s) - in - Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) | Aentry (u,s) -> let e = get_entry (get_univ u) s in Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) @@ -809,6 +794,10 @@ let rec interp_entry_name static up_level s sep = | None -> ExtraArgType s in EntryName (t, se) +let name_of_entry e = match String.split ':' (Gram.Entry.name e) with +| u :: s :: [] -> (u, s) +| _ -> assert false + let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in let ans = Hashtbl.fold add_entry (snd uprim) [] in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index cdffbcba50..d13ff548ca 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -274,8 +274,9 @@ type ('self, _) entry_key = | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key | Atactic : int -> ('self, raw_tactic_expr) entry_key -| Agram : string -> ('self, 'a) entry_key -| Aentry : string * string -> ('self, 'a) entry_key +| Aentry : (string * string) -> ('self, 'a) entry_key + +val name_of_entry : 'a Gram.entry -> string * string (** Binding general entry keys to symbols *) -- cgit v1.2.3 From af89d24f9d54b18068046545af1268dffbeb3e07 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 25 Oct 2015 16:27:44 +0100 Subject: Getting rid of the Atactic entry. --- parsing/pcoq.ml | 26 +++++++++++++++----------- parsing/pcoq.mli | 2 +- 2 files changed, 16 insertions(+), 12 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b1692e9e2b..b244a021e2 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -76,8 +76,8 @@ type ('self, _) entry_key = | Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key -| Atactic : int -> ('self, Tacexpr.raw_tactic_expr) entry_key | Aentry : (string * string) -> ('self, 'a) entry_key +| Aentryl : (string * string) * int -> ('self, 'a) entry_key type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name @@ -370,8 +370,8 @@ module Tactic = (* Main entries for ltac *) let tactic_arg = Gram.entry_create "tactic:tactic_arg" - let tactic_expr = Gram.entry_create "tactic:tactic_expr" - let binder_tactic = Gram.entry_create "tactic:binder_tactic" + let tactic_expr = make_gen_entry utactic (rawwit wit_tactic) "tactic_expr" + let binder_tactic = make_gen_entry utactic (rawwit wit_tactic) "binder_tactic" let tactic = make_gen_entry utactic (rawwit wit_tactic) "tactic" @@ -707,12 +707,12 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function Gram.action (fun _ l _ _loc -> l))] | Aself -> Symbols.sself | Anext -> Symbols.snext - | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) - | Atactic n -> - Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) | Aentry (u,s) -> let e = get_entry (get_univ u) s in Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) + | Aentryl ((u, s), n) -> + let e = get_entry (get_univ u) s in + Symbols.snterml (Gram.Entry.obj (object_of_typed_entry e), string_of_int n) let level_of_snterml e = int_of_string (Symbols.snterml_level e) @@ -740,6 +740,14 @@ let tactic_level s = let type_of_entry u s = type_of_typed_entry (get_entry u s) +let name_of_entry e = match String.split ':' (Gram.Entry.name e) with +| u :: s :: [] -> (u, s) +| _ -> assert false + +let atactic n = + if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) + else Aentryl (name_of_entry Tactic.tactic_expr, n) + let rec interp_entry_name static up_level s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then @@ -777,7 +785,7 @@ let rec interp_entry_name static up_level s sep = let se = if check_lvl n then Aself else if check_lvl (n + 1) then Anext - else Atactic n + else atactic n in (Some t, se) | None -> @@ -794,10 +802,6 @@ let rec interp_entry_name static up_level s sep = | None -> ExtraArgType s in EntryName (t, se) -let name_of_entry e = match String.split ':' (Gram.Entry.name e) with -| u :: s :: [] -> (u, s) -| _ -> assert false - let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in let ans = Hashtbl.fold add_entry (snd uprim) [] in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index d13ff548ca..959c039d30 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -273,8 +273,8 @@ type ('self, _) entry_key = | Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key -| Atactic : int -> ('self, raw_tactic_expr) entry_key | Aentry : (string * string) -> ('self, 'a) entry_key +| Aentryl : (string * string) * int -> ('self, 'a) entry_key val name_of_entry : 'a Gram.entry -> string * string -- cgit v1.2.3 From 010775eba60ea89645792b48a0686ff15c4ebcb5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 25 Oct 2015 18:43:32 +0100 Subject: Pcoq entries are given a proper module. Entries defined in the Pcoq AST of symbols must be marshallable, because they are present in the libstack. Yet, CAMLP4/5 entries are not marshallable as they contain functional values. This is why the Pcoq module used a pair [string * string] to describe entries. It is obviously type-unsafe, so we define a new abstract type in its own module. There is a little issue though, which is that our entries and CAMLP4/5 entries must be kept synchronized through an association table. The Pcoq module tries to maintain this invariant. --- parsing/entry.ml | 63 ++++++++++++++++++++++++++++++ parsing/entry.mli | 50 ++++++++++++++++++++++++ parsing/parsing.mllib | 1 + parsing/pcoq.ml | 103 ++++++++++++++++++++++++++++++-------------------- parsing/pcoq.mli | 12 ++---- 5 files changed, 180 insertions(+), 49 deletions(-) create mode 100644 parsing/entry.ml create mode 100644 parsing/entry.mli (limited to 'parsing') diff --git a/parsing/entry.ml b/parsing/entry.ml new file mode 100644 index 0000000000..97d601320d --- /dev/null +++ b/parsing/entry.ml @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + anomaly (Pp.str ("Unknown grammar universe: "^s)) + +(** Entries are registered with a unique name *) + +let entries = ref String.Set.empty + +let create u name = + let uname = u ^ ":" ^ name in + let () = + if String.Set.mem uname !entries then + anomaly (Pp.str ("Entry " ^ uname ^ " already defined")) + in + let () = entries := String.Set.add uname !entries in + (u, name) + +let dynamic name = ("", name) + +let unsafe_of_name (u, s) = + let uname = u ^ ":" ^ s in + assert (String.Set.mem uname !entries); + (u, s) + +let repr = function +| ("", u) -> Dynamic u +| (u, s) -> Static (u, s) diff --git a/parsing/entry.mli b/parsing/entry.mli new file mode 100644 index 0000000000..6854a5cb45 --- /dev/null +++ b/parsing/entry.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* universe +val univ_name : universe -> string + +val uprim : universe +val uconstr : universe +val utactic : universe +val uvernac : universe + +(** {5 Uniquely defined entries} *) + +val create : universe -> string -> 'a t +(** Create an entry. They should be synchronized with the entries defined in + {!Pcoq}. *) + +(** {5 Meta-programming} *) + +val dynamic : string -> 'a t +(** Dynamic entries. They refer to entries defined in the code source and may + only be used in meta-programming definitions from the grammar directory. *) + +val repr : 'a t -> repr + +val unsafe_of_name : (string * string) -> 'a t diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib index a0cb831931..024d8607fc 100644 --- a/parsing/parsing.mllib +++ b/parsing/parsing.mllib @@ -1,6 +1,7 @@ Tok Compat Lexer +Entry Pcoq Egramml Egramcoq diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b244a021e2..5b980b3489 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -76,8 +76,8 @@ type ('self, _) entry_key = | Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key -| Aentry : (string * string) -> ('self, 'a) entry_key -| Aentryl : (string * string) * int -> ('self, 'a) entry_key +| Aentry : 'a Entry.t -> ('self, 'a) entry_key +| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name @@ -217,45 +217,58 @@ let map_entry f en = let parse_string f x = let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm) -type gram_universe = string * (string, typed_entry) Hashtbl.t +type gram_universe = Entry.universe let trace = ref false -(* The univ_tab is not part of the state. It contains all the grammars that - exist or have existed before in the session. *) +let uprim = Entry.uprim +let uconstr = Entry.uconstr +let utactic = Entry.utactic +let uvernac = Entry.uvernac +let get_univ = Entry.get_univ -let univ_tab = (Hashtbl.create 7 : (string, gram_universe) Hashtbl.t) +let utables : (string, (string, typed_entry) Hashtbl.t) Hashtbl.t = + Hashtbl.create 97 -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 utactic = create_univ "tactic" -let uvernac = create_univ "vernac" - -let get_univ s = - try - Hashtbl.find univ_tab s +let get_utable u = + let u = Entry.univ_name u in + try Hashtbl.find utables u with Not_found -> - anomaly (Pp.str ("Unknown grammar universe: "^s)) - -let get_entry (u, utab) s = Hashtbl.find utab s - -let new_entry etyp (u, utab) s = - if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr); - let ename = u ^ ":" ^ s in + let table = Hashtbl.create 97 in + Hashtbl.add utables u table; + table + +let get_entry u s = + let utab = get_utable u in + Hashtbl.find utab s + +let get_typed_entry e = + let (u, s) = match Entry.repr e with + | Entry.Dynamic _ -> assert false + | Entry.Static (u, s) -> (u, s) + in + let u = Entry.get_univ u in + get_entry u s + +let new_entry etyp u s = + let utab = get_utable u in + let uname = Entry.univ_name u in + if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" uname s; flush stderr); + let _ = Entry.create u s in + let ename = uname ^ ":" ^ s in let e = in_typed_entry etyp (Gram.entry_create ename) in Hashtbl.add utab s e; e -let create_entry (u, utab) s etyp = +let create_entry u s etyp = + let utab = get_utable u in try let e = Hashtbl.find utab s in + let u = Entry.univ_name u in if not (argument_type_eq (type_of_typed_entry e) etyp) then failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); e with Not_found -> - new_entry etyp (u, utab) s + new_entry etyp u s let create_constr_entry s = outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) @@ -266,8 +279,11 @@ let create_generic_entry s wit = (* [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 +let make_gen_entry u rawwit s = + let univ = get_utable u in + let uname = Entry.univ_name u in + let e = Gram.entry_create (uname ^ ":" ^ s) in + let _ = Entry.create u s in Hashtbl.add univ s (inGramObj rawwit e); e (* Initial grammar entries *) @@ -355,7 +371,7 @@ module Tactic = make_gen_entry utactic (rawwit wit_bindings) "bindings" let hypident = Gram.entry_create "hypident" let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" - let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" + let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_eval" let uconstr = make_gen_entry utactic (rawwit wit_uconstr) "uconstr" let quantified_hypothesis = @@ -707,11 +723,11 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function Gram.action (fun _ l _ _loc -> l))] | Aself -> Symbols.sself | Anext -> Symbols.snext - | Aentry (u,s) -> - let e = get_entry (get_univ u) s in + | Aentry e -> + let e = get_typed_entry e in Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) - | Aentryl ((u, s), n) -> - let e = get_entry (get_univ u) s in + | Aentryl (e, n) -> + let e = get_typed_entry e in Symbols.snterml (Gram.Entry.obj (object_of_typed_entry e), string_of_int n) let level_of_snterml e = int_of_string (Symbols.snterml_level e) @@ -741,13 +757,18 @@ let type_of_entry u s = type_of_typed_entry (get_entry u s) let name_of_entry e = match String.split ':' (Gram.Entry.name e) with -| u :: s :: [] -> (u, s) +| u :: s :: [] -> Entry.unsafe_of_name (u, s) | _ -> assert false let atactic n = if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) else Aentryl (name_of_entry Tactic.tactic_expr, n) +let try_get_entry u s = + (** Order the effects: type_of_entry can raise Not_found *) + let typ = type_of_entry u s in + Some typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s)) + let rec interp_entry_name static up_level s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then @@ -789,13 +810,13 @@ let rec interp_entry_name static up_level s sep = in (Some t, se) | None -> - try Some (type_of_entry uprim s), Aentry ("prim",s) with Not_found -> - try Some (type_of_entry uconstr s), Aentry ("constr",s) with Not_found -> - try Some (type_of_entry utactic s), Aentry ("tactic",s) with Not_found -> + try try_get_entry uprim s with Not_found -> + try try_get_entry uconstr s with Not_found -> + try try_get_entry utactic s with Not_found -> if static then error ("Unknown entry "^s^".") else - None, Aentry ("",s) in + None, Aentry (Entry.dynamic s) in let t = match t with | Some t -> t @@ -804,6 +825,6 @@ let rec interp_entry_name static up_level s sep = let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in - let ans = Hashtbl.fold add_entry (snd uprim) [] in - let ans = Hashtbl.fold add_entry (snd uconstr) ans in - Hashtbl.fold add_entry (snd utactic) ans + let ans = Hashtbl.fold add_entry (get_utable uprim) [] in + let ans = Hashtbl.fold add_entry (get_utable uconstr) ans in + Hashtbl.fold add_entry (get_utable utactic) ans diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 959c039d30..18eb3eed34 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -137,11 +137,7 @@ val parse_string : 'a Gram.entry -> string -> 'a val eoi_entry : 'a Gram.entry -> 'a Gram.entry val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry -(** Table of Coq statically defined grammar entries *) - -type gram_universe - -(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *) +type gram_universe = Entry.universe val get_univ : string -> gram_universe @@ -273,10 +269,10 @@ type ('self, _) entry_key = | Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key -| Aentry : (string * string) -> ('self, 'a) entry_key -| Aentryl : (string * string) * int -> ('self, 'a) entry_key +| Aentry : 'a Entry.t -> ('self, 'a) entry_key +| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key -val name_of_entry : 'a Gram.entry -> string * string +val name_of_entry : 'a Gram.entry -> 'a Entry.t (** Binding general entry keys to symbols *) -- cgit v1.2.3 From fb50a8aaf8826349ac8c3a90a6d9b354b9cf34ca Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 26 Oct 2015 11:50:11 +0100 Subject: Type-safe grammar extensions. --- parsing/egramcoq.ml | 8 ++++---- parsing/pcoq.ml | 29 +++++++++++++++++++++++++++-- parsing/pcoq.mli | 46 ++++++++++++++++++++++++++-------------------- 3 files changed, 57 insertions(+), 26 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index fba754eaaf..7bfcf65e3e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -170,7 +170,7 @@ let prepare_empty_levels forpat (pos,p4assoc,name,reinit) = let entry = if forpat then weaken_entry Constr.pattern else weaken_entry Constr.operconstr in - grammar_extend entry reinit (pos,[(name, p4assoc, [])]) + unsafe_grammar_extend entry reinit (pos,[(name, p4assoc, [])]) let pure_sublevels level symbs = let filter s = @@ -195,7 +195,7 @@ let extend_constr (entry,level) (n,assoc) mkact forpat rules = let pos,p4assoc,name,reinit = find_position forpat assoc level in let nb_decls = List.length needed_levels + 1 in List.iter (prepare_empty_levels forpat) needed_levels; - grammar_extend entry reinit (Option.map of_coq_position pos, + unsafe_grammar_extend entry reinit (Option.map of_coq_position pos, [(name, Option.map of_coq_assoc p4assoc, [symbs, mkact pt])]); nb_decls) 0 rules @@ -265,7 +265,7 @@ let add_ml_tactic_entry name prods = in let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in synchronize_level_positions (); - grammar_extend entry None (None ,[(None, None, List.rev rules)]); + unsafe_grammar_extend entry None (None ,[(None, None, List.rev rules)]); 1 (* Declaration of the tactic grammar rule *) @@ -285,7 +285,7 @@ let add_tactic_entry kn tg = in let rules = make_rule mkact tg.tacgram_prods in synchronize_level_positions (); - grammar_extend entry None (Option.map of_coq_position pos,[(None, None, List.rev [rules])]); + unsafe_grammar_extend entry None (Option.map of_coq_position pos,[(None, None, List.rev [rules])]); 1 let (grammar_state : (int * all_grammar_command) list ref) = ref [] diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 5b980b3489..1dea3497e4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -67,7 +67,8 @@ let weaken_entry x = Gramobj.weaken_entry x dynamically interpreted as entries for the Coq level extensions *) -type ('self, _) entry_key = +type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = +| Atoken : Tok.t -> ('self, Tok.t) entry_key | Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key | Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key @@ -168,7 +169,7 @@ module Gram = (** This extension command is used by the Grammar constr *) -let grammar_extend e reinit ext = +let unsafe_grammar_extend e reinit ext = camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state; camlp4_verbose (maybe_uncurry (G.extend e)) ext @@ -707,6 +708,7 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = (** Binding general entry keys to symbol *) let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function + | Atoken t -> Symbols.stoken t | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) @@ -732,6 +734,29 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function let level_of_snterml e = int_of_string (Symbols.snterml_level e) +let rec of_coq_rule : type self a r. (self, a, r) Extend.rule -> _ = function +| Stop -> fun accu -> accu +| Next (r, tok) -> fun accu -> + let symb = symbol_of_prod_entry_key tok in + of_coq_rule r (symb :: accu) + +let rec of_coq_action : type a r. (r, a, Loc.t -> r) Extend.rule -> a -> Gram.action = function +| Stop -> fun f -> Gram.action (fun loc -> f (to_coqloc loc)) +| Next (r, _) -> fun f -> Gram.action (fun x -> of_coq_action r (f x)) + +let of_coq_production_rule : type a. a Extend.production_rule -> _ = function +| Rule (toks, act) -> (of_coq_rule toks [], of_coq_action toks act) + +let of_coq_single_extend_statement (lvl, assoc, rule) = + (lvl, Option.map of_coq_assoc assoc, List.map of_coq_production_rule rule) + +let of_coq_extend_statement (pos, st) = + (Option.map of_coq_position pos, List.map of_coq_single_extend_statement st) + +let grammar_extend e reinit ext = + let ext = of_coq_extend_statement ext in + unsafe_grammar_extend e reinit ext + (**********************************************************************) (* Interpret entry names of the form "ne_constr_list" as entry keys *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 18eb3eed34..74b7bcc93f 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -105,12 +105,37 @@ type grammar_object (** Type of reinitialization data *) type gram_reinit = gram_assoc * gram_position +(** General entry keys *) + +(** This intermediate abstract representation of entries can + both be reified into mlexpr for the ML extensions and + dynamically interpreted as entries for the Coq level extensions +*) + +type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = +| Atoken : Tok.t -> ('self, Tok.t) entry_key +| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key +| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Aself : ('self, 'self) entry_key +| Anext : ('self, 'self) entry_key +| Aentry : 'a Entry.t -> ('self, 'a) entry_key +| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key + (** Add one extension at some camlp4 position of some camlp4 entry *) -val grammar_extend : +val unsafe_grammar_extend : grammar_object Gram.entry -> gram_reinit option (** for reinitialization if ever needed *) -> Gram.extend_statment -> unit +val grammar_extend : + 'a Gram.entry -> + gram_reinit option (** for reinitialization if ever needed *) -> + 'a Extend.extend_statment -> unit + (** Remove the last n extensions *) val remove_grammars : int -> unit @@ -253,25 +278,6 @@ val symbol_of_constr_prod_entry_key : gram_assoc option -> constr_entry_key -> bool -> constr_prod_entry_key -> Gram.symbol -(** General entry keys *) - -(** This intermediate abstract representation of entries can - both be reified into mlexpr for the ML extensions and - dynamically interpreted as entries for the Coq level extensions -*) - -type ('self, _) entry_key = -| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key -| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Aself : ('self, 'self) entry_key -| Anext : ('self, 'self) entry_key -| Aentry : 'a Entry.t -> ('self, 'a) entry_key -| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key - val name_of_entry : 'a Gram.entry -> 'a Entry.t (** Binding general entry keys to symbols *) -- cgit v1.2.3 From 9b2bb33662a4a1e39202cb81f894b739782c3434 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 26 Oct 2015 14:35:02 +0100 Subject: Indexing existentially quantified entries returned by interp_entry_name. --- parsing/egramcoq.ml | 4 ++-- parsing/egramcoq.mli | 4 ++-- parsing/egramml.ml | 4 ++-- parsing/egramml.mli | 14 ++++++++------ parsing/pcoq.ml | 2 +- parsing/pcoq.mli | 4 ++-- 6 files changed, 17 insertions(+), 15 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 7bfcf65e3e..14fe15e89e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -246,13 +246,13 @@ let get_tactic_entry n = type tactic_grammar = { tacgram_level : int; - tacgram_prods : grammar_prod_item list; + tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; } type all_grammar_command = | Notation of Notation.level * notation_grammar | TacticGrammar of KerName.t * tactic_grammar - | MLTacticGrammar of ml_tactic_name * grammar_prod_item list list + | MLTacticGrammar of ml_tactic_name * Tacexpr.raw_tactic_expr grammar_prod_item list list (** ML Tactic grammar extensions *) diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 2b0f7da8c2..cdd5fbd0f9 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -38,7 +38,7 @@ type notation_grammar = { type tactic_grammar = { tacgram_level : int; - tacgram_prods : grammar_prod_item list; + tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; } (** {5 Adding notations} *) @@ -50,7 +50,7 @@ val extend_tactic_grammar : KerName.t -> tactic_grammar -> unit (** Add a tactic notation rule to the parsing system. This produces a TacAlias tactic with the provided kernel name. *) -val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> grammar_prod_item list list -> unit +val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> Tacexpr.raw_tactic_expr grammar_prod_item list list -> unit (** Add a ML tactic notation rule to the parsing system. This produces a TacML tactic with the provided string as name. *) diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 8f07087085..77d60ff7d5 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -28,10 +28,10 @@ let make_generic_action (** Grammar extensions declared at ML level *) -type grammar_prod_item = +type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> grammar_prod_item + Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item let make_prod_item = function | GramTerminal s -> (gram_token_of_string s, None) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 60ec6a05a8..182a72086f 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -6,24 +6,26 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Vernacexpr + (** Mapping of grammar productions to camlp4 actions. *) (** This is the part specific to vernac extensions. For the Coq-level Notation and Tactic Notation, see Egramcoq. *) -type grammar_prod_item = +type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : Loc.t * Genarg.argument_type * - ('s, 'a) Pcoq.entry_key * Names.Id.t option -> grammar_prod_item + ('s, 'a) Pcoq.entry_key * Names.Id.t option -> 's grammar_prod_item val extend_vernac_command_grammar : - Vernacexpr.extend_name -> Vernacexpr.vernac_expr Pcoq.Gram.entry option -> - grammar_prod_item list -> unit + Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option -> + vernac_expr grammar_prod_item list -> unit -val get_extend_vernac_rule : Vernacexpr.extend_name -> grammar_prod_item list +val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_item list (** Utility function reused in Egramcoq : *) val make_rule : (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'b) -> - grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action + 's grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 1dea3497e4..2227f7e9ce 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -80,7 +80,7 @@ type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = | Aentry : 'a Entry.t -> ('self, 'a) entry_key | Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key -type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name +type 's entry_name = EntryName : entry_type * ('s, 'a) entry_key -> 's entry_name module type Gramtypes = sig diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 74b7bcc93f..8a1bc884a1 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -285,12 +285,12 @@ val name_of_entry : 'a Gram.entry -> 'a Entry.t val symbol_of_prod_entry_key : ('self, 'a) entry_key -> Gram.symbol -type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name +type 's entry_name = EntryName : entry_type * ('s, 'a) entry_key -> 's entry_name (** Interpret entry names of the form "ne_constr_list" as entry keys *) val interp_entry_name : bool (** true to fail on unknown entry *) -> - int option -> string -> string -> entry_name + int option -> string -> string -> 's entry_name (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * entry_type) list -- cgit v1.2.3 From 7264b11ca63eeb57f3b42cd9869793308b6c552f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 26 Oct 2015 17:06:00 +0100 Subject: Type-safe Egramml.make_rule. --- parsing/egramml.ml | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 50 insertions(+), 2 deletions(-) (limited to 'parsing') diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 77d60ff7d5..96c1566c4f 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -43,6 +43,54 @@ let make_rule mkact pt = let act = make_generic_action mkact ntl in (symbs, act) +type 'a ty_arg = Id.t * ('a -> raw_generic_argument) + +type ('self, _, 'r) ty_rule = +| TyStop : ('self, 'r, 'r) ty_rule +| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) Extend.symbol * 'b ty_arg option -> + ('self, 'b -> 'a, 'r) ty_rule + +type ('self, 'r) any_ty_rule = +| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule + +let rec ty_rule_of_gram = function +| [] -> AnyTyRule TyStop +| GramTerminal s :: rem -> + let AnyTyRule rem = ty_rule_of_gram rem in + let tok = Atoken (Lexer.terminal s) in + let r = TyNext (rem, tok, None) in + AnyTyRule r +| GramNonTerminal (_, t, tok, idopt) :: rem -> + let AnyTyRule rem = ty_rule_of_gram rem in + let inj = match idopt with + | None -> None + | Some id -> + (** FIXME *) + Some (id, fun obj -> Genarg.Unsafe.inj t (Obj.repr obj)) + in + let r = TyNext (rem, tok, inj) in + AnyTyRule r + +let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function +| TyStop -> Extend.Stop +| TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) + +type 'r gen_eval = Loc.t -> (Id.t * raw_generic_argument) list -> 'r + +let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function +| TyStop -> fun f loc -> f loc [] +| TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f +| TyNext (rem, tok, Some (id, inj)) -> fun f x -> + let f loc args = f loc ((id, inj x) :: args) in + ty_eval rem f + +let make_rule' f prod = + let AnyTyRule ty_rule = ty_rule_of_gram (List.rev prod) in + let symb = ty_erase ty_rule in + let f loc l = f loc (List.rev l) in + let act = ty_eval ty_rule f in + Extend.Rule (symb, act) + (** Vernac grammar extensions *) let vernac_exts = ref [] @@ -59,5 +107,5 @@ let extend_vernac_command_grammar s nt gl = let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; let mkact loc l = VernacExtend (s,List.map snd l) in - let rules = [make_rule mkact gl] in - maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)]) + let rules = [make_rule' mkact gl] in + grammar_extend nt None (None, [None, None, rules]) -- cgit v1.2.3 From 73c3dddc94dda003b1bb854d3b6ca9d15474e299 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 27 Oct 2015 10:28:23 +0100 Subject: Getting rid of most uses of unsafe_grammar_extend. --- parsing/egramcoq.ml | 22 +++++++++------------- parsing/egramml.ml | 27 ++------------------------- parsing/egramml.mli | 4 ++-- 3 files changed, 13 insertions(+), 40 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 14fe15e89e..84736f8aba 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -167,10 +167,9 @@ let rec make_constr_prod_item assoc from forpat = function [] let prepare_empty_levels forpat (pos,p4assoc,name,reinit) = - let entry = - if forpat then weaken_entry Constr.pattern - else weaken_entry Constr.operconstr in - unsafe_grammar_extend entry reinit (pos,[(name, p4assoc, [])]) + let empty = (pos, [(name, p4assoc, [])]) in + if forpat then grammar_extend Constr.pattern reinit empty + else grammar_extend Constr.operconstr reinit empty let pure_sublevels level symbs = let filter s = @@ -189,9 +188,6 @@ let extend_constr (entry,level) (n,assoc) mkact forpat rules = let symbs = make_constr_prod_item assoc n forpat pt in let pure_sublevels = pure_sublevels level symbs in let needed_levels = register_empty_levels forpat pure_sublevels in - let map_level (pos, ass1, name, ass2) = - (Option.map of_coq_position pos, Option.map of_coq_assoc ass1, name, ass2) in - let needed_levels = List.map map_level needed_levels in let pos,p4assoc,name,reinit = find_position forpat assoc level in let nb_decls = List.length needed_levels + 1 in List.iter (prepare_empty_levels forpat) needed_levels; @@ -233,11 +229,11 @@ let extend_constr_notation ng = let get_tactic_entry n = if Int.equal n 0 then - weaken_entry Tactic.simple_tactic, None + Tactic.simple_tactic, None else if Int.equal n 5 then - weaken_entry Tactic.binder_tactic, None + Tactic.binder_tactic, None else if 1<=n && n<5 then - weaken_entry Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) + Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) else error ("Invalid Tactic Notation level: "^(string_of_int n)^".") @@ -257,7 +253,7 @@ type all_grammar_command = (** ML Tactic grammar extensions *) let add_ml_tactic_entry name prods = - let entry = weaken_entry Tactic.simple_tactic in + let entry = Tactic.simple_tactic in let mkact i loc l : raw_tactic_expr = let open Tacexpr in let entry = { mltac_name = name; mltac_index = i } in @@ -265,7 +261,7 @@ let add_ml_tactic_entry name prods = in let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in synchronize_level_positions (); - unsafe_grammar_extend entry None (None ,[(None, None, List.rev rules)]); + grammar_extend entry None (None, [(None, None, List.rev rules)]); 1 (* Declaration of the tactic grammar rule *) @@ -285,7 +281,7 @@ let add_tactic_entry kn tg = in let rules = make_rule mkact tg.tacgram_prods in synchronize_level_positions (); - unsafe_grammar_extend entry None (Option.map of_coq_position pos,[(None, None, List.rev [rules])]); + grammar_extend entry None (pos, [(None, None, List.rev [rules])]); 1 let (grammar_state : (int * all_grammar_command) list ref) = ref [] diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 96c1566c4f..7a66b24f31 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -13,19 +13,6 @@ open Pcoq open Genarg open Vernacexpr -(** Making generic actions in type generic_argument *) - -let make_generic_action - (f:Loc.t -> ('b * raw_generic_argument) list -> 'a) pil = - let rec make env = function - | [] -> - Gram.action (fun loc -> f (to_coqloc loc) env) - | None :: tl -> (* parse a non-binding item *) - Gram.action (fun _ -> make env tl) - | Some (p, t) :: tl -> (* non-terminal *) - Gram.action (fun v -> make ((p, Unsafe.inj t v) :: env) tl) in - make [] (List.rev pil) - (** Grammar extensions declared at ML level *) type 's grammar_prod_item = @@ -33,16 +20,6 @@ type 's grammar_prod_item = | GramNonTerminal : Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item -let make_prod_item = function - | GramTerminal s -> (gram_token_of_string s, None) - | GramNonTerminal (_,t,e,po) -> - (symbol_of_prod_entry_key e, Option.map (fun p -> (p,t)) po) - -let make_rule mkact pt = - let (symbs,ntl) = List.split (List.map make_prod_item pt) in - let act = make_generic_action mkact ntl in - (symbs, act) - type 'a ty_arg = Id.t * ('a -> raw_generic_argument) type ('self, _, 'r) ty_rule = @@ -84,7 +61,7 @@ let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = fu let f loc args = f loc ((id, inj x) :: args) in ty_eval rem f -let make_rule' f prod = +let make_rule f prod = let AnyTyRule ty_rule = ty_rule_of_gram (List.rev prod) in let symb = ty_erase ty_rule in let f loc l = f loc (List.rev l) in @@ -107,5 +84,5 @@ let extend_vernac_command_grammar s nt gl = let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; let mkact loc l = VernacExtend (s,List.map snd l) in - let rules = [make_rule' mkact gl] in + let rules = [make_rule mkact gl] in grammar_extend nt None (None, [None, None, rules]) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 182a72086f..32646cfafa 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -27,5 +27,5 @@ val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_ (** Utility function reused in Egramcoq : *) val make_rule : - (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'b) -> - 's grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action + (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'a) -> + 'a grammar_prod_item list -> 'a Extend.production_rule -- cgit v1.2.3 From d51e5688f521c8a77a1dbdb0b88d8f99d5ff8060 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 27 Oct 2015 11:44:58 +0100 Subject: Finer type for Pcoq.interp_entry_name. --- parsing/pcoq.ml | 69 ++++++++++++++++++++++++++++++++------------------------ parsing/pcoq.mli | 7 ++++-- 2 files changed, 44 insertions(+), 32 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 2227f7e9ce..4bb1fd0a49 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -80,7 +80,8 @@ type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = | Aentry : 'a Entry.t -> ('self, 'a) entry_key | Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key -type 's entry_name = EntryName : entry_type * ('s, 'a) entry_key -> 's entry_name +type 's entry_name = EntryName : + 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name module type Gramtypes = sig @@ -789,51 +790,64 @@ let atactic n = if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) else Aentryl (name_of_entry Tactic.tactic_expr, n) +let unsafe_of_genarg : argument_type -> 'a raw_abstract_argument_type = + (** FIXME *) + Obj.magic + let try_get_entry u s = (** Order the effects: type_of_entry can raise Not_found *) let typ = type_of_entry u s in - Some typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s)) + let typ = unsafe_of_genarg typ in + EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s))) + +let wit_list : 'a raw_abstract_argument_type -> 'a list raw_abstract_argument_type = + fun t -> unsafe_of_genarg (ListArgType (unquote t)) + +let wit_opt : 'a raw_abstract_argument_type -> 'a option raw_abstract_argument_type = + fun t -> unsafe_of_genarg (OptArgType (unquote t)) + +type _ target = +| TgAny : 's target +| TgTactic : int -> Tacexpr.raw_tactic_expr target + +(** Quite ad-hoc *) +let get_tacentry (type s) (n : int) (t : s target) : s entry_name = match t with +| TgAny -> EntryName (rawwit wit_tactic, atactic n) +| TgTactic m -> + let check_lvl n = + Int.equal m n + && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) + && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) + in + if check_lvl n then EntryName (rawwit wit_tactic, Aself) + else if check_lvl (n + 1) then EntryName (rawwit wit_tactic, Anext) + else EntryName (rawwit wit_tactic, atactic n) let rec interp_entry_name static up_level s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - EntryName (ListArgType t, Alist1 g) + EntryName (wit_list t, Alist1 g) else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - EntryName (ListArgType t, Alist1sep (g,sep)) + EntryName (wit_list t, Alist1sep (g,sep)) else if l > 5 && coincide s "_list" (l-5) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - EntryName (ListArgType t, Alist0 g) + EntryName (wit_list t, Alist0 g) else if l > 9 && coincide s "_list_sep" (l-9) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - EntryName (ListArgType t, Alist0sep (g,sep)) + EntryName (wit_list t, Alist0sep (g,sep)) else if l > 4 && coincide s "_opt" (l-4) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in - EntryName (OptArgType t, Aopt g) + EntryName (wit_opt t, Aopt g) else if l > 5 && coincide s "_mods" (l-5) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - EntryName (ListArgType t, Amodifiers g) + EntryName (wit_list t, Amodifiers g) else let s = match s with "hyp" -> "var" | _ -> s in - let check_lvl n = match up_level with - | None -> false - | Some m -> Int.equal m n - && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) - && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) - in - let t, se = match tactic_level s with - | Some n -> - (** Quite ad-hoc *) - let t = unquote (rawwit wit_tactic) in - let se = - if check_lvl n then Aself - else if check_lvl (n + 1) then Anext - else atactic n - in - (Some t, se) + | Some n -> get_tacentry n up_level | None -> try try_get_entry uprim s with Not_found -> try try_get_entry uconstr s with Not_found -> @@ -841,12 +855,7 @@ let rec interp_entry_name static up_level s sep = if static then error ("Unknown entry "^s^".") else - None, Aentry (Entry.dynamic s) in - let t = - match t with - | Some t -> t - | None -> ExtraArgType s in - EntryName (t, se) + EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s)) let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 8a1bc884a1..69b25879bf 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -285,12 +285,15 @@ val name_of_entry : 'a Gram.entry -> 'a Entry.t val symbol_of_prod_entry_key : ('self, 'a) entry_key -> Gram.symbol -type 's entry_name = EntryName : entry_type * ('s, 'a) entry_key -> 's entry_name +type 's entry_name = EntryName : + 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name (** Interpret entry names of the form "ne_constr_list" as entry keys *) +type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target + val interp_entry_name : bool (** true to fail on unknown entry *) -> - int option -> string -> string -> 's entry_name + 's target -> string -> string -> 's entry_name (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * entry_type) list -- cgit v1.2.3 From 72bed859fb8d037044abd8a1518661c52502f7be Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 27 Oct 2015 11:44:58 +0100 Subject: Type-safe Egramml.grammar_prod_item. --- parsing/egramml.ml | 6 ++---- parsing/egramml.mli | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) (limited to 'parsing') diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 7a66b24f31..984027b815 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -18,7 +18,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item + Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item type 'a ty_arg = Id.t * ('a -> raw_generic_argument) @@ -41,9 +41,7 @@ let rec ty_rule_of_gram = function let AnyTyRule rem = ty_rule_of_gram rem in let inj = match idopt with | None -> None - | Some id -> - (** FIXME *) - Some (id, fun obj -> Genarg.Unsafe.inj t (Obj.repr obj)) + | Some id -> Some (id, fun obj -> Genarg.in_gen t obj) in let r = TyNext (rem, tok, inj) in AnyTyRule r diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 32646cfafa..e3ae4e0118 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -15,7 +15,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string - | GramNonTerminal : Loc.t * Genarg.argument_type * + | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type * ('s, 'a) Pcoq.entry_key * Names.Id.t option -> 's grammar_prod_item val extend_vernac_command_grammar : -- cgit v1.2.3 From 04b244a4ba8605a97cd96855b4c4e628ba27db7b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 27 Oct 2015 14:08:54 +0100 Subject: Removing unused code in Pcoq. --- parsing/pcoq.ml | 1 - parsing/pcoq.mli | 16 +--------------- 2 files changed, 1 insertion(+), 16 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 4bb1fd0a49..b017fddc71 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -52,7 +52,6 @@ end (** Grammar entries with associated types *) -type entry_type = argument_type type grammar_object = Gramobj.grammar_object type typed_entry = argument_type * grammar_object G.entry let in_typed_entry t e = (t,Gramobj.weaken_entry e) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 69b25879bf..9a27b6e045 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -139,19 +139,6 @@ val grammar_extend : (** Remove the last n extensions *) val remove_grammars : int -> unit - - - -(** The type of typed grammar objects *) -type typed_entry - -(** The possible types for extensible grammars *) -type entry_type = argument_type - -val type_of_typed_entry : typed_entry -> entry_type -val object_of_typed_entry : typed_entry -> grammar_object Gram.entry -val weaken_entry : 'a Gram.entry -> grammar_object Gram.entry - (** Temporary activate camlp4 verbosity *) val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit @@ -171,7 +158,6 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe -val create_entry : gram_universe -> string -> entry_type -> typed_entry val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> 'a Gram.entry @@ -296,7 +282,7 @@ val interp_entry_name : bool (** true to fail on unknown entry *) -> 's target -> string -> string -> 's entry_name (** Recover the list of all known tactic notation entries. *) -val list_entry_names : unit -> (string * entry_type) list +val list_entry_names : unit -> (string * argument_type) list (** Registering/resetting the level of a constr entry *) -- cgit v1.2.3 From 4444f04cfdbe449d184ac1ce0a56eb484805364d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 28 Oct 2015 12:56:29 +0100 Subject: Fixing the return type of the Atoken symbol. --- parsing/pcoq.ml | 2 +- parsing/pcoq.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b017fddc71..4565b87a01 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -67,7 +67,7 @@ let weaken_entry x = Gramobj.weaken_entry x *) type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, Tok.t) entry_key +| Atoken : Tok.t -> ('self, string) entry_key | Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key | Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 9a27b6e045..c224dbad9c 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -113,7 +113,7 @@ type gram_reinit = gram_assoc * gram_position *) type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, Tok.t) entry_key +| Atoken : Tok.t -> ('self, string) entry_key | Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key | Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -- cgit v1.2.3 From 7f8a31e21edd533ba12399b7ee5647ef30e38fe5 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 29 Oct 2015 17:22:08 +0100 Subject: Manually expand the debugging versions of "trivial" and "auto". (Fix bug #4392) Without this expansion, camlp4 fails to properly factor a user notation starting with either "trivial" or "auto". --- parsing/g_tactic.ml4 | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 69593f993c..d3eb6bbcbb 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -452,16 +452,6 @@ GEXTEND Gram [ [ "using"; l = LIST1 constr SEP "," -> l | -> [] ] ] ; - trivial: - [ [ IDENT "trivial" -> Off - | IDENT "info_trivial" -> Info - | IDENT "debug"; IDENT "trivial" -> Debug ] ] - ; - auto: - [ [ IDENT "auto" -> Off - | IDENT "info_auto" -> Info - | IDENT "debug"; IDENT "auto" -> Debug ] ] - ; eliminator: [ [ "using"; el = constr_with_bindings -> el ] ] ; @@ -627,9 +617,18 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Automation tactic *) - | d = trivial; lems = auto_using; db = hintbases -> TacAtom (!@loc, TacTrivial (d,lems,db)) - | d = auto; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (d,n,lems,db)) + | IDENT "trivial"; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacTrivial (Off, lems, db)) + | IDENT "info_trivial"; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacTrivial (Info, lems, db)) + | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacTrivial (Debug, lems, db)) + | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (Off, n, lems, db)) + | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (Info, n, lems, db)) + | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (Debug, n, lems, db)) (* Context management *) | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) -- cgit v1.2.3 From 668c2edc15aad38229eb46c022571df2cbf31079 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 30 Oct 2015 17:18:12 +0100 Subject: Manually expand red_tactic so that notations do not break reduction tactics. (Fix bug #3654) --- parsing/g_tactic.ml4 | 41 +++++++++++++++++++++++++---------------- 1 file changed, 25 insertions(+), 16 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index d3eb6bbcbb..c94ac846f1 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -339,21 +339,6 @@ GEXTEND Gram | d = delta_flag -> all_with d ] ] ; - red_tactic: - [ [ IDENT "red" -> Red false - | IDENT "hnf" -> Hnf - | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po) - | IDENT "cbv"; s = strategy_flag -> Cbv s - | IDENT "cbn"; s = strategy_flag -> Cbn s - | IDENT "lazy"; s = strategy_flag -> Lazy s - | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) - | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po - | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po - | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul - | IDENT "fold"; cl = LIST1 constr -> Fold cl - | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl ] ] - ; - (* This is [red_tactic] including possible extensions *) red_expr: [ [ IDENT "red" -> Red false | IDENT "hnf" -> Hnf @@ -676,7 +661,31 @@ GEXTEND Gram TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) (* Conversion *) - | r = red_tactic; cl = clause_dft_concl -> TacAtom (!@loc, TacReduce (r, cl)) + | IDENT "red"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Red false, cl)) + | IDENT "hnf"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Hnf, cl)) + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Simpl (all_with d, po), cl)) + | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv s, cl)) + | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbn s, cl)) + | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Lazy s, cl)) + | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv (all_with delta), cl)) + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvVm po, cl)) + | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvNative po, cl)) + | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Unfold ul, cl)) + | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Fold l, cl)) + | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Pattern pl, cl)) + (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl -> let p,cl = merge_occurrences (!@loc) cl oc in -- cgit v1.2.3 From 4e643d134f02cfa9a73754c3cf48048541324834 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 31 Oct 2015 15:49:09 +0100 Subject: Adding syntax "Show id" to show goal named id (shelved or not). --- parsing/g_proofs.ml4 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 7f5459bfa6..017f0ea50b 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -73,8 +73,10 @@ GEXTEND Gram | IDENT "Unfocused" -> VernacUnfocused | IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals) | IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n)) + | IDENT "Show"; id = ident -> VernacShow (ShowGoal (GoalId id)) + | IDENT "Show"; IDENT "Goal" -> VernacShow (ShowGoal (GoalId (Names.Id.of_string "Goal"))) | IDENT "Show"; IDENT "Goal"; n = string -> - VernacShow (ShowGoal (GoalId n)) + VernacShow (ShowGoal (GoalUid n)) | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> VernacShow (ShowGoalImplicitly n) | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode -- cgit v1.2.3 From 982460743a54ecfab1d601ba930d61c04972d17a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 26 Nov 2015 19:05:25 +0100 Subject: Fixing the "parsing rules with idents later declared as keywords" problem. The fix was actually elementary. The lexer comes with a function to compare parsed tokens against tokens of the parsing rules. It is enough to have this function considering an ident in a parsing rule to be equal to the corresponding string parsed as a keyword. --- parsing/tok.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'parsing') diff --git a/parsing/tok.ml b/parsing/tok.ml index efd57968d2..12140f4036 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -21,6 +21,7 @@ type t = | EOI let equal t1 t2 = match t1, t2 with +| IDENT s1, KEYWORD s2 -> CString.equal s1 s2 | KEYWORD s1, KEYWORD s2 -> CString.equal s1 s2 | METAIDENT s1, METAIDENT s2 -> CString.equal s1 s2 | PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2 -- cgit v1.2.3 From 9205d8dc7b9e97b6c2f0815fddc5673c21d11089 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 2 Nov 2015 12:26:53 +0100 Subject: Changing syntax "$(tactic)$" into "ltac:(tactic)", as discussed in WG. --- parsing/g_constr.ml4 | 2 +- parsing/g_ltac.ml4 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'parsing') diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index e2e6795f73..8df91da24b 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -218,7 +218,7 @@ GEXTEND Gram CGeneralization (!@loc, Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> CGeneralization (!@loc, Explicit, None, c) - | "$("; tac = Tactic.tactic; ")$" -> + | "ltac:"; "("; tac = Tactic.tactic_expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in CHole (!@loc, None, IntroAnonymous, Some arg) ] ] diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index a4dba506d2..4a9ca23f15 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -134,8 +134,8 @@ GEXTEND Gram ; (* Tactic arguments *) tactic_arg: - [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a - | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n) + [ [ "ltac:"; a = tactic_expr LEVEL "0" -> arg_of_expr a + | "ltac:"; n = natural -> TacGeneric (genarg_of_int n) | a = tactic_top_or_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) -- cgit v1.2.3 From cc153dbbe45d5cf7f6ebfef6010adcc4f5bb568c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 2 Dec 2015 15:18:42 +0100 Subject: Dead code from August 2014 in apply in. --- parsing/g_tactic.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index c94ac846f1..8e5e1f1fb8 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -399,7 +399,7 @@ GEXTEND Gram | -> [] ] ] ; in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (None,id,ipat) + [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) | -> None ] ] ; orient: -- cgit v1.2.3 From 6ab4479dfa0f9b8fd4df4342fdfdab6c25b62fb7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 2 Dec 2015 12:10:53 +0100 Subject: Improving syntax of pat/constr introduction pattern so that pat/c1/.../cn behaves as intro H; apply c1, ... , cn in H as pat. Open to other suggestions of syntax though. --- parsing/g_tactic.ml4 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 8e5e1f1fb8..b7559a1989 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -296,11 +296,17 @@ GEXTEND Gram | "**" -> !@loc, IntroForthcoming false ]] ; simple_intropattern: + [ [ pat = simple_intropattern_closed; l = LIST0 ["/"; c = constr -> c] -> + let loc0,pat = pat in + let f c pat = + let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in + IntroAction (IntroApplyOn (c,(loc,pat))) in + !@loc, List.fold_right f l pat ] ] + ; + simple_intropattern_closed: [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat) | pat = equality_intropattern -> !@loc, IntroAction pat | "_" -> !@loc, IntroAction IntroWildcard - | pat = simple_intropattern; "/"; c = constr -> - !@loc, IntroAction (IntroApplyOn (c,pat)) | pat = naming_intropattern -> !@loc, IntroNaming pat ] ] ; simple_binding: -- cgit v1.2.3 From 387351b4c0ffeff65d8a7192f5073cfd4bd20f53 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Dec 2015 00:14:37 +0100 Subject: Changing "destruct !hyp" into "destruct (hyp)" (and similarly for induction) based on a suggestion of Guillaume M. (done like this in ssreflect). This is actually consistent with the hack of using "destruct (1)" to mean the term 1 by opposition to the use of "destruct 1" to mean the first non-dependent hypothesis of the goal. --- parsing/g_tactic.ml4 | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index b7559a1989..4d42dfe85a 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -44,6 +44,20 @@ let test_lpar_id_coloneq = | _ -> err ()) | _ -> err ()) +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ")" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = Gram.Entry.of_parser "test_lpar_idnum_coloneq" @@ -224,8 +238,9 @@ GEXTEND Gram ; induction_arg: [ [ n = natural -> (None,ElimOnAnonHyp n) + | test_lpar_id_rpar; c = constr_with_bindings -> + (Some false,induction_arg_of_constr c) | c = constr_with_bindings -> (None,induction_arg_of_constr c) - | "!"; c = constr_with_bindings -> (Some false,induction_arg_of_constr c) ] ] ; constr_with_bindings_arg: -- cgit v1.2.3 From fb77937a6ba0fe45e978911db08de57f931683e1 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 9 Dec 2015 23:38:00 +0100 Subject: Changing syntax of pat/constr1.../constrn into pat%constr1...%constrn. Marking it as experimental. --- parsing/g_tactic.ml4 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 4d42dfe85a..3d59b9b8db 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -311,7 +311,8 @@ GEXTEND Gram | "**" -> !@loc, IntroForthcoming false ]] ; simple_intropattern: - [ [ pat = simple_intropattern_closed; l = LIST0 ["/"; c = constr -> c] -> + [ [ pat = simple_intropattern_closed; + l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> let loc0,pat = pat in let f c pat = let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in -- cgit v1.2.3 From 1aecaf88e5491d29b200515fc64ce3d479318758 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 10 Dec 2015 11:47:38 +0100 Subject: Tactics: Generalizing the use of the experimental clearing modifier to all cases of rewrite. --- parsing/g_tactic.ml4 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 3d59b9b8db..3e4a6c6a1b 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -240,7 +240,7 @@ GEXTEND Gram [ [ n = natural -> (None,ElimOnAnonHyp n) | test_lpar_id_rpar; c = constr_with_bindings -> (Some false,induction_arg_of_constr c) - | c = constr_with_bindings -> (None,induction_arg_of_constr c) + | c = constr_with_bindings_arg -> on_snd induction_arg_of_constr c ] ] ; constr_with_bindings_arg: @@ -499,12 +499,12 @@ GEXTEND Gram [ [ id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> (id1,id2) ] ] ; rewriter : - [ [ "!"; c = constr_with_bindings -> (RepeatPlus,(None,c)) + [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c) - | n = natural; "!"; c = constr_with_bindings -> (Precisely n,(None,c)) + | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,c) | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c) | n = natural; c = constr_with_bindings_arg -> (Precisely n,c) - | c = constr_with_bindings -> (Precisely 1, (None,c)) + | c = constr_with_bindings_arg -> (Precisely 1, c) ] ] ; oriented_rewriter : -- cgit v1.2.3 From 003fe3d5e60b8d89b28e718e3d048818caceb56a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 15 Dec 2015 10:46:15 +0100 Subject: Adding a token "index" representing positions (1st, 2nd, etc.). --- parsing/g_prim.ml4 | 5 ++++- parsing/lexer.ml4 | 24 +++++++++++++++++++----- parsing/pcoq.ml | 1 + parsing/pcoq.mli | 1 + parsing/tok.ml | 7 +++++++ parsing/tok.mli | 1 + 6 files changed, 33 insertions(+), 6 deletions(-) (limited to 'parsing') diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 84da9c424c..b3cd939266 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -32,7 +32,7 @@ let my_int_of_string loc s = GEXTEND Gram GLOBAL: - bigint natural integer identref name ident var preident + bigint natural index integer identref name ident var preident fullyqualid qualid reference dirpath ne_lstring ne_string string pattern_ident pattern_identref by_notation smart_global; preident: @@ -113,6 +113,9 @@ GEXTEND Gram natural: [ [ i = INT -> my_int_of_string (!@loc) i ] ] ; + index: + [ [ i = INDEX -> my_int_of_string (!@loc) i ] ] + ; bigint: (* Negative numbers are dealt with specially *) [ [ i = INT -> (Bigint.of_string i) ] ] ; diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 23bd74da95..d7941bedb4 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -262,9 +262,23 @@ let rec ident_tail len = parser ident_tail (nstore n len s) s | _ -> len -let rec number len = parser - | [< ' ('0'..'9' as c); s >] -> number (store len c) s - | [< >] -> len +let check_no_char s = + match Stream.npeek 3 s with + | [_;_;('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_')] -> false + | [_;_;_] -> true + | [_;_] -> true + | _ -> assert false + +let rec number_or_index c len = parser + | [< ' ('0'..'9' as c); s >] -> number_or_index c (store len c) s + | [< s >] -> + match Stream.npeek 2 s with + | ['s';'t'] when c = '1' && check_no_char s -> njunk 2 s; false, len + | ['n';'d'] when c = '2' && check_no_char s -> njunk 2 s; false, len + | ['r';'d'] when c = '3' && check_no_char s -> njunk 2 s; false, len + | ['t';'h'] when not (len=1 && c='0') && check_no_char s -> + njunk 2 s; false, len + | _ -> true, len let rec string in_comments bp len = parser | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] -> @@ -513,9 +527,9 @@ let rec next_token = parser bp let id = get_buff len in comment_stop bp; (try find_keyword id s with Not_found -> IDENT id), (bp, ep) - | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep -> + | [< ' ('0'..'9' as c); (b,len) = number_or_index c (store 0 c) >] ep -> comment_stop bp; - (INT (get_buff len), (bp, ep)) + (if b then INT (get_buff len) else INDEX (get_buff len)), (bp, ep) | [< ''\"'; len = string None bp 0 >] ep -> comment_stop bp; (STRING (get_buff len), (bp, ep)) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 4565b87a01..df0d262062 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -298,6 +298,7 @@ module Prim = let preident = gec_gen (rawwit wit_pre_ident) "preident" let ident = gec_gen (rawwit wit_ident) "ident" let natural = gec_gen (rawwit wit_int) "natural" + let index = gec_gen (rawwit wit_int) "index" let integer = gec_gen (rawwit wit_int) "integer" let bigint = Gram.entry_create "Prim.bigint" let string = gec_gen (rawwit wit_string) "string" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index c224dbad9c..ad4d9e5019 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -173,6 +173,7 @@ module Prim : val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry val natural : int Gram.entry + val index : int Gram.entry val bigint : Bigint.bigint Gram.entry val integer : int Gram.entry val string : string Gram.entry diff --git a/parsing/tok.ml b/parsing/tok.ml index 12140f4036..427080788a 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -15,6 +15,7 @@ type t = | IDENT of string | FIELD of string | INT of string + | INDEX of string | STRING of string | LEFTQMARK | BULLET of string @@ -28,6 +29,7 @@ let equal t1 t2 = match t1, t2 with | IDENT s1, IDENT s2 -> CString.equal s1 s2 | FIELD s1, FIELD s2 -> CString.equal s1 s2 | INT s1, INT s2 -> CString.equal s1 s2 +| INDEX s1, INDEX s2 -> CString.equal s1 s2 | STRING s1, STRING s2 -> CString.equal s1 s2 | LEFTQMARK, LEFTQMARK -> true | BULLET s1, BULLET s2 -> CString.equal s1 s2 @@ -42,6 +44,7 @@ let extract_string = function | PATTERNIDENT s -> s | FIELD s -> s | INT s -> s + | INDEX s -> s | LEFTQMARK -> "?" | BULLET s -> s | EOI -> "" @@ -53,6 +56,7 @@ let to_string = function | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s | FIELD s -> Format.sprintf "FIELD %S" s | INT s -> Format.sprintf "INT %s" s + | INDEX s -> Format.sprintf "INDEX %s" s | STRING s -> Format.sprintf "STRING %S" s | LEFTQMARK -> "LEFTQMARK" | BULLET s -> Format.sprintf "STRING %S" s @@ -76,6 +80,7 @@ let of_pattern = function | "PATTERNIDENT", s -> PATTERNIDENT s | "FIELD", s -> FIELD s | "INT", s -> INT s + | "INDEX", s -> INDEX s | "STRING", s -> STRING s | "LEFTQMARK", _ -> LEFTQMARK | "BULLET", s -> BULLET s @@ -89,6 +94,7 @@ let to_pattern = function | PATTERNIDENT s -> "PATTERNIDENT", s | FIELD s -> "FIELD", s | INT s -> "INT", s + | INDEX s -> "INDEX", s | STRING s -> "STRING", s | LEFTQMARK -> "LEFTQMARK", "" | BULLET s -> "BULLET", s @@ -103,6 +109,7 @@ let match_pattern = | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ()) | "FIELD", "" -> (function FIELD s -> s | _ -> err ()) | "INT", "" -> (function INT s -> s | _ -> err ()) + | "INDEX", "" -> (function INDEX s -> s | _ -> err ()) | "STRING", "" -> (function STRING s -> s | _ -> err ()) | "LEFTQMARK", "" -> (function LEFTQMARK -> "" | _ -> err ()) | "BULLET", "" -> (function BULLET s -> s | _ -> err ()) diff --git a/parsing/tok.mli b/parsing/tok.mli index feee1983d0..3414de36bc 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -15,6 +15,7 @@ type t = | IDENT of string | FIELD of string | INT of string + | INDEX of string | STRING of string | LEFTQMARK | BULLET of string -- cgit v1.2.3 From e181c9b043e64342c1e51763f4fe88c78bc4736d Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 12:20:47 +0100 Subject: CLEANUP: Vernacexpr.vernac_expr Originally, "VernacTime" and "VernacRedirect" were defined like this: type vernac_expr = ... | VernacTime of vernac_list | VernacRedirect of string * vernac_list ... where type vernac_list = located_vernac_expr list Currently, that list always contained one and only one element. So I propose changing the definition of these two variants in the following way: | VernacTime of located_vernac_expr | VernacRedirect of string * located_vernac_expr which covers all our current needs and enforces the invariant related to the number of commands that are part of the "VernacTime" and "VernacRedirect" variants. --- parsing/g_vernac.ml4 | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 1f9f57f698..975dee934f 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -89,8 +89,8 @@ let default_command_entry = GEXTEND Gram GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; vernac: FIRST - [ [ IDENT "Time"; l = vernac_list -> VernacTime l - | IDENT "Redirect"; s = ne_string; l = vernac_list -> VernacRedirect (s, l) + [ [ IDENT "Time"; c = located_vernac -> VernacTime c + | IDENT "Redirect"; s = ne_string; c = located_vernac -> VernacRedirect (s, c) | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) | IDENT "Fail"; v = vernac -> VernacFail v @@ -128,9 +128,6 @@ GEXTEND Gram | c = subprf -> c ] ] ; - vernac_list: - [ [ c = located_vernac -> [c] ] ] - ; vernac_aux: LAST [ [ prfcom = default_command_entry -> prfcom ] ] ; @@ -806,7 +803,7 @@ GEXTEND Gram command: [ [ IDENT "Ltac"; l = LIST1 tacdef_body SEP "with" -> - VernacDeclareTacticDefinition (true, l) + VernacDeclareTacticDefinition l | IDENT "Comments"; l = LIST0 comment -> VernacComments l -- cgit v1.2.3 From ee3d0f32051d98bdba2a4ad2234966a2fa30a8ec Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 14:27:20 +0100 Subject: ALPHA-CONVERSION: in "parsing/g_vernac.ml4" file --- parsing/g_vernac.ml4 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 975dee934f..2c9894dad2 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -174,13 +174,13 @@ GEXTEND Gram ; END -let test_plurial_form = function +let test_plural_form = function | [(_,([_],_))] -> Flags.if_verbose msg_warning (strbrk "Keywords Variables/Hypotheses/Parameters expect more than one assumption") | _ -> () -let test_plurial_form_types = function +let test_plural_form_types = function | [([_],_)] -> Flags.if_verbose msg_warning (strbrk "Keywords Implicit Types expect more than one type") @@ -201,7 +201,7 @@ GEXTEND Gram | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | stre = assumptions_token; nl = inline; bl = assum_list -> - test_plurial_form bl; + test_plural_form bl; VernacAssumption (stre, nl, bl) | d = def_token; id = pidentref; b = def_body -> VernacDefinition (d, id, b) @@ -733,7 +733,7 @@ GEXTEND Gram VernacReserve bl | IDENT "Implicit"; IDENT "Types"; bl = reserv_list -> - test_plurial_form_types bl; + test_plural_form_types bl; VernacReserve bl | IDENT "Generalizable"; -- cgit v1.2.3 From 20641795624dbb03da0401e4dc503660e5e73df6 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:50:40 +0100 Subject: CLEANUP: Vernacexpr.VernacDeclareTacticDefinition The definition of Vernacexpr.VernacDeclareTacticDefinition was changed. The original definition allowed us to represent non-sensical value such as: VernacDeclareTacticDefinition(Qualid ..., false, ...) The new definition prevents that. --- parsing/g_ltac.ml4 | 20 ++++++++++---------- parsing/pcoq.mli | 2 +- 2 files changed, 11 insertions(+), 11 deletions(-) (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 4a9ca23f15..181c2395d2 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -242,17 +242,17 @@ GEXTEND Gram | n = integer -> MsgInt n ] ] ; - ltac_def_kind: - [ [ ":=" -> false - | "::=" -> true ] ] - ; - (* Definitions for tactics *) - tacdef_body: - [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - (name, redef, TacFun (it, body)) - | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - (name, redef, body) ] ] + tacdef_body: + [ [ id = ident; it=LIST1 input_fun; ":="; body = tactic_expr -> + Vernacexpr.TacticDefinition ((!@loc,id), TacFun (it, body)) + | name = Constr.global; it=LIST1 input_fun; "::="; body = tactic_expr -> + Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + | id = ident; ":="; body = tactic_expr -> + Vernacexpr.TacticDefinition ((!@loc,id), body) + | name = Constr.global; "::="; body = tactic_expr -> + Vernacexpr.TacticRedefinition (name, body) + ] ] ; tactic: [ [ tac = tactic_expr -> tac ] ] diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index ad4d9e5019..fdba413854 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -237,7 +237,7 @@ module Tactic : val binder_tactic : raw_tactic_expr Gram.entry val tactic : raw_tactic_expr Gram.entry val tactic_eoi : raw_tactic_expr Gram.entry - val tacdef_body : (reference * bool * raw_tactic_expr) Gram.entry + val tacdef_body : Vernacexpr.tacdef_body Gram.entry end module Vernac_ : -- cgit v1.2.3 From 1b5f85d38db7a0d7cb9a4b9491a5563461373182 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 17:31:25 +0100 Subject: CLEANUP: the definition of the "Constrexpr.case_expr" type was simplified --- parsing/g_constr.ml4 | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) (limited to 'parsing') diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 8df91da24b..2dec3b222a 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -267,14 +267,14 @@ GEXTEND Gram CLetTuple (!@loc,lb,po,c1,c2) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, None, [(c1,(None,None))], [(!@loc, [(!@loc,[p])], c2)]) + CCases (!@loc, LetPatternStyle, None, [c1, None, None], [(!@loc, [(!@loc,[p])], c2)]) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(!@loc, [(!@loc, [p])], c2)]) + CCases (!@loc, LetPatternStyle, Some rt, [c1, aliasvar p, None], [(!@loc, [(!@loc, [p])], c2)]) | "let"; "'"; p=pattern; "in"; t = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, Some t))], [(!@loc, [(!@loc, [p])], c2)]) + CCases (!@loc, LetPatternStyle, Some rt, [c1, aliasvar p, Some t], [(!@loc, [(!@loc, [p])], c2)]) | "if"; c=operconstr LEVEL "200"; po = return_type; "then"; b1=operconstr LEVEL "200"; "else"; b2=operconstr LEVEL "200" -> @@ -338,11 +338,10 @@ GEXTEND Gram br=branches; "end" -> CCases(!@loc,RegularStyle,ty,ci,br) ] ] ; case_item: - [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] - ; - pred_pattern: - [ [ ona = OPT ["as"; id=name -> id]; - ty = OPT ["in"; t=pattern -> t] -> (ona,ty) ] ] + [ [ c=operconstr LEVEL "100"; + ona = OPT ["as"; id=name -> id]; + ty = OPT ["in"; t=pattern -> t] -> + (c,ona,ty) ] ] ; case_type: [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ] -- cgit v1.2.3 From 74ebc8b3c20a41f17244d3ab13f984ede2e201e3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 23 Dec 2015 17:32:23 +0100 Subject: Partial backtrack on commit 20641795624. The parsing rules were broken and disallowed tactic replacement of the form Ltac ident ::= expr. --- parsing/g_ltac.ml4 | 31 ++++++++++++++++++++++--------- 1 file changed, 22 insertions(+), 9 deletions(-) (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 181c2395d2..3f8dd9f193 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -29,6 +29,12 @@ let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat +let reference_to_id = function + | Libnames.Ident (loc, id) -> (loc, id) + | Libnames.Qualid (loc,_) -> + Errors.user_err_loc (loc, "", + str "This expression should be a simple identifier.") + (* Tactics grammar rules *) GEXTEND Gram @@ -242,16 +248,23 @@ GEXTEND Gram | n = integer -> MsgInt n ] ] ; + ltac_def_kind: + [ [ ":=" -> false + | "::=" -> true ] ] + ; + (* Definitions for tactics *) - tacdef_body: - [ [ id = ident; it=LIST1 input_fun; ":="; body = tactic_expr -> - Vernacexpr.TacticDefinition ((!@loc,id), TacFun (it, body)) - | name = Constr.global; it=LIST1 input_fun; "::="; body = tactic_expr -> - Vernacexpr.TacticRedefinition (name, TacFun (it, body)) - | id = ident; ":="; body = tactic_expr -> - Vernacexpr.TacticDefinition ((!@loc,id), body) - | name = Constr.global; "::="; body = tactic_expr -> - Vernacexpr.TacticRedefinition (name, body) + tacdef_body: + [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, TacFun (it, body)) + | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, body) ] ] ; tactic: -- cgit v1.2.3 From daa7cb065a238c7d4ee394e00315d66d023e5259 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Dec 2015 17:55:25 +0100 Subject: Removing auto from the tactic AST. --- parsing/g_tactic.ml4 | 14 -------------- 1 file changed, 14 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 3e4a6c6a1b..a197e0209c 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -623,20 +623,6 @@ GEXTEND Gram | IDENT "edestruct"; icl = induction_clause_list -> TacAtom (!@loc, TacInductionDestruct(false,true,icl)) - (* Automation tactic *) - | IDENT "trivial"; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacTrivial (Off, lems, db)) - | IDENT "info_trivial"; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacTrivial (Info, lems, db)) - | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacTrivial (Debug, lems, db)) - | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (Off, n, lems, db)) - | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (Info, n, lems, db)) - | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (Debug, n, lems, db)) - (* Context management *) | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) | IDENT "clear"; l = LIST0 id_or_meta -> -- cgit v1.2.3 From 83b2b197eb33b78f2e3054819f1a36f971c24426 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 16 Dec 2015 23:23:56 +0100 Subject: Fixing non exhaustive pattern-matching in 003fe3d5e60b. --- parsing/compat.ml4 | 1 + 1 file changed, 1 insertion(+) (limited to 'parsing') diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 4208fd364e..a214b58a60 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -266,6 +266,7 @@ IFDEF CAMLP5 THEN | Tok.PATTERNIDENT s -> "PATTERNIDENT", s | Tok.FIELD s -> "FIELD", s | Tok.INT s -> "INT", s + | Tok.INDEX s -> "INDEX", s | Tok.STRING s -> "STRING", s | Tok.LEFTQMARK -> "LEFTQMARK", "" | Tok.BULLET s -> "BULLET", s -- cgit v1.2.3 From 1f2cc4026cd5e977979ff1507fd5fa0d96e1a92f Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 25 Dec 2015 06:08:29 +0100 Subject: Moving the ad hoc interpretation of "intros" as "intros **" from tacinterp.ml to g_tactic.ml4 so as to leave room for "IntroPattern []" to mean "no introduction". --- parsing/g_tactic.ml4 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index a197e0209c..31125e37cf 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -281,6 +281,9 @@ GEXTEND Gram intropatterns: [ [ l = LIST0 nonsimple_intropattern -> l ]] ; + ne_intropatterns: + [ [ l = LIST1 nonsimple_intropattern -> l ]] + ; or_and_intropattern: [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> tc | "()" -> [[]] @@ -532,7 +535,10 @@ GEXTEND Gram simple_tactic: [ [ (* Basic tactics *) - IDENT "intros"; pl = intropatterns -> TacAtom (!@loc, TacIntroPattern pl) + IDENT "intros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern pl) + | IDENT "intros" -> + TacAtom (!@loc, TacIntroPattern [!@loc,IntroForthcoming false]) | IDENT "intro"; id = ident; hto = move_location -> TacAtom (!@loc, TacIntroMove (Some id, hto)) | IDENT "intro"; hto = move_location -> TacAtom (!@loc, TacIntroMove (None, hto)) -- cgit v1.2.3 From cb2f6a95ee72edb956f419a24f8385c8ae7f96f4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 Dec 2015 02:08:42 +0100 Subject: Removing the special status of open_constr generic argument. We also intepret it at toplevel as a true constr and push the resulting evarmap in the current state. --- parsing/g_tactic.ml4 | 2 +- parsing/pcoq.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 31125e37cf..1fe12ce3e0 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -231,7 +231,7 @@ GEXTEND Gram [ [ id = identref -> id ] ] ; open_constr: - [ [ c = constr -> ((),c) ] ] + [ [ c = constr -> c ] ] ; uconstr: [ [ c = constr -> c ] ] diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index fdba413854..592c879197 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -219,7 +219,7 @@ module Module : module Tactic : sig - val open_constr : open_constr_expr Gram.entry + val open_constr : constr_expr Gram.entry val constr_with_bindings : constr_expr with_bindings Gram.entry val bindings : constr_expr bindings Gram.entry val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry -- cgit v1.2.3 From a4cc4ea007b074009bea485e75f7efef3d4d25f3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 Dec 2015 15:42:16 +0100 Subject: Removing unused parsing entries. --- parsing/g_tactic.ml4 | 9 --------- 1 file changed, 9 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 1fe12ce3e0..a7b05dd5eb 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -453,15 +453,6 @@ GEXTEND Gram [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] ; - hintbases: - [ [ "with"; "*" -> None - | "with"; l = LIST1 [ x = IDENT -> x] -> Some l - | -> Some [] ] ] - ; - auto_using: - [ [ "using"; l = LIST1 constr SEP "," -> l - | -> [] ] ] - ; eliminator: [ [ "using"; el = constr_with_bindings -> el ] ] ; -- cgit v1.2.3 From 203b0eaac832af3b62e484c1aef89a02ffe8e29b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Dec 2015 18:31:17 +0100 Subject: External tactics and notations now accept any tactic argument. This commit has deep consequences in term of tactic evaluation, as it allows to pass any tac_arg to ML and alias tactics rather than mere generic arguments. This makes the evaluation much more uniform, and in particular it removes the special evaluation function for notations. This last point may break some notations out there unluckily. I had to treat in an ad-hoc way the tactic(...) entry of tactic notations because it is actually not interpreted as a generic argument but rather as a proper tactic expression instead. There is for now no syntax to pass any tactic argument to a given ML or notation tactic, but this should come soon. Also fixes bug #3849 en passant. --- parsing/egramcoq.ml | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 84736f8aba..2bc5b0f83f 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -257,7 +257,8 @@ let add_ml_tactic_entry name prods = let mkact i loc l : raw_tactic_expr = let open Tacexpr in let entry = { mltac_name = name; mltac_index = i } in - TacML (loc, entry, List.map snd l) + let map (_, arg) = TacGeneric arg in + TacML (loc, entry, List.map map l) in let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in synchronize_level_positions (); @@ -274,7 +275,24 @@ let head_is_ident tg = match tg.tacgram_prods with let add_tactic_entry kn tg = let entry, pos = get_tactic_entry tg.tacgram_level in - let mkact loc l = (TacAlias (loc,kn,l):raw_tactic_expr) in + let mkact loc l = + let filter = function + | GramTerminal _ -> None + | GramNonTerminal (_, t, _, None) -> None + | GramNonTerminal (_, t, _, Some _) -> Some (Genarg.unquote t) + in + let types = List.map_filter filter tg.tacgram_prods in + let map (id, arg) t = + (** HACK to handle especially the tactic(...) entry *) + let wit = Genarg.rawwit Constrarg.wit_tactic in + if Genarg.argument_type_eq t (Genarg.unquote wit) then + (id, Tacexp (Genarg.out_gen wit arg)) + else + (id, TacGeneric arg) + in + let l = List.map2 map l types in + (TacAlias (loc,kn,l):raw_tactic_expr) + in let () = if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then error "Notation for simple tactic must start with an identifier." -- cgit v1.2.3 From f3e611b2115b425f875e971ac9ff7534c2af2800 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Dec 2015 13:56:40 +0100 Subject: Separation of concern in TacAlias API. The TacAlias node now only contains the arguments fed to the tactic notation. The binding variables are worn by the tactic representation in Tacenv. --- parsing/egramcoq.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 2bc5b0f83f..bd9bacbc60 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -286,9 +286,9 @@ let add_tactic_entry kn tg = (** HACK to handle especially the tactic(...) entry *) let wit = Genarg.rawwit Constrarg.wit_tactic in if Genarg.argument_type_eq t (Genarg.unquote wit) then - (id, Tacexp (Genarg.out_gen wit arg)) + Tacexp (Genarg.out_gen wit arg) else - (id, TacGeneric arg) + TacGeneric arg in let l = List.map2 map l types in (TacAlias (loc,kn,l):raw_tactic_expr) -- cgit v1.2.3 From a5e1b40b93e47a278746ee6752474891cd856c29 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Dec 2015 19:26:02 +0100 Subject: Simplification of grammar_prod_item type. Actually the identifier was never used and just carried along. --- parsing/egramcoq.ml | 7 +++---- parsing/egramml.ml | 19 ++++++++----------- parsing/egramml.mli | 4 ++-- parsing/g_vernac.ml4 | 2 +- 4 files changed, 14 insertions(+), 18 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index bd9bacbc60..29f8555c81 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -257,7 +257,7 @@ let add_ml_tactic_entry name prods = let mkact i loc l : raw_tactic_expr = let open Tacexpr in let entry = { mltac_name = name; mltac_index = i } in - let map (_, arg) = TacGeneric arg in + let map arg = TacGeneric arg in TacML (loc, entry, List.map map l) in let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in @@ -278,11 +278,10 @@ let add_tactic_entry kn tg = let mkact loc l = let filter = function | GramTerminal _ -> None - | GramNonTerminal (_, t, _, None) -> None - | GramNonTerminal (_, t, _, Some _) -> Some (Genarg.unquote t) + | GramNonTerminal (_, t, _) -> Some (Genarg.unquote t) in let types = List.map_filter filter tg.tacgram_prods in - let map (id, arg) t = + let map arg t = (** HACK to handle especially the tactic(...) entry *) let wit = Genarg.rawwit Constrarg.wit_tactic in if Genarg.argument_type_eq t (Genarg.unquote wit) then diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 984027b815..e95b85bc26 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -18,9 +18,9 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item + Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's grammar_prod_item -type 'a ty_arg = Id.t * ('a -> raw_generic_argument) +type 'a ty_arg = ('a -> raw_generic_argument) type ('self, _, 'r) ty_rule = | TyStop : ('self, 'r, 'r) ty_rule @@ -37,12 +37,9 @@ let rec ty_rule_of_gram = function let tok = Atoken (Lexer.terminal s) in let r = TyNext (rem, tok, None) in AnyTyRule r -| GramNonTerminal (_, t, tok, idopt) :: rem -> +| GramNonTerminal (_, t, tok) :: rem -> let AnyTyRule rem = ty_rule_of_gram rem in - let inj = match idopt with - | None -> None - | Some id -> Some (id, fun obj -> Genarg.in_gen t obj) - in + let inj = Some (fun obj -> Genarg.in_gen t obj) in let r = TyNext (rem, tok, inj) in AnyTyRule r @@ -50,13 +47,13 @@ let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = func | TyStop -> Extend.Stop | TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) -type 'r gen_eval = Loc.t -> (Id.t * raw_generic_argument) list -> 'r +type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function | TyStop -> fun f loc -> f loc [] | TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f -| TyNext (rem, tok, Some (id, inj)) -> fun f x -> - let f loc args = f loc ((id, inj x) :: args) in +| TyNext (rem, tok, Some inj) -> fun f x -> + let f loc args = f loc (inj x :: args) in ty_eval rem f let make_rule f prod = @@ -81,6 +78,6 @@ let get_extend_vernac_rule (s, i) = let extend_vernac_command_grammar s nt gl = let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; - let mkact loc l = VernacExtend (s,List.map snd l) in + let mkact loc l = VernacExtend (s, l) in let rules = [make_rule mkact gl] in grammar_extend nt None (None, [None, None, rules]) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index e3ae4e0118..8a494d70ba 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -16,7 +16,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type * - ('s, 'a) Pcoq.entry_key * Names.Id.t option -> 's grammar_prod_item + ('s, 'a) Pcoq.entry_key -> 's grammar_prod_item val extend_vernac_command_grammar : Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option -> @@ -27,5 +27,5 @@ val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_ (** Utility function reused in Egramcoq : *) val make_rule : - (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'a) -> + (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> 'a grammar_prod_item list -> 'a Extend.production_rule diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 2c9894dad2..f79aa8d3dd 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1165,7 +1165,7 @@ GEXTEND Gram production_item: [ [ s = ne_string -> TacTerm s | nt = IDENT; - po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; + po = [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; ")" -> (p,sep) ] -> TacNonTerm (!@loc,nt,po) ] ] ; END -- cgit v1.2.3 From 74c29764359272b29af081b30762549777ae8825 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 17:05:03 +0100 Subject: Remove some useless type declarations. --- parsing/egramml.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/egramml.ml b/parsing/egramml.ml index e95b85bc26..9a380822eb 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -49,7 +49,7 @@ let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = func type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r -let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function +let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function | TyStop -> fun f loc -> f loc [] | TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f | TyNext (rem, tok, Some inj) -> fun f x -> -- cgit v1.2.3 From a1aff01d16bad2f44392fd5cb804092e12e558ed Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 16:19:51 +0100 Subject: CLEANUP: removing unused field I have removed the second field of the "Constrexpr.CRecord" variant because once it was set to "None" it never changed to anything else. It was just carried and copied around. --- parsing/g_constr.ml4 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'parsing') diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 2dec3b222a..440b368b95 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -224,10 +224,7 @@ GEXTEND Gram ] ] ; record_declaration: - [ [ fs = record_fields -> CRecord (!@loc, None, fs) -(* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) -(* CRecord (!@loc, Some c, fs) *) - ] ] + [ [ fs = record_fields -> CRecord (!@loc, fs) ] ] ; record_fields: -- cgit v1.2.3 From 10fd3ae92d9077a1ef0ad19e35e205b1941a6278 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 1 Jan 2016 12:06:31 +0100 Subject: Continuing 003fe3d5e on parsing positions. - Being stricter on the ordinal suffix accepted (only st for 1, 21, etc, nd for 2, 22, etc., etc.) - Reporting when the suffix is not the expected one (rather than considering that, e.g. 2st, is two tokens, a number then an identifier). --- parsing/lexer.ml4 | 45 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 35 insertions(+), 10 deletions(-) (limited to 'parsing') diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index d7941bedb4..d6d03cb85d 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -80,6 +80,7 @@ module Error = struct | Undefined_token | Bad_token of string | UnsupportedUnicode of int + | IncorrectIndex of char list exception E of t @@ -92,7 +93,16 @@ module Error = struct | Undefined_token -> "Undefined token" | Bad_token tok -> Format.sprintf "Bad token %S" tok | UnsupportedUnicode x -> - Printf.sprintf "Unsupported Unicode character (0x%x)" x) + Printf.sprintf "Unsupported Unicode character (0x%x)" x + | IncorrectIndex l -> + let l = List.map (fun c -> Char.code c - 48) l in + let s = match l with + | c::d::l -> + let l = List.map string_of_int (List.rev l) in + String.concat "" l ^ CString.ordinal (10 * d + c) + | [c] -> CString.ordinal c + | [] -> assert false in + Printf.sprintf "%s expected" s) (* Require to fix the Camlp4 signature *) let print ppf x = Pp.pp_with ppf (Pp.str (to_string x)) @@ -269,15 +279,30 @@ let check_no_char s = | [_;_] -> true | _ -> assert false -let rec number_or_index c len = parser - | [< ' ('0'..'9' as c); s >] -> number_or_index c (store len c) s - | [< s >] -> +let is_teen = function + | _::'1'::l -> true + | _ -> false + +let is_gt3 = function + | c::_ when c == '1' || c == '2' || c == '3' -> false + | _ -> true + +let check_gt3 l loc len = + if not (l == ['0']) && (is_teen l || is_gt3 l) then (false, len) + else err loc (IncorrectIndex l) + +let check_n n l loc len = + if List.hd l == n && not (is_teen l) then (false, len) + else err loc (IncorrectIndex l) + +let rec number_or_index bp l len = parser + | [< ' ('0'..'9' as c); s >] -> number_or_index bp (c::l) (store len c) s + | [< s >] ep -> match Stream.npeek 2 s with - | ['s';'t'] when c = '1' && check_no_char s -> njunk 2 s; false, len - | ['n';'d'] when c = '2' && check_no_char s -> njunk 2 s; false, len - | ['r';'d'] when c = '3' && check_no_char s -> njunk 2 s; false, len - | ['t';'h'] when not (len=1 && c='0') && check_no_char s -> - njunk 2 s; false, len + | ['s';'t'] when check_no_char s -> njunk 2 s; check_n '1' l (bp,ep) len + | ['n';'d'] when check_no_char s -> njunk 2 s; check_n '2' l (bp,ep) len + | ['r';'d'] when check_no_char s -> njunk 2 s; check_n '3' l (bp,ep) len + | ['t';'h'] when check_no_char s -> njunk 2 s; check_gt3 l (bp,ep) len | _ -> true, len let rec string in_comments bp len = parser @@ -527,7 +552,7 @@ let rec next_token = parser bp let id = get_buff len in comment_stop bp; (try find_keyword id s with Not_found -> IDENT id), (bp, ep) - | [< ' ('0'..'9' as c); (b,len) = number_or_index c (store 0 c) >] ep -> + | [< ' ('0'..'9' as c); (b,len) = number_or_index bp [c] (store 0 c) >] ep -> comment_stop bp; (if b then INT (get_buff len) else INDEX (get_buff len)), (bp, ep) | [< ''\"'; len = string None bp 0 >] ep -> -- cgit v1.2.3 From 448866f0ec5291d58677d8fccbefde493ade0ee2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Jan 2016 22:20:16 +0100 Subject: Removing constr generic argument. --- parsing/pcoq.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index df0d262062..3ed5304251 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -272,7 +272,7 @@ let create_entry u s etyp = new_entry etyp u s let create_constr_entry s = - outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) + outGramObj (rawwit wit_constr) (create_entry uconstr s (unquote (rawwit wit_constr))) let create_generic_entry s wit = outGramObj wit (create_entry utactic s (unquote wit)) @@ -633,7 +633,7 @@ let compute_entry allow_create adjust forpat = function let u = get_univ u in let e = try get_entry u n - with Not_found when allow_create -> create_entry u n ConstrArgType in + with Not_found when allow_create -> create_entry u n (unquote (rawwit wit_constr)) in object_of_typed_entry e, None, true (* This computes the name of the level where to add a new rule *) -- cgit v1.2.3 From 74a5cfa8b2f1a881ebf010160421cf0775c2a084 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 15 Jan 2016 17:49:49 +0100 Subject: Hooks for a third-party XML plugin. Contributed by Claudio Sacerdoti Coen. --- parsing/lexer.ml4 | 6 ++++++ parsing/lexer.mli | 2 ++ 2 files changed, 8 insertions(+) (limited to 'parsing') diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index c6d5f3b925..022f19fdbb 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -298,6 +298,9 @@ let rec string in_comments bp len = parser | [< 'c; s >] -> string in_comments bp (store len c) s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string +(* Hook for exporting comment into xml theory files *) +let (f_xml_output_comment, xml_output_comment) = Hook.make ~default:ignore () + (* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = match !comment_begin with @@ -340,6 +343,9 @@ let null_comment s = let comment_stop ep = let current_s = Buffer.contents current in + if !Flags.xml_export && Buffer.length current > 0 && + (!between_com || not(null_comment current_s)) then + Hook.get f_xml_output_comment current_s; (if Flags.do_beautify() && Buffer.length current > 0 && (!between_com || not(null_comment current_s)) then let bp = match !comment_begin with diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 2b9bd37df7..2da3f3bfd9 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -29,6 +29,8 @@ type com_state val com_state: unit -> com_state val restore_com_state: com_state -> unit +val xml_output_comment : (string -> unit) Hook.t + val terminal : string -> Tok.t (** The lexer of Coq: *) -- cgit v1.2.3 From 3914cc110faeb67c399dda0791a600bad7b7ef31 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 16 Jan 2016 14:06:38 +0100 Subject: Less type-unsafety in Pcoq. --- parsing/pcoq.ml | 57 +++++++++++++++++---------------------------------------- 1 file changed, 17 insertions(+), 40 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 3ed5304251..313a62c680 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -53,10 +53,8 @@ end (** Grammar entries with associated types *) type grammar_object = Gramobj.grammar_object -type typed_entry = argument_type * grammar_object G.entry -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 +type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a G.entry -> typed_entry +let object_of_typed_entry (TypedEntry (_, e)) = Gramobj.weaken_entry e let weaken_entry x = Gramobj.weaken_entry x (** General entry keys *) @@ -82,24 +80,6 @@ type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = type 's entry_name = EntryName : 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name -module type Gramtypes = -sig - val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry - val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry -end - -module Gramtypes : Gramtypes = -struct - let inGramObj rawwit = in_typed_entry (unquote rawwit) - let outGramObj (a:'a raw_abstract_argument_type) o = - if not (argument_type_eq (type_of_typed_entry o) (unquote a)) - then anomaly ~label:"outGramObj" (str "wrong type"); - (* downcast from grammar_object *) - Obj.magic (object_of_typed_entry o) -end - -open Gramtypes - (** Grammar extensions *) (** NB: [extend_statment = @@ -257,25 +237,23 @@ let new_entry etyp u s = if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" uname s; flush stderr); let _ = Entry.create u s in let ename = uname ^ ":" ^ s in - let e = in_typed_entry etyp (Gram.entry_create ename) in - Hashtbl.add utab s e; e + let e = Gram.entry_create ename in + Hashtbl.add utab s (TypedEntry (etyp, e)); e let create_entry u s etyp = let utab = get_utable u in try - let e = Hashtbl.find utab s in + let TypedEntry (typ, e) = Hashtbl.find utab s in let u = Entry.univ_name u in - if not (argument_type_eq (type_of_typed_entry e) etyp) then + if not (argument_type_eq (unquote typ) (unquote etyp)) then failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - e + Obj.magic e with Not_found -> new_entry etyp u s -let create_constr_entry s = - outGramObj (rawwit wit_constr) (create_entry uconstr s (unquote (rawwit wit_constr))) +let create_constr_entry s = create_entry uconstr s (rawwit wit_constr) -let create_generic_entry s wit = - outGramObj wit (create_entry utactic s (unquote wit)) +let create_generic_entry s wit = create_entry utactic s wit (* [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 *) @@ -285,7 +263,7 @@ let make_gen_entry u rawwit s = let uname = Entry.univ_name u in let e = Gram.entry_create (uname ^ ":" ^ s) in let _ = Entry.create u s in - Hashtbl.add univ s (inGramObj rawwit e); e + Hashtbl.add univ s (TypedEntry (rawwit, e)); e (* Initial grammar entries *) @@ -633,7 +611,10 @@ let compute_entry allow_create adjust forpat = function let u = get_univ u in let e = try get_entry u n - with Not_found when allow_create -> create_entry u n (unquote (rawwit wit_constr)) in + with Not_found when allow_create -> + let wit = rawwit wit_constr in + TypedEntry (wit, create_entry u n wit) + in object_of_typed_entry e, None, true (* This computes the name of the level where to add a new rule *) @@ -779,9 +760,6 @@ let tactic_level s = else None else None -let type_of_entry u s = - type_of_typed_entry (get_entry u s) - let name_of_entry e = match String.split ':' (Gram.Entry.name e) with | u :: s :: [] -> Entry.unsafe_of_name (u, s) | _ -> assert false @@ -795,9 +773,8 @@ let unsafe_of_genarg : argument_type -> 'a raw_abstract_argument_type = Obj.magic let try_get_entry u s = - (** Order the effects: type_of_entry can raise Not_found *) - let typ = type_of_entry u s in - let typ = unsafe_of_genarg typ in + (** Order the effects: get_entry can raise Not_found *) + let TypedEntry (typ, _) = get_entry u s in EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s))) let wit_list : 'a raw_abstract_argument_type -> 'a list raw_abstract_argument_type = @@ -858,7 +835,7 @@ let rec interp_entry_name static up_level s sep = EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s)) let list_entry_names () = - let add_entry key (entry, _) accu = (key, entry) :: accu in + let add_entry key (TypedEntry (entry, _)) accu = (key, unquote entry) :: accu in let ans = Hashtbl.fold add_entry (get_utable uprim) [] in let ans = Hashtbl.fold add_entry (get_utable uconstr) ans in Hashtbl.fold add_entry (get_utable utactic) ans -- cgit v1.2.3 From 8a3b19b62720e2324ef24003407c2e83335a51a5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 16 Jan 2016 14:57:48 +0100 Subject: Separating the parsing of user-defined entries from their intepretation. --- parsing/pcoq.ml | 69 +++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 47 insertions(+), 22 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 313a62c680..c8cd16aaf4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -754,12 +754,6 @@ let coincide s pat off = done; !break -let tactic_level s = - if Int.equal (String.length s) 7 && coincide s "tactic" 0 then - let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48) - else None - else None - let name_of_entry e = match String.split ':' (Gram.Entry.name e) with | u :: s :: [] -> Entry.unsafe_of_name (u, s) | _ -> assert false @@ -800,32 +794,56 @@ let get_tacentry (type s) (n : int) (t : s target) : s entry_name = match t with else if check_lvl (n + 1) then EntryName (rawwit wit_tactic, Anext) else EntryName (rawwit wit_tactic, atactic n) -let rec interp_entry_name static up_level s sep = +let rec parse_user_entry s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - EntryName (wit_list t, Alist1 g) + let entry = parse_user_entry (String.sub s 3 (l-8)) "" in + Ulist1 entry else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - EntryName (wit_list t, Alist1sep (g,sep)) + let entry = parse_user_entry (String.sub s 3 (l-12)) "" in + Ulist1sep (entry, sep) else if l > 5 && coincide s "_list" (l-5) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - EntryName (wit_list t, Alist0 g) + let entry = parse_user_entry (String.sub s 0 (l-5)) "" in + Ulist0 entry else if l > 9 && coincide s "_list_sep" (l-9) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - EntryName (wit_list t, Alist0sep (g,sep)) + let entry = parse_user_entry (String.sub s 0 (l-9)) "" in + Ulist0sep (entry, sep) else if l > 4 && coincide s "_opt" (l-4) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in - EntryName (wit_opt t, Aopt g) + let entry = parse_user_entry (String.sub s 0 (l-4)) "" in + Uopt entry else if l > 5 && coincide s "_mods" (l-5) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - EntryName (wit_list t, Amodifiers g) + let entry = parse_user_entry (String.sub s 0 (l-1)) "" in + Umodifiers entry + else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then + let n = Char.code s.[6] - 48 in + Uentryl ("tactic", n) else let s = match s with "hyp" -> "var" | _ -> s in - match tactic_level s with - | Some n -> get_tacentry n up_level - | None -> + Uentry s + +let rec interp_entry_name static up_level s sep = + let rec eval = function + | Ulist1 e -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Alist1 g) + | Ulist1sep (e, sep) -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Alist1sep (g, sep)) + | Ulist0 e -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Alist0 g) + | Ulist0sep (e, sep) -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Alist0sep (g, sep)) + | Uopt e -> + let EntryName (t, g) = eval e in + EntryName (wit_opt t, Aopt g) + | Umodifiers e -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Amodifiers g) + | Uentry s -> + begin try try_get_entry uprim s with Not_found -> try try_get_entry uconstr s with Not_found -> try try_get_entry utactic s with Not_found -> @@ -833,6 +851,13 @@ let rec interp_entry_name static up_level s sep = error ("Unknown entry "^s^".") else EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s)) + end + | Uentryl (s, n) -> + (** FIXME: do better someday *) + assert (String.equal s "tactic"); + get_tacentry n up_level + in + eval (parse_user_entry s sep) let list_entry_names () = let add_entry key (TypedEntry (entry, _)) accu = (key, unquote entry) :: accu in -- cgit v1.2.3 From e6b05180d789fb46bc91c71bc97efaf8b552f0fd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 16 Jan 2016 23:19:40 +0100 Subject: ML extensions use untyped representation of user entries. --- parsing/pcoq.mli | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'parsing') diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 592c879197..aa2e092adc 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -153,11 +153,15 @@ type gram_universe = Entry.universe val get_univ : string -> gram_universe +type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a Gram.entry -> typed_entry + val uprim : gram_universe val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe +val get_entry : gram_universe -> string -> typed_entry + val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> 'a Gram.entry @@ -282,6 +286,8 @@ type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target val interp_entry_name : bool (** true to fail on unknown entry *) -> 's target -> string -> string -> 's entry_name +val parse_user_entry : string -> string -> user_symbol + (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * argument_type) list -- cgit v1.2.3 From 43490147b0749f46eb90ff69c3bbdb3991fb526c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 17 Jan 2016 00:36:40 +0100 Subject: Removing dynamic entries from Pcoq. --- parsing/entry.ml | 8 ++------ parsing/entry.mli | 8 +------- parsing/pcoq.ml | 12 +++--------- parsing/pcoq.mli | 3 +-- 4 files changed, 7 insertions(+), 24 deletions(-) (limited to 'parsing') diff --git a/parsing/entry.ml b/parsing/entry.ml index 97d601320d..0519903d3d 100644 --- a/parsing/entry.ml +++ b/parsing/entry.ml @@ -11,9 +11,7 @@ open Util type 'a t = string * string -type repr = -| Static of string * string -| Dynamic of string +type repr = string * string type universe = string @@ -58,6 +56,4 @@ let unsafe_of_name (u, s) = assert (String.Set.mem uname !entries); (u, s) -let repr = function -| ("", u) -> Dynamic u -| (u, s) -> Static (u, s) +let repr (u, s) = (u, s) diff --git a/parsing/entry.mli b/parsing/entry.mli index 6854a5cb45..97cd5b1105 100644 --- a/parsing/entry.mli +++ b/parsing/entry.mli @@ -14,9 +14,7 @@ type 'a t unique names made of a universe and an entry name. They should be kept synchronized with the {!Pcoq} entries though. *) -type repr = -| Static of string * string -| Dynamic of string +type repr = string * string (** Representation of entries. *) (** Table of Coq statically defined grammar entries *) @@ -41,10 +39,6 @@ val create : universe -> string -> 'a t (** {5 Meta-programming} *) -val dynamic : string -> 'a t -(** Dynamic entries. They refer to entries defined in the code source and may - only be used in meta-programming definitions from the grammar directory. *) - val repr : 'a t -> repr val unsafe_of_name : (string * string) -> 'a t diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index c8cd16aaf4..291e919d85 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -224,10 +224,7 @@ let get_entry u s = Hashtbl.find utab s let get_typed_entry e = - let (u, s) = match Entry.repr e with - | Entry.Dynamic _ -> assert false - | Entry.Static (u, s) -> (u, s) - in + let (u, s) = Entry.repr e in let u = Entry.get_univ u in get_entry u s @@ -822,7 +819,7 @@ let rec parse_user_entry s sep = let s = match s with "hyp" -> "var" | _ -> s in Uentry s -let rec interp_entry_name static up_level s sep = +let rec interp_entry_name up_level s sep = let rec eval = function | Ulist1 e -> let EntryName (t, g) = eval e in @@ -847,10 +844,7 @@ let rec interp_entry_name static up_level s sep = try try_get_entry uprim s with Not_found -> try try_get_entry uconstr s with Not_found -> try try_get_entry utactic s with Not_found -> - if static then - error ("Unknown entry "^s^".") - else - EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s)) + error ("Unknown entry "^s^".") end | Uentryl (s, n) -> (** FIXME: do better someday *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index aa2e092adc..816220b47d 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -283,8 +283,7 @@ type 's entry_name = EntryName : type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target -val interp_entry_name : bool (** true to fail on unknown entry *) -> - 's target -> string -> string -> 's entry_name +val interp_entry_name : 's target -> string -> string -> 's entry_name val parse_user_entry : string -> string -> user_symbol -- cgit v1.2.3 From 0d1345ea2423fc418a470786b0b33b80df3a67bc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 17 Jan 2016 01:08:21 +0100 Subject: Temporary commit getting rid of Obj.magic unsafety for Genarg. This will allow an easier landing of the rewriting of Genarg. --- parsing/pcoq.ml | 22 ++++++---------------- 1 file changed, 6 insertions(+), 16 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 291e919d85..d5acf59f6f 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -759,21 +759,11 @@ let atactic n = if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) else Aentryl (name_of_entry Tactic.tactic_expr, n) -let unsafe_of_genarg : argument_type -> 'a raw_abstract_argument_type = - (** FIXME *) - Obj.magic - let try_get_entry u s = (** Order the effects: get_entry can raise Not_found *) let TypedEntry (typ, _) = get_entry u s in EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s))) -let wit_list : 'a raw_abstract_argument_type -> 'a list raw_abstract_argument_type = - fun t -> unsafe_of_genarg (ListArgType (unquote t)) - -let wit_opt : 'a raw_abstract_argument_type -> 'a option raw_abstract_argument_type = - fun t -> unsafe_of_genarg (OptArgType (unquote t)) - type _ target = | TgAny : 's target | TgTactic : int -> Tacexpr.raw_tactic_expr target @@ -823,22 +813,22 @@ let rec interp_entry_name up_level s sep = let rec eval = function | Ulist1 e -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Alist1 g) + EntryName (arg_list t, Alist1 g) | Ulist1sep (e, sep) -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Alist1sep (g, sep)) + EntryName (arg_list t, Alist1sep (g, sep)) | Ulist0 e -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Alist0 g) + EntryName (arg_list t, Alist0 g) | Ulist0sep (e, sep) -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Alist0sep (g, sep)) + EntryName (arg_list t, Alist0sep (g, sep)) | Uopt e -> let EntryName (t, g) = eval e in - EntryName (wit_opt t, Aopt g) + EntryName (arg_opt t, Aopt g) | Umodifiers e -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Amodifiers g) + EntryName (arg_list t, Amodifiers g) | Uentry s -> begin try try_get_entry uprim s with Not_found -> -- cgit v1.2.3 From 88a16f49efd315aa1413da67f6d321a5fe269772 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 17 Jan 2016 01:46:02 +0100 Subject: Simplification and type-safety of Pcoq thanks to GADTs in Genarg. --- parsing/pcoq.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index d5acf59f6f..c87084f2cc 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -237,14 +237,15 @@ let new_entry etyp u s = let e = Gram.entry_create ename in Hashtbl.add utab s (TypedEntry (etyp, e)); e -let create_entry u s etyp = +let create_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in try let TypedEntry (typ, e) = Hashtbl.find utab s in - let u = Entry.univ_name u in - if not (argument_type_eq (unquote typ) (unquote etyp)) then + match abstract_argument_type_eq typ etyp with + | None -> + let u = Entry.univ_name u in failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - Obj.magic e + | Some Refl -> e with Not_found -> new_entry etyp u s @@ -809,6 +810,9 @@ let rec parse_user_entry s sep = let s = match s with "hyp" -> "var" | _ -> s in Uentry s +let arg_list = function Rawwit t -> Rawwit (ListArg t) +let arg_opt = function Rawwit t -> Rawwit (OptArg t) + let rec interp_entry_name up_level s sep = let rec eval = function | Ulist1 e -> -- cgit v1.2.3 From 86f5c0cbfa64c5d0949365369529c5b607878ef8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 20 Jan 2016 17:25:10 +0100 Subject: Update copyright headers. --- parsing/compat.ml4 | 2 +- parsing/egramcoq.ml | 2 +- parsing/egramcoq.mli | 2 +- parsing/egramml.ml | 2 +- parsing/egramml.mli | 2 +- parsing/g_constr.ml4 | 2 +- parsing/g_ltac.ml4 | 2 +- parsing/g_prim.ml4 | 2 +- parsing/g_proofs.ml4 | 2 +- parsing/g_tactic.ml4 | 2 +- parsing/g_vernac.ml4 | 2 +- parsing/lexer.ml4 | 2 +- parsing/lexer.mli | 2 +- parsing/pcoq.ml4 | 2 +- parsing/pcoq.mli | 2 +- parsing/tok.ml | 2 +- parsing/tok.mli | 2 +- 17 files changed, 17 insertions(+), 17 deletions(-) (limited to 'parsing') diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index eba1d2b8f0..d1d55c81fe 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* l ]] ; or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> tc - | "()" -> [[]] - | "("; si = simple_intropattern; ")" -> [[si]] + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc + | "()" -> IntroAndPattern [] + | "("; si = simple_intropattern; ")" -> IntroAndPattern [si] | "("; si = simple_intropattern; ","; - tc = LIST1 simple_intropattern SEP "," ; ")" -> [si::tc] + tc = LIST1 simple_intropattern SEP "," ; ")" -> + IntroAndPattern (si::tc) | "("; si = simple_intropattern; "&"; tc = LIST1 simple_intropattern SEP "&" ; ")" -> (* (A & B & C) is translated into (A,(B,C)) *) let rec pairify = function - | ([]|[_]|[_;_]) as l -> [l] - | t::q -> [[t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (pairify q)))]] - in pairify (si::tc) ] ] + | ([]|[_]|[_;_]) as l -> l + | t::q -> [t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] + in IntroAndPattern (pairify (si::tc)) ] ] ; equality_intropattern: [ [ "->" -> IntroRewrite true -- cgit v1.2.3 From 5cbcc8fd761df0779f6202fef935f07cfef8a228 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 23 Jan 2016 15:17:29 -0500 Subject: Implement support for universe binder lists in Instance and Program Fixpoint/Definition. --- parsing/g_vernac.ml4 | 8 ++++---- parsing/pcoq.ml4 | 1 + parsing/pcoq.mli | 1 + 3 files changed, 6 insertions(+), 4 deletions(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 839f768b98..f3766a7d79 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -192,7 +192,7 @@ let test_plurial_form_types = function (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - record_field decl_notation rec_definition; + record_field decl_notation rec_definition pidentref; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -783,10 +783,10 @@ GEXTEND Gram | IDENT "transparent" -> Conv_oracle.transparent ] ] ; instance_name: - [ [ name = identref; sup = OPT binders -> - (let (loc,id) = name in (loc, Name id)), + [ [ name = pidentref; sup = OPT binders -> + (let ((loc,id),l) = name in ((loc, Name id),l)), (Option.default [] sup) - | -> (!@loc, Anonymous), [] ] ] + | -> ((!@loc, Anonymous), None), [] ] ] ; reserv_list: [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ] diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 32dbeaa4dd..28dc74e81b 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -315,6 +315,7 @@ module Prim = let name = Gram.entry_create "Prim.name" let identref = Gram.entry_create "Prim.identref" + let pidentref = Gram.entry_create "Prim.pidentref" let pattern_ident = Gram.entry_create "pattern_ident" let pattern_identref = Gram.entry_create "pattern_identref" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 24b58775a2..54e6423877 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -163,6 +163,7 @@ module Prim : val ident : Id.t Gram.entry val name : Name.t located Gram.entry val identref : Id.t located Gram.entry + val pidentref : (Id.t located * (Id.t located list) option) Gram.entry val pattern_ident : Id.t Gram.entry val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry -- cgit v1.2.3 From 292e205138ca11c3dce37d48cb34ef4172f6fa06 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 2 Feb 2016 10:28:16 +0100 Subject: Removing a source of type-unsafeness in Pcoq. --- parsing/egramcoq.ml | 18 +++++++++--------- parsing/pcoq.mli | 3 --- 2 files changed, 9 insertions(+), 12 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index e9c3a7073d..465073b7aa 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -387,16 +387,16 @@ let create_ltac_quotation name cast wit e = let () = ltac_quotations := String.Set.add name !ltac_quotations in (* let level = Some "1" in *) let level = None in - let assoc = Some (of_coq_assoc Extend.RightA) in - let rule = [ - gram_token_of_string name; - gram_token_of_string ":"; - symbol_of_prod_entry_key (Aentry (name_of_entry e)); - ] in + let assoc = Some Extend.RightA in + let rule = + Next (Next (Next (Stop, + Atoken (Lexer.terminal name)), + Atoken (Lexer.terminal ":")), + Aentry (name_of_entry e)) + in let action v _ _ loc = - let loc = !@loc in let arg = TacGeneric (Genarg.in_gen (Genarg.rawwit wit) (cast (loc, v))) in TacArg (loc, arg) in - let gram = (level, assoc, [rule, Gram.action action]) in - maybe_uncurry (Gram.extend Tactic.tactic_expr) (None, [gram]) + let gram = (level, assoc, [Rule (rule, action)]) in + Pcoq.grammar_extend Tactic.tactic_expr None (None, [gram]) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 9b3a96975f..b26c3044bd 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -274,9 +274,6 @@ val name_of_entry : 'a Gram.entry -> 'a Entry.t (** Binding general entry keys to symbols *) -val symbol_of_prod_entry_key : - ('self, 'a) entry_key -> Gram.symbol - type 's entry_name = EntryName : 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name -- cgit v1.2.3 From ee162ba3b28fccca0a2b3ea4b1e0811006840570 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 24 Feb 2016 10:07:57 +0100 Subject: Removing the MetaIdArg entry of tactic expressions. This was historically used together with the <:tactic< ... >> quotation to insert foreign code as $foo, but it actually only survived in the implementation of Tauto. With the removal of the quotation feature, this is now totally obsolete. --- parsing/g_ltac.ml4 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 12d53030d7..0a11d3928a 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -146,7 +146,6 @@ GEXTEND Gram | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) (* Unambigous entries: tolerated w/o "ltac:" modifier *) - | id = METAIDENT -> MetaIdArg (!@loc,true,id) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) @@ -179,8 +178,7 @@ GEXTEND Gram | c = Constr.constr -> ConstrTerm c ] ] ; tactic_atom: - [ [ id = METAIDENT -> MetaIdArg (!@loc,true,id) - | n = integer -> TacGeneric (genarg_of_int n) + [ [ n = integer -> TacGeneric (genarg_of_int n) | r = reference -> TacCall (!@loc,r,[]) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; -- cgit v1.2.3 From d96bf1b1ec79fa93787d23e1c42f803d74b49321 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 24 Feb 2016 10:26:56 +0100 Subject: Removing the METAIDENT token, as it is not used anymore. METAIDENT were idents of the form $foobar, only used in quotations. Note that it removes two dollars in the Coq codebase! Guess I'm absolved for the $(...) syntax. --- parsing/compat.ml4 | 1 - parsing/g_constr.ml4 | 5 +---- parsing/lexer.ml4 | 3 --- parsing/tok.ml | 7 ------- parsing/tok.mli | 1 - 5 files changed, 1 insertion(+), 16 deletions(-) (limited to 'parsing') diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 3405d2429b..0e416fe32c 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -262,7 +262,6 @@ IFDEF CAMLP5 THEN let pattern = match tok with | Tok.KEYWORD s -> "", s | Tok.IDENT s -> "IDENT", s - | Tok.METAIDENT s -> "METAIDENT", s | Tok.PATTERNIDENT s -> "PATTERNIDENT", s | Tok.FIELD s -> "FIELD", s | Tok.INT s -> "INT", s diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 1ac260ebeb..0fe0ac42b1 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -132,10 +132,7 @@ GEXTEND Gram closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; Constr.ident: - [ [ id = Prim.ident -> id - - (* This is used in quotations and Syntax *) - | id = METAIDENT -> Id.of_string id ] ] + [ [ id = Prim.ident -> id ] ] ; Prim.name: [ [ "_" -> (!@loc, Anonymous) ] ] diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 74e05ce84d..232e9aee3f 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -493,7 +493,6 @@ let process_chars bp c cs = err (bp, ep') Undefined_token let token_of_special c s = match c with - | '$' -> METAIDENT s | '.' -> FIELD s | _ -> assert false @@ -532,8 +531,6 @@ let blank_or_eof cs = let rec next_token = parser bp | [< '' ' | '\t' | '\n' |'\r' as c; s >] -> comm_loc bp; push_char c; next_token s - | [< ''$' as c; t = parse_after_special c bp >] ep -> - comment_stop bp; (t, (ep, bp)) | [< ''.' as c; t = parse_after_special c bp; s >] ep -> comment_stop bp; (* We enforce that "." should either be part of a larger keyword, diff --git a/parsing/tok.ml b/parsing/tok.ml index 4f50c48d0d..6b90086155 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -10,7 +10,6 @@ type t = | KEYWORD of string - | METAIDENT of string | PATTERNIDENT of string | IDENT of string | FIELD of string @@ -24,7 +23,6 @@ type t = let equal t1 t2 = match t1, t2 with | IDENT s1, KEYWORD s2 -> CString.equal s1 s2 | KEYWORD s1, KEYWORD s2 -> CString.equal s1 s2 -| METAIDENT s1, METAIDENT s2 -> CString.equal s1 s2 | PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2 | IDENT s1, IDENT s2 -> CString.equal s1 s2 | FIELD s1, FIELD s2 -> CString.equal s1 s2 @@ -40,7 +38,6 @@ let extract_string = function | KEYWORD s -> s | IDENT s -> s | STRING s -> s - | METAIDENT s -> s | PATTERNIDENT s -> s | FIELD s -> s | INT s -> s @@ -52,7 +49,6 @@ let extract_string = function let to_string = function | KEYWORD s -> Format.sprintf "%S" s | IDENT s -> Format.sprintf "IDENT %S" s - | METAIDENT s -> Format.sprintf "METAIDENT %S" s | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s | FIELD s -> Format.sprintf "FIELD %S" s | INT s -> Format.sprintf "INT %s" s @@ -76,7 +72,6 @@ let print ppf tok = Format.pp_print_string ppf (to_string tok) let of_pattern = function | "", s -> KEYWORD s | "IDENT", s -> IDENT s - | "METAIDENT", s -> METAIDENT s | "PATTERNIDENT", s -> PATTERNIDENT s | "FIELD", s -> FIELD s | "INT", s -> INT s @@ -90,7 +85,6 @@ let of_pattern = function let to_pattern = function | KEYWORD s -> "", s | IDENT s -> "IDENT", s - | METAIDENT s -> "METAIDENT", s | PATTERNIDENT s -> "PATTERNIDENT", s | FIELD s -> "FIELD", s | INT s -> "INT", s @@ -105,7 +99,6 @@ let match_pattern = function | "", "" -> (function KEYWORD s -> s | _ -> err ()) | "IDENT", "" -> (function IDENT s -> s | _ -> err ()) - | "METAIDENT", "" -> (function METAIDENT s -> s | _ -> err ()) | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ()) | "FIELD", "" -> (function FIELD s -> s | _ -> err ()) | "INT", "" -> (function INT s -> s | _ -> err ()) diff --git a/parsing/tok.mli b/parsing/tok.mli index f37de05a44..416ce468e3 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -10,7 +10,6 @@ type t = | KEYWORD of string - | METAIDENT of string | PATTERNIDENT of string | IDENT of string | FIELD of string -- cgit v1.2.3 From 48327426b59144f1a7181092068077c5a6df7c60 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 10:45:31 +0100 Subject: Moving the "fix" tactic to TACTIC EXTEND. --- parsing/g_tactic.ml4 | 2 -- 1 file changed, 2 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 77b7b05a39..497819b327 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -555,8 +555,6 @@ GEXTEND Gram TacAtom (!@loc, TacElim (true,cl,el)) | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl) | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) - | "fix"; n = natural -> TacAtom (!@loc, TacFix (None,n)) - | "fix"; id = ident; n = natural -> TacAtom (!@loc, TacFix (Some id,n)) | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) | "cofix" -> TacAtom (!@loc, TacCofix None) -- cgit v1.2.3 From bda8b2e8f90235ca875422f211cb781068b20b3c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 10:54:08 +0100 Subject: Moving the "cofix" tactic to TACTIC EXTEND. --- parsing/g_tactic.ml4 | 2 -- 1 file changed, 2 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 497819b327..6c3918be3a 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -557,8 +557,6 @@ GEXTEND Gram | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) - | "cofix" -> TacAtom (!@loc, TacCofix None) - | "cofix"; id = ident -> TacAtom (!@loc, TacCofix (Some id)) | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) -- cgit v1.2.3 From d0bc16d1a0626f4137797bbf0c91e972a0ff43ac Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 11:05:26 +0100 Subject: Moving the "clear" tactic to TACTIC EXTEND. --- parsing/g_tactic.ml4 | 4 ---- 1 file changed, 4 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 6c3918be3a..ad5f78b46d 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -618,10 +618,6 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Context management *) - | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) - | IDENT "clear"; l = LIST0 id_or_meta -> - let is_empty = match l with [] -> true | _ -> false in - TacAtom (!@loc, TacClear (is_empty, l)) | IDENT "clearbody"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClearBody l) | IDENT "move"; hfrom = id_or_meta; hto = move_location -> TacAtom (!@loc, TacMove (hfrom,hto)) -- cgit v1.2.3 From 7dd8c2bf4747c94be6f18d7fdd0e3b593f560a2f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 11:20:26 +0100 Subject: Moving the "clearbody" tactic to TACTIC EXTEND. --- parsing/g_tactic.ml4 | 1 - 1 file changed, 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index ad5f78b46d..04ee02f944 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -618,7 +618,6 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Context management *) - | IDENT "clearbody"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClearBody l) | IDENT "move"; hfrom = id_or_meta; hto = move_location -> TacAtom (!@loc, TacMove (hfrom,hto)) | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l) -- cgit v1.2.3 From 6c4fcb156dea5a71fd227606b87333ae00aacb69 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 11:35:34 +0100 Subject: Moving the "generalize dependent" tactic to TACTIC EXTEND. --- parsing/g_tactic.ml4 | 1 - 1 file changed, 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 04ee02f944..238b9a60f7 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -603,7 +603,6 @@ GEXTEND Gram na = as_name; l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) - | IDENT "generalize"; IDENT "dependent"; c = constr -> TacAtom (!@loc, TacGeneralizeDep c) (* Derived basic tactics *) | IDENT "induction"; ic = induction_clause_list -> -- cgit v1.2.3 From ae3bbff3ca2564fe24bdf3dd517c82807eae9151 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 12:11:52 +0100 Subject: Moving the "symmetry" tactic to TACTIC EXTEND. --- parsing/g_tactic.ml4 | 2 -- 1 file changed, 2 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 238b9a60f7..4587e321f0 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -625,8 +625,6 @@ GEXTEND Gram | "exists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (false,bll)) | IDENT "eexists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (true,bll)) - (* Equivalence relations *) - | IDENT "symmetry"; "in"; cl = in_clause -> TacAtom (!@loc, TacSymmetry cl) (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; -- cgit v1.2.3 From 293222e49ff81bc1299b3822d2a8c526ca803307 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 12:40:45 +0100 Subject: Moving the "exists" tactic to TACTIC EXTEND. --- parsing/g_tactic.ml4 | 5 ----- 1 file changed, 5 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 4587e321f0..e50eca25be 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -621,11 +621,6 @@ GEXTEND Gram TacAtom (!@loc, TacMove (hfrom,hto)) | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l) - (* Constructors *) - | "exists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (false,bll)) - | IDENT "eexists"; bll = opt_bindings -> - TacAtom (!@loc, TacSplit (true,bll)) - (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; cl = clause_dft_concl; t=opt_by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) -- cgit v1.2.3 From 1397f791b1699b0f04d971465270d5b2df9a6d7f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 13:32:39 +0100 Subject: Moving the "move" tactic to TACTIC EXTEND. --- parsing/g_tactic.ml4 | 2 -- 1 file changed, 2 deletions(-) (limited to 'parsing') diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index e50eca25be..0c90a8bca4 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -617,8 +617,6 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Context management *) - | IDENT "move"; hfrom = id_or_meta; hto = move_location -> - TacAtom (!@loc, TacMove (hfrom,hto)) | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l) (* Equality and inversion *) -- cgit v1.2.3 From 143bb68613bcb314e2feffd643f539fba9cd3912 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Mar 2016 23:52:15 +0100 Subject: Uniformizing the parsing of argument scopes in Ltac. --- parsing/g_constr.ml4 | 2 +- parsing/g_ltac.ml4 | 9 ++++----- 2 files changed, 5 insertions(+), 6 deletions(-) (limited to 'parsing') diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 0fe0ac42b1..6eeae925a3 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -215,7 +215,7 @@ GEXTEND Gram CGeneralization (!@loc, Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> CGeneralization (!@loc, Explicit, None, c) - | "ltac:"; "("; tac = Tactic.tactic_expr; ")" -> + | IDENT "ltac"; ":"; "("; tac = Tactic.tactic_expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in CHole (!@loc, None, IntroAnonymous, Some arg) ] ] diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 0a11d3928a..45d2a09e73 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -111,8 +111,6 @@ GEXTEND Gram | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; l = LIST0 message_token -> TacFail (g,n,l) | st = simple_tactic -> st - | IDENT "constr"; ":"; c = Constr.constr -> - TacArg(!@loc,ConstrMayEval(ConstrTerm c)) | a = tactic_top_or_arg -> TacArg(!@loc,a) | r = reference; la = LIST0 tactic_arg -> TacArg(!@loc,TacCall (!@loc,r,la)) ] @@ -140,9 +138,7 @@ GEXTEND Gram ; (* Tactic arguments *) tactic_arg: - [ [ "ltac:"; a = tactic_expr LEVEL "0" -> arg_of_expr a - | "ltac:"; n = natural -> TacGeneric (genarg_of_int n) - | a = tactic_top_or_arg -> a + [ [ a = tactic_top_or_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) (* Unambigous entries: tolerated w/o "ltac:" modifier *) @@ -151,6 +147,9 @@ GEXTEND Gram (* Can be used as argument and at toplevel in tactic expressions. *) tactic_top_or_arg: [ [ IDENT "uconstr"; ":" ; c = uconstr -> UConstr c + | IDENT "constr"; ":"; c = Constr.constr -> ConstrMayEval (ConstrTerm c) + | IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a + | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n) | IDENT "ipattern"; ":"; ipat = simple_intropattern -> TacGeneric (genarg_of_ipattern ipat) | c = constr_eval -> ConstrMayEval c -- cgit v1.2.3 From d5656a6c28f79d59590d4fde60c5158a649d1b65 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 11:16:03 +0100 Subject: Making parentheses mandatory in tactic scopes. --- parsing/g_ltac.ml4 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 45d2a09e73..b76f5dda25 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -146,11 +146,11 @@ GEXTEND Gram ; (* Can be used as argument and at toplevel in tactic expressions. *) tactic_top_or_arg: - [ [ IDENT "uconstr"; ":" ; c = uconstr -> UConstr c - | IDENT "constr"; ":"; c = Constr.constr -> ConstrMayEval (ConstrTerm c) - | IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a - | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n) - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> + [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> UConstr c + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> ConstrMayEval (ConstrTerm c) + | IDENT "ltac"; ":"; "("; a = tactic_expr LEVEL "5"; ")" -> arg_of_expr a + | IDENT "ltac"; ":"; "("; n = natural; ")" -> TacGeneric (genarg_of_int n) + | IDENT "ipattern"; ":"; "("; ipat = simple_intropattern; ")" -> TacGeneric (genarg_of_ipattern ipat) | c = constr_eval -> ConstrMayEval c | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l -- cgit v1.2.3 From 098d283e58966124cfe0e97a3229a9e7e6284120 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 15:04:35 +0100 Subject: Removing the UConstr entry of the tactic_arg AST. This was redundant with the wit_uconstr generic argument, so there was no real point on keeping it there. --- parsing/g_ltac.ml4 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index b76f5dda25..4da32c9b26 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -28,6 +28,7 @@ let arg_of_expr = function let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c let reference_to_id = function | Libnames.Ident (loc, id) -> (loc, id) @@ -146,7 +147,7 @@ GEXTEND Gram ; (* Can be used as argument and at toplevel in tactic expressions. *) tactic_top_or_arg: - [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> UConstr c + [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> TacGeneric (genarg_of_uconstr c) | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> ConstrMayEval (ConstrTerm c) | IDENT "ltac"; ":"; "("; a = tactic_expr LEVEL "5"; ")" -> arg_of_expr a | IDENT "ltac"; ":"; "("; n = natural; ")" -> TacGeneric (genarg_of_int n) -- cgit v1.2.3 From 5b4fd2f5a3c6d031d551f9b5730fe30a69337c76 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 15:47:27 +0100 Subject: Exchanging roles of tactic_arg and tactic_top_or_arg entries. The tactic_arg entry was essentially a hack to keep parsing constrs as tactic arguments. We rather use tactic_top_or_arg as the true entry for tactic arguments now. --- parsing/g_ltac.ml4 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 4da32c9b26..06675baa7d 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -112,8 +112,8 @@ GEXTEND Gram | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; l = LIST0 message_token -> TacFail (g,n,l) | st = simple_tactic -> st - | a = tactic_top_or_arg -> TacArg(!@loc,a) - | r = reference; la = LIST0 tactic_arg -> + | a = tactic_arg -> TacArg(!@loc,a) + | r = reference; la = LIST0 tactic_arg_compat -> TacArg(!@loc,TacCall (!@loc,r,la)) ] | "0" [ "("; a = tactic_expr; ")" -> a @@ -137,16 +137,16 @@ GEXTEND Gram body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] ; - (* Tactic arguments *) - tactic_arg: - [ [ a = tactic_top_or_arg -> a + (* Tactic arguments to the right of an application *) + tactic_arg_compat: + [ [ a = tactic_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) (* Unambigous entries: tolerated w/o "ltac:" modifier *) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_top_or_arg: + tactic_arg: [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> TacGeneric (genarg_of_uconstr c) | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> ConstrMayEval (ConstrTerm c) | IDENT "ltac"; ":"; "("; a = tactic_expr LEVEL "5"; ")" -> arg_of_expr a -- cgit v1.2.3 From 8e77752080b6f0da3ce396e7537db9676e848a70 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 15:55:02 +0100 Subject: Replacing ad-hoc tactic scopes by generic ones using [create_ltac_quotations]. --- parsing/egramcoq.ml | 21 ++++++++++++--------- parsing/egramcoq.mli | 10 +++++----- parsing/g_ltac.ml4 | 8 +------- 3 files changed, 18 insertions(+), 21 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 465073b7aa..2cf590b1d8 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -379,24 +379,27 @@ let with_grammar_rule_protection f x = let ltac_quotations = ref String.Set.empty -let create_ltac_quotation name cast wit e = +let create_ltac_quotation name cast (e, l) = let () = if String.Set.mem name !ltac_quotations then failwith ("Ltac quotation " ^ name ^ " already registered") in let () = ltac_quotations := String.Set.add name !ltac_quotations in + let entry = match l with + | None -> Aentry (name_of_entry e) + | Some l -> Aentryl (name_of_entry e, l) + in (* let level = Some "1" in *) let level = None in - let assoc = Some Extend.RightA in + let assoc = None in let rule = - Next (Next (Next (Stop, + Next (Next (Next (Next (Next (Stop, Atoken (Lexer.terminal name)), Atoken (Lexer.terminal ":")), - Aentry (name_of_entry e)) - in - let action v _ _ loc = - let arg = TacGeneric (Genarg.in_gen (Genarg.rawwit wit) (cast (loc, v))) in - TacArg (loc, arg) + Atoken (Lexer.terminal "(")), + entry), + Atoken (Lexer.terminal ")")) in + let action _ v _ _ _ loc = cast (loc, v) in let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Tactic.tactic_expr None (None, [gram]) + Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram]) diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 17524971f2..23eaa64eec 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -62,8 +62,8 @@ val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b (** {5 Adding tactic quotations} *) -val create_ltac_quotation : string -> ('grm Loc.located -> 'raw) -> - ('raw, 'glb, 'top) genarg_type -> 'grm Gram.entry -> unit -(** [create_ltac_quotation name f wit e] adds a quotation rule to Ltac, that is, - Ltac grammar now accepts arguments of the form ["name" ":" ], and - generates a generic argument using [f] on the entry parsed by [e]. *) +val create_ltac_quotation : string -> + ('grm Loc.located -> Tacexpr.raw_tactic_arg) -> ('grm Gram.entry * int option) -> unit +(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, + Ltac grammar now accepts arguments of the form ["name" ":" "(" ")"], and + generates an argument using [f] on the entry parsed by [e]. *) diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 06675baa7d..e4ca936a69 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -147,13 +147,7 @@ GEXTEND Gram ; (* Can be used as argument and at toplevel in tactic expressions. *) tactic_arg: - [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> TacGeneric (genarg_of_uconstr c) - | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> ConstrMayEval (ConstrTerm c) - | IDENT "ltac"; ":"; "("; a = tactic_expr LEVEL "5"; ")" -> arg_of_expr a - | IDENT "ltac"; ":"; "("; n = natural; ")" -> TacGeneric (genarg_of_int n) - | IDENT "ipattern"; ":"; "("; ipat = simple_intropattern; ")" -> - TacGeneric (genarg_of_ipattern ipat) - | c = constr_eval -> ConstrMayEval c + [ [ c = constr_eval -> ConstrMayEval c | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l | IDENT "type_term"; c=uconstr -> TacPretype c | IDENT "numgoals" -> TacNumgoals ] ] -- cgit v1.2.3 From d3653c6da5770dfc4d439639b49193e30172763a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 15:10:27 +0100 Subject: Fixing bug #4610: Fails to build with camlp4 since the TACTIC EXTEND move. We just reuse the same one weird old trick in CAMLP4 to compare keywords and identifiers as tokens. Note though that the commit 982460743 does not fix the keyword vs. identifier issue in CAMLP4, so that the corresponding test fails. This means that since that commit, some code compiling with CAMLP5 does not when using CAMLP4, making it a second-class citizen. --- parsing/compat.ml4 | 2 +- parsing/tok.mli | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 0e416fe32c..c482c694e1 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -276,7 +276,7 @@ ELSE module Gramext = G let stoken tok = match tok with | Tok.KEYWORD s -> Gramext.Skeyword s - | tok -> Gramext.Stoken ((=) tok, G.Token.to_string tok) + | tok -> Gramext.Stoken (Tok.equal tok, G.Token.to_string tok) END IFDEF CAMLP5_6_00 THEN diff --git a/parsing/tok.mli b/parsing/tok.mli index 416ce468e3..54b747952a 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -20,6 +20,7 @@ type t = | BULLET of string | EOI +val equal : t -> t -> bool val extract_string : t -> string val to_string : t -> string (* Needed to fit Camlp4 signature *) -- cgit v1.2.3 From ffac73b8f3f3bf6877ce652eecac7849b7c2a182 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 23:00:58 +0100 Subject: Moving Autorewrite to Hightatctic. --- parsing/g_vernac.ml4 | 1 - 1 file changed, 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index b5e9f9e067..49baeb5560 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -951,7 +951,6 @@ GEXTEND Gram | IDENT "Hint"; qid = smart_global -> PrintHint qid | IDENT "Hint"; "*" -> PrintHintDb | IDENT "HintDb"; s = IDENT -> PrintHintDbName s - | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s | IDENT "Scopes" -> PrintScopes | IDENT "Scope"; s = IDENT -> PrintScope s | IDENT "Visibility"; s = OPT [x = IDENT -> x ] -> PrintVisibility s -- cgit v1.2.3 From d868820ad1f00b896c5f44f18678fac2f8e0f720 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 13 Mar 2016 13:18:10 +0100 Subject: Supporting "(@foo) args" in patterns, where "@foo" has no arguments. --- parsing/g_constr.ml4 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'parsing') diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 6eeae925a3..b11204cbc5 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -379,14 +379,14 @@ GEXTEND Gram | "10" RIGHTA [ p = pattern; lp = LIST1 NEXT -> (match p with - | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, [], lp) + | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp) | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) | _ -> Errors.user_err_loc (cases_pattern_expr_loc p, "compound_pattern", Pp.str "Such pattern cannot have arguments.")) - |"@"; r = Prim.reference; lp = LIST1 NEXT -> - CPatCstr (!@loc, r, lp, []) ] + |"@"; r = Prim.reference; lp = LIST0 NEXT -> + CPatCstr (!@loc, r, Some lp, []) ] | "1" LEFTA [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ] | "0" -- cgit v1.2.3 From 3366f05ab09aa90dcc96d7432bff09617162c3e4 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 13 Mar 2016 17:49:25 +0100 Subject: Adopting the same rules for interpreting @, abbreviations and notations in patterns than in terms, wrt implicit arguments and scopes. See file Notations2.v for the conventions in use in terms. Somehow this could be put in 8.5 since it puts in agreement the interpretation of abbreviations and notations in "symmetric patterns" to what is done in terms (even though the interpretation rules for terms are a bit ad hoc). There is one exception: in terms, "(foo args) args'" deactivates the implicit arguments and scopes in args'. This is a bit complicated to implement in patterns so the syntax is not supported (and anyway, this convention is a bit questionable). --- parsing/g_constr.ml4 | 3 +++ 1 file changed, 3 insertions(+) (limited to 'parsing') diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index b11204cbc5..7e470e8445 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -380,6 +380,9 @@ GEXTEND Gram [ p = pattern; lp = LIST1 NEXT -> (match p with | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp) + | CPatCstr (_, r, None, l2) -> Errors.user_err_loc + (cases_pattern_expr_loc p, "compound_pattern", + Pp.str "Nested applications not supported.") | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) | _ -> Errors.user_err_loc -- cgit v1.2.3 From 92a6a72ec4680d0f241e8b1ddd7b87f7ad11f65e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 14:01:37 +0100 Subject: Relying on parsing rules rather than genarg to check if an argument is empty. --- parsing/pcoq.ml | 7 +++++++ parsing/pcoq.mli | 2 ++ 2 files changed, 9 insertions(+) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index cf65262c4a..52437e3867 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -853,3 +853,10 @@ let list_entry_names () = let ans = Hashtbl.fold add_entry (get_utable uprim) [] in let ans = Hashtbl.fold add_entry (get_utable uconstr) ans in Hashtbl.fold add_entry (get_utable utactic) ans + +let epsilon_value f e = + let r = Rule (Next (Stop, e), fun x _ -> f x) in + let ext = of_coq_extend_statement (None, [None, None, [r]]) in + let entry = G.entry_create "epsilon" in + let () = maybe_uncurry (Gram.extend entry) ext in + try Some (parse_string entry "") with _ -> None diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index b26c3044bd..7e0c89fd12 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -272,6 +272,8 @@ val symbol_of_constr_prod_entry_key : gram_assoc option -> val name_of_entry : 'a Gram.entry -> 'a Entry.t +val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option + (** Binding general entry keys to symbols *) type 's entry_name = EntryName : -- cgit v1.2.3 From d66fe71c93bc06f6006c64118deb1d5b01bf7487 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 16:01:23 +0100 Subject: Adding a universe argument to Pcoq.create_generic_entry. --- parsing/pcoq.ml | 2 +- parsing/pcoq.mli | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 52437e3867..e150578196 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -251,7 +251,7 @@ let create_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.ent let create_constr_entry s = create_entry uconstr s (rawwit wit_constr) -let create_generic_entry s wit = create_entry utactic s wit +let create_generic_entry = create_entry (* [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 *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 7e0c89fd12..625f0370e6 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -162,8 +162,8 @@ val uvernac : gram_universe val get_entry : gram_universe -> string -> typed_entry -val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> - 'a Gram.entry +val create_generic_entry : gram_universe -> string -> + ('a, rlevel) abstract_argument_type -> 'a Gram.entry module Prim : sig -- cgit v1.2.3 From 4d13842869647790c9bd3084dce672fee7b648a1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 16:23:59 +0100 Subject: Code factorization in Pcoq. --- parsing/pcoq.ml | 37 +++++++++---------------------------- 1 file changed, 9 insertions(+), 28 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index e150578196..1b1ecaf910 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -200,8 +200,6 @@ let parse_string f x = type gram_universe = Entry.universe -let trace = ref false - let uprim = Entry.uprim let uconstr = Entry.uconstr let utactic = Entry.utactic @@ -231,38 +229,21 @@ let get_typed_entry e = let new_entry etyp u s = let utab = get_utable u in let uname = Entry.univ_name u in - if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" uname s; flush stderr); let _ = Entry.create u s in let ename = uname ^ ":" ^ s in let e = Gram.entry_create ename in Hashtbl.add utab s (TypedEntry (etyp, e)); e -let create_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = +let make_gen_entry u rawwit s = new_entry rawwit u s + +let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in - try - let TypedEntry (typ, e) = Hashtbl.find utab s in - match abstract_argument_type_eq typ etyp with - | None -> - let u = Entry.univ_name u in - failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - | Some Refl -> e - with Not_found -> + if Hashtbl.mem utab s then + let u = Entry.univ_name u in + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists"); + else new_entry etyp u s -let create_constr_entry s = create_entry uconstr s (rawwit wit_constr) - -let create_generic_entry = create_entry - -(* [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 rawwit s = - let univ = get_utable u in - let uname = Entry.univ_name u in - let e = Gram.entry_create (uname ^ ":" ^ s) in - let _ = Entry.create u s in - Hashtbl.add univ s (TypedEntry (rawwit, e)); e - (* Initial grammar entries *) module Prim = @@ -312,7 +293,7 @@ module Constr = let operconstr = gec_constr "operconstr" let constr_eoi = eoi_entry constr let lconstr = gec_constr "lconstr" - let binder_constr = create_constr_entry "binder_constr" + let binder_constr = gec_constr "binder_constr" let ident = make_gen_entry uconstr (rawwit wit_ident) "ident" let global = make_gen_entry uconstr (rawwit wit_ref) "global" let sort = make_gen_entry uconstr (rawwit wit_sort) "sort" @@ -612,7 +593,7 @@ let compute_entry allow_create adjust forpat = function try get_entry u n with Not_found when allow_create -> let wit = rawwit wit_constr in - TypedEntry (wit, create_entry u n wit) + TypedEntry (wit, create_generic_entry u n wit) in object_of_typed_entry e, None, true -- cgit v1.2.3 From 36e865119e5bb5fbaed14428fc89ecd4e96fb7be Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 18:27:39 +0100 Subject: Removing the special status of generic arguments defined by Coq itself. This makes the TACTIC EXTEND macro insensitive to Coq-defined arguments. They now have to be reachable in the ML code. Note that this has some consequences, as the previous macro was potentially mixing grammar entries and arguments as long as their name was the same. Now, each genarg comes with its grammar instead, so there is no way to abuse the macro. --- parsing/highparsing.mllib | 1 - parsing/pcoq.ml | 51 +++++++++++++++++++++++++++++++++++++++++++---- parsing/pcoq.mli | 2 ++ 3 files changed, 49 insertions(+), 5 deletions(-) (limited to 'parsing') diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index 13ed804641..eed6caea30 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -4,4 +4,3 @@ G_prim G_proofs G_tactic G_ltac -G_obligations diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 1b1ecaf910..05fd9f9d8c 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -229,12 +229,23 @@ let get_typed_entry e = let new_entry etyp u s = let utab = get_utable u in let uname = Entry.univ_name u in - let _ = Entry.create u s in + let entry = Entry.create u s in let ename = uname ^ ":" ^ s in let e = Gram.entry_create ename in - Hashtbl.add utab s (TypedEntry (etyp, e)); e + Hashtbl.add utab s (TypedEntry (etyp, e)); (entry, e) -let make_gen_entry u rawwit s = new_entry rawwit u s +let make_gen_entry u rawwit s = snd (new_entry rawwit u s) + +module GrammarObj = +struct + type ('r, _, _) obj = 'r Entry.t + let name = "grammar" + let default _ = None +end + +module Grammar = Register(GrammarObj) + +let genarg_grammar wit = Grammar.obj wit let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in @@ -242,7 +253,10 @@ let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a let u = Entry.univ_name u in failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists"); else - new_entry etyp u s + let (entry, e) = new_entry etyp u s in + let Rawwit t = etyp in + let () = Grammar.register0 t entry in + e (* Initial grammar entries *) @@ -841,3 +855,32 @@ let epsilon_value f e = let entry = G.entry_create "epsilon" in let () = maybe_uncurry (Gram.extend entry) ext in try Some (parse_string entry "") with _ -> None + +(** Registering grammar of generic arguments *) + +let () = + let open Stdarg in + let open Constrarg in +(* Grammar.register0 wit_unit; *) +(* Grammar.register0 wit_bool; *) + Grammar.register0 wit_int (name_of_entry Prim.integer); + Grammar.register0 wit_string (name_of_entry Prim.string); + Grammar.register0 wit_pre_ident (name_of_entry Prim.preident); + Grammar.register0 wit_int_or_var (name_of_entry Tactic.int_or_var); + Grammar.register0 wit_intro_pattern (name_of_entry Tactic.simple_intropattern); + Grammar.register0 wit_ident (name_of_entry Prim.ident); + Grammar.register0 wit_var (name_of_entry Prim.var); + Grammar.register0 wit_ref (name_of_entry Prim.reference); + Grammar.register0 wit_quant_hyp (name_of_entry Tactic.quantified_hypothesis); + Grammar.register0 wit_sort (name_of_entry Constr.sort); + Grammar.register0 wit_constr (name_of_entry Constr.constr); + Grammar.register0 wit_constr_may_eval (name_of_entry Tactic.constr_may_eval); + Grammar.register0 wit_uconstr (name_of_entry Tactic.uconstr); + Grammar.register0 wit_open_constr (name_of_entry Tactic.open_constr); + Grammar.register0 wit_constr_with_bindings (name_of_entry Tactic.constr_with_bindings); + Grammar.register0 wit_bindings (name_of_entry Tactic.bindings); +(* Grammar.register0 wit_hyp_location_flag; *) + Grammar.register0 wit_red_expr (name_of_entry Tactic.red_expr); + Grammar.register0 wit_tactic (name_of_entry Tactic.tactic); + Grammar.register0 wit_clause_dft_concl (name_of_entry Tactic.clause_dft_concl); + () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 625f0370e6..b1353ef8ad 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -160,6 +160,8 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe +val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Entry.t + val get_entry : gram_universe -> string -> typed_entry val create_generic_entry : gram_universe -> string -> -- cgit v1.2.3 From b5f6eb57a480d705be9362067e2fb887533c822c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 23:49:40 +0100 Subject: ARGUMENT EXTEND made of only one entry share the same grammar. This fixes parsing conflicts with the [fix ... with] tactic. --- parsing/pcoq.ml | 53 +++++++++++++++++++++++++++-------------------------- parsing/pcoq.mli | 3 ++- 2 files changed, 29 insertions(+), 27 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 05fd9f9d8c..b769a3cbc4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -229,23 +229,24 @@ let get_typed_entry e = let new_entry etyp u s = let utab = get_utable u in let uname = Entry.univ_name u in - let entry = Entry.create u s in + let _ = Entry.create u s in let ename = uname ^ ":" ^ s in let e = Gram.entry_create ename in - Hashtbl.add utab s (TypedEntry (etyp, e)); (entry, e) + Hashtbl.add utab s (TypedEntry (etyp, e)); e -let make_gen_entry u rawwit s = snd (new_entry rawwit u s) +let make_gen_entry u rawwit s = new_entry rawwit u s module GrammarObj = struct - type ('r, _, _) obj = 'r Entry.t + type ('r, _, _) obj = 'r Gram.entry let name = "grammar" let default _ = None end module Grammar = Register(GrammarObj) -let genarg_grammar wit = Grammar.obj wit +let register_grammar = Grammar.register0 +let genarg_grammar = Grammar.obj let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in @@ -253,9 +254,9 @@ let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a let u = Entry.univ_name u in failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists"); else - let (entry, e) = new_entry etyp u s in + let e = new_entry etyp u s in let Rawwit t = etyp in - let () = Grammar.register0 t entry in + let () = Grammar.register0 t e in e (* Initial grammar entries *) @@ -863,24 +864,24 @@ let () = let open Constrarg in (* Grammar.register0 wit_unit; *) (* Grammar.register0 wit_bool; *) - Grammar.register0 wit_int (name_of_entry Prim.integer); - Grammar.register0 wit_string (name_of_entry Prim.string); - Grammar.register0 wit_pre_ident (name_of_entry Prim.preident); - Grammar.register0 wit_int_or_var (name_of_entry Tactic.int_or_var); - Grammar.register0 wit_intro_pattern (name_of_entry Tactic.simple_intropattern); - Grammar.register0 wit_ident (name_of_entry Prim.ident); - Grammar.register0 wit_var (name_of_entry Prim.var); - Grammar.register0 wit_ref (name_of_entry Prim.reference); - Grammar.register0 wit_quant_hyp (name_of_entry Tactic.quantified_hypothesis); - Grammar.register0 wit_sort (name_of_entry Constr.sort); - Grammar.register0 wit_constr (name_of_entry Constr.constr); - Grammar.register0 wit_constr_may_eval (name_of_entry Tactic.constr_may_eval); - Grammar.register0 wit_uconstr (name_of_entry Tactic.uconstr); - Grammar.register0 wit_open_constr (name_of_entry Tactic.open_constr); - Grammar.register0 wit_constr_with_bindings (name_of_entry Tactic.constr_with_bindings); - Grammar.register0 wit_bindings (name_of_entry Tactic.bindings); + Grammar.register0 wit_int (Prim.integer); + Grammar.register0 wit_string (Prim.string); + Grammar.register0 wit_pre_ident (Prim.preident); + Grammar.register0 wit_int_or_var (Tactic.int_or_var); + Grammar.register0 wit_intro_pattern (Tactic.simple_intropattern); + Grammar.register0 wit_ident (Prim.ident); + Grammar.register0 wit_var (Prim.var); + Grammar.register0 wit_ref (Prim.reference); + Grammar.register0 wit_quant_hyp (Tactic.quantified_hypothesis); + Grammar.register0 wit_sort (Constr.sort); + Grammar.register0 wit_constr (Constr.constr); + Grammar.register0 wit_constr_may_eval (Tactic.constr_may_eval); + Grammar.register0 wit_uconstr (Tactic.uconstr); + Grammar.register0 wit_open_constr (Tactic.open_constr); + Grammar.register0 wit_constr_with_bindings (Tactic.constr_with_bindings); + Grammar.register0 wit_bindings (Tactic.bindings); (* Grammar.register0 wit_hyp_location_flag; *) - Grammar.register0 wit_red_expr (name_of_entry Tactic.red_expr); - Grammar.register0 wit_tactic (name_of_entry Tactic.tactic); - Grammar.register0 wit_clause_dft_concl (name_of_entry Tactic.clause_dft_concl); + Grammar.register0 wit_red_expr (Tactic.red_expr); + Grammar.register0 wit_tactic (Tactic.tactic); + Grammar.register0 wit_clause_dft_concl (Tactic.clause_dft_concl); () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index b1353ef8ad..64f6f720c2 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -160,7 +160,8 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe -val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Entry.t +val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit +val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry val get_entry : gram_universe -> string -> typed_entry -- cgit v1.2.3 From 1730369cd4f7b62a076c93b2a0ece190ee08f7eb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Mar 2016 00:32:02 +0100 Subject: Making the EXTEND macros almost self-contained. --- parsing/lexer.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 232e9aee3f..8b8b38c34b 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -724,7 +724,7 @@ let strip s = let terminal s = let s = strip s in - let () = match s with "" -> Errors.error "empty token." | _ -> () in + let () = match s with "" -> failwith "empty token." | _ -> () in if is_ident_not_keyword s then IDENT s else if is_number s then INT s else KEYWORD s -- cgit v1.2.3 From 13c50b98b0a294a6056d2e00a0de44cedca7af12 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 16 Feb 2016 20:03:45 +0100 Subject: Removing dead code in Pcoq. --- parsing/egramcoq.ml | 4 ++-- parsing/pcoq.ml | 37 ++++++++++++------------------------- parsing/pcoq.mli | 21 +++++++-------------- 3 files changed, 21 insertions(+), 41 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 2cf590b1d8..8c4930806e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -206,14 +206,14 @@ type notation_grammar = { let extend_constr_constr_notation ng = let level = ng.notgram_level in let mkact loc env = CNotation (loc, ng.notgram_notation, env) in - let e = interp_constr_entry_key false (ETConstr (level, ())) in + let e = interp_constr_entry_key false level in let ext = (ETConstr (level, ()), ng.notgram_assoc) in extend_constr e ext (make_constr_action mkact) false ng.notgram_prods let extend_constr_pat_notation ng = let level = ng.notgram_level in let mkact loc env = CPatNotation (loc, ng.notgram_notation, env, []) in - let e = interp_constr_entry_key true (ETConstr (level, ())) in + let e = interp_constr_entry_key true level in let ext = ETConstr (level, ()), ng.notgram_assoc in extend_constr e ext (make_cases_pattern_action mkact) true ng.notgram_prods diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b769a3cbc4..bf46fffffe 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -77,8 +77,8 @@ type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = | Aentry : 'a Entry.t -> ('self, 'a) entry_key | Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key -type 's entry_name = EntryName : - 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name +type entry_name = EntryName : + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) entry_key -> entry_name (** Grammar extensions *) @@ -586,7 +586,7 @@ let adjust_level assoc from = function | ETConstr (p,()) -> Some (Some (n, Int.equal n p)) | _ -> Some (Some (n,false)) -let compute_entry allow_create adjust forpat = function +let compute_entry adjust forpat = function | ETConstr (n,q) -> (if forpat then weaken_entry Constr.pattern else weaken_entry Constr.operconstr), @@ -604,26 +604,19 @@ let compute_entry allow_create adjust forpat = function | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") | ETOther (u,n) -> let u = get_univ u in - let e = - try get_entry u n - with Not_found when allow_create -> - let wit = rawwit wit_constr in - TypedEntry (wit, create_generic_entry u n wit) - in + let e = get_entry u n in object_of_typed_entry e, None, true (* This computes the name of the level where to add a new rule *) -let interp_constr_entry_key forpat = function - | ETConstr(200,()) when not forpat -> - weaken_entry Constr.binder_constr, None - | e -> - let (e,level,_) = compute_entry true (fun (n,()) -> Some n) forpat e in - (e, level) +let interp_constr_entry_key forpat level = + if level = 200 && not forpat then weaken_entry Constr.binder_constr, None + else if forpat then weaken_entry Constr.pattern, Some level + else weaken_entry Constr.operconstr, Some level (* This computes the name to give to a production knowing the name and associativity of the level where it must be added *) let interp_constr_prod_entry_key ass from forpat en = - compute_entry false (adjust_level ass from) forpat en + compute_entry (adjust_level ass from) forpat en (**********************************************************************) (* Binding constr entry keys to symbols *) @@ -759,17 +752,11 @@ let atactic n = let try_get_entry u s = (** Order the effects: get_entry can raise Not_found *) - let TypedEntry (typ, _) = get_entry u s in - EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s))) - -type _ target = -| TgAny : 's target -| TgTactic : int -> Tacexpr.raw_tactic_expr target + let TypedEntry (typ, e) = get_entry u s in + EntryName (typ, Aentry (name_of_entry e)) (** Quite ad-hoc *) -let get_tacentry (type s) (n : int) (t : s target) : s entry_name = match t with -| TgAny -> EntryName (rawwit wit_tactic, atactic n) -| TgTactic m -> +let get_tacentry n m = let check_lvl n = Int.equal m n && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 64f6f720c2..e57da42cb3 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -153,8 +153,6 @@ type gram_universe = Entry.universe val get_univ : string -> gram_universe -type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a Gram.entry -> typed_entry - val uprim : gram_universe val uconstr : gram_universe val utactic : gram_universe @@ -163,8 +161,6 @@ val uvernac : gram_universe val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -val get_entry : gram_universe -> string -> typed_entry - val create_generic_entry : gram_universe -> string -> ('a, rlevel) abstract_argument_type -> 'a Gram.entry @@ -267,7 +263,7 @@ val main_entry : (Loc.t * vernac_expr) option Gram.entry (** Binding constr entry keys to entries and symbols *) val interp_constr_entry_key : bool (** true for cases_pattern *) -> - constr_entry_key -> grammar_object Gram.entry * int option + int -> grammar_object Gram.entry * int option val symbol_of_constr_prod_entry_key : gram_assoc option -> constr_entry_key -> bool -> constr_prod_entry_key -> @@ -279,16 +275,13 @@ val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option (** Binding general entry keys to symbols *) -type 's entry_name = EntryName : - 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name - -(** Interpret entry names of the form "ne_constr_list" as entry keys *) - -type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target - -val interp_entry_name : 's target -> string -> string -> 's entry_name +type entry_name = EntryName : + 'a raw_abstract_argument_type * (raw_tactic_expr, 'a) entry_key -> entry_name -val parse_user_entry : string -> string -> user_symbol +(** [interp_entry_name lev n sep] returns the entry corresponding to the name + [n] of the form "ne_constr_list" in a tactic entry of level [lev] with + separator [sep]. *) +val interp_entry_name : int -> string -> string -> entry_name (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * argument_type) list -- cgit v1.2.3 From a99aa093b962e228817066d00f7e12698f8df73a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Mar 2016 22:27:17 +0100 Subject: Simplifying the code of Entry. --- parsing/entry.ml | 49 +++++++++---------------------------------- parsing/entry.mli | 29 ++++--------------------- parsing/pcoq.ml | 63 ++++++++++++++++++++++++++++++------------------------- parsing/pcoq.mli | 3 ++- 4 files changed, 50 insertions(+), 94 deletions(-) (limited to 'parsing') diff --git a/parsing/entry.ml b/parsing/entry.ml index 0519903d3d..b7c6c23fa6 100644 --- a/parsing/entry.ml +++ b/parsing/entry.ml @@ -9,51 +9,22 @@ open Errors open Util -type 'a t = string * string - -type repr = string * string - -type universe = string - -(* The univ_tab is not part of the state. It contains all the grammars that - exist or have existed before in the session. *) - -let univ_tab = (Hashtbl.create 7 : (string, unit) Hashtbl.t) - -let create_univ s = - Hashtbl.add univ_tab s (); s - -let univ_name s = s - -let uprim = create_univ "prim" -let uconstr = create_univ "constr" -let utactic = create_univ "tactic" -let uvernac = create_univ "vernac" - -let get_univ s = - try - Hashtbl.find univ_tab s; s - with Not_found -> - anomaly (Pp.str ("Unknown grammar universe: "^s)) +type 'a t = string (** Entries are registered with a unique name *) let entries = ref String.Set.empty -let create u name = - let uname = u ^ ":" ^ name in +let create name = let () = - if String.Set.mem uname !entries then - anomaly (Pp.str ("Entry " ^ uname ^ " already defined")) + if String.Set.mem name !entries then + anomaly (Pp.str ("Entry " ^ name ^ " already defined")) in - let () = entries := String.Set.add uname !entries in - (u, name) - -let dynamic name = ("", name) + let () = entries := String.Set.add name !entries in + name -let unsafe_of_name (u, s) = - let uname = u ^ ":" ^ s in - assert (String.Set.mem uname !entries); - (u, s) +let unsafe_of_name name = + assert (String.Set.mem name !entries); + name -let repr (u, s) = (u, s) +let repr s = s diff --git a/parsing/entry.mli b/parsing/entry.mli index 97cd5b1105..4c73fe2049 100644 --- a/parsing/entry.mli +++ b/parsing/entry.mli @@ -11,34 +11,13 @@ type 'a t (** Typed grammar entries. We need to defined them here so that they are marshallable and defined before the Pcoq.Gram module. They are basically - unique names made of a universe and an entry name. They should be kept - synchronized with the {!Pcoq} entries though. *) + unique names. They should be kept synchronized with the {!Pcoq} entries. *) -type repr = string * string -(** Representation of entries. *) - -(** Table of Coq statically defined grammar entries *) - -type universe - -(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *) - -val get_univ : string -> universe -val univ_name : universe -> string - -val uprim : universe -val uconstr : universe -val utactic : universe -val uvernac : universe - -(** {5 Uniquely defined entries} *) - -val create : universe -> string -> 'a t +val create : string -> 'a t (** Create an entry. They should be synchronized with the entries defined in {!Pcoq}. *) (** {5 Meta-programming} *) -val repr : 'a t -> repr - -val unsafe_of_name : (string * string) -> 'a t +val repr : 'a t -> string +val unsafe_of_name : string -> 'a t diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index bf46fffffe..238b9edd44 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -198,40 +198,49 @@ let map_entry f en = let parse_string f x = let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm) -type gram_universe = Entry.universe - -let uprim = Entry.uprim -let uconstr = Entry.uconstr -let utactic = Entry.utactic -let uvernac = Entry.uvernac -let get_univ = Entry.get_univ +type gram_universe = string let utables : (string, (string, typed_entry) Hashtbl.t) Hashtbl.t = Hashtbl.create 97 +let create_universe u = + let table = Hashtbl.create 97 in + let () = Hashtbl.add utables u table in + u + +let uprim = create_universe "prim" +let uconstr = create_universe "constr" +let utactic = create_universe "tactic" +let uvernac = create_universe "vernac" + +let get_univ u = + if Hashtbl.mem utables u then u + else raise Not_found + let get_utable u = - let u = Entry.univ_name u in try Hashtbl.find utables u - with Not_found -> - let table = Hashtbl.create 97 in - Hashtbl.add utables u table; - table + with Not_found -> assert false let get_entry u s = let utab = get_utable u in Hashtbl.find utab s -let get_typed_entry e = - let (u, s) = Entry.repr e in - let u = Entry.get_univ u in - get_entry u s +(** A table associating grammar to entries *) +let gtable : Obj.t Gram.entry String.Map.t ref = ref String.Map.empty + +let get_grammar (e : 'a Entry.t) : 'a Gram.entry = + Obj.magic (String.Map.find (Entry.repr e) !gtable) + +let set_grammar (e : 'a Entry.t) (g : 'a Gram.entry) = + assert (not (String.Map.mem (Entry.repr e) !gtable)); + gtable := String.Map.add (Entry.repr e) (Obj.magic g) !gtable let new_entry etyp u s = let utab = get_utable u in - let uname = Entry.univ_name u in - let _ = Entry.create u s in - let ename = uname ^ ":" ^ s in + let ename = u ^ ":" ^ s in + let entry = Entry.create ename in let e = Gram.entry_create ename in + let () = set_grammar entry e in Hashtbl.add utab s (TypedEntry (etyp, e)); e let make_gen_entry u rawwit s = new_entry rawwit u s @@ -251,8 +260,7 @@ let genarg_grammar = Grammar.obj let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in if Hashtbl.mem utab s then - let u = Entry.univ_name u in - failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists"); + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists") else let e = new_entry etyp u s in let Rawwit t = etyp in @@ -603,7 +611,6 @@ let compute_entry adjust forpat = function | ETPattern -> weaken_entry Constr.pattern, None, false | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") | ETOther (u,n) -> - let u = get_univ u in let e = get_entry u n in object_of_typed_entry e, None, true @@ -696,11 +703,11 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function | Aself -> Symbols.sself | Anext -> Symbols.snext | Aentry e -> - let e = get_typed_entry e in - Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) + let e = get_grammar e in + Symbols.snterm (Gram.Entry.obj (weaken_entry e)) | Aentryl (e, n) -> - let e = get_typed_entry e in - Symbols.snterml (Gram.Entry.obj (object_of_typed_entry e), string_of_int n) + let e = get_grammar e in + Symbols.snterml (Gram.Entry.obj (weaken_entry e), string_of_int n) let level_of_snterml e = int_of_string (Symbols.snterml_level e) @@ -742,9 +749,7 @@ let coincide s pat off = done; !break -let name_of_entry e = match String.split ':' (Gram.Entry.name e) with -| u :: s :: [] -> Entry.unsafe_of_name (u, s) -| _ -> assert false +let name_of_entry e = Entry.unsafe_of_name (Gram.Entry.name e) let atactic n = if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index e57da42cb3..c1c0187137 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -149,7 +149,7 @@ val parse_string : 'a Gram.entry -> string -> 'a val eoi_entry : 'a Gram.entry -> 'a Gram.entry val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry -type gram_universe = Entry.universe +type gram_universe val get_univ : string -> gram_universe @@ -158,6 +158,7 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe +val set_grammar : 'a Entry.t -> 'a Gram.entry -> unit val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -- cgit v1.2.3 From 805c8987fbb5fdeb94838bb5a3a7364c0a3d3374 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 17 Feb 2016 13:45:24 +0100 Subject: Do not export entry_key from Pcoq anymore. --- parsing/egramml.ml | 3 ++- parsing/egramml.mli | 2 +- parsing/pcoq.ml | 17 ++--------------- parsing/pcoq.mli | 15 +-------------- 4 files changed, 6 insertions(+), 31 deletions(-) (limited to 'parsing') diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 77252e7425..37fccdb3c2 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -9,6 +9,7 @@ open Util open Compat open Names +open Extend open Pcoq open Genarg open Vernacexpr @@ -18,7 +19,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's grammar_prod_item + Loc.t * 'a raw_abstract_argument_type * ('s, 'a) symbol -> 's grammar_prod_item type 'a ty_arg = ('a -> raw_generic_argument) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index edf971574d..1ad9472007 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -16,7 +16,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type * - ('s, 'a) Pcoq.entry_key -> 's grammar_prod_item + ('s, 'a) Extend.symbol -> 's grammar_prod_item val extend_vernac_command_grammar : Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option -> diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 238b9edd44..dac5b3bfd8 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -64,21 +64,8 @@ let weaken_entry x = Gramobj.weaken_entry x dynamically interpreted as entries for the Coq level extensions *) -type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, string) entry_key -| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key -| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Aself : ('self, 'self) entry_key -| Anext : ('self, 'self) entry_key -| Aentry : 'a Entry.t -> ('self, 'a) entry_key -| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key - type entry_name = EntryName : - 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) entry_key -> entry_name + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) symbol -> entry_name (** Grammar extensions *) @@ -684,7 +671,7 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = (** Binding general entry keys to symbol *) -let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function +let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function | Atoken t -> Symbols.stoken t | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index c1c0187137..d6bfe3eb39 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -112,19 +112,6 @@ type gram_reinit = gram_assoc * gram_position dynamically interpreted as entries for the Coq level extensions *) -type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, string) entry_key -| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key -| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Aself : ('self, 'self) entry_key -| Anext : ('self, 'self) entry_key -| Aentry : 'a Entry.t -> ('self, 'a) entry_key -| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key - (** Add one extension at some camlp4 position of some camlp4 entry *) val unsafe_grammar_extend : grammar_object Gram.entry -> @@ -277,7 +264,7 @@ val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option (** Binding general entry keys to symbols *) type entry_name = EntryName : - 'a raw_abstract_argument_type * (raw_tactic_expr, 'a) entry_key -> entry_name + 'a raw_abstract_argument_type * (raw_tactic_expr, 'a) Extend.symbol -> entry_name (** [interp_entry_name lev n sep] returns the entry corresponding to the name [n] of the form "ne_constr_list" in a tactic entry of level [lev] with -- cgit v1.2.3 From 25f39e54e4e8eaf08865121f06635dc3bd1092da Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 16 Feb 2016 21:17:12 +0100 Subject: Allowing generalized rules in typed symbols. --- parsing/pcoq.ml | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index dac5b3bfd8..91f933987b 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -671,6 +671,13 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = (** Binding general entry keys to symbol *) +let tuplify l = + List.fold_left (fun accu x -> Obj.repr (x, accu)) (Obj.repr ()) l + +let rec adj : type a b c. (a, b, Loc.t -> Loc.t * c) adj -> _ = function +| Adj0 -> Obj.magic (fun accu f loc -> f (Obj.repr (to_coqloc loc, tuplify accu))) +| AdjS e -> Obj.magic (fun accu f x -> adj e (x :: accu) f) + let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function | Atoken t -> Symbols.stoken t | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) @@ -695,21 +702,27 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function | Aentryl (e, n) -> let e = get_grammar e in Symbols.snterml (Gram.Entry.obj (weaken_entry e), string_of_int n) + | Arules rs -> Gram.srules' (symbol_of_rules rs [] (fun x -> I0 x)) -let level_of_snterml e = int_of_string (Symbols.snterml_level e) - -let rec of_coq_rule : type self a r. (self, a, r) Extend.rule -> _ = function +and symbol_of_rule : type s a r. (s, a, r) Extend.rule -> _ = function | Stop -> fun accu -> accu -| Next (r, tok) -> fun accu -> - let symb = symbol_of_prod_entry_key tok in - of_coq_rule r (symb :: accu) +| Next (r, s) -> fun accu -> symbol_of_rule r (symbol_of_prod_entry_key s :: accu) + +and symbol_of_rules : type a. a Extend.rules -> _ = function +| Rule0 -> fun accu _ -> accu +| RuleS (r, e, rs) -> fun accu f -> + let symb = symbol_of_rule r [] in + let act = adj e [] f in + symbol_of_rules rs ((symb, act) :: accu) (fun x -> IS (f x)) + +let level_of_snterml e = int_of_string (Symbols.snterml_level e) let rec of_coq_action : type a r. (r, a, Loc.t -> r) Extend.rule -> a -> Gram.action = function | Stop -> fun f -> Gram.action (fun loc -> f (to_coqloc loc)) | Next (r, _) -> fun f -> Gram.action (fun x -> of_coq_action r (f x)) let of_coq_production_rule : type a. a Extend.production_rule -> _ = function -| Rule (toks, act) -> (of_coq_rule toks [], of_coq_action toks act) +| Rule (toks, act) -> (symbol_of_rule toks [], of_coq_action toks act) let of_coq_single_extend_statement (lvl, assoc, rule) = (lvl, Option.map of_coq_assoc assoc, List.map of_coq_production_rule rule) -- cgit v1.2.3 From d94a8b2024497e11ff9392a7fa4401ffcc131cc0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 10 Mar 2016 15:20:47 +0100 Subject: Moving the proof mode parsing management to Pcoq. --- parsing/g_vernac.ml4 | 12 +----------- parsing/pcoq.ml | 9 +++++++++ parsing/pcoq.mli | 6 ++++++ 3 files changed, 16 insertions(+), 11 deletions(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 49baeb5560..2eb590132a 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -35,7 +35,6 @@ let _ = List.iter Lexer.add_keyword vernac_kw let query_command = Gram.entry_create "vernac:query_command" let tactic_mode = Gram.entry_create "vernac:tactic_command" -let noedit_mode = Gram.entry_create "vernac:noedit_command" let subprf = Gram.entry_create "vernac:subprf" let class_rawexpr = Gram.entry_create "vernac:class_rawexpr" @@ -48,11 +47,6 @@ let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" let section_subset_expr = Gram.entry_create "vernac:section_subset_expr" -let command_entry = ref noedit_mode -let set_command_entry e = command_entry := e -let get_command_entry () = !command_entry - - (* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for proof editing and changes nothing else). Then sets it as the default proof mode. *) let set_tactic_mode () = set_command_entry tactic_mode @@ -82,10 +76,6 @@ let test_bracket_ident = | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) -let default_command_entry = - Gram.Entry.of_parser "command_entry" - (fun strm -> Gram.parse_tokens_after_filter (get_command_entry ()) strm) - GEXTEND Gram GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; vernac: FIRST @@ -129,7 +119,7 @@ GEXTEND Gram ] ] ; vernac_aux: LAST - [ [ prfcom = default_command_entry -> prfcom ] ] + [ [ prfcom = command_entry -> prfcom ] ] ; noedit_mode: [ [ c = subgoal_command -> c None] ] diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 91f933987b..9c2f09db84 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -383,6 +383,7 @@ module Vernac_ = let rec_definition = gec_vernac "Vernac.rec_definition" (* Main vernac entry *) let main_entry = Gram.entry_create "vernac" + let noedit_mode = gec_vernac "noedit_command" let () = let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in @@ -393,10 +394,18 @@ module Vernac_ = ] in maybe_uncurry (Gram.extend main_entry) (None, make_rule rule) + let command_entry_ref = ref noedit_mode + let command_entry = + Gram.Entry.of_parser "command_entry" + (fun strm -> Gram.parse_tokens_after_filter !command_entry_ref strm) + end let main_entry = Vernac_.main_entry +let set_command_entry e = Vernac_.command_entry_ref := e +let get_command_entry () = !Vernac_.command_entry_ref + (**********************************************************************) (* This determines (depending on the associativity of the current level and on the expected associativity) if a reference to constr_n is diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index d6bfe3eb39..7410d4e44c 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -241,11 +241,17 @@ module Vernac_ : val vernac : vernac_expr Gram.entry val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry val vernac_eoi : vernac_expr Gram.entry + val noedit_mode : vernac_expr Gram.entry + val command_entry : vernac_expr Gram.entry end (** The main entry: reads an optional vernac command *) val main_entry : (Loc.t * vernac_expr) option Gram.entry +(** Handling of the proof mode entry *) +val get_command_entry : unit -> vernac_expr Gram.entry +val set_command_entry : vernac_expr Gram.entry -> unit + (** Mapping formal entries into concrete ones *) (** Binding constr entry keys to entries and symbols *) -- cgit v1.2.3 From 5c8fc9aebe072237a65fc9ed7acf8ae559a78243 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 16 Mar 2016 19:27:00 +0100 Subject: Moving the parsing of the Ltac proof mode to G_ltac. --- parsing/g_ltac.ml4 | 42 +++++++++++++++++++++++++++++++++++++++++- parsing/g_vernac.ml4 | 44 ++------------------------------------------ 2 files changed, 43 insertions(+), 43 deletions(-) (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index e4ca936a69..35a9fede1b 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util open Pp open Compat open Constrexpr @@ -36,11 +37,35 @@ let reference_to_id = function Errors.user_err_loc (loc, "", str "This expression should be a simple identifier.") +let tactic_mode = Gram.entry_create "vernac:tactic_command" +let selector = Gram.entry_create "vernac:selector" + +(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for + proof editing and changes nothing else). Then sets it as the default proof mode. *) +let _ = + let mode = { + Proof_global.name = "Classic"; + set = (fun () -> set_command_entry tactic_mode); + reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + } in + Proof_global.register_proof_mode mode + +(* Hack to parse "[ id" without dropping [ *) +let test_bracket_ident = + Gram.Entry.of_parser "test_bracket_ident" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "[" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + (* Tactics grammar rules *) GEXTEND Gram GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg - constr_may_eval constr_eval; + tactic_mode constr_may_eval constr_eval selector; tactic_then_last: [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> @@ -262,4 +287,19 @@ GEXTEND Gram tactic: [ [ tac = tactic_expr -> tac ] ] ; + selector: + [ [ n=natural; ":" -> Vernacexpr.SelectNth n + | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id + | IDENT "all" ; ":" -> Vernacexpr.SelectAll + | IDENT "par" ; ":" -> Vernacexpr.SelectAllParallel ] ] + ; + tactic_mode: + [ [ g = OPT selector; + tac = G_vernac.subgoal_command -> tac g + | g = OPT selector; info = OPT [IDENT "Info";n=natural -> n]; + tac = Tactic.tactic; use_dft_tac = [ "." -> false | "..." -> true ] -> + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + Vernacexpr.VernacSolve (g, info, tac, use_dft_tac) + ] ] + ; END diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 2eb590132a..c89238d296 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -34,7 +34,6 @@ let _ = List.iter Lexer.add_keyword vernac_kw let query_command = Gram.entry_create "vernac:query_command" -let tactic_mode = Gram.entry_create "vernac:tactic_command" let subprf = Gram.entry_create "vernac:subprf" let class_rawexpr = Gram.entry_create "vernac:class_rawexpr" @@ -47,16 +46,6 @@ let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" let section_subset_expr = Gram.entry_create "vernac:section_subset_expr" -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let set_tactic_mode () = set_command_entry tactic_mode -let set_noedit_mode () = set_command_entry noedit_mode -let _ = Proof_global.register_proof_mode {Proof_global. - name = "Classic" ; - set = set_tactic_mode ; - reset = set_noedit_mode - } - let make_bullet s = let n = String.length s in match s.[0] with @@ -65,19 +54,8 @@ let make_bullet s = | '*' -> Star n | _ -> assert false -(* Hack to parse "[ id" without dropping [ *) -let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "[" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - GEXTEND Gram - GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; + GLOBAL: vernac gallina_ext noedit_mode subprf subgoal_command; vernac: FIRST [ [ IDENT "Time"; c = located_vernac -> VernacTime c | IDENT "Redirect"; s = ne_string; c = located_vernac -> VernacRedirect (s, c) @@ -125,18 +103,6 @@ GEXTEND Gram [ [ c = subgoal_command -> c None] ] ; - selector: - [ [ n=natural; ":" -> SelectNth n - | test_bracket_ident; "["; id = ident; "]"; ":" -> SelectId id - | IDENT "all" ; ":" -> SelectAll - | IDENT "par" ; ":" -> SelectAllParallel ] ] - ; - - tactic_mode: - [ [ gln = OPT selector; - tac = subgoal_command -> tac gln ] ] - ; - subprf: [ [ s = BULLET -> VernacBullet (make_bullet s) | "{" -> VernacSubproof None @@ -151,13 +117,7 @@ GEXTEND Gram | None -> c None | _ -> VernacError (UserError ("",str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) - end - | info = OPT [IDENT "Info";n=natural -> n]; - tac = Tactic.tactic; - use_dft_tac = [ "." -> false | "..." -> true ] -> - (fun g -> - let g = Option.default (Proof_global.get_default_goal_selector ()) g in - VernacSolve(g,info,tac,use_dft_tac)) ] ] + end ] ] ; located_vernac: [ [ v = vernac -> !@loc, v ] ] -- cgit v1.2.3 From ce2ffd090bd64963279cbbb84012d1b266ed9918 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 01:43:29 +0100 Subject: Moving VernacSolve to an EXTEND-based definition. --- parsing/g_ltac.ml4 | 86 +++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 76 insertions(+), 10 deletions(-) (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 35a9fede1b..79392195fb 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(*i camlp4deps: "grammar/grammar.cma" i*) + open Util open Pp open Compat @@ -38,7 +40,14 @@ let reference_to_id = function str "This expression should be a simple identifier.") let tactic_mode = Gram.entry_create "vernac:tactic_command" -let selector = Gram.entry_create "vernac:selector" + +let new_entry name = + let e = Gram.entry_create name in + let entry = Entry.create name in + let () = Pcoq.set_grammar entry e in + e + +let selector = new_entry "vernac:selector" (* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for proof editing and changes nothing else). Then sets it as the default proof mode. *) @@ -290,16 +299,73 @@ GEXTEND Gram selector: [ [ n=natural; ":" -> Vernacexpr.SelectNth n | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id - | IDENT "all" ; ":" -> Vernacexpr.SelectAll - | IDENT "par" ; ":" -> Vernacexpr.SelectAllParallel ] ] + | IDENT "all" ; ":" -> Vernacexpr.SelectAll ] ] ; tactic_mode: - [ [ g = OPT selector; - tac = G_vernac.subgoal_command -> tac g - | g = OPT selector; info = OPT [IDENT "Info";n=natural -> n]; - tac = Tactic.tactic; use_dft_tac = [ "." -> false | "..." -> true ] -> - let g = Option.default (Proof_global.get_default_goal_selector ()) g in - Vernacexpr.VernacSolve (g, info, tac, use_dft_tac) - ] ] + [ [ g = OPT selector; tac = G_vernac.subgoal_command -> tac g ] ] ; END + +open Stdarg +open Constrarg +open Vernacexpr +open Vernac_classifier + +let print_info_trace = ref None + +let _ = let open Goptions in declare_int_option { + optsync = true; + optdepr = false; + optname = "print info trace"; + optkey = ["Info" ; "Level"]; + optread = (fun () -> !print_info_trace); + optwrite = fun n -> print_info_trace := n; +} + +let vernac_solve n info tcom b = + let status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) in + if not status then Pp.feedback Feedback.AddedAxiom + +let pr_ltac_selector = function +| SelectNth i -> int i ++ str ":" +| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" +| SelectAll -> str "all" ++ str ":" + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector +| [ selector(s) ] -> [ s ] +END + +let pr_ltac_info n = str "Info" ++ spc () ++ int n + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info +| [ "Info" natural(n) ] -> [ n ] +END + +let pr_ltac_use_default b = if b then str ".." else mt () + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default +| [ "." ] -> [ false ] +| [ "..." ] -> [ true ] +END + +VERNAC tactic_mode EXTEND VernacSolve +| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ classify_as_proofstep ] -> [ + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + vernac_solve g n t def + ] +| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ VtProofStep true, VtLater ] -> [ + vernac_solve SelectAll n t def + ] +END -- cgit v1.2.3 From f25396b3a35ea5cd64b8b68670e66a14a78c418c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 17:04:07 +0100 Subject: Further reducing the dependencies of the EXTEND macros. --- parsing/tok.ml | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) (limited to 'parsing') diff --git a/parsing/tok.ml b/parsing/tok.ml index 6b90086155..df7e7c2a6b 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -8,6 +8,8 @@ (** The type of token for the Coq lexer and parser *) +let string_equal (s1 : string) s2 = s1 = s2 + type t = | KEYWORD of string | PATTERNIDENT of string @@ -21,16 +23,16 @@ type t = | EOI let equal t1 t2 = match t1, t2 with -| IDENT s1, KEYWORD s2 -> CString.equal s1 s2 -| KEYWORD s1, KEYWORD s2 -> CString.equal s1 s2 -| PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2 -| IDENT s1, IDENT s2 -> CString.equal s1 s2 -| FIELD s1, FIELD s2 -> CString.equal s1 s2 -| INT s1, INT s2 -> CString.equal s1 s2 -| INDEX s1, INDEX s2 -> CString.equal s1 s2 -| STRING s1, STRING s2 -> CString.equal s1 s2 +| IDENT s1, KEYWORD s2 -> string_equal s1 s2 +| KEYWORD s1, KEYWORD s2 -> string_equal s1 s2 +| PATTERNIDENT s1, PATTERNIDENT s2 -> string_equal s1 s2 +| IDENT s1, IDENT s2 -> string_equal s1 s2 +| FIELD s1, FIELD s2 -> string_equal s1 s2 +| INT s1, INT s2 -> string_equal s1 s2 +| INDEX s1, INDEX s2 -> string_equal s1 s2 +| STRING s1, STRING s2 -> string_equal s1 s2 | LEFTQMARK, LEFTQMARK -> true -| BULLET s1, BULLET s2 -> CString.equal s1 s2 +| BULLET s1, BULLET s2 -> string_equal s1 s2 | EOI, EOI -> true | _ -> false -- cgit v1.2.3 From 13dd3f8ebaf90f30afbcb48034e5bdd90c825765 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 20:33:32 +0100 Subject: Fixing compilation with old versions of CAMLP5. --- parsing/g_ltac.ml4 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 79392195fb..d1992c57bb 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -310,10 +310,11 @@ open Stdarg open Constrarg open Vernacexpr open Vernac_classifier +open Goptions let print_info_trace = ref None -let _ = let open Goptions in declare_int_option { +let _ = declare_int_option { optsync = true; optdepr = false; optname = "print info trace"; -- cgit v1.2.3 From 8cb2040e4af40594826df97a735c38c8882934ca Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 00:30:24 +0100 Subject: Moving Tacinterp to Hightactics. --- parsing/g_ltac.ml4 | 372 ---------------------------------------------- parsing/highparsing.mllib | 1 - 2 files changed, 373 deletions(-) delete mode 100644 parsing/g_ltac.ml4 (limited to 'parsing') diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 deleted file mode 100644 index d1992c57bb..0000000000 --- a/parsing/g_ltac.ml4 +++ /dev/null @@ -1,372 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a - | e -> Tacexp (e:raw_tactic_expr) - -let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () -let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n -let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat -let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c - -let reference_to_id = function - | Libnames.Ident (loc, id) -> (loc, id) - | Libnames.Qualid (loc,_) -> - Errors.user_err_loc (loc, "", - str "This expression should be a simple identifier.") - -let tactic_mode = Gram.entry_create "vernac:tactic_command" - -let new_entry name = - let e = Gram.entry_create name in - let entry = Entry.create name in - let () = Pcoq.set_grammar entry e in - e - -let selector = new_entry "vernac:selector" - -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let _ = - let mode = { - Proof_global.name = "Classic"; - set = (fun () -> set_command_entry tactic_mode); - reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); - } in - Proof_global.register_proof_mode mode - -(* Hack to parse "[ id" without dropping [ *) -let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "[" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -(* Tactics grammar rules *) - -GEXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg - tactic_mode constr_may_eval constr_eval selector; - - tactic_then_last: - [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> - Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) - | -> [||] - ] ] - ; - tactic_then_gen: - [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) - | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) - | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) - | ta = tactic_expr -> ([ta], None) - | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) - | -> ([TacId []], None) - ] ] - ; - tactic_then_locality: (* [true] for the local variant [TacThens] and [false] - for [TacExtend] *) - [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] - ; - tactic_expr: - [ "5" RIGHTA - [ te = binder_tactic -> te ] - | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) - | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> - match l , tail with - | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) - | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) - | false , None -> TacThen (ta0,TacDispatch first) - | true , None -> TacThens (ta0,first) ] - | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> TacTry ta - | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) - | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) - | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) - | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta - | IDENT "progress"; ta = tactic_expr -> TacProgress ta - | IDENT "once"; ta = tactic_expr -> TacOnce ta - | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta - | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta -(*To do: put Abstract in Refiner*) - | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) - | IDENT "abstract"; tc = NEXT; "using"; s = ident -> - TacAbstract (tc,Some s) ] -(*End of To do*) - | "2" RIGHTA - [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) - | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) - | IDENT "tryif" ; ta = tactic_expr ; - "then" ; tat = tactic_expr ; - "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) - | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) - | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] - | "1" RIGHTA - [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> - TacMatchGoal (b,false,mrl) - | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; - mrl = match_context_list; "end" -> - TacMatchGoal (b,true,mrl) - | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> - TacMatch (b,c,mrl) - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacFirst l - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacSolve l - | IDENT "idtac"; l = LIST0 message_token -> TacId l - | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; - l = LIST0 message_token -> TacFail (g,n,l) - | st = simple_tactic -> st - | a = tactic_arg -> TacArg(!@loc,a) - | r = reference; la = LIST0 tactic_arg_compat -> - TacArg(!@loc,TacCall (!@loc,r,la)) ] - | "0" - [ "("; a = tactic_expr; ")" -> a - | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> - begin match tail with - | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) - | None -> TacDispatch tf - end - | a = tactic_atom -> TacArg (!@loc,a) ] ] - ; - failkw: - [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] - ; - (* binder_tactic: level 5 of tactic_expr *) - binder_tactic: - [ RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> - TacFun (it,body) - | "let"; isrec = [IDENT "rec" -> true | -> false]; - llc = LIST1 let_clause SEP "with"; "in"; - body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) - | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] - ; - (* Tactic arguments to the right of an application *) - tactic_arg_compat: - [ [ a = tactic_arg -> a - | r = reference -> Reference r - | c = Constr.constr -> ConstrMayEval (ConstrTerm c) - (* Unambigous entries: tolerated w/o "ltac:" modifier *) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_arg: - [ [ c = constr_eval -> ConstrMayEval c - | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l - | IDENT "type_term"; c=uconstr -> TacPretype c - | IDENT "numgoals" -> TacNumgoals ] ] - ; - (* If a qualid is given, use its short name. TODO: have the shortest - non ambiguous name where dots are replaced by "_"? Probably too - verbose most of the time. *) - fresh_id: - [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) - | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] - ; - constr_eval: - [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrEval (rtc,c) - | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> - ConstrContext (id,c) - | IDENT "type"; IDENT "of"; c = Constr.constr -> - ConstrTypeOf c ] ] - ; - constr_may_eval: (* For extensions *) - [ [ c = constr_eval -> c - | c = Constr.constr -> ConstrTerm c ] ] - ; - tactic_atom: - [ [ n = integer -> TacGeneric (genarg_of_int n) - | r = reference -> TacCall (!@loc,r,[]) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - match_key: - [ [ "match" -> Once - | "lazymatch" -> Select - | "multimatch" -> General ] ] - ; - input_fun: - [ [ "_" -> None - | l = ident -> Some l ] ] - ; - let_clause: - [ [ id = identref; ":="; te = tactic_expr -> - (id, arg_of_expr te) - | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> - (id, arg_of_expr (TacFun(args,te))) ] ] - ; - match_pattern: - [ [ IDENT "context"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - let mode = not (!Flags.tactic_context_compat) in - Subterm (mode, oid, pc) - | IDENT "appcontext"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - msg_warning (strbrk "appcontext is deprecated"); - Subterm (true,oid, pc) - | pc = Constr.lconstr_pattern -> Term pc ] ] - ; - match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) - | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) - | na = name; ":="; mpv = match_pattern -> - let t, ty = - match mpv with - | Term t -> (match t with - | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) - | _ -> mpv, None) - | _ -> mpv, None - in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) - ] ] - ; - 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 ] ] - ; - message_token: - [ [ id = identref -> MsgIdent id - | s = STRING -> MsgString s - | n = integer -> MsgInt n ] ] - ; - - ltac_def_kind: - [ [ ":=" -> false - | "::=" -> true ] ] - ; - - (* Definitions for tactics *) - tacdef_body: - [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) - else - let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, TacFun (it, body)) - | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, body) - else - let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, body) - ] ] - ; - tactic: - [ [ tac = tactic_expr -> tac ] ] - ; - selector: - [ [ n=natural; ":" -> Vernacexpr.SelectNth n - | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id - | IDENT "all" ; ":" -> Vernacexpr.SelectAll ] ] - ; - tactic_mode: - [ [ g = OPT selector; tac = G_vernac.subgoal_command -> tac g ] ] - ; - END - -open Stdarg -open Constrarg -open Vernacexpr -open Vernac_classifier -open Goptions - -let print_info_trace = ref None - -let _ = declare_int_option { - optsync = true; - optdepr = false; - optname = "print info trace"; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} - -let vernac_solve n info tcom b = - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) in - if not status then Pp.feedback Feedback.AddedAxiom - -let pr_ltac_selector = function -| SelectNth i -> int i ++ str ":" -| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" -| SelectAll -> str "all" ++ str ":" - -VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector -| [ selector(s) ] -> [ s ] -END - -let pr_ltac_info n = str "Info" ++ spc () ++ int n - -VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info -| [ "Info" natural(n) ] -> [ n ] -END - -let pr_ltac_use_default b = if b then str ".." else mt () - -VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default -| [ "." ] -> [ false ] -| [ "..." ] -> [ true ] -END - -VERNAC tactic_mode EXTEND VernacSolve -| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ classify_as_proofstep ] -> [ - let g = Option.default (Proof_global.get_default_goal_selector ()) g in - vernac_solve g n t def - ] -| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ VtProofStep true, VtLater ] -> [ - vernac_solve SelectAll n t def - ] -END diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index eed6caea30..8df519b567 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -3,4 +3,3 @@ G_vernac G_prim G_proofs G_tactic -G_ltac -- cgit v1.2.3 From 0af598b77a6242d796c66884477a046448ef1e21 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 01:31:43 +0100 Subject: Moving Tactic Notation to an EXTEND based command. --- parsing/g_vernac.ml4 | 13 ------------- 1 file changed, 13 deletions(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index c89238d296..3b5d276dd2 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1048,10 +1048,6 @@ GEXTEND Gram | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> VernacNotationAddFormat (n,s,fmt) - | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; - pil = LIST1 production_item; ":="; t = Tactic.tactic - -> VernacTacticNotation (n,pil,t) - | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> Metasyntax.check_infix_modifiers l; @@ -1077,9 +1073,6 @@ GEXTEND Gram obsolete_locality: [ [ IDENT "Local" -> true | -> false ] ] ; - tactic_level: - [ [ "("; "at"; IDENT "level"; n = natural; ")" -> n | -> 0 ] ] - ; level: [ [ IDENT "level"; n = natural -> NumLevel n | IDENT "next"; IDENT "level" -> NextLevel ] ] @@ -1111,10 +1104,4 @@ GEXTEND Gram | IDENT "closed"; IDENT "binder" -> ETBinder false ] ] ; - production_item: - [ [ s = ne_string -> TacTerm s - | nt = IDENT; - po = [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; - ")" -> (p,sep) ] -> TacNonTerm (!@loc,nt,po) ] ] - ; END -- cgit v1.2.3 From 01cd0dd64e4faa52b5094a99e2c31ecc4e7b767d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 02:09:54 +0100 Subject: Moving Print Ltac to an EXTEND based command. --- parsing/g_vernac.ml4 | 1 - 1 file changed, 1 deletion(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 3b5d276dd2..0ad39d8047 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -890,7 +890,6 @@ GEXTEND Gram | IDENT "Classes" -> PrintClasses | IDENT "TypeClasses" -> PrintTypeClasses | IDENT "Instances"; qid = smart_global -> PrintInstances qid - | IDENT "Ltac"; qid = global -> PrintLtac qid | IDENT "Coercions" -> PrintCoercions | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr -> PrintCoercionPaths (s,t) -- cgit v1.2.3 From 4f52bd681ad9bbcbbd68406a58b47d8e962336ed Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 02:23:21 +0100 Subject: Moving the Ltac definition command to an EXTEND based command. --- parsing/g_vernac.ml4 | 6 +----- parsing/pcoq.ml | 3 --- parsing/pcoq.mli | 1 - 3 files changed, 1 insertion(+), 9 deletions(-) (limited to 'parsing') diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 0ad39d8047..8d7b6a2b48 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -751,11 +751,7 @@ GEXTEND Gram GLOBAL: command query_command class_rawexpr; command: - [ [ IDENT "Ltac"; - l = LIST1 tacdef_body SEP "with" -> - VernacDeclareTacticDefinition l - - | IDENT "Comments"; l = LIST0 comment -> VernacComments l + [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l (* Hack! Should be in grammar_ext, but camlp4 factorize badly *) | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 9c2f09db84..c7cb62d592 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -364,9 +364,6 @@ module Tactic = (* Main entry for quotations *) let tactic_eoi = eoi_entry tactic - (* For Ltac definition *) - let tacdef_body = Gram.entry_create "tactic:tacdef_body" - end module Vernac_ = diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 7410d4e44c..35973a4d72 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -229,7 +229,6 @@ module Tactic : val binder_tactic : raw_tactic_expr Gram.entry val tactic : raw_tactic_expr Gram.entry val tactic_eoi : raw_tactic_expr Gram.entry - val tacdef_body : Vernacexpr.tacdef_body Gram.entry end module Vernac_ : -- cgit v1.2.3 From dc7b77f09fe5e59e6e48486d9a8c0bdc6acf83b7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 16:59:15 +0100 Subject: Adding a new Ltac generic argument for forced tactics returing unit. --- parsing/pcoq.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index c7cb62d592..207b43064c 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -881,5 +881,6 @@ let () = (* Grammar.register0 wit_hyp_location_flag; *) Grammar.register0 wit_red_expr (Tactic.red_expr); Grammar.register0 wit_tactic (Tactic.tactic); + Grammar.register0 wit_ltac (Tactic.tactic); Grammar.register0 wit_clause_dft_concl (Tactic.clause_dft_concl); () -- cgit v1.2.3 From f5e85670b9c106fbde736654c32f4042c6a39d3f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Mar 2016 17:16:38 +0200 Subject: Moving the Tactic Notation entry parser from Pcoq to Tacentries. --- parsing/pcoq.ml | 110 ------------------------------------------------------- parsing/pcoq.mli | 8 +--- 2 files changed, 2 insertions(+), 116 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 207b43064c..75144addb2 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -57,16 +57,6 @@ type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a G.entry -> ty let object_of_typed_entry (TypedEntry (_, e)) = Gramobj.weaken_entry e let weaken_entry x = Gramobj.weaken_entry x -(** General entry keys *) - -(** This intermediate abstract representation of entries can - both be reified into mlexpr for the ML extensions and - dynamically interpreted as entries for the Coq level extensions -*) - -type entry_name = EntryName : - 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) symbol -> entry_name - (** Grammar extensions *) (** NB: [extend_statment = @@ -740,108 +730,8 @@ let grammar_extend e reinit ext = let ext = of_coq_extend_statement ext in unsafe_grammar_extend e reinit ext -(**********************************************************************) -(* Interpret entry names of the form "ne_constr_list" as entry keys *) - -let coincide s pat off = - let len = String.length pat in - let break = ref true in - let i = ref 0 in - while !break && !i < len do - let c = Char.code s.[off + !i] in - let d = Char.code pat.[!i] in - break := Int.equal c d; - incr i - done; - !break - let name_of_entry e = Entry.unsafe_of_name (Gram.Entry.name e) -let atactic n = - if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) - else Aentryl (name_of_entry Tactic.tactic_expr, n) - -let try_get_entry u s = - (** Order the effects: get_entry can raise Not_found *) - let TypedEntry (typ, e) = get_entry u s in - EntryName (typ, Aentry (name_of_entry e)) - -(** Quite ad-hoc *) -let get_tacentry n m = - let check_lvl n = - Int.equal m n - && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) - && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) - in - if check_lvl n then EntryName (rawwit wit_tactic, Aself) - else if check_lvl (n + 1) then EntryName (rawwit wit_tactic, Anext) - else EntryName (rawwit wit_tactic, atactic n) - -let rec parse_user_entry s sep = - let l = String.length s in - if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let entry = parse_user_entry (String.sub s 3 (l-8)) "" in - Ulist1 entry - else if l > 12 && coincide s "ne_" 0 && - coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 3 (l-12)) "" in - Ulist1sep (entry, sep) - else if l > 5 && coincide s "_list" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-5)) "" in - Ulist0 entry - else if l > 9 && coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 0 (l-9)) "" in - Ulist0sep (entry, sep) - else if l > 4 && coincide s "_opt" (l-4) then - let entry = parse_user_entry (String.sub s 0 (l-4)) "" in - Uopt entry - else if l > 5 && coincide s "_mods" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-1)) "" in - Umodifiers entry - else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then - let n = Char.code s.[6] - 48 in - Uentryl ("tactic", n) - else - let s = match s with "hyp" -> "var" | _ -> s in - Uentry s - -let arg_list = function Rawwit t -> Rawwit (ListArg t) -let arg_opt = function Rawwit t -> Rawwit (OptArg t) - -let rec interp_entry_name up_level s sep = - let rec eval = function - | Ulist1 e -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Alist1 g) - | Ulist1sep (e, sep) -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Alist1sep (g, sep)) - | Ulist0 e -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Alist0 g) - | Ulist0sep (e, sep) -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Alist0sep (g, sep)) - | Uopt e -> - let EntryName (t, g) = eval e in - EntryName (arg_opt t, Aopt g) - | Umodifiers e -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Amodifiers g) - | Uentry s -> - begin - try try_get_entry uprim s with Not_found -> - try try_get_entry uconstr s with Not_found -> - try try_get_entry utactic s with Not_found -> - error ("Unknown entry "^s^".") - end - | Uentryl (s, n) -> - (** FIXME: do better someday *) - assert (String.equal s "tactic"); - get_tacentry n up_level - in - eval (parse_user_entry s sep) - let list_entry_names () = let add_entry key (TypedEntry (entry, _)) accu = (key, unquote entry) :: accu in let ans = Hashtbl.fold add_entry (get_utable uprim) [] in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 35973a4d72..afe8889096 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -268,13 +268,9 @@ val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option (** Binding general entry keys to symbols *) -type entry_name = EntryName : - 'a raw_abstract_argument_type * (raw_tactic_expr, 'a) Extend.symbol -> entry_name +type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a Gram.entry -> typed_entry -(** [interp_entry_name lev n sep] returns the entry corresponding to the name - [n] of the form "ne_constr_list" in a tactic entry of level [lev] with - separator [sep]. *) -val interp_entry_name : int -> string -> string -> entry_name +val get_entry : gram_universe -> string -> typed_entry (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * argument_type) list -- cgit v1.2.3 From 63cef1ee8de62312df9afc2d515578df9c4cb9b1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Mar 2016 17:36:52 +0200 Subject: Abstracting away the Summary-synchronized grammar-modifying commands. We provide an API so that external code such as plugins can define grammar extensions synchronized with the summary. This API is not perfect yet and is a mere abstraction of the current behaviour. In particular, it expects the user to modify the parser in an imperative way. --- parsing/egramcoq.ml | 69 +++++++++++++++++++++++++++++++--------------------- parsing/egramcoq.mli | 14 +++++++++++ 2 files changed, 55 insertions(+), 28 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 8c4930806e..5e89567cc4 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -217,7 +217,7 @@ let extend_constr_pat_notation ng = let ext = ETConstr (level, ()), ng.notgram_assoc in extend_constr e ext (make_cases_pattern_action mkact) true ng.notgram_prods -let extend_constr_notation ng = +let extend_constr_notation (_, ng) = (* Add the notation in constr *) let nb = extend_constr_constr_notation ng in (* Add the notation in cases_pattern *) @@ -245,14 +245,24 @@ type tactic_grammar = { tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; } -type all_grammar_command = - | Notation of Notation.level * notation_grammar - | TacticGrammar of KerName.t * tactic_grammar - | MLTacticGrammar of ml_tactic_name * Tacexpr.raw_tactic_expr grammar_prod_item list list +module GrammarCommand = Dyn.Make(struct end) +module GrammarInterp = struct type 'a t = 'a -> int end +module GrammarInterpMap = GrammarCommand.Map(GrammarInterp) + +let grammar_interp = ref GrammarInterpMap.empty + +let (grammar_state : (int * GrammarCommand.t) list ref) = ref [] + +type 'a grammar_command = 'a GrammarCommand.tag + +let create_grammar_command name interp : _ grammar_command = + let obj = GrammarCommand.create name in + let () = grammar_interp := GrammarInterpMap.add obj interp !grammar_interp in + obj (** ML Tactic grammar extensions *) -let add_ml_tactic_entry name prods = +let add_ml_tactic_entry (name, prods) = let entry = Tactic.simple_tactic in let mkact i loc l : raw_tactic_expr = let open Tacexpr in @@ -273,7 +283,7 @@ let head_is_ident tg = match tg.tacgram_prods with (** Tactic grammar extensions *) -let add_tactic_entry kn tg = +let add_tactic_entry (kn, tg) = let entry, pos = get_tactic_entry tg.tacgram_level in let mkact loc l = let filter = function @@ -301,31 +311,34 @@ let add_tactic_entry kn tg = grammar_extend entry None (pos, [(None, None, List.rev [rules])]); 1 -let (grammar_state : (int * all_grammar_command) list ref) = ref [] +let extend_grammar tag g = + let nb = GrammarInterpMap.find tag !grammar_interp g in + grammar_state := (nb, GrammarCommand.Dyn (tag, g)) :: !grammar_state -let extend_grammar gram = - let nb = match gram with - | Notation (_,a) -> extend_constr_notation a - | TacticGrammar (kn, g) -> add_tactic_entry kn g - | MLTacticGrammar (name, pr) -> add_ml_tactic_entry name pr - in - grammar_state := (nb,gram) :: !grammar_state +let extend_dyn_grammar (GrammarCommand.Dyn (tag, g)) = extend_grammar tag g + +let constr_grammar : (Notation.level * notation_grammar) GrammarCommand.tag = + create_grammar_command "Notation" extend_constr_notation -let extend_constr_grammar pr ntn = - extend_grammar (Notation (pr, ntn)) +let tactic_grammar = + create_grammar_command "TacticGrammar" add_tactic_entry -let extend_tactic_grammar kn ntn = - extend_grammar (TacticGrammar (kn, ntn)) +let ml_tactic_grammar = + create_grammar_command "MLTacticGrammar" add_ml_tactic_entry -let extend_ml_tactic_grammar name ntn = - extend_grammar (MLTacticGrammar (name, ntn)) +let extend_constr_grammar pr ntn = extend_grammar constr_grammar (pr, ntn) +let extend_tactic_grammar kn ntn = extend_grammar tactic_grammar (kn, ntn) +let extend_ml_tactic_grammar n ntn = extend_grammar ml_tactic_grammar (n, ntn) let recover_constr_grammar ntn prec = - let filter = function - | _, Notation (prec', ng) when - Notation.level_eq prec prec' && - String.equal ntn ng.notgram_notation -> Some ng - | _ -> None + let filter (_, gram) : notation_grammar option = match gram with + | GrammarCommand.Dyn (tag, obj) -> + match GrammarCommand.eq tag constr_grammar with + | None -> None + | Some Refl -> + let (prec', ng) = obj in + if Notation.level_eq prec prec' && String.equal ntn ng.notgram_notation then Some ng + else None in match List.map_filter filter !grammar_state with | [x] -> x @@ -334,7 +347,7 @@ let recover_constr_grammar ntn prec = (* Summary functions: the state of the lexer is included in that of the parser. Because the grammar affects the set of keywords when adding or removing grammar rules. *) -type frozen_t = (int * all_grammar_command) list * Lexer.frozen_t +type frozen_t = (int * GrammarCommand.t) list * Lexer.frozen_t let freeze _ : frozen_t = (!grammar_state, Lexer.freeze ()) @@ -353,7 +366,7 @@ let unfreeze (grams, lex) = remove_levels n; grammar_state := common; Lexer.unfreeze lex; - List.iter extend_grammar (List.rev_map snd redo) + List.iter extend_dyn_grammar (List.rev_map snd redo) (** No need to provide an init function : the grammar state is statically available, and already empty initially, while diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 23eaa64eec..153f7528ff 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -41,6 +41,20 @@ type tactic_grammar = { tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; } +(** {5 Extending the parser with Summary-synchronized commands} *) + +type 'a grammar_command +(** Type of synchronized parsing extensions. The ['a] type should be + marshallable. *) + +val create_grammar_command : string -> ('a -> int) -> 'a grammar_command +(** Create a new grammar-modifying command with the given name. The function + should modify the parser state and return the number of grammar extensions + performed. *) + +val extend_grammar : 'a grammar_command -> 'a -> unit +(** Extend the grammar of Coq with the given data. *) + (** {5 Adding notations} *) val extend_constr_grammar : Notation.level -> notation_grammar -> unit -- cgit v1.2.3 From b5de86be330f6c878b8f12173d46a4c250fac755 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Mar 2016 18:42:07 +0200 Subject: Moving the code handling tactic notations to Tacentries. --- parsing/egramcoq.ml | 110 --------------------------------------------------- parsing/egramcoq.mli | 21 ---------- 2 files changed, 131 deletions(-) (limited to 'parsing') diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 5e89567cc4..f0c12ab8ef 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -224,27 +224,6 @@ let extend_constr_notation (_, ng) = let nb' = extend_constr_pat_notation ng in nb + nb' -(**********************************************************************) -(** Grammar declaration for Tactic Notation (Coq level) *) - -let get_tactic_entry n = - if Int.equal n 0 then - Tactic.simple_tactic, None - else if Int.equal n 5 then - Tactic.binder_tactic, None - else if 1<=n && n<5 then - Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) - else - error ("Invalid Tactic Notation level: "^(string_of_int n)^".") - -(**********************************************************************) -(** State of the grammar extensions *) - -type tactic_grammar = { - tacgram_level : int; - tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; -} - module GrammarCommand = Dyn.Make(struct end) module GrammarInterp = struct type 'a t = 'a -> int end module GrammarInterpMap = GrammarCommand.Map(GrammarInterp) @@ -260,57 +239,6 @@ let create_grammar_command name interp : _ grammar_command = let () = grammar_interp := GrammarInterpMap.add obj interp !grammar_interp in obj -(** ML Tactic grammar extensions *) - -let add_ml_tactic_entry (name, prods) = - let entry = Tactic.simple_tactic in - let mkact i loc l : raw_tactic_expr = - let open Tacexpr in - let entry = { mltac_name = name; mltac_index = i } in - let map arg = TacGeneric arg in - TacML (loc, entry, List.map map l) - in - let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in - synchronize_level_positions (); - grammar_extend entry None (None, [(None, None, List.rev rules)]); - 1 - -(* Declaration of the tactic grammar rule *) - -let head_is_ident tg = match tg.tacgram_prods with -| GramTerminal _::_ -> true -| _ -> false - -(** Tactic grammar extensions *) - -let add_tactic_entry (kn, tg) = - let entry, pos = get_tactic_entry tg.tacgram_level in - let mkact loc l = - let filter = function - | GramTerminal _ -> None - | GramNonTerminal (_, t, _) -> Some (Genarg.unquote t) - in - let types = List.map_filter filter tg.tacgram_prods in - let map arg t = - (** HACK to handle especially the tactic(...) entry *) - let wit = Genarg.rawwit Constrarg.wit_tactic in - if Genarg.argument_type_eq t (Genarg.unquote wit) then - Tacexp (Genarg.out_gen wit arg) - else - TacGeneric arg - in - let l = List.map2 map l types in - (TacAlias (loc,kn,l):raw_tactic_expr) - in - let () = - if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then - error "Notation for simple tactic must start with an identifier." - in - let rules = make_rule mkact tg.tacgram_prods in - synchronize_level_positions (); - grammar_extend entry None (pos, [(None, None, List.rev [rules])]); - 1 - let extend_grammar tag g = let nb = GrammarInterpMap.find tag !grammar_interp g in grammar_state := (nb, GrammarCommand.Dyn (tag, g)) :: !grammar_state @@ -320,15 +248,7 @@ let extend_dyn_grammar (GrammarCommand.Dyn (tag, g)) = extend_grammar tag g let constr_grammar : (Notation.level * notation_grammar) GrammarCommand.tag = create_grammar_command "Notation" extend_constr_notation -let tactic_grammar = - create_grammar_command "TacticGrammar" add_tactic_entry - -let ml_tactic_grammar = - create_grammar_command "MLTacticGrammar" add_ml_tactic_entry - let extend_constr_grammar pr ntn = extend_grammar constr_grammar (pr, ntn) -let extend_tactic_grammar kn ntn = extend_grammar tactic_grammar (kn, ntn) -let extend_ml_tactic_grammar n ntn = extend_grammar ml_tactic_grammar (n, ntn) let recover_constr_grammar ntn prec = let filter (_, gram) : notation_grammar option = match gram with @@ -386,33 +306,3 @@ let with_grammar_rule_protection f x = let reraise = Errors.push reraise in let () = unfreeze fs in iraise reraise - -(**********************************************************************) -(** Ltac quotations *) - -let ltac_quotations = ref String.Set.empty - -let create_ltac_quotation name cast (e, l) = - let () = - if String.Set.mem name !ltac_quotations then - failwith ("Ltac quotation " ^ name ^ " already registered") - in - let () = ltac_quotations := String.Set.add name !ltac_quotations in - let entry = match l with - | None -> Aentry (name_of_entry e) - | Some l -> Aentryl (name_of_entry e, l) - in -(* let level = Some "1" in *) - let level = None in - let assoc = None in - let rule = - Next (Next (Next (Next (Next (Stop, - Atoken (Lexer.terminal name)), - Atoken (Lexer.terminal ":")), - Atoken (Lexer.terminal "(")), - entry), - Atoken (Lexer.terminal ")")) - in - let action _ v _ _ _ loc = cast (loc, v) in - let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram]) diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 153f7528ff..6ec1066260 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -36,11 +36,6 @@ type notation_grammar = { notgram_typs : notation_var_internalization_type list; } -type tactic_grammar = { - tacgram_level : int; - tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; -} - (** {5 Extending the parser with Summary-synchronized commands} *) type 'a grammar_command @@ -60,24 +55,8 @@ val extend_grammar : 'a grammar_command -> 'a -> unit val extend_constr_grammar : Notation.level -> notation_grammar -> unit (** Add a term notation rule to the parsing system. *) -val extend_tactic_grammar : KerName.t -> tactic_grammar -> unit -(** Add a tactic notation rule to the parsing system. This produces a TacAlias - tactic with the provided kernel name. *) - -val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> Tacexpr.raw_tactic_expr grammar_prod_item list list -> unit -(** Add a ML tactic notation rule to the parsing system. This produces a - TacML tactic with the provided string as name. *) - val recover_constr_grammar : notation -> Notation.level -> notation_grammar (** For a declared grammar, returns the rule + the ordered entry types of variables in the rule (for use in the interpretation) *) val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b - -(** {5 Adding tactic quotations} *) - -val create_ltac_quotation : string -> - ('grm Loc.located -> Tacexpr.raw_tactic_arg) -> ('grm Gram.entry * int option) -> unit -(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, - Ltac grammar now accepts arguments of the form ["name" ":" "(" ")"], and - generates an argument using [f] on the entry parsed by [e]. *) -- cgit v1.2.3 From b3315a798edcaea533b592cc442e82260502bd49 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 1 Apr 2016 11:13:07 +0200 Subject: Getting rid of the "_mods" parsing entry. It was only used by setoid_ring for the Add Ring command, and was easily replaced by a dedicated argument. Moreover, it was of no use to tactic notations. --- parsing/pcoq.ml | 7 ------- 1 file changed, 7 deletions(-) (limited to 'parsing') diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 75144addb2..802c24eef4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -683,13 +683,6 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function | Alist0sep (s,sep) -> Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep) | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) - | Amodifiers s -> - Gram.srules' - [([], Gram.action (fun _loc -> [])); - ([gram_token_of_string "("; - Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ","); - gram_token_of_string ")"], - Gram.action (fun _ l _ _loc -> l))] | Aself -> Symbols.sself | Anext -> Symbols.snext | Aentry e -> -- cgit v1.2.3