From 7c62654a4a1c0711ebdd492193bb8b7bd0e4f1fb Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Sun, 20 May 2018 18:59:00 +0200 Subject: [api] Make `vernac/` self-contained. We make the vernacular implementation self-contained in the `vernac/` directory. To this extent we relocate the parser, printer, and AST to the `vernac/` directory, and move a couple of hint-related types to `Hints`, where they do indeed belong. IMO this makes the code easier to understand, and provides a better modularity of the codebase as now all things under `tactics` have 0 knowledge about vernaculars. The vernacular extension machinery has also been moved to `vernac/`, this will help when #6171 [proof state cleanup] is completed along with a stronger typing for vernacular interpretation that can distinguish different types of effects vernacular commands can perform. This PR introduces some very minor source-level incompatibilities due to a different module layering [thus deprecating is not possible]. Impact should be relatively minor. --- parsing/g_proofs.ml4 | 134 ------ parsing/g_vernac.ml4 | 1154 ------------------------------------------------- parsing/parsing.mllib | 3 - parsing/pcoq.ml | 41 -- parsing/pcoq.mli | 34 +- parsing/vernacexpr.ml | 530 ----------------------- 6 files changed, 10 insertions(+), 1886 deletions(-) delete mode 100644 parsing/g_proofs.ml4 delete mode 100644 parsing/g_vernac.ml4 delete mode 100644 parsing/vernacexpr.ml (limited to 'parsing') diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 deleted file mode 100644 index 4f3d83a8a..000000000 --- a/parsing/g_proofs.ml4 +++ /dev/null @@ -1,134 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* - Pp.strbrk - "The Focus command is deprecated; use bullets or focusing brackets instead" - ) - -let warn_deprecated_focus_n n = - CWarnings.create ~name:"deprecated-focus" ~category:"deprecated" - (fun () -> - Pp.(str "The Focus command is deprecated;" ++ spc () - ++ str "use '" ++ int n ++ str ": {' instead") - ) - -let warn_deprecated_unfocus = - CWarnings.create ~name:"deprecated-unfocus" ~category:"deprecated" - (fun () -> Pp.strbrk "The Unfocus command is deprecated") - -(* Proof commands *) -GEXTEND Gram - GLOBAL: hint command; - - opt_hintbases: - [ [ -> [] - | ":"; l = LIST1 [id = IDENT -> id ] -> l ] ] - ; - command: - [ [ IDENT "Goal"; c = lconstr -> - VernacDefinition (Decl_kinds.(NoDischarge, Definition), ((CAst.make ~loc:!@loc Names.Anonymous), None), ProveBody ([], c)) - | IDENT "Proof" -> VernacProof (None,None) - | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn - | IDENT "Proof"; c = lconstr -> VernacExactProof c - | IDENT "Abort" -> VernacAbort None - | IDENT "Abort"; IDENT "All" -> VernacAbortAll - | IDENT "Abort"; id = identref -> VernacAbort (Some id) - | IDENT "Existential"; n = natural; c = constr_body -> - VernacSolveExistential (n,c) - | IDENT "Admitted" -> VernacEndProof Admitted - | IDENT "Qed" -> VernacEndProof (Proved (Opaque,None)) - | IDENT "Save"; id = identref -> - VernacEndProof (Proved (Opaque, Some id)) - | IDENT "Defined" -> VernacEndProof (Proved (Transparent,None)) - | IDENT "Defined"; id=identref -> - VernacEndProof (Proved (Transparent,Some id)) - | IDENT "Restart" -> VernacRestart - | IDENT "Undo" -> VernacUndo 1 - | IDENT "Undo"; n = natural -> VernacUndo n - | IDENT "Undo"; IDENT "To"; n = natural -> VernacUndoTo n - | IDENT "Focus" -> - warn_deprecated_focus ~loc:!@loc (); - VernacFocus None - | IDENT "Focus"; n = natural -> - warn_deprecated_focus_n n ~loc:!@loc (); - VernacFocus (Some n) - | IDENT "Unfocus" -> - warn_deprecated_unfocus ~loc:!@loc (); - VernacUnfocus - | 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 "Script" -> VernacShow ShowScript - | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials - | IDENT "Show"; IDENT "Universes" -> VernacShow ShowUniverses - | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames - | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof - | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false) - | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true) - | IDENT "Show"; IDENT "Match"; id = reference -> VernacShow (ShowMatch id) - | IDENT "Guarded" -> VernacCheckGuard - (* Hints for Auto and EAuto *) - | IDENT "Create"; IDENT "HintDb" ; - id = IDENT ; b = [ "discriminated" -> true | -> false ] -> - VernacCreateHintDb (id, b) - | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> - VernacRemoveHints (dbnames, ids) - | IDENT "Hint"; h = hint; - dbnames = opt_hintbases -> - VernacHints (dbnames, h) - (* Declare "Resolve" explicitly so as to be able to later extend with - "Resolve ->" and "Resolve <-" *) - | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 reference_or_constr; - info = hint_info; dbnames = opt_hintbases -> - VernacHints (dbnames, - HintsResolve (List.map (fun x -> (info, true, x)) lc)) - ] ]; - reference_or_constr: - [ [ r = global -> HintsReference r - | c = constr -> HintsConstr c ] ] - ; - hint: - [ [ IDENT "Resolve"; lc = LIST1 reference_or_constr; info = hint_info -> - HintsResolve (List.map (fun x -> (info, true, x)) lc) - | IDENT "Immediate"; lc = LIST1 reference_or_constr -> HintsImmediate lc - | IDENT "Transparent"; lc = LIST1 global -> HintsTransparency (lc, true) - | IDENT "Opaque"; lc = LIST1 global -> HintsTransparency (lc, false) - | IDENT "Mode"; l = global; m = mode -> HintsMode (l, m) - | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid - | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc ] ] - ; - constr_body: - [ [ ":="; c = lconstr -> c - | ":"; t = lconstr; ":="; c = lconstr -> CAst.make ~loc:!@loc @@ CCast(c,CastConv t) ] ] - ; - mode: - [ [ l = LIST1 [ "+" -> ModeInput - | "!" -> ModeNoHeadEvar - | "-" -> ModeOutput ] -> l ] ] - ; -END diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 deleted file mode 100644 index a1c563f53..000000000 --- a/parsing/g_vernac.ml4 +++ /dev/null @@ -1,1154 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* ->"; ":<"; "<:"; "where"; "at" ] -let _ = List.iter CLexer.add_keyword vernac_kw - -(* Rem: do not join the different GEXTEND into one, it breaks native *) -(* compilation on PowerPC and Sun architectures *) - -let query_command = Gram.entry_create "vernac:query_command" - -let subprf = Gram.entry_create "vernac:subprf" - -let class_rawexpr = Gram.entry_create "vernac:class_rawexpr" -let thm_token = Gram.entry_create "vernac:thm_token" -let def_body = Gram.entry_create "vernac:def_body" -let decl_notation = Gram.entry_create "vernac:decl_notation" -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 instance_name = Gram.entry_create "vernac:instance_name" -let section_subset_expr = Gram.entry_create "vernac:section_subset_expr" - -let make_bullet s = - let open Proof_bullet in - let n = String.length s in - match s.[0] with - | '-' -> Dash n - | '+' -> Plus n - | '*' -> Star n - | _ -> assert false - -let parse_compat_version ?(allow_old = true) = let open Flags in function - | "8.8" -> Current - | "8.7" -> V8_7 - | "8.6" -> V8_6 - | ("8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> - CErrors.user_err ~hdr:"get_compat_version" - Pp.(str "Compatibility with version " ++ str s ++ str " not supported.") - | s -> - CErrors.user_err ~hdr:"get_compat_version" - Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".") - -GEXTEND Gram - GLOBAL: vernac_control gallina_ext noedit_mode subprf; - vernac_control: FIRST - [ [ IDENT "Time"; c = located_vernac -> VernacTime (false,c) - | IDENT "Redirect"; s = ne_string; c = located_vernac -> VernacRedirect (s, c) - | IDENT "Timeout"; n = natural; v = vernac_control -> VernacTimeout(n,v) - | IDENT "Fail"; v = vernac_control -> VernacFail v - | (f, v) = vernac -> VernacExpr(f, v) ] - ] - ; - vernac: - [ [ IDENT "Local"; (f, v) = vernac_poly -> (VernacLocal true :: f, v) - | IDENT "Global"; (f, v) = vernac_poly -> (VernacLocal false :: f, v) - - | v = vernac_poly -> v ] - ] - ; - vernac_poly: - [ [ IDENT "Polymorphic"; (f, v) = vernac_aux -> (VernacPolymorphic true :: f, v) - | IDENT "Monomorphic"; (f, v) = vernac_aux -> (VernacPolymorphic false :: f, v) - | v = vernac_aux -> v ] - ] - ; - vernac_aux: - (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *) - (* "." is still in the stream and discard_to_dot works correctly *) - [ [ IDENT "Program"; g = gallina; "." -> ([VernacProgram], g) - | IDENT "Program"; g = gallina_ext; "." -> ([VernacProgram], g) - | g = gallina; "." -> ([], g) - | g = gallina_ext; "." -> ([], g) - | c = command; "." -> ([], c) - | c = syntax; "." -> ([], c) - | c = subprf -> ([], c) - ] ] - ; - vernac_aux: LAST - [ [ prfcom = command_entry -> ([], prfcom) ] ] - ; - noedit_mode: - [ [ c = query_command -> c None] ] - ; - - subprf: - [ [ s = BULLET -> VernacBullet (make_bullet s) - | "{" -> VernacSubproof None - | "}" -> VernacEndSubproof - ] ] - ; - - located_vernac: - [ [ v = vernac_control -> CAst.make ~loc:!@loc v ] ] - ; -END - -let warn_plural_command = - CWarnings.create ~name:"plural-command" ~category:"pedantic" ~default:CWarnings.Disabled - (fun kwd -> strbrk (Printf.sprintf "Command \"%s\" expects more than one assumption." kwd)) - -let test_plural_form loc kwd = function - | [(_,([_],_))] -> - warn_plural_command ~loc:!@loc kwd - | _ -> () - -let test_plural_form_types loc kwd = function - | [([_],_)] -> - warn_plural_command ~loc:!@loc kwd - | _ -> () - -let lname_of_lident : lident -> lname = - CAst.map (fun s -> Name s) - -let name_of_ident_decl : ident_decl -> name_decl = - on_fst lname_of_lident - -(* Gallina declarations *) -GEXTEND Gram - GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - record_field decl_notation rec_definition ident_decl univ_decl; - - gallina: - (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = ident_decl; bl = binders; ":"; c = lconstr; - l = LIST0 - [ "with"; id = ident_decl; bl = binders; ":"; c = lconstr -> - (id,(bl,c)) ] -> - VernacStartTheoremProof (thm, (id,(bl,c))::l) - | stre = assumption_token; nl = inline; bl = assum_list -> - VernacAssumption (stre, nl, bl) - | (kwd,stre) = assumptions_token; nl = inline; bl = assum_list -> - test_plural_form loc kwd bl; - VernacAssumption (stre, nl, bl) - | d = def_token; id = ident_decl; b = def_body -> - VernacDefinition (d, name_of_ident_decl id, b) - | IDENT "Let"; id = identref; b = def_body -> - VernacDefinition ((DoDischarge, Let), (lname_of_lident id, None), b) - (* Gallina inductive declarations *) - | cum = OPT cumulativity_token; priv = private_token; f = finite_token; - indl = LIST1 inductive_definition SEP "with" -> - let (k,f) = f in - let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in - VernacInductive (cum, priv,f,indl) - | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (NoDischarge, recs) - | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (DoDischarge, recs) - | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint (NoDischarge, corecs) - | IDENT "Let"; "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint (DoDischarge, corecs) - | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l - | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; - l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) - | IDENT "Register"; IDENT "Inline"; id = identref -> - VernacRegister(id, RegisterInline) - | IDENT "Universe"; l = LIST1 identref -> VernacUniverse l - | IDENT "Universes"; l = LIST1 identref -> VernacUniverse l - | IDENT "Constraint"; l = LIST1 univ_constraint SEP "," -> VernacConstraint l - ] ] - ; - - thm_token: - [ [ "Theorem" -> Theorem - | IDENT "Lemma" -> Lemma - | IDENT "Fact" -> Fact - | IDENT "Remark" -> Remark - | IDENT "Corollary" -> Corollary - | IDENT "Proposition" -> Proposition - | IDENT "Property" -> Property ] ] - ; - def_token: - [ [ "Definition" -> (NoDischarge,Definition) - | IDENT "Example" -> (NoDischarge,Example) - | IDENT "SubClass" -> (NoDischarge,SubClass) ] ] - ; - assumption_token: - [ [ "Hypothesis" -> (DoDischarge, Logical) - | "Variable" -> (DoDischarge, Definitional) - | "Axiom" -> (NoDischarge, Logical) - | "Parameter" -> (NoDischarge, Definitional) - | IDENT "Conjecture" -> (NoDischarge, Conjectural) ] ] - ; - assumptions_token: - [ [ IDENT "Hypotheses" -> ("Hypotheses", (DoDischarge, Logical)) - | IDENT "Variables" -> ("Variables", (DoDischarge, Definitional)) - | IDENT "Axioms" -> ("Axioms", (NoDischarge, Logical)) - | IDENT "Parameters" -> ("Parameters", (NoDischarge, Definitional)) - | IDENT "Conjectures" -> ("Conjectures", (NoDischarge, Conjectural)) ] ] - ; - inline: - [ [ IDENT "Inline"; "("; i = INT; ")" -> InlineAt (int_of_string i) - | IDENT "Inline" -> DefaultInline - | -> NoInline] ] - ; - univ_constraint: - [ [ l = universe_level; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; - r = universe_level -> (l, ord, r) ] ] - ; - univ_decl : - [ [ "@{" ; l = LIST0 identref; ext = [ "+" -> true | -> false ]; - cs = [ "|"; l' = LIST0 univ_constraint SEP ","; - ext = [ "+" -> true | -> false ]; "}" -> (l',ext) - | ext = [ "}" -> true | "|}" -> false ] -> ([], ext) ] - -> - { univdecl_instance = l; - univdecl_extensible_instance = ext; - univdecl_constraints = fst cs; - univdecl_extensible_constraints = snd cs } - ] ] - ; - ident_decl: - [ [ i = identref; l = OPT univ_decl -> (i, l) - ] ] - ; - finite_token: - [ [ IDENT "Inductive" -> (Inductive_kw,Finite) - | IDENT "CoInductive" -> (CoInductive,CoFinite) - | IDENT "Variant" -> (Variant,BiFinite) - | IDENT "Record" -> (Record,BiFinite) - | IDENT "Structure" -> (Structure,BiFinite) - | IDENT "Class" -> (Class true,BiFinite) ] ] - ; - cumulativity_token: - [ [ IDENT "Cumulative" -> VernacCumulative - | IDENT "NonCumulative" -> VernacNonCumulative ] ] - ; - private_token: - [ [ IDENT "Private" -> true | -> false ] ] - ; - (* Simple definitions *) - def_body: - [ [ bl = binders; ":="; red = reduce; c = lconstr -> - if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = mkCLambdaN ~loc:!@loc bl c in - DefineBody ([], red, c, None) - else - (match c with - | { CAst.v = CCast(c, CastConv t) } -> DefineBody (bl, red, c, Some t) - | _ -> DefineBody (bl, red, c, None)) - | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> - let ((bl, c), tyo) = - if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = CAst.make ~loc:!@loc @@ CCast (c, CastConv t) in - (([],mkCLambdaN ~loc:!@loc bl c), None) - else ((bl, c), Some t) - in - DefineBody (bl, red, c, tyo) - | bl = binders; ":"; t = lconstr -> - ProveBody (bl, t) ] ] - ; - reduce: - [ [ IDENT "Eval"; r = red_expr; "in" -> Some r - | -> None ] ] - ; - one_decl_notation: - [ [ ntn = ne_lstring; ":="; c = constr; - scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] - ; - decl_notation: - [ [ "where"; l = LIST1 one_decl_notation SEP IDENT "and" -> l - | -> [] ] ] - ; - (* Inductives and records *) - opt_constructors_or_fields: - [ [ ":="; lc = constructor_list_or_record_decl -> lc - | -> RecordDecl (None, []) ] ] - ; - inductive_definition: - [ [ oc = opt_coercion; id = ident_decl; indpar = binders; - c = OPT [ ":"; c = lconstr -> c ]; - lc=opt_constructors_or_fields; ntn = decl_notation -> - (((oc,id),indpar,c,lc),ntn) ] ] - ; - constructor_list_or_record_decl: - [ [ "|"; l = LIST1 constructor SEP "|" -> Constructors l - | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> - Constructors ((c id)::l) - | id = identref ; c = constructor_type -> Constructors [ c id ] - | cstr = identref; "{"; fs = record_fields; "}" -> - RecordDecl (Some cstr,fs) - | "{";fs = record_fields; "}" -> RecordDecl (None,fs) - | -> Constructors [] ] ] - ; -(* - csort: - [ [ s = sort -> CSort (loc,s) ] ] - ; -*) - opt_coercion: - [ [ ">" -> true - | -> false ] ] - ; - (* (co)-fixpoints *) - rec_definition: - [ [ id = ident_decl; - 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 = ident_decl; bl = binders; ty = type_cstr; - def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> - ((id,bl,ty,def),ntn) ] ] - ; - type_cstr: - [ [ ":"; c=lconstr -> c - | -> CAst.make ~loc:!@loc @@ CHole (None, Misctypes.IntroAnonymous, None) ] ] - ; - (* Inductive schemes *) - scheme: - [ [ kind = scheme_kind -> (None,kind) - | id = identref; ":="; kind = scheme_kind -> (Some id,kind) ] ] - ; - scheme_kind: - [ [ IDENT "Induction"; "for"; ind = smart_global; - IDENT "Sort"; s = sort_family-> InductionScheme(true,ind,s) - | IDENT "Minimality"; "for"; ind = smart_global; - IDENT "Sort"; s = sort_family-> InductionScheme(false,ind,s) - | IDENT "Elimination"; "for"; ind = smart_global; - IDENT "Sort"; s = sort_family-> CaseScheme(true,ind,s) - | IDENT "Case"; "for"; ind = smart_global; - IDENT "Sort"; s = sort_family-> CaseScheme(false,ind,s) - | IDENT "Equality"; "for" ; ind = smart_global -> EqualityScheme(ind) ] ] - ; - (* Various Binders *) -(* - (* ... without coercions *) - binder_nodef: - [ [ b = binder_let -> - (match b with - CLocalAssum(l,ty) -> (l,ty) - | CLocalDef _ -> - Util.user_err_loc - (loc,"fix_param",Pp.str"defined binder not allowed here.")) ] ] - ; -*) - (* ... with coercions *) - record_field: - [ [ 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:!@loc l t)) - | l = binders; oc = of_type_with_opt_coercion; - t = lconstr; ":="; b = lconstr -> fun id -> - (oc,DefExpr (id,mkCLambdaN ~loc:!@loc l b,Some (mkCProdN ~loc:!@loc l t))) - | l = binders; ":="; b = lconstr -> fun id -> - match b.CAst.v with - | CCast(b', (CastConv t|CastVM t|CastNative t)) -> - (None,DefExpr(id,mkCLambdaN ~loc:!@loc l b',Some (mkCProdN ~loc:!@loc l t))) - | _ -> - (None,DefExpr(id,mkCLambdaN ~loc:!@loc l b,None)) ] ] - ; - record_binder: - [ [ id = name -> (None,AssumExpr(id, CAst.make ~loc:!@loc @@ CHole (None, Misctypes.IntroAnonymous, None))) - | id = name; f = record_binder_body -> f id ] ] - ; - assum_list: - [ [ bl = LIST1 assum_coe -> bl | b = simple_assum_coe -> [b] ] ] - ; - assum_coe: - [ [ "("; a = simple_assum_coe; ")" -> a ] ] - ; - simple_assum_coe: - [ [ idl = LIST1 ident_decl; oc = of_type_with_opt_coercion; c = lconstr -> - (not (Option.is_empty oc),(idl,c)) ] ] - ; - - constructor_type: - [[ l = binders; - t= [ coe = of_type_with_opt_coercion; c = lconstr -> - fun l id -> (not (Option.is_empty coe),(id,mkCProdN ~loc:!@loc l c)) - | -> - fun l id -> (false,(id,mkCProdN ~loc:!@loc l (CAst.make ~loc:!@loc @@ CHole (None, Misctypes.IntroAnonymous, None)))) ] - -> t l - ]] -; - - constructor: - [ [ id = identref; c=constructor_type -> c id ] ] - ; - of_type_with_opt_coercion: - [ [ ":>>" -> Some false - | ":>"; ">" -> Some false - | ":>" -> Some true - | ":"; ">"; ">" -> Some false - | ":"; ">" -> Some true - | ":" -> None ] ] - ; -END - -let only_starredidentrefs = - Gram.Entry.of_parser "test_only_starredidentrefs" - (fun strm -> - let rec aux n = - match Util.stream_nth n strm with - | KEYWORD "." -> () - | KEYWORD ")" -> () - | (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 - -let warn_deprecated_include_type = - CWarnings.create ~name:"deprecated-include-type" ~category:"deprecated" - (fun () -> strbrk "Include Type is deprecated; use Include instead") - -(* Modules and Sections *) -GEXTEND Gram - GLOBAL: gallina_ext module_expr module_type section_subset_expr; - - gallina_ext: - [ [ (* Interactive module declaration *) - IDENT "Module"; export = export_token; id = identref; - bl = LIST0 module_binder; sign = of_module_type; - body = is_module_expr -> - VernacDefineModule (export, id, bl, sign, body) - | IDENT "Module"; "Type"; id = identref; - bl = LIST0 module_binder; sign = check_module_types; - body = is_module_type -> - VernacDeclareModuleType (id, bl, sign, body) - | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref; - bl = LIST0 module_binder; ":"; mty = module_type_inl -> - VernacDeclareModule (export, id, bl, mty) - (* Section beginning *) - | IDENT "Section"; id = identref -> VernacBeginSection id - | IDENT "Chapter"; id = identref -> VernacBeginSection id - - (* This end a Section a Module or a Module Type *) - | IDENT "End"; id = identref -> VernacEndSegment id - - (* Naming a set of section hyps *) - | IDENT "Collection"; id = identref; ":="; expr = section_subset_expr -> - VernacNameSectionHypSet (id, expr) - - (* Requiring an already compiled module *) - | IDENT "Require"; export = export_token; qidl = LIST1 global -> - VernacRequire (None, export, qidl) - | IDENT "From" ; ns = global ; IDENT "Require"; export = export_token - ; qidl = LIST1 global -> - VernacRequire (Some ns, export, qidl) - | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) - | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) - | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr -> - VernacInclude(e::l) - | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type -> - warn_deprecated_include_type ~loc:!@loc (); - VernacInclude(e::l) ] ] - ; - export_token: - [ [ IDENT "Import" -> Some false - | IDENT "Export" -> Some true - | -> None ] ] - ; - ext_module_type: - [ [ "<+"; mty = module_type_inl -> mty ] ] - ; - ext_module_expr: - [ [ "<+"; mexpr = module_expr_inl -> mexpr ] ] - ; - check_module_type: - [ [ "<:"; mty = module_type_inl -> mty ] ] - ; - check_module_types: - [ [ mtys = LIST0 check_module_type -> mtys ] ] - ; - of_module_type: - [ [ ":"; mty = module_type_inl -> Enforce mty - | mtys = check_module_types -> Check mtys ] ] - ; - is_module_type: - [ [ ":="; mty = module_type_inl ; l = LIST0 ext_module_type -> (mty::l) - | -> [] ] ] - ; - is_module_expr: - [ [ ":="; mexpr = module_expr_inl; l = LIST0 ext_module_expr -> (mexpr::l) - | -> [] ] ] - ; - functor_app_annot: - [ [ "["; IDENT "inline"; "at"; IDENT "level"; i = INT; "]" -> - InlineAt (int_of_string i) - | "["; IDENT "no"; IDENT "inline"; "]" -> NoInline - | -> DefaultInline - ] ] - ; - module_expr_inl: - [ [ "!"; me = module_expr -> (me,NoInline) - | me = module_expr; a = functor_app_annot -> (me,a) ] ] - ; - module_type_inl: - [ [ "!"; me = module_type -> (me,NoInline) - | me = module_type; a = functor_app_annot -> (me,a) ] ] - ; - (* Module binder *) - module_binder: - [ [ "("; export = export_token; idl = LIST1 identref; ":"; - mty = module_type_inl; ")" -> (export,idl,mty) ] ] - ; - (* Module expressions *) - module_expr: - [ [ me = module_expr_atom -> me - | me1 = module_expr; me2 = module_expr_atom -> CAst.make ~loc:!@loc @@ CMapply (me1,me2) - ] ] - ; - module_expr_atom: - [ [ qid = qualid -> CAst.make ~loc:!@loc @@ CMident (qid.CAst.v) | "("; me = module_expr; ")" -> me ] ] - ; - with_declaration: - [ [ "Definition"; fqid = fullyqualid; udecl = OPT univ_decl; ":="; c = Constr.lconstr -> - CWith_Definition (fqid,udecl,c) - | IDENT "Module"; fqid = fullyqualid; ":="; qid = qualid -> - CWith_Module (fqid,qid) - ] ] - ; - module_type: - [ [ qid = qualid -> CAst.make ~loc:!@loc @@ CMident (qid.CAst.v) - | "("; mt = module_type; ")" -> mt - | mty = module_type; me = module_expr_atom -> - CAst.make ~loc:!@loc @@ CMapply (mty,me) - | mty = module_type; "with"; decl = with_declaration -> - CAst.make ~loc:!@loc @@ CMwith (mty,decl) - ] ] - ; - (* 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" -> SsType - | "Type"; "*" -> SsFwdClose SsType ]] - ; - ssexpr: - [ "35" - [ "-"; e = ssexpr -> SsCompl e ] - | "50" - [ e1 = ssexpr; "-"; e2 = ssexpr->SsSubstr(e1,e2) - | e1 = ssexpr; "+"; e2 = ssexpr->SsUnion(e1,e2)] - | "0" - [ 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 - -(* Extensions: implicits, coercions, etc. *) -GEXTEND Gram - GLOBAL: gallina_ext instance_name hint_info; - - gallina_ext: - [ [ (* Transparent and Opaque *) - IDENT "Transparent"; l = LIST1 smart_global -> - VernacSetOpacity (Conv_oracle.transparent, l) - | IDENT "Opaque"; l = LIST1 smart_global -> - VernacSetOpacity (Conv_oracle.Opaque, l) - | IDENT "Strategy"; l = - LIST1 [ v=strategy_level; "["; q=LIST1 smart_global; "]" -> (v,q)] -> - VernacSetStrategy l - (* Canonical structure *) - | IDENT "Canonical"; IDENT "Structure"; qid = global -> - VernacCanonical CAst.(make ~loc:!@loc @@ AN qid) - | IDENT "Canonical"; IDENT "Structure"; ntn = by_notation -> - VernacCanonical CAst.(make ~loc:!@loc @@ ByNotation ntn) - | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> - let s = coerce_reference_to_id qid in - VernacDefinition ((NoDischarge,CanonicalStructure),((CAst.make (Name s)),None),d) - - (* Coercions *) - | IDENT "Coercion"; qid = global; d = def_body -> - let s = coerce_reference_to_id qid in - VernacDefinition ((NoDischarge,Coercion),((CAst.make (Name s)),None),d) - | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (f, s, t) - | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; - t = class_rawexpr -> - VernacCoercion (CAst.make ~loc:!@loc @@ AN qid, s, t) - | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; - t = class_rawexpr -> - VernacCoercion (CAst.make ~loc:!@loc @@ ByNotation ntn, s, t) - - | IDENT "Context"; c = binders -> - VernacContext c - - | IDENT "Instance"; namesup = instance_name; ":"; - expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200"; - info = hint_info ; - props = [ ":="; "{"; r = record_declaration; "}" -> Some (true,r) | - ":="; c = lconstr -> Some (false,c) | -> None ] -> - VernacInstance (false,snd namesup,(fst namesup,expl,t),props,info) - - | IDENT "Existing"; IDENT "Instance"; id = global; - info = hint_info -> - VernacDeclareInstances [id, info] - - | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global; - pri = OPT [ "|"; i = natural -> i ] -> - let info = { Typeclasses.hint_priority = pri; hint_pattern = None } in - let insts = List.map (fun i -> (i, info)) ids in - VernacDeclareInstances insts - - | IDENT "Existing"; IDENT "Class"; is = global -> VernacDeclareClass is - - (* Arguments *) - | IDENT "Arguments"; qid = smart_global; - args = LIST0 argument_spec_block; - more_implicits = OPT - [ ","; impl = LIST1 - [ impl = LIST0 more_implicits_block -> List.flatten impl] - SEP "," -> impl - ]; - mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> l ] -> - let mods = match mods with None -> [] | Some l -> List.flatten l in - let slash_position = ref None in - let rec parse_args i = function - | [] -> [] - | `Id x :: args -> x :: parse_args (i+1) args - | `Slash :: args -> - if Option.is_empty !slash_position then - (slash_position := Some i; parse_args i args) - else - user_err Pp.(str "The \"/\" modifier can occur only once") - in - let args = parse_args 0 (List.flatten args) in - let more_implicits = Option.default [] more_implicits in - VernacArguments (qid, args, more_implicits, !slash_position, mods) - - | IDENT "Implicit"; "Type"; bl = reserv_list -> - VernacReserve bl - - | IDENT "Implicit"; IDENT "Types"; bl = reserv_list -> - test_plural_form_types loc "Implicit Types" bl; - VernacReserve bl - - | IDENT "Generalizable"; - gen = [IDENT "All"; IDENT "Variables" -> Some [] - | IDENT "No"; IDENT "Variables" -> None - | ["Variable" | IDENT "Variables"]; - idl = LIST1 identref -> Some idl ] -> - VernacGeneralizable gen ] ] - ; - arguments_modifier: - [ [ IDENT "simpl"; IDENT "nomatch" -> [`ReductionDontExposeCase] - | IDENT "simpl"; IDENT "never" -> [`ReductionNeverUnfold] - | IDENT "default"; IDENT "implicits" -> [`DefaultImplicits] - | IDENT "clear"; IDENT "implicits" -> [`ClearImplicits] - | IDENT "clear"; IDENT "scopes" -> [`ClearScopes] - | IDENT "rename" -> [`Rename] - | IDENT "assert" -> [`Assert] - | IDENT "extra"; IDENT "scopes" -> [`ExtraScopes] - | IDENT "clear"; IDENT "scopes"; IDENT "and"; IDENT "implicits" -> - [`ClearImplicits; `ClearScopes] - | IDENT "clear"; IDENT "implicits"; IDENT "and"; IDENT "scopes" -> - [`ClearImplicits; `ClearScopes] - ] ] - ; - scope: - [ [ "%"; key = IDENT -> key ] ] - ; - argument_spec: [ - [ b = OPT "!"; id = name ; s = OPT scope -> - id.CAst.v, not (Option.is_empty b), Option.map (fun x -> CAst.make ~loc:!@loc x) s - ] - ]; - (* List of arguments implicit status, scope, modifiers *) - argument_spec_block: [ - [ item = argument_spec -> - let name, recarg_like, notation_scope = item in - [`Id { name=name; recarg_like=recarg_like; - notation_scope=notation_scope; - implicit_status = NotImplicit}] - | "/" -> [`Slash] - | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> - let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc:!@loc y) x - | Some _, Some _ -> user_err Pp.(str "scope declared twice") in - List.map (fun (name,recarg_like,notation_scope) -> - `Id { name=name; recarg_like=recarg_like; - notation_scope=f notation_scope; - implicit_status = NotImplicit}) items - | "["; items = LIST1 argument_spec; "]"; sc = OPT scope -> - let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc:!@loc y) x - | Some _, Some _ -> user_err Pp.(str "scope declared twice") in - List.map (fun (name,recarg_like,notation_scope) -> - `Id { name=name; recarg_like=recarg_like; - notation_scope=f notation_scope; - implicit_status = Implicit}) items - | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope -> - let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc:!@loc y) x - | Some _, Some _ -> user_err Pp.(str "scope declared twice") in - List.map (fun (name,recarg_like,notation_scope) -> - `Id { name=name; recarg_like=recarg_like; - notation_scope=f notation_scope; - implicit_status = MaximallyImplicit}) items - ] - ]; - (* Same as [argument_spec_block], but with only implicit status and names *) - more_implicits_block: [ - [ name = name -> [(name.CAst.v, Vernacexpr.NotImplicit)] - | "["; items = LIST1 name; "]" -> - List.map (fun name -> (name.CAst.v, Vernacexpr.Implicit)) items - | "{"; items = LIST1 name; "}" -> - List.map (fun name -> (name.CAst.v, Vernacexpr.MaximallyImplicit)) items - ] - ]; - strategy_level: - [ [ IDENT "expand" -> Conv_oracle.Expand - | IDENT "opaque" -> Conv_oracle.Opaque - | n=INT -> Conv_oracle.Level (int_of_string n) - | "-"; n=INT -> Conv_oracle.Level (- int_of_string n) - | IDENT "transparent" -> Conv_oracle.transparent ] ] - ; - instance_name: - [ [ name = ident_decl; sup = OPT binders -> - (CAst.map (fun id -> Name id) (fst name), snd name), - (Option.default [] sup) - | -> ((CAst.make ~loc:!@loc Anonymous), None), [] ] ] - ; - hint_info: - [ [ "|"; i = OPT natural; pat = OPT constr_pattern -> - { Typeclasses.hint_priority = i; hint_pattern = pat } - | -> { Typeclasses.hint_priority = None; hint_pattern = None } ] ] - ; - reserv_list: - [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ] - ; - reserv_tuple: - [ [ "("; a = simple_reserv; ")" -> a ] ] - ; - simple_reserv: - [ [ idl = LIST1 identref; ":"; c = lconstr -> (idl,c) ] ] - ; - -END - -GEXTEND Gram - GLOBAL: command query_command class_rawexpr gallina_ext; - - gallina_ext: - [ [ IDENT "Export"; "Set"; table = option_table; v = option_value -> - VernacSetOption (true, table, v) - | IDENT "Export"; IDENT "Unset"; table = option_table -> - VernacUnsetOption (true, table) - ] ]; - - command: - [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l - - (* Hack! Should be in grammar_ext, but camlp5 factorizes badly *) - | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; - expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200"; - info = hint_info -> - VernacInstance (true, snd namesup, (fst namesup, expl, t), None, info) - - (* System directory *) - | IDENT "Pwd" -> VernacChdir None - | IDENT "Cd" -> VernacChdir None - | IDENT "Cd"; dir = ne_string -> VernacChdir (Some dir) - - | IDENT "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ]; - s = [ s = ne_string -> s | s = IDENT -> s ] -> - VernacLoad (verbosely, s) - | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string -> - VernacDeclareMLModule l - - | IDENT "Locate"; l = locatable -> VernacLocate l - - (* Managing load paths *) - | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> - VernacAddLoadPath (false, dir, alias) - | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; - alias = as_dirpath -> VernacAddLoadPath (true, dir, alias) - | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string -> - VernacRemoveLoadPath dir - - (* For compatibility *) - | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath -> - VernacAddLoadPath (false, dir, alias) - | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath -> - VernacAddLoadPath (true, dir, alias) - | IDENT "DelPath"; dir = ne_string -> - VernacRemoveLoadPath dir - - (* Type-Checking (pas dans le refman) *) - | "Type"; c = lconstr -> VernacGlobalCheck c - - (* Printing (careful factorization of entries) *) - | IDENT "Print"; p = printable -> VernacPrint p - | IDENT "Print"; qid = smart_global; l = OPT univ_name_list -> VernacPrint (PrintName (qid,l)) - | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> - VernacPrint (PrintModuleType qid) - | IDENT "Print"; IDENT "Module"; qid = global -> - VernacPrint (PrintModule qid) - | IDENT "Print"; IDENT "Namespace" ; ns = dirpath -> - VernacPrint (PrintNamespace ns) - | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) - - | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string -> - VernacAddMLPath (false, dir) - | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string -> - VernacAddMLPath (true, dir) - - (* For acting on parameter tables *) - | "Set"; table = option_table; v = option_value -> - VernacSetOption (false, table, v) - | IDENT "Unset"; table = option_table -> - VernacUnsetOption (false, table) - - | IDENT "Print"; IDENT "Table"; table = option_table -> - VernacPrintOption table - - | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value - -> VernacAddOption ([table;field], v) - (* A global value below will be hidden by a field above! *) - (* In fact, we give priority to secondary tables *) - (* No syntax for tertiary tables due to conflict *) - (* (but they are unused anyway) *) - | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> - VernacAddOption ([table], v) - - | IDENT "Test"; table = option_table; "for"; v = LIST1 option_ref_value - -> VernacMemOption (table, v) - | IDENT "Test"; table = option_table -> - VernacPrintOption table - - | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value - -> VernacRemoveOption ([table;field], v) - | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> - VernacRemoveOption ([table], v) ]] - ; - query_command: (* TODO: rapprocher Eval et Check *) - [ [ IDENT "Eval"; r = red_expr; "in"; c = lconstr; "." -> - fun g -> VernacCheckMayEval (Some r, g, c) - | IDENT "Compute"; c = lconstr; "." -> - fun g -> VernacCheckMayEval (Some (Genredexpr.CbvVm None), g, c) - | IDENT "Check"; c = lconstr; "." -> - fun g -> VernacCheckMayEval (None, g, c) - (* Searching the environment *) - | IDENT "About"; qid = smart_global; l = OPT univ_name_list; "." -> - fun g -> VernacPrint (PrintAbout (qid,l,g)) - | IDENT "SearchHead"; c = constr_pattern; l = in_or_out_modules; "." -> - fun g -> VernacSearch (SearchHead c,g, l) - | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules; "." -> - fun g -> VernacSearch (SearchPattern c,g, l) - | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules; "." -> - fun g -> VernacSearch (SearchRewrite c,g, l) - | IDENT "Search"; s = searchabout_query; l = searchabout_queries; "." -> - let (sl,m) = l in fun g -> VernacSearch (SearchAbout (s::sl),g, m) - (* compatibility: SearchAbout *) - | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries; "." -> - fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m) - (* compatibility: SearchAbout with "[ ... ]" *) - | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]"; - l = in_or_out_modules; "." -> - fun g -> VernacSearch (SearchAbout sl,g, l) - ] ] - ; - printable: - [ [ IDENT "Term"; qid = smart_global; l = OPT univ_name_list -> PrintName (qid,l) - | IDENT "All" -> PrintFullContext - | IDENT "Section"; s = global -> PrintSectionContext s - | IDENT "Grammar"; ent = IDENT -> - (* This should be in "syntax" section but is here for factorization*) - PrintGrammar ent - | IDENT "LoadPath"; dir = OPT dirpath -> PrintLoadPath dir - | IDENT "Modules" -> - user_err Pp.(str "Print Modules is obsolete; use Print Libraries instead") - | IDENT "Libraries" -> PrintModules - - | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath - | IDENT "ML"; IDENT "Modules" -> PrintMLModules - | IDENT "Debug"; IDENT "GC" -> PrintDebugGC - | IDENT "Graph" -> PrintGraph - | IDENT "Classes" -> PrintClasses - | IDENT "TypeClasses" -> PrintTypeClasses - | IDENT "Instances"; qid = smart_global -> PrintInstances qid - | IDENT "Coercions" -> PrintCoercions - | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr - -> PrintCoercionPaths (s,t) - | IDENT "Canonical"; IDENT "Projections" -> PrintCanonicalConversions - | IDENT "Tables" -> PrintTables - | IDENT "Options" -> PrintTables (* A Synonymous to Tables *) - | IDENT "Hint" -> PrintHintGoal - | IDENT "Hint"; qid = smart_global -> PrintHint qid - | IDENT "Hint"; "*" -> PrintHintDb - | IDENT "HintDb"; s = IDENT -> PrintHintDbName s - | IDENT "Scopes" -> PrintScopes - | IDENT "Scope"; s = IDENT -> PrintScope s - | IDENT "Visibility"; s = OPT [x = IDENT -> x ] -> PrintVisibility s - | IDENT "Implicit"; qid = smart_global -> PrintImplicit qid - | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (false, fopt) - | IDENT "Sorted"; IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (true, fopt) - | IDENT "Assumptions"; qid = smart_global -> PrintAssumptions (false, false, qid) - | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, false, qid) - | IDENT "Transparent"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (false, true, qid) - | IDENT "All"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, true, qid) - | IDENT "Strategy"; qid = smart_global -> PrintStrategy (Some qid) - | IDENT "Strategies" -> PrintStrategy None ] ] - ; - class_rawexpr: - [ [ IDENT "Funclass" -> FunClass - | IDENT "Sortclass" -> SortClass - | qid = smart_global -> RefClass qid ] ] - ; - locatable: - [ [ qid = smart_global -> LocateAny qid - | IDENT "Term"; qid = smart_global -> LocateTerm qid - | IDENT "File"; f = ne_string -> LocateFile f - | IDENT "Library"; qid = global -> LocateLibrary qid - | IDENT "Module"; qid = global -> LocateModule qid ] ] - ; - option_value: - [ [ -> BoolValue true - | n = integer -> IntValue (Some n) - | s = STRING -> StringValue s ] ] - ; - option_ref_value: - [ [ id = global -> QualidRefValue id - | s = STRING -> StringRefValue s ] ] - ; - option_table: - [ [ fl = LIST1 [ x = IDENT -> x ] -> fl ]] - ; - as_dirpath: - [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ] - ; - ne_in_or_out_modules: - [ [ IDENT "inside"; l = LIST1 global -> SearchInside l - | IDENT "outside"; l = LIST1 global -> SearchOutside l ] ] - ; - in_or_out_modules: - [ [ m = ne_in_or_out_modules -> m - | -> SearchOutside [] ] ] - ; - comment: - [ [ c = constr -> CommentConstr c - | s = STRING -> CommentString s - | n = natural -> CommentInt n ] ] - ; - positive_search_mark: - [ [ "-" -> false | -> true ] ] - ; - scope: - [ [ "%"; key = IDENT -> key ] ] - ; - searchabout_query: - [ [ b = positive_search_mark; s = ne_string; sc = OPT scope -> - (b, SearchString (s,sc)) - | b = positive_search_mark; p = constr_pattern -> - (b, SearchSubPattern p) - ] ] - ; - searchabout_queries: - [ [ m = ne_in_or_out_modules -> ([],m) - | s = searchabout_query; l = searchabout_queries -> - let (sl,m) = l in (s::sl,m) - | -> ([],SearchOutside []) - ] ] - ; - univ_name_list: - [ [ "@{" ; l = LIST0 name; "}" -> l ] ] - ; -END; - -GEXTEND Gram - command: - [ [ -(* State management *) - IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s - | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s - | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s - | IDENT "Restore"; IDENT "State"; s = ne_string -> VernacRestoreState s - -(* Resetting *) - | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial - | IDENT "Reset"; id = identref -> VernacResetName id - | IDENT "Back" -> VernacBack 1 - | IDENT "Back"; n = natural -> VernacBack n - | IDENT "BackTo"; n = natural -> VernacBackTo n - -(* Tactic Debugger *) - | IDENT "Debug"; IDENT "On" -> - VernacSetOption (false, ["Ltac";"Debug"], BoolValue true) - - | IDENT "Debug"; IDENT "Off" -> - VernacSetOption (false, ["Ltac";"Debug"], BoolValue false) - -(* registration of a custom reduction *) - - | IDENT "Declare"; IDENT "Reduction"; s = IDENT; ":="; - r = red_expr -> - VernacDeclareReduction (s,r) - - ] ]; - END -;; - -(* Grammar extensions *) - -GEXTEND Gram - GLOBAL: syntax; - - syntax: - [ [ IDENT "Open"; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (true,sc) - - | IDENT "Close"; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (false,sc) - - | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> - VernacDelimiters (sc, Some key) - | IDENT "Undelimit"; IDENT "Scope"; sc = IDENT -> - VernacDelimiters (sc, None) - - | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; - refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) - - | IDENT "Infix"; op = ne_lstring; ":="; p = constr; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; - sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacInfix ((op,modl),p,sc) - | IDENT "Notation"; id = identref; - idl = LIST0 ident; ":="; c = constr; b = only_parsing -> - VernacSyntacticDefinition - (id,(idl,c),b) - | IDENT "Notation"; s = lstring; ":="; - c = constr; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; - sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacNotation (c,(s,modl),sc) - | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> - VernacNotationAddFormat (n,s,fmt) - - | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; - l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> - let s = CAst.map (fun s -> "x '"^s^"' y") s in - VernacSyntaxExtension (true,(s,l)) - - | IDENT "Reserved"; IDENT "Notation"; - s = ne_lstring; - l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] - -> VernacSyntaxExtension (false, (s,l)) - - (* "Print" "Grammar" should be here but is in "command" entry in order - to factorize with other "Print"-based vernac entries *) - ] ] - ; - only_parsing: - [ [ "("; IDENT "only"; IDENT "parsing"; ")" -> - Some Flags.Current - | "("; IDENT "compat"; s = STRING; ")" -> - Some (parse_compat_version s) - | -> None ] ] - ; - level: - [ [ IDENT "level"; n = natural -> NumLevel n - | IDENT "next"; IDENT "level" -> NextLevel ] ] - ; - syntax_modifier: - [ [ "at"; IDENT "level"; n = natural -> SetLevel n - | IDENT "left"; IDENT "associativity" -> SetAssoc LeftA - | IDENT "right"; IDENT "associativity" -> SetAssoc RightA - | IDENT "no"; IDENT "associativity" -> SetAssoc NonA - | IDENT "only"; IDENT "printing" -> SetOnlyPrinting - | IDENT "only"; IDENT "parsing" -> SetOnlyParsing - | IDENT "compat"; s = STRING -> - SetCompatVersion (parse_compat_version s) - | IDENT "format"; s1 = [s = STRING -> CAst.make ~loc:!@loc s]; - s2 = OPT [s = STRING -> CAst.make ~loc:!@loc s] -> - begin match s1, s2 with - | { CAst.v = k }, Some s -> SetFormat(k,s) - | s, None -> SetFormat ("text",s) end - | x = IDENT; ","; l = LIST1 [id = IDENT -> id ] SEP ","; "at"; - lev = level -> SetItemLevel (x::l,lev) - | x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) - | x = IDENT; "at"; lev = level; b = constr_as_binder_kind -> SetItemLevelAsBinder ([x],b,Some lev) - | x = IDENT; b = constr_as_binder_kind -> SetItemLevelAsBinder ([x],b,None) - | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) - ] ] - ; - syntax_extension_type: - [ [ IDENT "ident" -> ETName | IDENT "global" -> ETReference - | IDENT "bigint" -> ETBigint - | IDENT "binder" -> ETBinder true - | IDENT "constr"; n = OPT at_level; b = constr_as_binder_kind -> ETConstrAsBinder (b,n) - | IDENT "pattern" -> ETPattern (false,None) - | IDENT "pattern"; "at"; IDENT "level"; n = natural -> ETPattern (false,Some n) - | IDENT "strict"; IDENT "pattern" -> ETPattern (true,None) - | IDENT "strict"; IDENT "pattern"; "at"; IDENT "level"; n = natural -> ETPattern (true,Some n) - | IDENT "closed"; IDENT "binder" -> ETBinder false - ] ] - ; - at_level: - [ [ "at"; n = level -> n ] ] - ; - constr_as_binder_kind: - [ [ "as"; IDENT "ident" -> AsIdent - | "as"; IDENT "pattern" -> AsIdentOrPattern - | "as"; IDENT "strict"; IDENT "pattern" -> AsStrictPattern ] ] - ; -END diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib index e5a0a31cc..da4a0421b 100644 --- a/parsing/parsing.mllib +++ b/parsing/parsing.mllib @@ -1,9 +1,6 @@ Tok CLexer Extend -Vernacexpr Pcoq G_constr -G_vernac G_prim -G_proofs diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 258c4bb11..b78c35c26 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -145,7 +145,6 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct end - let warning_verbose = Gramext.warning_verbose let of_coq_assoc = function @@ -387,7 +386,6 @@ let create_universe 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 @@ -493,44 +491,6 @@ module Module = let module_type = Gram.entry_create "module_type" 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_control = gec_vernac "Vernac.vernac_control" - let rec_definition = gec_vernac "Vernac.rec_definition" - let red_expr = make_gen_entry utactic "red_expr" - let hint_info = gec_vernac "hint_info" - (* 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 (to_coqloc 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_control) ], act_vernac ); - ] in - 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 - 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 @@ -635,7 +595,6 @@ let () = Grammar.register0 wit_ref (Prim.reference); Grammar.register0 wit_sort_family (Constr.sort_family); Grammar.register0 wit_constr (Constr.constr); - Grammar.register0 wit_red_expr (Vernac_.red_expr); () (** Registering extra grammar *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 387a62604..36e5e420a 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -10,12 +10,10 @@ open Names open Extend -open Vernacexpr open Genarg open Constrexpr open Libnames open Misctypes -open Genredexpr (** The parser of Coq *) @@ -89,6 +87,12 @@ module type S = end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e +module Symbols : sig + + val stoken : Tok.t -> Gram.symbol + val snterm : Gram.internal_entry -> Gram.symbol +end + (** The parser of Coq is built from three kinds of rule declarations: - dynamic rules declared at the evaluation of Coq files (using @@ -177,11 +181,14 @@ val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry type gram_universe val get_univ : string -> gram_universe +val create_universe : string -> gram_universe + +val new_entry : gram_universe -> string -> 'a Gram.entry val uprim : gram_universe val uconstr : gram_universe val utactic : gram_universe -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 @@ -249,27 +256,6 @@ module Module : val module_type : module_ast Gram.entry end -module Vernac_ : - sig - val gallina : vernac_expr Gram.entry - val gallina_ext : vernac_expr Gram.entry - val command : vernac_expr Gram.entry - val syntax : vernac_expr Gram.entry - val vernac_control : vernac_control Gram.entry - val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry - val noedit_mode : vernac_expr Gram.entry - val command_entry : vernac_expr Gram.entry - val red_expr : raw_red_expr Gram.entry - val hint_info : Typeclasses.hint_info_expr Gram.entry - end - -(** The main entry: reads an optional vernac command *) -val main_entry : (Loc.t * vernac_control) 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 - val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option (** {5 Extending the parser without synchronization} *) diff --git a/parsing/vernacexpr.ml b/parsing/vernacexpr.ml deleted file mode 100644 index 6ebf66349..000000000 --- a/parsing/vernacexpr.ml +++ /dev/null @@ -1,530 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* Current, it contains the name of the coq version - which this notation is trying to be compatible with *) -type locality_flag = bool (* true = Local *) - -type option_value = Goptions.option_value = - | BoolValue of bool - | IntValue of int option - | StringValue of string - | StringOptValue of string option - -type option_ref_value = - | StringRefValue of string - | QualidRefValue of reference - -(** Identifier and optional list of bound universes and constraints. *) - -type sort_expr = Sorts.family - -type definition_expr = - | ProveBody of local_binder_expr list * constr_expr - | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr - * constr_expr option - -type fixpoint_expr = - ident_decl * (lident option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr option - -type cofixpoint_expr = - ident_decl * local_binder_expr list * constr_expr * constr_expr option - -type local_decl_expr = - | AssumExpr of lname * constr_expr - | DefExpr of lname * constr_expr * constr_expr option - -type inductive_kind = Inductive_kw | CoInductive | Variant | Record | Structure | Class of bool (* true = definitional, false = inductive *) -type decl_notation = lstring * constr_expr * scope_name option -type simple_binder = lident list * constr_expr -type class_binder = lident * constr_expr list -type 'a with_coercion = coercion_flag * 'a -type 'a with_instance = instance_flag * 'a -type 'a with_notation = 'a * decl_notation list -type 'a with_priority = 'a * int option -type constructor_expr = (lident * constr_expr) with_coercion -type constructor_list_or_record_decl_expr = - | Constructors of constructor_expr list - | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list -type inductive_expr = - ident_decl with_coercion * local_binder_expr list * constr_expr option * inductive_kind * - constructor_list_or_record_decl_expr - -type one_inductive_expr = - ident_decl * local_binder_expr list * constr_expr option * constructor_expr list - -type typeclass_constraint = name_decl * Decl_kinds.binding_kind * constr_expr -and typeclass_context = typeclass_constraint list - -type proof_expr = - ident_decl * (local_binder_expr list * constr_expr) - -type syntax_modifier = - | SetItemLevel of string list * Extend.production_level - | SetItemLevelAsBinder of string list * Extend.constr_as_binder_kind * Extend.production_level option - | SetLevel of int - | SetAssoc of Extend.gram_assoc - | SetEntryType of string * Extend.simple_constr_prod_entry_key - | SetOnlyParsing - | SetOnlyPrinting - | SetCompatVersion of Flags.compat_version - | SetFormat of string * lstring - -type proof_end = - | Admitted - (* name in `Save ident` when closing goal *) - | Proved of Proof_global.opacity_flag * lident option - -type scheme = - | InductionScheme of bool * reference or_by_notation * sort_expr - | CaseScheme of bool * reference or_by_notation * sort_expr - | EqualityScheme of reference or_by_notation - -type section_subset_expr = - | SsEmpty - | SsType - | SsSingl of lident - | SsCompl of section_subset_expr - | SsUnion of section_subset_expr * section_subset_expr - | SsSubstr of section_subset_expr * section_subset_expr - | SsFwdClose of section_subset_expr - -(** Extension identifiers for the VERNAC EXTEND mechanism. - - {b ("Extraction", 0} indicates {b Extraction {i qualid}} command. - - {b ("Extraction", 1} indicates {b Recursive Extraction {i qualid}} command. - - {b ("Extraction", 2)} indicates {b Extraction "{i filename}" {i qualid{_ 1}} ... {i qualid{_ n}}} command. - - {b ("ExtractionLibrary", 0)} indicates {b Extraction Library {i ident}} command. - - {b ("RecursiveExtractionLibrary", 0)} indicates {b Recursive Extraction Library {i ident}} command. - - {b ("SeparateExtraction", 0)} indicates {b Separate Extraction {i qualid{_ 1}} ... {i qualid{_ n}}} command. - - {b ("ExtractionLanguage", 0)} indicates {b Extraction Language Ocaml} or {b Extraction Language Haskell} or {b Extraction Language Scheme} or {b Extraction Language JSON} commands. - - {b ("ExtractionImplicit", 0)} indicates {b Extraction Implicit {i qualid} \[ {i ident{_1}} ... {i ident{_n} } \] } command. - - {b ("ExtractionConstant", 0)} indicates {b Extract Constant {i qualid} => {i string}} command. - - {b ("ExtractionInlinedConstant", 0)} indicates {b Extract Inlined Constant {i qualid} => {i string}} command. - - {b ("ExtractionInductive", 0)} indicates {b Extract Inductive {i qualid} => {i string} [ {i string} ... {string} ] {i optstring}} command. - - {b ("ExtractionBlacklist", 0)} indicates {b Extraction Blacklist {i ident{_1}} ... {i ident{_n}}} command. - *) -type extend_name = - (** Name of the vernac entry where the tactic is defined, typically found - after the VERNAC EXTEND statement in the source. *) - string * - (** Index of the extension in the VERNAC EXTEND statement. Each parsing branch - is given an offset, starting from zero. *) - int - -(* This type allows registering the inlining of constants in native compiler. - It will be extended with primitive inductive types and operators *) -type register_kind = - | RegisterInline - -type bullet = Proof_bullet.t -[@@ocaml.deprecated "Alias type, please use [Proof_bullet.t]"] - -(** {6 Types concerning the module layer} *) - -(** Rigid / flexible module signature *) - -type 'a module_signature = 'a Declaremods.module_signature = - | Enforce of 'a (** ... : T *) - | Check of 'a list (** ... <: T1 <: T2, possibly empty *) -[@@ocaml.deprecated "please use [Declaremods.module_signature]."] - -(** Which module inline annotations should we honor, - either None or the ones whose level is less or equal - to the given integer *) - -type inline = Declaremods.inline = - | NoInline - | DefaultInline - | InlineAt of int -[@@ocaml.deprecated "please use [Declaremods.inline]."] - -type module_ast_inl = module_ast * Declaremods.inline -type module_binder = bool option * lident list * module_ast_inl - -(** [Some b] if locally enabled/disabled according to [b], [None] if - we should use the global flag. *) -type vernac_cumulative = VernacCumulative | VernacNonCumulative - -(** {6 The type of vernacular expressions} *) - -type vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit - -type vernac_argument_status = { - name : Name.t; - recarg_like : bool; - notation_scope : string CAst.t option; - implicit_status : vernac_implicit_status; -} - -type nonrec vernac_expr = - - | VernacLoad of verbose_flag * string - (* Syntax *) - | VernacSyntaxExtension of bool * (lstring * syntax_modifier list) - | VernacOpenCloseScope of bool * scope_name - | VernacDelimiters of scope_name * string option - | VernacBindScope of scope_name * class_rawexpr list - | VernacInfix of (lstring * syntax_modifier list) * - constr_expr * scope_name option - | VernacNotation of - constr_expr * (lstring * syntax_modifier list) * - scope_name option - | VernacNotationAddFormat of string * string * string - - (* Gallina *) - | VernacDefinition of (Decl_kinds.discharge * Decl_kinds.definition_object_kind) * name_decl * definition_expr - | VernacStartTheoremProof of Decl_kinds.theorem_kind * proof_expr list - | VernacEndProof of proof_end - | VernacExactProof of constr_expr - | VernacAssumption of (Decl_kinds.discharge * Decl_kinds.assumption_object_kind) * - Declaremods.inline * (ident_decl list * constr_expr) with_coercion list - | VernacInductive of vernac_cumulative option * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list - | VernacFixpoint of Decl_kinds.discharge * (fixpoint_expr * decl_notation list) list - | VernacCoFixpoint of Decl_kinds.discharge * (cofixpoint_expr * decl_notation list) list - | VernacScheme of (lident option * scheme) list - | VernacCombinedScheme of lident * lident list - | VernacUniverse of lident list - | VernacConstraint of Glob_term.glob_constraint list - - (* Gallina extensions *) - | VernacBeginSection of lident - | VernacEndSegment of lident - | VernacRequire of - reference option * export_flag option * reference list - | VernacImport of export_flag * reference list - | VernacCanonical of reference or_by_notation - | VernacCoercion of reference or_by_notation * - class_rawexpr * class_rawexpr - | VernacIdentityCoercion of lident * class_rawexpr * class_rawexpr - | VernacNameSectionHypSet of lident * section_subset_expr - - (* Type classes *) - | VernacInstance of - bool * (* abstract instance *) - local_binder_expr list * (* super *) - typeclass_constraint * (* instance name, class name, params *) - (bool * constr_expr) option * (* props *) - Typeclasses.hint_info_expr - - | VernacContext of local_binder_expr list - - | VernacDeclareInstances of - (reference * Typeclasses.hint_info_expr) list (* instances names, priorities and patterns *) - - | VernacDeclareClass of reference (* inductive or definition name *) - - (* Modules and Module Types *) - | VernacDeclareModule of bool option * lident * - module_binder list * module_ast_inl - | VernacDefineModule of bool option * lident * module_binder list * - module_ast_inl Declaremods.module_signature * module_ast_inl list - | VernacDeclareModuleType of lident * - module_binder list * module_ast_inl list * module_ast_inl list - | VernacInclude of module_ast_inl list - - (* Solving *) - - | VernacSolveExistential of int * constr_expr - - (* Auxiliary file and library management *) - | VernacAddLoadPath of rec_flag * string * DirPath.t option - | VernacRemoveLoadPath of string - | VernacAddMLPath of rec_flag * string - | VernacDeclareMLModule of string list - | VernacChdir of string option - - (* State management *) - | VernacWriteState of string - | VernacRestoreState of string - - (* Resetting *) - | VernacResetName of lident - | VernacResetInitial - | VernacBack of int - | VernacBackTo of int - - (* Commands *) - | VernacCreateHintDb of string * bool - | VernacRemoveHints of string list * reference list - | VernacHints of string list * hints_expr - | VernacSyntacticDefinition of lident * (Id.t list * constr_expr) * - onlyparsing_flag - | VernacArguments of reference or_by_notation * - vernac_argument_status list (* Main arguments status list *) * - (Name.t * vernac_implicit_status) list list (* Extra implicit status lists *) * - int option (* Number of args to trigger reduction *) * - [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | - `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | - `DefaultImplicits ] list - | VernacReserve of simple_binder list - | VernacGeneralizable of (lident list) option - | VernacSetOpacity of (Conv_oracle.level * reference or_by_notation list) - | VernacSetStrategy of - (Conv_oracle.level * reference or_by_notation list) list - | VernacUnsetOption of export_flag * Goptions.option_name - | VernacSetOption of export_flag * Goptions.option_name * option_value - | VernacAddOption of Goptions.option_name * option_ref_value list - | VernacRemoveOption of Goptions.option_name * option_ref_value list - | VernacMemOption of Goptions.option_name * option_ref_value list - | VernacPrintOption of Goptions.option_name - | VernacCheckMayEval of Genredexpr.raw_red_expr option * Goal_select.t option * constr_expr - | VernacGlobalCheck of constr_expr - | VernacDeclareReduction of string * Genredexpr.raw_red_expr - | VernacPrint of printable - | VernacSearch of searchable * Goal_select.t option * search_restriction - | VernacLocate of locatable - | VernacRegister of lident * register_kind - | VernacComments of comment list - - (* Proof management *) - | VernacAbort of lident option - | VernacAbortAll - | VernacRestart - | VernacUndo of int - | VernacUndoTo of int - | VernacFocus of int option - | VernacUnfocus - | VernacUnfocused - | VernacBullet of Proof_bullet.t - | VernacSubproof of Goal_select.t option - | VernacEndSubproof - | VernacShow of showable - | VernacCheckGuard - | VernacProof of Genarg.raw_generic_argument option * section_subset_expr option - | VernacProofMode of string - - (* For extension *) - | VernacExtend of extend_name * Genarg.raw_generic_argument list - -type nonrec vernac_flag = - | VernacProgram - | VernacPolymorphic of bool - | VernacLocal of bool - -type vernac_control = - | VernacExpr of vernac_flag list * vernac_expr - (* boolean is true when the `-time` batch-mode command line flag was set. - the flag is used to print differently in `-time` vs `Time foo` *) - | VernacTime of bool * vernac_control CAst.t - | VernacRedirect of string * vernac_control CAst.t - | VernacTimeout of int * vernac_control - | VernacFail of vernac_control - -(* A vernac classifier provides information about the exectuion of a - command: - - - vernac_when: encodes if the vernac may alter the parser [thus - forcing immediate execution], or if indeed it is pure and parsing - can continue without its execution. - - - vernac_type: if it is starts, ends, continues a proof or - alters the global state or is a control command like BackTo or is - a query like Check. - - The classification works on the assumption that we have 3 states: - parsing, execution (global enviroment, etc...), and proof - state. For example, commands that only alter the proof state are - considered safe to delegate to a worker. - -*) -type vernac_type = - (* Start of a proof *) - | VtStartProof of vernac_start - (* Command altering the global state, bad for parallel - processing. *) - | VtSideff of vernac_sideff_type - (* End of a proof *) - | VtQed of vernac_qed_type - (* A proof step *) - | VtProofStep of proof_step - (* To be removed *) - | VtProofMode of string - (* Queries are commands assumed to be "pure", that is to say, they - don't modify the interpretation state. *) - | VtQuery - (* To be removed *) - | VtMeta - | VtUnknown -and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) -and vernac_start = string * opacity_guarantee * Id.t list -and vernac_sideff_type = Id.t list -and opacity_guarantee = - | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) - | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) -and proof_step = { (* TODO: inline with OCaml 4.03 *) - parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; - proof_block_detection : proof_block_name option -} -and solving_tac = bool (* a terminator *) -and anon_abstracting_tac = bool (* abstracting anonymously its result *) -and proof_block_name = string (* open type of delimiters *) -type vernac_when = - | VtNow - | VtLater -type vernac_classification = vernac_type * vernac_when - - -(** Deprecated stuff *) -type universe_decl_expr = Constrexpr.universe_decl_expr -[@@ocaml.deprecated "alias of Constrexpr.universe_decl_expr"] - -type ident_decl = Constrexpr.ident_decl -[@@ocaml.deprecated "alias of Constrexpr.ident_decl"] - -type name_decl = Constrexpr.name_decl -[@@ocaml.deprecated "alias of Constrexpr.name_decl"] -- cgit v1.2.3