diff options
| author |  Stephane Glondu <steph@glondu.net> | 2012-01-12 16:04:54 +0100 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2012-01-12 16:04:54 +0100 |
| commit | 39efc41237ec906226a3a53d7396d51173495204 (patch) | |
| tree | 87cd58d72d43469d2a2a0a127c1060d7c9e0206b /parsing | |
| parent | 5fe4ac437bed43547b3695664974f492b55cb553 (diff) | |
| parent | 97fefe1fcca363a1317e066e7f4b99b9c1e9987b (diff) | |
Remove non-DFSG contentsupstream/8.4_beta+dfsg
Diffstat (limited to 'parsing')
49 files changed, 2194 insertions, 2527 deletions
diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index 848223a0..3266fcf9 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -1,21 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) - -(* $Id: argextend.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) +(*i camlp4deps: "tools/compat5b.cmo" i*) open Genarg open Q_util -open Q_coqast open Egrammar +open Pcoq +open Compat -let join_loc = Util.join_loc let loc = Util.dummy_loc let default_loc = <:expr< Util.dummy_loc >> @@ -42,7 +40,12 @@ let rec make_rawwit loc = function | OptArgType t -> <:expr< Genarg.wit_opt $make_rawwit loc t$ >> | PairArgType (t1,t2) -> <:expr< Genarg.wit_pair $make_rawwit loc t1$ $make_rawwit loc t2$ >> - | ExtraArgType s -> <:expr< $lid:"rawwit_"^s$ >> + | ExtraArgType s -> + <:expr< + let module WIT = struct + open Extrawit; + value wit = $lid:"rawwit_"^s$; + end in WIT.wit >> let rec make_globwit loc = function | BoolArgType -> <:expr< Genarg.globwit_bool >> @@ -67,7 +70,12 @@ let rec make_globwit loc = function | OptArgType t -> <:expr< Genarg.wit_opt $make_globwit loc t$ >> | PairArgType (t1,t2) -> <:expr< Genarg.wit_pair $make_globwit loc t1$ $make_globwit loc t2$ >> - | ExtraArgType s -> <:expr< $lid:"globwit_"^s$ >> + | ExtraArgType s -> + <:expr< + let module WIT = struct + open Extrawit; + value wit = $lid:"globwit_"^s$; + end in WIT.wit >> let rec make_wit loc = function | BoolArgType -> <:expr< Genarg.wit_bool >> @@ -92,48 +100,51 @@ let rec make_wit loc = function | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> | PairArgType (t1,t2) -> <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >> - | ExtraArgType s -> <:expr< $lid:"wit_"^s$ >> + | ExtraArgType s -> + <:expr< + let module WIT = struct + open Extrawit; + value wit = $lid:"wit_"^s$; + end in WIT.wit >> let make_act loc act pil = let rec make = function - | [] -> <:expr< Gramext.action (fun loc -> ($act$ : 'a)) >> + | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >> | GramNonTerminal (_,t,_,Some p) :: tl -> let p = Names.string_of_id p in <:expr< - Gramext.action + Pcoq.Gram.action (fun $lid:p$ -> let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) >> | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl -> - <:expr< Gramext.action (fun _ -> $make tl$) >> in + <:expr< Pcoq.Gram.action (fun _ -> $make tl$) >> in make (List.rev pil) let make_prod_item = function - | GramTerminal s -> <:expr< (Gramext.Stoken (Lexer.terminal $str:s$)) >> + | GramTerminal s -> <:expr< Pcoq.gram_token_of_string $str:s$ >> | GramNonTerminal (_,_,g,_) -> <:expr< Pcoq.symbol_of_prod_entry_key $mlexpr_of_prod_entry_key g$ >> let make_rule loc (prods,act) = <:expr< ($mlexpr_of_list make_prod_item prods$,$make_act loc act prods$) >> -let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl = - let rawtyp, rawpr = match rawtyppr with - | None -> typ,pr - | Some (t,p) -> t,p in - let globtyp, globpr = match globtyppr with - | None -> typ,pr - | Some (t,p) -> t,p in +let declare_tactic_argument loc s (typ, pr, f, g, h) cl = + let rawtyp, rawpr, globtyp, globpr = match typ with + | `Uniform typ -> typ, pr, typ, pr + | `Specialized (a, b, c, d) -> a, b, c, d + in let glob = match g with | None -> <:expr< fun e x -> - out_gen $make_globwit loc typ$ + out_gen $make_globwit loc rawtyp$ (Tacinterp.intern_genarg e (Genarg.in_gen $make_rawwit loc rawtyp$ x)) >> | Some f -> <:expr< $lid:f$>> in let interp = match f with | None -> <:expr< fun ist gl x -> - out_gen $make_wit loc typ$ + out_gen $make_wit loc globtyp$ (Tacinterp.interp_genarg ist gl (Genarg.in_gen $make_globwit loc globtyp$ x)) >> | Some f -> <:expr< $lid:f$>> in @@ -149,13 +160,13 @@ let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl = let rawwit = <:expr< $lid:"rawwit_"^s$ >> in let globwit = <:expr< $lid:"globwit_"^s$ >> in let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in - <:str_item< - declare - open Pcoq; - open Extrawit; + declare_str_items loc + [ <:str_item< value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) = - Genarg.create_arg $se$; - value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$; + Genarg.create_arg $se$ >>; + <:str_item< + value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; + <:str_item< do { Tacinterp.add_interp_genarg $se$ ((fun e x -> (Genarg.in_gen $globwit$ ($glob$ e (out_gen $rawwit$ x)))), @@ -163,14 +174,13 @@ let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl = (Genarg.in_gen $wit$ ($interp$ ist gl (out_gen $globwit$ x)))), (fun subst x -> (Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x))))); - Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None - [(None, None, $rules$)]; + Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a)) + (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule ($rawwit$, $lid:rawpr$) ($globwit$, $lid:globpr$) - ($wit$, $lid:pr$); - end - >> + ($wit$, $lid:pr$) } + >> ] let declare_vernac_argument loc s pr cl = let se = mlexpr_of_string s in @@ -181,56 +191,58 @@ let declare_vernac_argument loc s pr cl = let pr_rules = match pr with | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >> | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in - <:str_item< - declare - open Pcoq; - open Extrawit; + declare_str_items loc + [ <:str_item< value (($lid:"wit_"^s$:Genarg.abstract_argument_type unit Genarg.tlevel), ($lid:"globwit_"^s$:Genarg.abstract_argument_type unit Genarg.glevel), - $lid:"rawwit_"^s$) = Genarg.create_arg $se$; - value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$; - Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None - [(None, None, $rules$)]; + $lid:"rawwit_"^s$) = Genarg.create_arg $se$ >>; + <:str_item< + value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; + <:str_item< do { + Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a)) + (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule ($rawwit$, $pr_rules$) ($globwit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not globwit printer") - ($wit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not wit printer"); - end - >> + ($wit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not wit printer") } + >> ] open Vernacexpr open Pcoq open Pcaml +open PcamlSig EXTEND GLOBAL: str_item; str_item: - [ [ "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; - "TYPED"; "AS"; typ = argtype; - "PRINTED"; "BY"; pr = LIDENT; - f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; - g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; - h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; - rawtyppr = - (* Necessary if the globalized type is different from the final type *) - OPT [ "RAW_TYPED"; "AS"; t = argtype; - "RAW_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; - globtyppr = - OPT [ "GLOB_TYPED"; "AS"; t = argtype; - "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; + [ [ "ARGUMENT"; "EXTEND"; s = entry_name; + header = argextend_header; OPT "|"; l = LIST1 argrule SEP "|"; "END" -> - if String.capitalize s = s then - failwith "Argument entry names must be lowercase"; - declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr l - | "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; + declare_tactic_argument loc s header l + | "VERNAC"; "ARGUMENT"; "EXTEND"; s = entry_name; pr = OPT ["PRINTED"; "BY"; pr = LIDENT -> pr]; OPT "|"; l = LIST1 argrule SEP "|"; "END" -> - if String.capitalize s = s then - failwith "Argument entry names must be lowercase"; declare_vernac_argument loc s pr l ] ] ; + argextend_header: + [ [ "TYPED"; "AS"; typ = argtype; + "PRINTED"; "BY"; pr = LIDENT; + f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; + g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; + h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ] -> + (`Uniform typ, pr, f, g, h) + | "PRINTED"; "BY"; pr = LIDENT; + f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; + g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; + h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; + "RAW_TYPED"; "AS"; rawtyp = argtype; + "RAW_PRINTED"; "BY"; rawpr = LIDENT; + "GLOB_TYPED"; "AS"; globtyp = argtype; + "GLOB_PRINTED"; "BY"; globpr = LIDENT -> + (`Specialized (rawtyp, rawpr, globtyp, globpr), pr, f, g, h) ] ] + ; argtype: [ "2" [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ] @@ -253,9 +265,14 @@ EXTEND GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then - Lexer.add_token ("", s); + Lexer.add_keyword s; GramTerminal s ] ] ; + entry_name: + [ [ s = LIDENT -> s + | UIDENT -> failwith "Argument entry names must be lowercase" + ] ] + ; END diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index ba965a54..4418a45f 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -1,14 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: egrammar.ml 14779 2011-12-07 21:54:18Z herbelin $ *) - open Pp +open Compat open Util open Pcoq open Extend @@ -57,45 +56,43 @@ let cases_pattern_expr_of_name (loc,na) = match na with | Name id -> CPatAtom (loc,Some (Ident (loc,id))) type grammar_constr_prod_item = - | GramConstrTerminal of Token.pattern + | GramConstrTerminal of Tok.t | GramConstrNonTerminal of constr_prod_entry_key * identifier option | GramConstrListMark of int * bool (* tells action rule to make a list of the n previous parsed items; concat with last parsed list if true *) -type 'a action_env = 'a list * 'a list list - let make_constr_action (f : loc -> constr_notation_substitution -> constr_expr) pil = let rec make (constrs,constrlists,binders as fullsubst) = function | [] -> - Gramext.action (fun loc -> f loc fullsubst) + Gram.action (fun loc -> f loc fullsubst) | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl -> (* parse a non-binding item *) - Gramext.action (fun _ -> make fullsubst tl) + Gram.action (fun _ -> make fullsubst tl) | GramConstrNonTerminal (typ, Some _) :: tl -> (* parse a binding non-terminal *) - (match typ with - | (ETConstr _| ETOther _) -> - Gramext.action (fun (v:constr_expr) -> + (match typ with + | (ETConstr _| ETOther _) -> + Gram.action (fun (v:constr_expr) -> make (v :: constrs, constrlists, binders) tl) - | ETReference -> - Gramext.action (fun (v:reference) -> + | ETReference -> + Gram.action (fun (v:reference) -> make (CRef v :: constrs, constrlists, binders) tl) - | ETName -> - Gramext.action (fun (na:name located) -> + | ETName -> + Gram.action (fun (na:name located) -> make (constr_expr_of_name na :: constrs, constrlists, binders) tl) - | ETBigint -> - Gramext.action (fun (v:Bigint.bigint) -> + | ETBigint -> + Gram.action (fun (v:Bigint.bigint) -> make (CPrim(dummy_loc,Numeral v) :: constrs, constrlists, binders) tl) - | ETConstrList (_,n) -> - Gramext.action (fun (v:constr_expr list) -> + | ETConstrList (_,n) -> + Gram.action (fun (v:constr_expr list) -> make (constrs, v::constrlists, binders) tl) | ETBinder _ | ETBinderList (true,_) -> - Gramext.action (fun (v:local_binder list) -> + Gram.action (fun (v:local_binder list) -> make (constrs, constrlists, v::binders) tl) | ETBinderList (false,_) -> - Gramext.action (fun (v:local_binder list list) -> + Gram.action (fun (v:local_binder list list) -> make (constrs, constrlists, List.flatten v::binders) tl) | ETPattern -> failwith "Unexpected entry of type cases pattern") @@ -113,26 +110,26 @@ let make_cases_pattern_action (f : loc -> cases_pattern_notation_substitution -> cases_pattern_expr) pil = let rec make (env,envlist as fullenv) = function | [] -> - Gramext.action (fun loc -> f loc fullenv) + Gram.action (fun loc -> f loc fullenv) | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl -> (* parse a non-binding item *) - Gramext.action (fun _ -> make fullenv tl) + Gram.action (fun _ -> make fullenv tl) | GramConstrNonTerminal (typ, Some _) :: tl -> (* parse a binding non-terminal *) (match typ with | ETConstr _ -> (* pattern non-terminal *) - Gramext.action (fun (v:cases_pattern_expr) -> make (v::env,envlist) tl) + Gram.action (fun (v:cases_pattern_expr) -> make (v::env,envlist) tl) | ETReference -> - Gramext.action (fun (v:reference) -> + Gram.action (fun (v:reference) -> make (CPatAtom (dummy_loc,Some v) :: env, envlist) tl) | ETName -> - Gramext.action (fun (na:name located) -> + Gram.action (fun (na:name located) -> make (cases_pattern_expr_of_name na :: env, envlist) tl) | ETBigint -> - Gramext.action (fun (v:Bigint.bigint) -> + Gram.action (fun (v:Bigint.bigint) -> make (CPatPrim (dummy_loc,Numeral v) :: env, envlist) tl) | ETConstrList (_,_) -> - Gramext.action (fun (vl:cases_pattern_expr list) -> + Gram.action (fun (vl:cases_pattern_expr list) -> make (env, vl :: envlist) tl) | (ETPattern | ETBinderList _ | ETBinder _ | ETOther _) -> failwith "Unexpected entry of type cases pattern or other") @@ -146,7 +143,7 @@ let make_cases_pattern_action let rec make_constr_prod_item assoc from forpat = function | GramConstrTerminal tok :: l -> - Gramext.Stoken tok :: make_constr_prod_item assoc from forpat l + gram_token_of_token tok :: make_constr_prod_item assoc from forpat l | GramConstrNonTerminal (nt, ovar) :: l -> symbol_of_constr_prod_entry_key assoc from forpat nt :: make_constr_prod_item assoc from forpat l @@ -156,17 +153,18 @@ let rec make_constr_prod_item assoc from forpat = function [] let prepare_empty_levels forpat (pos,p4assoc,name,reinit) = - let entry = + let entry = if forpat then weaken_entry Constr.pattern else weaken_entry Constr.operconstr in - grammar_extend entry pos reinit [(name, p4assoc, [])] + grammar_extend entry reinit (pos,[(name, p4assoc, [])]) let pure_sublevels level symbs = - map_succeed (function - | Gramext.Snterml (_,n) when Some (int_of_string n) <> level -> - int_of_string n - | _ -> - failwith "") symbs + map_succeed + (function s -> + let i = level_of_snterml s in + if level = Some i then failwith ""; + i) + symbs let extend_constr (entry,level) (n,assoc) mkact forpat rules = List.fold_left (fun nb pt -> @@ -176,7 +174,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 pos reinit [(name, p4assoc, [symbs, mkact pt])]; + grammar_extend entry reinit (pos,[(name, p4assoc, [symbs, mkact pt])]); nb_decls) 0 rules let extend_constr_notation (n,assoc,ntn,rules) = @@ -187,8 +185,8 @@ let extend_constr_notation (n,assoc,ntn,rules) = (* Add the notation in cases_pattern *) let mkact loc env = CPatNotation (loc,ntn,env) in let e = interp_constr_entry_key true (ETConstr (n,())) in - let nb' = - extend_constr e (ETConstr (n,()),assoc) (make_cases_pattern_action mkact) true rules in + let nb' = extend_constr e (ETConstr (n,()),assoc) (make_cases_pattern_action mkact) + true rules in nb+nb' (**********************************************************************) @@ -198,11 +196,11 @@ let make_generic_action (f:loc -> ('b * raw_generic_argument) list -> 'a) pil = let rec make env = function | [] -> - Gramext.action (fun loc -> f loc env) + Gram.action (fun loc -> f loc env) | None :: tl -> (* parse a non-binding item *) - Gramext.action (fun _ -> make env tl) + Gram.action (fun _ -> make env tl) | Some (p, t) :: tl -> (* non-terminal *) - Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in + Gram.action (fun v -> make ((p,in_generic t v) :: env) tl) in make [] (List.rev pil) let make_rule univ f g pt = @@ -216,10 +214,10 @@ let make_rule univ f g pt = type grammar_prod_item = | GramTerminal of string | GramNonTerminal of - loc * argument_type * Gram.te prod_entry_key * identifier option + loc * argument_type * prod_entry_key * identifier option let make_prod_item = function - | GramTerminal s -> (Gramext.Stoken (Lexer.terminal s), None) + | 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) @@ -229,19 +227,21 @@ let extend_tactic_grammar s gl = let univ = get_univ "tactic" in let mkact loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in let rules = List.map (make_rule univ mkact make_prod_item) gl in - Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)] + maybe_uncurry (Gram.extend Tactic.simple_tactic) + (None,[(None, None, List.rev rules)]) (* Vernac grammar extensions *) let vernac_exts = ref [] let get_extend_vernac_grammars () = !vernac_exts -let extend_vernac_command_grammar s gl = +let extend_vernac_command_grammar s nt gl = + let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; let univ = get_univ "vernac" in let mkact loc l = VernacExtend (s,List.map snd l) in let rules = List.map (make_rule univ mkact make_prod_item) gl in - Gram.extend Vernac_.command None [(None, None, List.rev rules)] + maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)]) (**********************************************************************) (** Grammar declaration for Tactic Notation (Coq level) *) @@ -252,7 +252,7 @@ let get_tactic_entry n = else if n = 5 then weaken_entry Tactic.binder_tactic, None else if 1<=n && n<5 then - weaken_entry Tactic.tactic_expr, Some (Gramext.Level (string_of_int n)) + weaken_entry Tactic.tactic_expr, Some (Compat.Level (string_of_int n)) else error ("Invalid Tactic Notation level: "^(string_of_int n)^".") @@ -276,14 +276,14 @@ let add_tactic_entry (key,lev,prods,tac) = (TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) in make_rule univ (mkact key tac) make_prod_item prods in synchronize_level_positions (); - grammar_extend entry pos None [(None, None, List.rev [rules])]; + grammar_extend entry None (pos,[(None, None, List.rev [rules])]); 1 (**********************************************************************) (** State of the grammar extensions *) type notation_grammar = - int * Gramext.g_assoc option * notation * grammar_constr_prod_item list list + int * gram_assoc option * notation * grammar_constr_prod_item list list type all_grammar_command = | Notation of diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli index 8554c9be..1d85c74e 100644 --- a/parsing/egrammar.mli +++ b/parsing/egrammar.mli @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: egrammar.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - -(*i*) +open Compat open Util open Names open Topconstr @@ -16,36 +14,35 @@ open Pcoq open Extend open Vernacexpr open Ppextend -open Rawterm +open Glob_term open Genarg open Mod_subst -(*i*) (** Mapping of grammar productions to camlp4 actions Used for Coq-level Notation and Tactic Notation, and for ML-level tactic and vernac extensions *) -(* For constr notations *) +(** For constr notations *) type grammar_constr_prod_item = - | GramConstrTerminal of Token.pattern + | GramConstrTerminal of Tok.t | GramConstrNonTerminal of constr_prod_entry_key * identifier option | GramConstrListMark of int * bool (* tells action rule to make a list of the n previous parsed items; concat with last parsed list if true *) type notation_grammar = - int * Gramext.g_assoc option * notation * grammar_constr_prod_item list list + int * gram_assoc option * notation * grammar_constr_prod_item list list -(* For tactic and vernac notations *) +(** For tactic and vernac notations *) type grammar_prod_item = | GramTerminal of string | GramNonTerminal of loc * argument_type * - Gram.te prod_entry_key * identifier option + prod_entry_key * identifier option -(* Adding notations *) +(** Adding notations *) type all_grammar_command = | Notation of @@ -64,7 +61,7 @@ val extend_tactic_grammar : string -> grammar_prod_item list list -> unit val extend_vernac_command_grammar : - string -> grammar_prod_item list list -> unit + string -> vernac_expr Gram.entry option -> grammar_prod_item list list -> unit val get_extend_vernac_grammars : unit -> (string * grammar_prod_item list list) list diff --git a/parsing/extend.ml b/parsing/extend.ml index 9b85ada5..fca24ed5 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -1,42 +1,20 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extend.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - +open Compat open Util -(**********************************************************************) -(* 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 'a prod_entry_key = - | Alist1 of 'a prod_entry_key - | Alist1sep of 'a prod_entry_key * string - | Alist0 of 'a prod_entry_key - | Alist0sep of 'a prod_entry_key * string - | Aopt of 'a prod_entry_key - | Amodifiers of 'a prod_entry_key - | Aself - | Anext - | Atactic of int - | Agram of 'a Gramext.g_entry - | Aentry of string * string - -(**********************************************************************) -(* Entry keys for constr notations *) +(** Entry keys for constr notations *) type side = Left | Right type production_position = - | BorderProd of side * Gramext.g_assoc option + | BorderProd of side * gram_assoc option | InternalProd type production_level = @@ -45,21 +23,24 @@ type production_level = type ('lev,'pos) constr_entry_key_gen = | ETName | ETReference | ETBigint - | ETBinder of bool + | ETBinder of bool (* true=open, as in "fun .."; false as in "let f .. :=" *) | ETConstr of ('lev * 'pos) | ETPattern | ETOther of string * string - | ETConstrList of ('lev * 'pos) * Token.pattern list - | ETBinderList of bool * Token.pattern list + | ETConstrList of ('lev * 'pos) * Tok.t list + | ETBinderList of bool * Tok.t list + +(** Entries level (left-hand-side of grammar rules) *) -(* Entries level (left-hand-side of grammar rules) *) type constr_entry_key = (int,unit) constr_entry_key_gen -(* Entries used in productions (in right-hand side of grammar rules) *) +(** Entries used in productions (in right-hand side of grammar rules) *) + type constr_prod_entry_key = (production_level,production_position) constr_entry_key_gen -(* Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *) +(** Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *) + type simple_constr_prod_entry_key = (production_level,unit) constr_entry_key_gen diff --git a/parsing/extend.mli b/parsing/extend.mli index 269331c2..6b29fc74 100644 --- a/parsing/extend.mli +++ b/parsing/extend.mli @@ -1,42 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extend.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) +open Compat -open Util - -(**********************************************************************) -(* 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 'a prod_entry_key = - | Alist1 of 'a prod_entry_key - | Alist1sep of 'a prod_entry_key * string - | Alist0 of 'a prod_entry_key - | Alist0sep of 'a prod_entry_key * string - | Aopt of 'a prod_entry_key - | Amodifiers of 'a prod_entry_key - | Aself - | Anext - | Atactic of int - | Agram of 'a Gramext.g_entry - | Aentry of string * string - -(**********************************************************************) -(* Entry keys for constr notations *) +(** Entry keys for constr notations *) type side = Left | Right type production_position = - | BorderProd of side * Gramext.g_assoc option + | BorderProd of side * gram_assoc option | InternalProd type production_level = @@ -49,17 +26,20 @@ type ('lev,'pos) constr_entry_key_gen = | ETConstr of ('lev * 'pos) | ETPattern | ETOther of string * string - | ETConstrList of ('lev * 'pos) * Token.pattern list - | ETBinderList of bool * Token.pattern list + | ETConstrList of ('lev * 'pos) * Tok.t list + | ETBinderList of bool * Tok.t list + +(** Entries level (left-hand-side of grammar rules) *) -(* Entries level (left-hand-side of grammar rules) *) type constr_entry_key = (int,unit) constr_entry_key_gen -(* Entries used in productions (in right-hand-side of grammar rules) *) +(** Entries used in productions (in right-hand-side of grammar rules) *) + type constr_prod_entry_key = (production_level,production_position) constr_entry_key_gen -(* Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *) +(** Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *) + type simple_constr_prod_entry_key = (production_level,unit) constr_entry_key_gen diff --git a/parsing/extrawit.ml b/parsing/extrawit.ml index 94179d95..ce734622 100644 --- a/parsing/extrawit.ml +++ b/parsing/extrawit.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extrawit.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Util open Genarg diff --git a/parsing/extrawit.mli b/parsing/extrawit.mli index 9b0aac39..2d2eef37 100644 --- a/parsing/extrawit.mli +++ b/parsing/extrawit.mli @@ -1,20 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extrawit.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Util open Genarg open Tacexpr -(* This file defines extra argument types *) +(** This file defines extra argument types *) -(* Tactics as arguments *) +(** Tactics as arguments *) val tactic_main_level : int diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index e7d4684b..5d5f6e4d 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -1,26 +1,23 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo" i*) - -(* $Id: g_constr.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pp open Pcoq open Constr open Prim -open Rawterm +open Glob_term open Term open Names open Libnames open Topconstr - open Util +open Tok +open Compat let constr_kw = [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; @@ -28,7 +25,7 @@ let constr_kw = "Prop"; "Set"; "Type"; ".("; "_"; ".."; "`{"; "`("; "{|"; "|}" ] -let _ = List.iter (fun s -> Lexer.add_token("",s)) constr_kw +let _ = List.iter Lexer.add_keyword constr_kw let mk_cast = function (c,(_,None)) -> c @@ -36,7 +33,7 @@ let mk_cast = function let binders_of_lidents l = List.map (fun (loc, id) -> - LocalRawAssum ([loc, Name id], Default Rawterm.Explicit, + LocalRawAssum ([loc, Name id], Default Glob_term.Explicit, CHole (loc, Some (Evd.BinderType (Name id))))) l let mk_fixb (id,bl,ann,body,(loc,tyc)) = @@ -66,60 +63,49 @@ let mk_fix(loc,kw,id,dcls) = let mk_single_fix (loc,kw,dcl) = let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl]) +let err () = raise Stream.Failure + (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) let lpar_id_coloneq = Gram.Entry.of_parser "test_lpar_id_coloneq" (fun strm -> - match Stream.npeek 1 strm with - | [("","(")] -> - (match Stream.npeek 2 strm with - | [_; ("IDENT",s)] -> - (match Stream.npeek 3 strm with - | [_; _; ("", ":=")] -> - Stream.junk strm; Stream.junk strm; Stream.junk strm; + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT s -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ":=" -> + stream_njunk 3 strm; Names.id_of_string s - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) let impl_ident_head = Gram.Entry.of_parser "impl_ident_head" (fun strm -> - match Stream.npeek 1 strm with - | [(_,"{")] -> - (match Stream.npeek 2 strm with - | [_;("IDENT",("wf"|"struct"|"measure"))] -> - raise Stream.Failure - | [_;("IDENT",s)] -> - Stream.junk strm; Stream.junk strm; + match get_tok (stream_nth 0 strm) with + | KEYWORD "{" -> + (match get_tok (stream_nth 1 strm) with + | IDENT ("wf"|"struct"|"measure") -> err () + | IDENT s -> + stream_njunk 2 strm; Names.id_of_string s - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) + | _ -> err ()) + | _ -> err ()) let ident_colon = Gram.Entry.of_parser "ident_colon" (fun strm -> - match Stream.npeek 1 strm with - | [("IDENT",s)] -> - (match Stream.npeek 2 strm with - | [_; ("", ":")] -> - Stream.junk strm; Stream.junk strm; + match get_tok (stream_nth 0 strm) with + | IDENT s -> + (match get_tok (stream_nth 1 strm) with + | KEYWORD ":" -> + stream_njunk 2 strm; Names.id_of_string s - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -let ident_with = - Gram.Entry.of_parser "ident_with" - (fun strm -> - match Stream.npeek 1 strm with - | [("IDENT",s)] -> - (match Stream.npeek 2 strm with - | [_; ("", "with")] -> - Stream.junk strm; Stream.junk strm; - Names.id_of_string s - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) + | _ -> err ()) + | _ -> err ()) let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None @@ -147,9 +133,9 @@ GEXTEND Gram [ [ c = lconstr -> c ] ] ; sort: - [ [ "Set" -> RProp Pos - | "Prop" -> RProp Null - | "Type" -> RType None ] ] + [ [ "Set" -> GProp Pos + | "Prop" -> GProp Null + | "Type" -> GType None ] ] ; lconstr: [ [ c = operconstr LEVEL "200" -> c ] ] @@ -215,7 +201,7 @@ GEXTEND Gram [ [ "fun" -> () ] ] ; record_declaration: - [ [ fs = LIST1 record_field_declaration SEP ";" -> CRecord (loc, None, fs) + [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (loc, None, fs) (* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) (* CRecord (loc, Some c, fs) *) ] ] @@ -227,7 +213,7 @@ GEXTEND Gram binder_constr: [ [ forall; bl = open_binders; ","; c = operconstr LEVEL "200" -> mkCProdN loc bl c - | lambda; bl = open_binders; [ "=>" | "," ]; c = operconstr LEVEL "200" -> + | lambda; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> mkCLambdaN loc bl c | "let"; id=name; bl = binders; ty = type_cstr; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> @@ -334,14 +320,17 @@ GEXTEND Gram [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ] | "99" RIGHTA [ ] | "10" LEFTA + [ p = pattern; "as"; id = ident -> + CPatAlias (loc, p, id) ] + | "9" RIGHTA [ p = pattern; lp = LIST1 NEXT -> (match p with | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) | _ -> Util.user_err_loc (cases_pattern_expr_loc p, "compound_pattern", Pp.str "Constructor expected.")) - | p = pattern; "as"; id = ident -> - CPatAlias (loc, p, id) ] + |"@"; r = Prim.reference; lp = LIST1 NEXT -> + CPatCstrExpl (loc, r, lp) ] | "1" LEFTA [ c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ] | "0" diff --git a/parsing/g_decl_mode.ml4 b/parsing/g_decl_mode.ml4 deleted file mode 100644 index 8893ebcc..00000000 --- a/parsing/g_decl_mode.ml4 +++ /dev/null @@ -1,252 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) - -(* $Id: g_decl_mode.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - - -open Decl_expr -open Names -open Term -open Genarg -open Pcoq - -open Pcoq.Constr -open Pcoq.Tactic -open Pcoq.Vernac_ - -let none_is_empty = function - None -> [] - | Some l -> l - -GEXTEND Gram -GLOBAL: proof_instr; - thesis : - [[ "thesis" -> Plain - | "thesis"; "for"; i=ident -> (For i) - ]]; - statement : - [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} - | i=ident -> {st_label=Anonymous; - st_it=Topconstr.CRef (Libnames.Ident (loc, i))} - | c=constr -> {st_label=Anonymous;st_it=c} - ]]; - constr_or_thesis : - [[ t=thesis -> Thesis t ] | - [ c=constr -> This c - ]]; - statement_or_thesis : - [ - [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] - | - [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} - | i=ident -> {st_label=Anonymous; - st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))} - | c=constr -> {st_label=Anonymous;st_it=This c} - ] - ]; - justification_items : - [[ -> Some [] - | "by"; l=LIST1 constr SEP "," -> Some l - | "by"; "*" -> None ]] - ; - justification_method : - [[ -> None - | "using"; tac = tactic -> Some tac ]] - ; - simple_cut_or_thesis : - [[ ls = statement_or_thesis; - j = justification_items; - taco = justification_method - -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] - ; - simple_cut : - [[ ls = statement; - j = justification_items; - taco = justification_method - -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] - ; - elim_type: - [[ IDENT "induction" -> ET_Induction - | IDENT "cases" -> ET_Case_analysis ]] - ; - block_type : - [[ IDENT "claim" -> B_claim - | IDENT "focus" -> B_focus - | IDENT "proof" -> B_proof - | et=elim_type -> B_elim et ]] - ; - elim_obj: - [[ IDENT "on"; c=constr -> Real c - | IDENT "of"; c=simple_cut -> Virtual c ]] - ; - elim_step: - [[ IDENT "consider" ; - h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h) - | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj) - | IDENT "suffices"; ls=suff_clause; - j = justification_items; - taco = justification_method - -> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] - ; - rew_step : - [[ "~=" ; c=simple_cut -> (Rhs,c) - | "=~" ; c=simple_cut -> (Lhs,c)]] - ; - cut_step: - [[ "then"; tt=elim_step -> Pthen tt - | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c) - | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) - | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c) - | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c) - | tt=elim_step -> tt - | tt=rew_step -> let s,c=tt in Prew (s,c); - | IDENT "have"; c=simple_cut_or_thesis -> Pcut c; - | IDENT "claim"; c=statement -> Pclaim c; - | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c; - | "end"; bt = block_type -> Pend bt; - | IDENT "escape" -> Pescape ]] - ; - (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*) - loc_id: - [[ id=ident -> fun x -> (loc,(id,x)) ]]; - hyp: - [[ id=loc_id -> id None ; - | id=loc_id ; ":" ; c=constr -> id (Some c)]] - ; - consider_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=consider_vars -> (Hvar name) :: v - | name=hyp; - IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h - ]] - ; - consider_hyps: - [[ st=statement; IDENT "and"; h=consider_hyps -> Hprop st::h - | st=statement; IDENT "and"; - IDENT "consider" ; v=consider_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]] - ; - assume_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=assume_vars -> (Hvar name) :: v - | name=hyp; - IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h - ]] - ; - assume_hyps: - [[ st=statement; IDENT "and"; h=assume_hyps -> Hprop st::h - | st=statement; IDENT "and"; - IDENT "we"; IDENT "have" ; v=assume_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]] - ; - assume_clause: - [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v - | h=assume_hyps -> h ]] - ; - suff_vars: - [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> - [Hvar name],c - | name=hyp; ","; v=suff_vars -> - let (q,c) = v in ((Hvar name) :: q),c - | name=hyp; - IDENT "such"; IDENT "that"; h=suff_hyps -> - let (q,c) = h in ((Hvar name) :: q),c - ]]; - suff_hyps: - [[ st=statement; IDENT "and"; h=suff_hyps -> - let (q,c) = h in (Hprop st::q),c - | st=statement; IDENT "and"; - IDENT "to" ; IDENT "have" ; v=suff_vars -> - let (q,c) = v in (Hprop st::q),c - | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> - [Hprop st],c - ]] - ; - suff_clause: - [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v - | h=suff_hyps -> h ]] - ; - let_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=let_vars -> (Hvar name) :: v - | name=hyp; IDENT "be"; - IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h - ]] - ; - let_hyps: - [[ st=statement; IDENT "and"; h=let_hyps -> Hprop st::h - | st=statement; IDENT "and"; "let"; v=let_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]]; - given_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=given_vars -> (Hvar name) :: v - | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h - ]] - ; - given_hyps: - [[ st=statement; IDENT "and"; h=given_hyps -> Hprop st::h - | st=statement; IDENT "and"; IDENT "given"; v=given_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]]; - suppose_vars: - [[name=hyp -> [Hvar name] - |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v - |name=hyp; OPT[IDENT "be"]; - IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h - ]] - ; - suppose_hyps: - [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h - | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have"; - v=suppose_vars -> Hprop st::v - | st=statement_or_thesis -> [Hprop st] - ]] - ; - suppose_clause: - [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v; - | h=suppose_hyps -> h ]] - ; - intro_step: - [[ IDENT "suppose" ; h=assume_clause -> Psuppose h - | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ; - po=OPT[ "with"; p=LIST1 hyp SEP ","-> p ] ; - ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> - Pcase (none_is_empty po,c,none_is_empty ho) - | "let" ; v=let_vars -> Plet v - | IDENT "take"; witnesses = LIST1 constr SEP "," -> Ptake witnesses - | IDENT "assume"; h=assume_clause -> Passume h - | IDENT "given"; h=given_vars -> Pgiven h - | IDENT "define"; id=ident; args=LIST0 hyp; - "as"; body=constr -> Pdefine(id,args,body) - | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ) - | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ) - ]] - ; - emphasis : - [[ -> 0 - | "*" -> 1 - | "**" -> 2 - | "***" -> 3 - ]] - ; - bare_proof_instr: - [[ c = cut_step -> c ; - | i = intro_step -> i ]] - ; - proof_instr : - [[ e=emphasis;i=bare_proof_instr -> {emph=e;instr=i}]] - ; -END;; - - diff --git a/parsing/g_intsyntax.mli b/parsing/g_intsyntax.mli deleted file mode 100644 index de85b6af..00000000 --- a/parsing/g_intsyntax.mli +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - - -(*i $$ i*) - - -(* digit based syntax for int31 and bigint *) diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index dac4a135..2f129637 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -1,29 +1,26 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo" i*) - -(* $Id: g_ltac.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pp open Util open Topconstr -open Rawterm +open Glob_term open Tacexpr open Vernacexpr open Pcoq open Prim open Tactic +open Tok let fail_default_value = ArgArg 0 let arg_of_expr = function - TacArg a -> a + TacArg (loc,a) -> a | e -> Tacexp (e:raw_tactic_expr) (* Tactics grammar rules *) @@ -60,6 +57,7 @@ GEXTEND Gram | "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 "repeat"; ta = tactic_expr -> TacRepeat ta | IDENT "progress"; ta = tactic_expr -> TacProgress ta (*To do: put Abstract in Refiner*) @@ -87,20 +85,20 @@ GEXTEND Gram | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ]; l = LIST0 message_token -> TacFail (n,l) | IDENT "external"; com = STRING; req = STRING; la = LIST1 tactic_arg -> - TacArg (TacExternal (loc,com,req,la)) + TacArg (loc,TacExternal (loc,com,req,la)) | st = simple_tactic -> TacAtom (loc,st) - | a = may_eval_arg -> TacArg(a) + | a = may_eval_arg -> TacArg(loc,a) | IDENT "constr"; ":"; id = METAIDENT -> - TacArg(MetaIdArg (loc,false,id)) + TacArg(loc,MetaIdArg (loc,false,id)) | IDENT "constr"; ":"; c = Constr.constr -> - TacArg(ConstrMayEval(ConstrTerm c)) + TacArg(loc,ConstrMayEval(ConstrTerm c)) | IDENT "ipattern"; ":"; ipat = simple_intropattern -> - TacArg(IntroPattern ipat) + TacArg(loc,IntroPattern ipat) | r = reference; la = LIST0 tactic_arg -> - TacArg(TacCall (loc,r,la)) ] + TacArg(loc,TacCall (loc,r,la)) ] | "0" [ "("; a = tactic_expr; ")" -> a - | a = tactic_atom -> TacArg a ] ] + | a = tactic_atom -> TacArg (loc,a) ] ] ; (* binder_tactic: level 5 of tactic_expr *) binder_tactic: diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli deleted file mode 100644 index d3f12bed..00000000 --- a/parsing/g_natsyntax.mli +++ /dev/null @@ -1,15 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: g_natsyntax.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - -(* Nice syntax for naturals. *) - -open Notation - -val nat_of_int : Bigint.bigint prim_token_interpreter diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index c4fd3bb5..307e1779 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -1,22 +1,20 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo" i*) - -(*i $Id: g_prim.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pcoq open Names open Libnames open Topconstr +open Tok +open Compat let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"] -let _ = List.iter (fun s -> Lexer.add_token("",s)) prim_kw +let _ = List.iter Lexer.add_keyword prim_kw open Prim open Nametab @@ -45,7 +43,7 @@ GEXTEND Gram [ [ s = IDENT -> id_of_string s ] ] ; pattern_ident: - [ [ s = LEFTQMARK; id = ident -> id ] ] + [ [ LEFTQMARK; id = ident -> id ] ] ; pattern_identref: [ [ id = pattern_ident -> (loc, id) ] ] diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index f1dad3b2..9abb8cd1 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -1,16 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo" i*) - -(* $Id: g_proofs.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - - open Pcoq open Pp open Tactic @@ -20,6 +15,7 @@ open Topconstr open Vernacexpr open Prim open Constr +open Tok let thm_token = G_vernac.thm_token @@ -34,12 +30,19 @@ GEXTEND Gram ; opt_hintbases: [ [ -> [] - | ":"; l = LIST1 IDENT -> l ] ] + | ":"; l = LIST1 [id = IDENT -> id ] -> l ] ] ; command: [ [ IDENT "Goal"; c = lconstr -> VernacGoal c - | IDENT "Proof" -> VernacProof (Tacexpr.TacId []) - | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta + | IDENT "Proof" -> VernacProof (None,None) + | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn + | IDENT "Proof"; "with"; ta = tactic; + l = OPT [ "using"; l = LIST0 identref -> l ] -> + VernacProof (Some ta, l) + | IDENT "Proof"; "using"; l = LIST0 identref; + ta = OPT [ "with"; ta = tactic -> ta ] -> + VernacProof (ta,Some l) + | IDENT "Proof"; c = lconstr -> VernacExactProof c | IDENT "Abort" -> VernacAbort None | IDENT "Abort"; IDENT "All" -> VernacAbortAll | IDENT "Abort"; id = identref -> VernacAbort (Some id) @@ -59,15 +62,19 @@ GEXTEND Gram | IDENT "Resume" -> VernacResume None | IDENT "Resume"; id = identref -> VernacResume (Some id) | IDENT "Restart" -> VernacRestart - | IDENT "Proof"; c = lconstr -> VernacExactProof c | IDENT "Undo" -> VernacUndo 1 | IDENT "Undo"; n = natural -> VernacUndo n | IDENT "Undo"; IDENT "To"; n = natural -> VernacUndoTo n | IDENT "Focus" -> VernacFocus None | IDENT "Focus"; n = natural -> VernacFocus (Some n) | IDENT "Unfocus" -> VernacUnfocus - | IDENT "Show" -> VernacShow (ShowGoal None) - | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n)) + | IDENT "BeginSubproof" -> VernacSubproof None + | IDENT "BeginSubproof"; n = natural -> VernacSubproof (Some n) + | IDENT "EndSubproof" -> VernacEndSubproof + | IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals) + | IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n)) + | IDENT "Show"; IDENT "Goal"; n = string -> + VernacShow (ShowGoal (GoalId n)) | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> VernacShow (ShowGoalImplicitly n) | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode @@ -80,34 +87,22 @@ GEXTEND Gram | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true) | IDENT "Show"; IDENT "Match"; id = identref -> VernacShow (ShowMatch id) | IDENT "Show"; IDENT "Thesis" -> VernacShow ShowThesis - | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer -> - VernacShow (ExplainProof l) - | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> - VernacShow (ExplainTree l) - | IDENT "Go"; n = natural -> VernacGo (GoTo n) - | IDENT "Go"; IDENT "top" -> VernacGo GoTop - | IDENT "Go"; IDENT "prev" -> VernacGo GoPrev - | IDENT "Go"; IDENT "next" -> VernacGo GoNext | IDENT "Guarded" -> VernacCheckGuard -(* Hints for Auto and EAuto *) + (* Hints for Auto and EAuto *) | IDENT "Create"; IDENT "HintDb" ; id = IDENT ; b = [ "discriminated" -> true | -> false ] -> VernacCreateHintDb (use_module_locality (), id, b) + | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> + VernacRemoveHints (use_module_locality (), dbnames, ids) | IDENT "Hint"; local = obsolete_locality; h = hint; dbnames = opt_hintbases -> VernacHints (enforce_module_locality local,dbnames, h) - -(* Declare "Resolve" directly so as to be able to later extend with - "Resolve ->" and "Resolve <-" *) + (* Declare "Resolve" explicitly so as to be able to later extend with + "Resolve ->" and "Resolve <-" *) | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 constr; n = OPT natural; dbnames = opt_hintbases -> VernacHints (use_module_locality (),dbnames, HintsResolve (List.map (fun x -> (n, true, x)) lc)) - -(*This entry is not commented, only for debug*) - | IDENT "PrintConstr"; c = constr -> - VernacExtend ("PrintConstr", - [Genarg.in_gen Genarg.rawwit_constr c]) ] ]; obsolete_locality: @@ -134,6 +129,6 @@ GEXTEND Gram ; constr_body: [ [ ":="; c = lconstr -> c - | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Rawterm.CastConv (Term.DEFAULTcast,t)) ] ] + | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Glob_term.CastConv (Term.DEFAULTcast,t)) ] ] ; END diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index be20f891..f1b3ffed 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -1,122 +1,104 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo" i*) - -(* $Id: g_tactic.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pp open Pcoq open Util open Tacexpr -open Rawterm +open Glob_term open Genarg open Topconstr open Libnames open Termops +open Tok +open Compat let all_with delta = make_red_flag [FBeta;FIota;FZeta;delta] let tactic_kw = [ "->"; "<-" ; "by" ] -let _ = List.iter (fun s -> Lexer.add_token("",s)) tactic_kw +let _ = List.iter Lexer.add_keyword tactic_kw + +let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) let test_lpar_id_coloneq = Gram.Entry.of_parser "lpar_id_coloneq" (fun strm -> - match Stream.npeek 1 strm with - | [("","(")] -> - (match Stream.npeek 2 strm with - | [_; ("IDENT",s)] -> - (match Stream.npeek 3 strm with - | [_; _; ("", ":=")] -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) + 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" (fun strm -> - match Stream.npeek 1 strm with - | [("","(")] -> - (match Stream.npeek 2 strm with - | [_; (("IDENT"|"INT"),_)] -> - (match Stream.npeek 3 strm with - | [_; _; ("", ":=")] -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ | INT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) (* idem for (x:t) *) let test_lpar_id_colon = Gram.Entry.of_parser "lpar_id_colon" (fun strm -> - match Stream.npeek 1 strm with - | [("","(")] -> - (match Stream.npeek 2 strm with - | [_; ("IDENT",id)] -> - (match Stream.npeek 3 strm with - | [_; _; ("", ":")] -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) + 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 (x1..xn:t) [n^2 complexity but exceptional use] *) let check_for_coloneq = Gram.Entry.of_parser "lpar_id_colon" (fun strm -> let rec skip_to_rpar p n = - match list_last (Stream.npeek n strm) with - | ("","(") -> skip_to_rpar (p+1) (n+1) - | ("",")") -> if p=0 then n+1 else skip_to_rpar (p-1) (n+1) - | ("",".") -> raise Stream.Failure + match get_tok (list_last (Stream.npeek n strm)) with + | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) + | KEYWORD ")" -> if p=0 then n+1 else skip_to_rpar (p-1) (n+1) + | KEYWORD "." -> err () | _ -> skip_to_rpar p (n+1) in let rec skip_names n = - match list_last (Stream.npeek n strm) with - | ("IDENT",_) | ("","_") -> skip_names (n+1) - | ("",":") -> skip_to_rpar 0 (n+1) (* skip a constr *) - | _ -> raise Stream.Failure in + match get_tok (list_last (Stream.npeek n strm)) with + | IDENT _ | KEYWORD "_" -> skip_names (n+1) + | KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *) + | _ -> err () in let rec skip_binders n = - match list_last (Stream.npeek n strm) with - | ("","(") -> skip_binders (skip_names (n+1)) - | ("IDENT",_) | ("","_") -> skip_binders (n+1) - | ("",":=") -> () - | _ -> raise Stream.Failure in - match Stream.npeek 1 strm with - | [("","(")] -> skip_binders 2 - | _ -> raise Stream.Failure) - -let guess_lpar_ipat s strm = - match Stream.npeek 1 strm with - | [("","(")] -> - (match Stream.npeek 2 strm with - | [_; ("",("("|"["))] -> () - | [_; ("IDENT",_)] -> - (match Stream.npeek 3 strm with - | [_; _; ("", s')] when s = s' -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure - -let guess_lpar_coloneq = - Gram.Entry.of_parser "guess_lpar_coloneq" (guess_lpar_ipat ":=") - -let guess_lpar_colon = - Gram.Entry.of_parser "guess_lpar_colon" (guess_lpar_ipat ":") + match get_tok (list_last (Stream.npeek n strm)) with + | KEYWORD "(" -> skip_binders (skip_names (n+1)) + | IDENT _ | KEYWORD "_" -> skip_binders (n+1) + | KEYWORD ":=" -> () + | _ -> err () in + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> skip_binders 2 + | _ -> err ()) let lookup_at_as_coma = Gram.Entry.of_parser "lookup_at_as_coma" (fun strm -> - match Stream.npeek 1 strm with - | [("",(","|"at"|"as"))] -> () - | _ -> raise Stream.Failure) + match get_tok (stream_nth 0 strm) with + | KEYWORD (","|"at"|"as") -> () + | _ -> err ()) open Constr open Prim @@ -183,8 +165,8 @@ let mkCLambdaN_simple bl c = let loc_of_ne_list l = join_loc (fst (List.hd l)) (fst (list_last l)) let map_int_or_var f = function - | Rawterm.ArgArg x -> Rawterm.ArgArg (f x) - | Rawterm.ArgVar _ as y -> y + | Glob_term.ArgArg x -> Glob_term.ArgArg (f x) + | Glob_term.ArgVar _ as y -> y let all_concl_occs_clause = { onhyps=Some[]; concl_occs=all_occurrences_expr } @@ -222,12 +204,12 @@ GEXTEND Gram simple_intropattern; int_or_var: - [ [ n = integer -> Rawterm.ArgArg n - | id = identref -> Rawterm.ArgVar id ] ] + [ [ n = integer -> Glob_term.ArgArg n + | id = identref -> Glob_term.ArgVar id ] ] ; nat_or_var: - [ [ n = natural -> Rawterm.ArgArg n - | id = identref -> Rawterm.ArgVar id ] ] + [ [ n = natural -> Glob_term.ArgArg n + | id = identref -> Glob_term.ArgVar id ] ] ; (* An identifier or a quotation meta-variable *) id_or_meta: @@ -236,12 +218,6 @@ GEXTEND Gram (* This is used in quotations *) | id = METAIDENT -> MetaId (loc,id) ] ] ; - (* A number or a quotation meta-variable *) - num_or_meta: - [ [ n = integer -> AI n - | id = METAIDENT -> MetaId (loc,id) - ] ] - ; open_constr: [ [ c = constr -> ((),c) ] ] ; @@ -451,7 +427,7 @@ GEXTEND Gram ; hintbases: [ [ "with"; "*" -> None - | "with"; l = LIST1 IDENT -> Some l + | "with"; l = LIST1 [ x = IDENT -> x] -> Some l | -> Some [] ] ] ; auto_using: @@ -656,9 +632,9 @@ GEXTEND Gram | "exists"; bll = LIST1 opt_bindings SEP "," -> TacSplit (false,true,bll) | IDENT "eexists"; bll = LIST1 opt_bindings SEP "," -> TacSplit (true,true,bll) - | IDENT "constructor"; n = num_or_meta; l = with_bindings -> + | IDENT "constructor"; n = nat_or_var; l = with_bindings -> TacConstructor (false,n,l) - | IDENT "econstructor"; n = num_or_meta; l = with_bindings -> + | IDENT "econstructor"; n = nat_or_var; l = with_bindings -> TacConstructor (true,n,l) | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor (false,t) | IDENT "econstructor"; t = OPT tactic -> TacAnyConstructor (true,t) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index d761ed64..ac81786b 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1,30 +1,26 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo" i*) - -(* $Id: g_vernac.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - - open Pp +open Compat +open Tok open Util open Names open Topconstr open Extend open Vernacexpr open Pcoq -open Decl_mode open Tactic open Decl_kinds open Genarg open Ppextend open Goptions +open Declaremods open Prim open Constr @@ -32,39 +28,48 @@ open Vernac_ open Module let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ] -let _ = List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw +let _ = List.iter Lexer.add_keyword vernac_kw (* Rem: do not join the different GEXTEND into one, it breaks native *) (* compilation on PowerPC and Sun architectures *) -let check_command = Gram.Entry.create "vernac:check_command" +let check_command = Gram.entry_create "vernac:check_command" -let tactic_mode = Gram.Entry.create "vernac:tactic_command" -let proof_mode = Gram.Entry.create "vernac:proof_command" -let noedit_mode = Gram.Entry.create "vernac:noedit_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" -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 typeclass_context = Gram.Entry.create "vernac:typeclass_context" -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 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 subgoal_command = Gram.entry_create "proof_mode:subgoal_command" +let instance_name = Gram.entry_create "vernac:instance_name" -let get_command_entry () = - match Decl_mode.get_current_mode () with - Mode_proof -> proof_mode - | Mode_tactic -> tactic_mode - | Mode_none -> noedit_mode +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 +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 default_command_entry = Gram.Entry.of_parser "command_entry" - (fun strm -> Gram.Entry.parse_token (get_command_entry ()) strm) + (fun strm -> Gram.parse_tokens_after_filter (get_command_entry ()) strm) let no_hook _ _ = () GEXTEND Gram - GLOBAL: vernac gallina_ext tactic_mode proof_mode noedit_mode; + GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; vernac: FIRST [ [ IDENT "Time"; v = vernac -> VernacTime v | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) @@ -79,6 +84,7 @@ GEXTEND Gram | c = command; "." -> c | c = syntax; "." -> c | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l + | c = subprf -> c ] ] ; vernac_aux: LAST @@ -96,20 +102,27 @@ GEXTEND Gram [ [ gln = OPT[n=natural; ":" -> n]; tac = subgoal_command -> tac gln ] ] ; - subgoal_command: - [ [ c = check_command; "." -> c + + subprf: + [ [ + "-" -> VernacBullet Dash + | "*" -> VernacBullet Star + | "+" -> VernacBullet Plus + | "{" -> VernacSubproof None + | "}" -> VernacEndSubproof + ] ] + ; + + + + subgoal_command: + [ [ c = check_command; "." -> fun g -> c g | tac = Tactic.tactic; use_dft_tac = [ "." -> false | "..." -> true ] -> (fun g -> - let g = match g with Some gl -> gl | _ -> 1 in + let g = Option.default 1 g in VernacSolve(g,tac,use_dft_tac)) ] ] ; - proof_mode: - [ [ instr = proof_instr; "." -> VernacProofInstr instr ] ] - ; - proof_mode: LAST - [ [ c=subgoal_command -> c (Some 1) ] ] - ; located_vernac: [ [ v = vernac -> loc, v ] ] ; @@ -117,20 +130,20 @@ END let test_plurial_form = function | [(_,([_],_))] -> - Flags.if_verbose warning - "Keywords Variables/Hypotheses/Parameters expect more than one assumption" + Flags.if_verbose msg_warning + (str "Keywords Variables/Hypotheses/Parameters expect more than one assumption") | _ -> () let test_plurial_form_types = function | [([_],_)] -> - Flags.if_verbose warning - "Keywords Implicit Types expect more than one type" + Flags.if_verbose msg_warning + (str "Keywords Implicit Types expect more than one type") | _ -> () (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - typeclass_context typeclass_constraint record_field decl_notation; + typeclass_constraint record_field decl_notation rec_definition; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -144,10 +157,6 @@ GEXTEND Gram | stre = assumptions_token; nl = inline; bl = assum_list -> test_plurial_form bl; VernacAssumption (stre, nl, bl) - | IDENT "Boxed";"Definition";id = identref; b = def_body -> - VernacDefinition ((Global,true,Definition), id, b, no_hook) - | IDENT "Unboxed";"Definition";id = identref; b = def_body -> - VernacDefinition ((Global,false,Definition), id, b, no_hook) | (f,d) = def_token; id = identref; b = def_body -> VernacDefinition (d, id, b, f) (* Gallina inductive declarations *) @@ -156,14 +165,10 @@ GEXTEND Gram let (k,f) = f in let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in VernacInductive (f,false,indl) - | IDENT "Boxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (recs,true) - | IDENT "Unboxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (recs,false) - | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (recs,Flags.boxed_definitions()) + | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + VernacFixpoint recs | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint (corecs,false) + VernacCoFixpoint 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) ] ] @@ -178,10 +183,6 @@ GEXTEND Gram VernacInductive (indf,infer,[((oc,name),ps,s,recf,cfs),[]]) ] ] ; - typeclass_context: - [ [ "["; l=LIST1 typeclass_constraint SEP ","; "]" -> l - | -> [] ] ] - ; thm_token: [ [ "Theorem" -> Theorem | IDENT "Lemma" -> Lemma @@ -193,13 +194,13 @@ GEXTEND Gram ; def_token: [ [ "Definition" -> - no_hook, (Global, Flags.boxed_definitions(), Definition) + no_hook, (Global, Definition) | IDENT "Let" -> - no_hook, (Local, Flags.boxed_definitions(), Definition) + no_hook, (Local, Definition) | IDENT "Example" -> - no_hook, (Global, Flags.boxed_definitions(), Example) + no_hook, (Global, Example) | IDENT "SubClass" -> - Class.add_subclass_hook, (use_locality_exp (), false, SubClass) ] ] + Class.add_subclass_hook, (use_locality_exp (), SubClass) ] ] ; assumption_token: [ [ "Hypothesis" -> (Local, Logical) @@ -215,7 +216,9 @@ GEXTEND Gram | IDENT "Parameters" -> (Global, Definitional) ] ] ; inline: - [ ["Inline" -> true | -> false] ] + [ [ IDENT "Inline"; "("; i = INT; ")" -> Some (int_of_string i) + | IDENT "Inline" -> Some (Flags.get_inline_level()) + | -> None] ] ; finite_token: [ [ "Inductive" -> (Inductive_kw,Finite) @@ -233,7 +236,7 @@ GEXTEND Gram def_body: [ [ bl = binders; ":="; red = reduce; c = lconstr -> (match c with - CCast(_,c, Rawterm.CastConv (Term.DEFAULTcast,t)) -> DefineBody (bl, red, c, Some t) + CCast(_,c, Glob_term.CastConv (Term.DEFAULTcast,t)) -> DefineBody (bl, red, c, Some t) | _ -> DefineBody (bl, red, c, None)) | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> DefineBody (bl, red, c, Some t) @@ -325,7 +328,8 @@ GEXTEND Gram *) (* ... with coercions *) record_field: - [ [ bd = record_binder; ntn = decl_notation -> bd,ntn ] ] + [ [ bd = record_binder; pri = OPT [ "|"; n = natural -> n ]; + ntn = decl_notation -> (bd,pri),ntn ] ] ; record_binder_body: [ [ l = binders; oc = of_type_with_opt_coercion; @@ -335,13 +339,13 @@ GEXTEND Gram (oc,DefExpr (id,mkCLambdaN loc l b,Some (mkCProdN loc l t))) | l = binders; ":="; b = lconstr -> fun id -> match b with - | CCast(_,b, Rawterm.CastConv (_, t)) -> - (false,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t))) + | CCast(_,b, Glob_term.CastConv (_, t)) -> + (None,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t))) | _ -> - (false,DefExpr(id,mkCLambdaN loc l b,None)) ] ] + (None,DefExpr(id,mkCLambdaN loc l b,None)) ] ] ; record_binder: - [ [ id = name -> (false,AssumExpr(id,CHole (loc, None))) + [ [ id = name -> (None,AssumExpr(id,CHole (loc, None))) | id = name; f = record_binder_body -> f id ] ] ; assum_list: @@ -352,13 +356,13 @@ GEXTEND Gram ; simple_assum_coe: [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> - (oc,(idl,c)) ] ] + (oc <> None,(idl,c)) ] ] ; constructor_type: [[ l = binders; t= [ coe = of_type_with_opt_coercion; c = lconstr -> - fun l id -> (coe,(id,mkCProdN loc l c)) + fun l id -> (coe <> None,(id,mkCProdN loc l c)) | -> fun l id -> (false,(id,mkCProdN loc l (CHole (loc, None)))) ] -> t l @@ -369,9 +373,12 @@ GEXTEND Gram [ [ id = identref; c=constructor_type -> c id ] ] ; of_type_with_opt_coercion: - [ [ ":>" -> true - | ":"; ">" -> true - | ":" -> false ] ] + [ [ ":>>" -> Some false + | ":>"; ">" -> Some false + | ":>" -> Some true + | ":"; ">"; ">" -> Some false + | ":"; ">" -> Some true + | ":" -> None ] ] ; END @@ -410,7 +417,8 @@ GEXTEND Gram | IDENT "Include"; e = module_expr_inl; l = LIST0 ext_module_expr -> VernacInclude(e::l) | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type -> - warning "Include Type is deprecated; use Include instead"; + Flags.if_verbose + msg_warning (str "Include Type is deprecated; use Include instead"); VernacInclude(e::l) ] ] ; export_token: @@ -442,13 +450,33 @@ GEXTEND Gram [ [ ":="; 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], [] + | IDENT "scope"; sc1 = IDENT; IDENT "to"; sc2 = IDENT -> [], [sc1,sc2] + ] ] + ; + functor_app_annots: + [ [ "["; l = LIST1 functor_app_annot SEP ","; "]" -> + let inl,scs = List.split l in + let inl = match List.concat inl with + | [] -> DefaultInline + | [inl] -> inl + | _ -> error "Functor application with redundant inline annotations" + in { ann_inline = inl; ann_scope_subst = List.concat scs } + | -> { ann_inline = DefaultInline; ann_scope_subst = [] } + ] ] + ; module_expr_inl: - [ [ "!"; me = module_expr -> (me,false) - | me = module_expr -> (me,true) ] ] + [ [ "!"; me = module_expr -> + (me, { ann_inline = NoInline; ann_scope_subst = []}) + | me = module_expr; a = functor_app_annots -> (me,a) ] ] ; module_type_inl: - [ [ "!"; me = module_type -> (me,false) - | me = module_type -> (me,true) ] ] + [ [ "!"; me = module_type -> + (me, { ann_inline = NoInline; ann_scope_subst = []}) + | me = module_type; a = functor_app_annots -> (me,a) ] ] ; (* Module binder *) module_binder: @@ -458,7 +486,7 @@ GEXTEND Gram (* Module expressions *) module_expr: [ [ me = module_expr_atom -> me - | me1 = module_expr; me2 = module_expr_atom -> CMapply (me1,me2) + | me1 = module_expr; me2 = module_expr_atom -> CMapply (loc,me1,me2) ] ] ; module_expr_atom: @@ -474,8 +502,9 @@ GEXTEND Gram module_type: [ [ qid = qualid -> CMident qid | "("; mt = module_type; ")" -> mt - | mty = module_type; me = module_expr_atom -> CMapply (mty,me) - | mty = module_type; "with"; decl = with_declaration -> CMwith (mty,decl) + | mty = module_type; me = module_expr_atom -> CMapply (loc,mty,me) + | mty = module_type; "with"; decl = with_declaration -> + CMwith (loc,mty,decl) ] ] ; END @@ -502,16 +531,16 @@ GEXTEND Gram d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition - ((Global,false,CanonicalStructure),(dummy_loc,s),d, + ((Global,CanonicalStructure),(dummy_loc,s),d, (fun _ -> Recordops.declare_canonical_structure)) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((use_locality_exp (),false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + VernacDefinition ((use_locality_exp (),Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((enforce_locality_exp true,false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + VernacDefinition ((enforce_locality_exp true,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (enforce_locality_exp true, f, s, t) @@ -535,22 +564,75 @@ GEXTEND Gram VernacContext c | IDENT "Instance"; namesup = instance_name; ":"; - expl = [ "!" -> Rawterm.Implicit | -> Rawterm.Explicit ] ; t = operconstr LEVEL "200"; + expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200"; pri = OPT [ "|"; i = natural -> i ] ; - props = [ ":="; "{"; r = record_declaration; "}" -> r | - ":="; c = lconstr -> c | -> CRecord (loc, None, []) ] -> - VernacInstance (false, not (use_non_locality ()), + props = [ ":="; "{"; r = record_declaration; "}" -> Some r | + ":="; c = lconstr -> Some c | -> None ] -> + VernacInstance (false, not (use_section_locality ()), snd namesup, (fst namesup, expl, t), props, pri) - | IDENT "Existing"; IDENT "Instance"; is = global -> - VernacDeclareInstance (not (use_section_locality ()), is) + | IDENT "Existing"; IDENT "Instance"; id = global -> + VernacDeclareInstances (not (use_section_locality ()), [id]) + | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global -> + VernacDeclareInstances (not (use_section_locality ()), ids) | IDENT "Existing"; IDENT "Class"; is = global -> VernacDeclareClass is + (* Arguments *) + | IDENT "Arguments"; qid = smart_global; + impl = LIST1 [ l = LIST0 + [ item = argument_spec -> + let id, r, s = item in [`Id (id,r,s,false,false)] + | "/" -> [`Slash] + | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> + let f x = match sc, x with + | None, x -> x | x, None -> Option.map (fun y -> loc, y) x + | Some _, Some _ -> error "scope declared twice" in + List.map (fun (id,r,s) -> `Id(id,r,f s,false,false)) items + | "["; items = LIST1 argument_spec; "]"; sc = OPT scope -> + let f x = match sc, x with + | None, x -> x | x, None -> Option.map (fun y -> loc, y) x + | Some _, Some _ -> error "scope declared twice" in + List.map (fun (id,r,s) -> `Id(id,r,f s,true,false)) items + | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope -> + let f x = match sc, x with + | None, x -> x | x, None -> Option.map (fun y -> loc, y) x + | Some _, Some _ -> error "scope declared twice" in + List.map (fun (id,r,s) -> `Id(id,r,f s,true,true)) items + ] -> l ] SEP ","; + mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> l ] -> + let mods = match mods with None -> [] | Some l -> List.flatten l in + let impl = List.map List.flatten impl in + let rec aux n (narg, impl) = function + | `Id x :: tl -> aux (n+1) (narg, impl@[x]) tl + | `Slash :: tl -> aux (n+1) (n, impl) tl + | [] -> narg, impl in + let nargs, impl = List.split (List.map (aux 0 (-1, [])) impl) in + let nargs, rest = List.hd nargs, List.tl nargs in + if List.exists ((<>) nargs) rest then + error "All arguments lists must have the same length"; + let err_incompat x y = + error ("Options \""^x^"\" and \""^y^"\" are incompatible") in + if nargs > 0 && List.mem `SimplNeverUnfold mods then + err_incompat "simpl never" "/"; + if List.mem `SimplNeverUnfold mods && + List.mem `SimplDontExposeCase mods then + err_incompat "simpl never" "simpl nomatch"; + VernacArguments (use_section_locality(), qid, impl, nargs, mods) + + (* moved there so that camlp5 factors it with the previous rule *) + | IDENT "Arguments"; IDENT "Scope"; qid = smart_global; + "["; scl = LIST0 [ "_" -> None | sc = IDENT -> Some sc ]; "]" -> + Flags.if_verbose + msg_warning (str "Arguments Scope is deprecated; use Arguments instead"); + VernacArgumentsScope (use_section_locality (),qid,scl) + (* Implicit *) | IDENT "Implicit"; IDENT "Arguments"; qid = smart_global; pos = LIST0 [ "["; l = LIST0 implicit_name; "]" -> List.map (fun (id,b,f) -> (ExplByName id,b,f)) l ] -> + Flags.if_verbose + msg_warning (str "Implicit Arguments is deprecated; use Arguments instead"); VernacDeclareImplicits (use_section_locality (),qid,pos) | IDENT "Implicit"; "Type"; bl = reserv_list -> @@ -567,12 +649,33 @@ GEXTEND Gram idl = LIST1 identref -> Some idl ] -> VernacGeneralizable (use_non_locality (), gen) ] ] ; + arguments_modifier: + [ [ IDENT "simpl"; IDENT "nomatch" -> [`SimplDontExposeCase] + | IDENT "simpl"; IDENT "never" -> [`SimplNeverUnfold] + | IDENT "default"; IDENT "implicits" -> [`DefaultImplicits] + | IDENT "clear"; IDENT "implicits" -> [`ClearImplicits] + | IDENT "clear"; IDENT "scopes" -> [`ClearScopes] + | IDENT "rename" -> [`Rename] + | IDENT "clear"; IDENT "scopes"; IDENT "and"; IDENT "implicits" -> + [`ClearImplicits; `ClearScopes] + | IDENT "clear"; IDENT "implicits"; IDENT "and"; IDENT "scopes" -> + [`ClearImplicits; `ClearScopes] + ] ] + ; implicit_name: [ [ "!"; id = ident -> (id, false, true) | id = ident -> (id,false,false) | "["; "!"; id = ident; "]" -> (id,true,true) | "["; id = ident; "]" -> (id,true, false) ] ] ; + scope: + [ [ "%"; key = IDENT -> key ] ] + ; + argument_spec: [ + [ b = OPT "!"; id = name ; s = OPT scope -> + snd id, b <> None, Option.map (fun x -> loc, x) s + ] + ]; strategy_level: [ [ IDENT "expand" -> Conv_oracle.Expand | IDENT "opaque" -> Conv_oracle.Opaque @@ -606,11 +709,11 @@ GEXTEND Gram (* Hack! Should be in grammar_ext, but camlp4 factorize badly *) | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; - expl = [ "!" -> Rawterm.Implicit | -> Rawterm.Explicit ] ; t = operconstr LEVEL "200"; + expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200"; pri = OPT [ "|"; i = natural -> i ] -> - VernacInstance (true, not (use_non_locality ()), + VernacInstance (true, not (use_section_locality ()), snd namesup, (fst namesup, expl, t), - CRecord (loc, None, []), pri) + None, pri) (* System directory *) | IDENT "Pwd" -> VernacChdir None @@ -627,9 +730,6 @@ GEXTEND Gram | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string -> VernacDeclareMLModule (use_locality (), l) - | IDENT "Dump"; IDENT "Universes"; fopt = OPT ne_string -> - error "This command is deprecated, use Print Universes" - | IDENT "Locate"; l = locatable -> VernacLocate l (* Managing load paths *) @@ -668,18 +768,11 @@ GEXTEND Gram VernacSearch (SearchPattern c, l) | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules -> VernacSearch (SearchRewrite c, l) - | IDENT "SearchAbout"; - sl = [ "["; - l = LIST1 [ - b = positive_search_mark; s = ne_string; sc = OPT scope - -> b, SearchString (s,sc) - | b = positive_search_mark; p = constr_pattern - -> b, SearchSubPattern p - ]; "]" -> l - | p = constr_pattern -> [true,SearchSubPattern p] - | s = ne_string; sc = OPT scope -> [true,SearchString (s,sc)] ]; - l = in_or_out_modules -> - VernacSearch (SearchAbout sl, l) + | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries -> + let (sl,m) = l in VernacSearch (SearchAbout (s::sl), m) + (* compatibility format of SearchAbout, with "[ ... ]" *) + | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]"; + l = in_or_out_modules -> VernacSearch (SearchAbout sl, l) | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string -> VernacAddMLPath (false, dir) @@ -714,16 +807,13 @@ GEXTEND Gram | 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) - - | IDENT "proof" -> VernacDeclProof - | "return" -> VernacReturn ]] + VernacRemoveOption ([table], v) ]] ; check_command: (* TODO: rapprocher Eval et Check *) [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr -> fun g -> VernacCheckMayEval (Some r, g, c) | IDENT "Compute"; c = lconstr -> - fun g -> VernacCheckMayEval (Some Rawterm.CbvVm, g, c) + fun g -> VernacCheckMayEval (Some Glob_term.CbvVm, g, c) | IDENT "Check"; c = lconstr -> fun g -> VernacCheckMayEval (None, g, c) ] ] ; @@ -758,9 +848,10 @@ GEXTEND Gram | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s | IDENT "Scopes" -> PrintScopes | IDENT "Scope"; s = IDENT -> PrintScope s - | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s + | IDENT "Visibility"; s = OPT [x = IDENT -> x ] -> PrintVisibility s | IDENT "Implicit"; qid = smart_global -> PrintImplicit qid - | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses fopt + | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (false, fopt) + | IDENT "Sorted"; IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (true, fopt) | IDENT "Assumptions"; qid = smart_global -> PrintAssumptions (false, qid) | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, qid) ] ] ; @@ -777,7 +868,7 @@ GEXTEND Gram | IDENT "Ltac"; qid = global -> LocateTactic qid ] ] ; option_value: - [ [ n = integer -> IntValue n + [ [ n = integer -> IntValue (Some n) | s = STRING -> StringValue s ] ] ; option_ref_value: @@ -785,14 +876,17 @@ GEXTEND Gram | s = STRING -> StringRefValue s ] ] ; option_table: - [ [ fl = LIST1 IDENT -> fl ]] + [ [ fl = LIST1 [ x = IDENT -> x ] -> fl ]] ; as_dirpath: [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ] ; - in_or_out_modules: + ne_in_or_out_modules: [ [ IDENT "inside"; l = LIST1 global -> SearchInside l - | IDENT "outside"; l = LIST1 global -> SearchOutside l + | IDENT "outside"; l = LIST1 global -> SearchOutside l ] ] + ; + in_or_out_modules: + [ [ m = ne_in_or_out_modules -> m | -> SearchOutside [] ] ] ; comment: @@ -806,6 +900,20 @@ GEXTEND Gram 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 []) + ] ] + ; END; GEXTEND Gram @@ -862,10 +970,6 @@ GEXTEND Gram | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) - | IDENT "Arguments"; IDENT "Scope"; qid = smart_global; - "["; scl = LIST0 opt_scope; "]" -> - VernacArgumentsScope (use_section_locality (),qid,scl) - | IDENT "Infix"; local = obsolete_locality; op = ne_lstring; ":="; p = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; @@ -912,16 +1016,17 @@ GEXTEND Gram | IDENT "next"; IDENT "level" -> NextLevel ] ] ; syntax_modifier: - [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) - | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; + [ [ "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 "parsing" -> SetOnlyParsing + | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s + | x = IDENT; ","; l = LIST1 [id = IDENT -> id ] SEP ","; "at"; lev = level -> SetItemLevel (x::l,lev) - | "at"; IDENT "level"; n = natural -> SetLevel n - | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA - | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA - | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA + | x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) - | IDENT "only"; IDENT "parsing" -> SetOnlyParsing - | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s ] ] + ] ] ; syntax_extension_type: [ [ IDENT "ident" -> ETName | IDENT "global" -> ETReference @@ -930,9 +1035,6 @@ GEXTEND Gram | IDENT "closed"; IDENT "binder" -> ETBinder false ] ] ; - opt_scope: - [ [ "_" -> None | sc = IDENT -> Some sc ] ] - ; production_item: [ [ s = ne_string -> TacTerm s | nt = IDENT; diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index b8fee3ff..c9e135ed 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -1,27 +1,24 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo" i*) - -(* $Id: g_xml.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pp open Util open Names open Term open Pcoq -open Rawterm +open Glob_term open Genarg open Tacexpr open Libnames open Nametab open Detyping +open Tok (* Generic xml parser without raw data *) @@ -33,7 +30,7 @@ let check_tags loc otag ctag = user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ str "does not match open xml tag " ++ str otag ++ str ".") -let xml_eoi = (Gram.Entry.create "xml_eoi" : xml Gram.Entry.e) +let xml_eoi = (Gram.entry_create "xml_eoi" : xml Gram.entry) GEXTEND Gram GLOBAL: xml_eoi; @@ -98,9 +95,9 @@ let inductive_of_cdata a = match global_of_cdata a with let ltacref_of_cdata (loc,a) = (loc,locate_tactic (uri_of_data a)) let sort_of_cdata (loc,a) = match a with - | "Prop" -> RProp Null - | "Set" -> RProp Pos - | "Type" -> RType None + | "Prop" -> GProp Null + | "Set" -> GProp Pos + | "Type" -> GType None | _ -> user_err_loc (loc,"",str "sort expected.") let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al) @@ -138,63 +135,64 @@ let compute_branches_lengths ind = let compute_inductive_nargs ind = Inductiveops.inductive_nargs (Global.env()) ind -(* Interpreting constr as a rawconstr *) +(* Interpreting constr as a glob_constr *) let rec interp_xml_constr = function | XmlTag (loc,"REL",al,[]) -> - RVar (loc, get_xml_ident al) + GVar (loc, get_xml_ident al) | XmlTag (loc,"VAR",al,[]) -> error "XML parser: unable to interp free variables" | XmlTag (loc,"LAMBDA",al,(_::_ as xl)) -> let body,decls = list_sep_last xl in let ctx = List.map interp_xml_decl decls in - List.fold_right (fun (na,t) b -> RLambda (loc, na, Explicit, t, b)) + List.fold_right (fun (na,t) b -> GLambda (loc, na, Explicit, t, b)) ctx (interp_xml_target body) | XmlTag (loc,"PROD",al,(_::_ as xl)) -> let body,decls = list_sep_last xl in let ctx = List.map interp_xml_decl decls in - List.fold_right (fun (na,t) b -> RProd (loc, na, Explicit, t, b)) + List.fold_right (fun (na,t) b -> GProd (loc, na, Explicit, t, b)) ctx (interp_xml_target body) | XmlTag (loc,"LETIN",al,(_::_ as xl)) -> let body,defs = list_sep_last xl in let ctx = List.map interp_xml_def defs in - List.fold_right (fun (na,t) b -> RLetIn (loc, na, t, b)) + List.fold_right (fun (na,t) b -> GLetIn (loc, na, t, b)) ctx (interp_xml_target body) | XmlTag (loc,"APPLY",_,x::xl) -> - RApp (loc, interp_xml_constr x, List.map interp_xml_constr xl) + GApp (loc, interp_xml_constr x, List.map interp_xml_constr xl) | XmlTag (loc,"instantiate",_, (XmlTag (_,("CONST"|"MUTIND"|"MUTCONSTRUCT"),_,_) as x)::xl) -> - RApp (loc, interp_xml_constr x, List.map interp_xml_arg xl) + GApp (loc, interp_xml_constr x, List.map interp_xml_arg xl) | XmlTag (loc,"META",al,xl) -> - REvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl)) + GEvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl)) | XmlTag (loc,"CONST",al,[]) -> - RRef (loc, ConstRef (get_xml_constant al)) + GRef (loc, ConstRef (get_xml_constant al)) | XmlTag (loc,"MUTCASE",al,x::y::yl) -> let ind = get_xml_inductive al in let p = interp_xml_patternsType x in let tm = interp_xml_inductiveTerm y in - let brs = List.map interp_xml_pattern yl in - let brns = Array.to_list (compute_branches_lengths ind) in - let mat = simple_cases_matrix_of_branches ind brns brs in + let vars = compute_branches_lengths ind in + let brs = list_map_i (fun i c -> (i,vars.(i),interp_xml_pattern c)) 0 yl + in + let mat = simple_cases_matrix_of_branches ind brs in let nparams,n = compute_inductive_nargs ind in let nal,rtn = return_type_of_predicate ind nparams n p in - RCases (loc,RegularStyle,rtn,[tm,nal],mat) + GCases (loc,RegularStyle,rtn,[tm,nal],mat) | XmlTag (loc,"MUTIND",al,[]) -> - RRef (loc, IndRef (get_xml_inductive al)) + GRef (loc, IndRef (get_xml_inductive al)) | XmlTag (loc,"MUTCONSTRUCT",al,[]) -> - RRef (loc, ConstructRef (get_xml_constructor al)) + GRef (loc, ConstructRef (get_xml_constructor al)) | XmlTag (loc,"FIX",al,xl) -> let li,lnct = List.split (List.map interp_xml_FixFunction xl) in let ln,lc,lt = list_split3 lnct in let lctx = List.map (fun _ -> []) ln in - RRec (loc, RFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, Array.of_list lctx, Array.of_list lc, Array.of_list lt) + GRec (loc, GFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, Array.of_list lctx, Array.of_list lc, Array.of_list lt) | XmlTag (loc,"COFIX",al,xl) -> let ln,lc,lt = list_split3 (List.map interp_xml_CoFixFunction xl) in - RRec (loc, RCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt) + GRec (loc, GCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt) | XmlTag (loc,"CAST",al,[x1;x2]) -> - RCast (loc, interp_xml_term x1, CastConv (DEFAULTcast, interp_xml_type x2)) + GCast (loc, interp_xml_term x1, CastConv (DEFAULTcast, interp_xml_type x2)) | XmlTag (loc,"SORT",al,[]) -> - RSort (loc, get_xml_sort al) + GSort (loc, get_xml_sort al) | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s ++ str ".") @@ -232,15 +230,15 @@ and interp_xml_recursionOrder x = let (locs, s) = get_xml_attr "type" al in match s with "Structural" -> - (match l with [] -> RStructRec + (match l with [] -> GStructRec | _ -> error_expect_no_argument loc) | "WellFounded" -> (match l with - [c] -> RWfRec (interp_xml_type c) + [c] -> GWfRec (interp_xml_type c) | _ -> error_expect_one_argument loc) | "Measure" -> (match l with - [m;r] -> RMeasureRec (interp_xml_type m, Some (interp_xml_type r)) + [m;r] -> GMeasureRec (interp_xml_type m, Some (interp_xml_type r)) | _ -> error_expect_two_arguments loc) | _ -> user_err_loc (locs,"",str "Invalid recursion order.") @@ -252,7 +250,7 @@ and interp_xml_FixFunction x = interp_xml_recursionOrder x1), (get_xml_name al, interp_xml_type x2, interp_xml_body x3)) | (loc,al,[x1;x2]) -> - ((Some (nmtoken (get_xml_attr "recIndex" al)), RStructRec), + ((Some (nmtoken (get_xml_attr "recIndex" al)), GStructRec), (get_xml_name al, interp_xml_type x1, interp_xml_body x2)) | (loc,_,_) -> error_expect_one_argument loc @@ -277,5 +275,5 @@ let rec interp_xml_tactic_arg = function let parse_tactic_arg ch = interp_xml_tactic_arg - (Pcoq.Gram.Entry.parse xml_eoi - (Pcoq.Gram.parsable (Stream.of_channel ch))) + (Pcoq.Gram.entry_parse xml_eoi + (Pcoq.Gram.parsable (Stream.of_channel ch))) diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli deleted file mode 100644 index 05c161c2..00000000 --- a/parsing/g_zsyntax.mli +++ /dev/null @@ -1,11 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: g_zsyntax.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - -(* Nice syntax for integers. *) diff --git a/parsing/grammar.mllib b/parsing/grammar.mllib index 248a8ad9..ba393e63 100644 --- a/parsing/grammar.mllib +++ b/parsing/grammar.mllib @@ -8,12 +8,15 @@ Flags Segmenttree Unicodetable Util +Errors Bigint Dyn Hashcons Predicate Rtree Option +Store +Hashtbl_alt Names Univ @@ -58,13 +61,14 @@ Namegen Evd Reductionops Inductiveops -Rawterm +Glob_term Detyping Pattern Topconstr Genarg Ppextend Tacexpr +Tok Lexer Extend Vernacexpr diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index 3eb27abb..eed6caea 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -4,4 +4,3 @@ G_prim G_proofs G_tactic G_ltac -G_decl_mode diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 50349e22..e351061d 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -1,20 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pr_o.cmo pa_macro.cmo" i*) -(* Add pr_o.cmo to circumvent a useless-warning bug when preprocessed with - * ast-based camlp4 *) - -(*i $Id: lexer.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pp open Util -open Token +open Compat +open Tok (* Dictionaries: trees annotated with string options, each node being a map from chars to dictionaries (the subtrees). A trie, in other words. *) @@ -76,18 +71,37 @@ let ttree_remove ttree str = (* Errors occuring while lexing (explained as "Lexer error: ...") *) -type error = - | Illegal_character - | Unterminated_comment - | Unterminated_string - | Undefined_token - | Bad_token of string +module Error = struct + + type t = + | Illegal_character + | Unterminated_comment + | Unterminated_string + | Undefined_token + | Bad_token of string + | UnsupportedUnicode of int + + exception E of t + + let to_string x = + "Syntax Error: Lexer: " ^ + (match x with + | Illegal_character -> "Illegal character" + | Unterminated_comment -> "Unterminated comment" + | Unterminated_string -> "Unterminated string" + | Undefined_token -> "Undefined token" + | Bad_token tok -> Format.sprintf "Bad token %S" tok + | UnsupportedUnicode x -> + Printf.sprintf "Unsupported Unicode character (0x%x)" x) -exception Error of error + let print ppf x = Format.fprintf ppf "%s@." (to_string x) -let err loc str = Stdpp.raise_with_loc (Util.make_loc loc) (Error str) +end +open Error -let bad_token str = raise (Error (Bad_token str)) +let err loc str = Loc.raise (make_loc loc) (Error.E str) + +let bad_token str = raise (Error.E (Bad_token str)) (* Lexer conventions on tokens *) @@ -96,9 +110,9 @@ type token_kind = | AsciiChar | EmptyStream -let error_unsupported_unicode_character n cs = +let error_unsupported_unicode_character n unicode cs = let bp = Stream.count cs in - err (bp,bp+n) (Bad_token "Unsupported Unicode character") + err (bp,bp+n) (UnsupportedUnicode unicode) let error_utf8 cs = let bp = Stream.count cs in @@ -147,7 +161,8 @@ let lookup_utf8_tail c cs = | _ -> error_utf8 cs in try classify_unicode unicode, n - with UnsupportedUtf8 -> njunk n cs; error_unsupported_unicode_character n cs + with UnsupportedUtf8 -> + njunk n cs; error_unsupported_unicode_character n unicode cs let lookup_utf8 cs = match Stream.peek cs with @@ -155,14 +170,26 @@ let lookup_utf8 cs = | Some ('\x80'..'\xFF' as c) -> Utf8Token (lookup_utf8_tail c cs) | None -> EmptyStream -let check_special_token str = +let unlocated f x = + try f x with Loc.Exc_located (_,exc) -> raise exc + +let check_keyword str = let rec loop_symb = parser | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str - | [< _ = Stream.empty >] -> () - | [< '_ ; s >] -> loop_symb s + | [< s >] -> + match unlocated lookup_utf8 s with + | Utf8Token (_,n) -> njunk n s; loop_symb s + | AsciiChar -> Stream.junk s; loop_symb s + | EmptyStream -> () in loop_symb (Stream.of_string str) +let check_keyword_to_add s = + try check_keyword s + with Error.E (UnsupportedUnicode unicode) -> + Flags.if_verbose msg_warning + (strbrk (Printf.sprintf "Token '%s' contains unicode character 0x%x which will not be parsable." s unicode)) + let check_ident str = let rec loop_id intail = parser | [< ' ('a'..'z' | 'A'..'Z' | '_'); s >] -> @@ -170,7 +197,7 @@ let check_ident str = | [< ' ('0'..'9' | ''') when intail; s >] -> loop_id true s | [< s >] -> - match lookup_utf8 s with + match unlocated lookup_utf8 s with | Utf8Token (UnicodeLetter, n) -> njunk n s; loop_id true s | Utf8Token (UnicodeIdentPart, n) when intail -> njunk n s; loop_id true s | EmptyStream -> () @@ -178,9 +205,8 @@ let check_ident str = in loop_id false (Stream.of_string str) -let check_keyword str = - try check_special_token str - with Error _ -> check_ident str +let is_ident str = + try let _ = check_ident str in true with Error.E _ -> false (* Keyword and symbol dictionary *) let token_tree = ref empty_ttree @@ -190,22 +216,15 @@ let is_keyword s = with Not_found -> false let add_keyword str = - check_keyword str; - token_tree := ttree_add !token_tree str + if not (is_keyword str) then + begin + check_keyword_to_add str; + token_tree := ttree_add !token_tree str + end let remove_keyword str = token_tree := ttree_remove !token_tree str -(* Adding a new token (keyword or special token). *) -let add_token (con, str) = match con with - | "" -> add_keyword str - | "METAIDENT" | "LEFTQMARK" | "IDENT" | "FIELD" | "INT" | "STRING" | "EOI" - -> () - | _ -> - raise (Token.Error ("\ -the constructor \"" ^ con ^ "\" is not recognized by Lexer")) - - (* Freeze and unfreeze the state of the lexer *) type frozen_t = ttree @@ -249,17 +268,22 @@ let rec number len = parser | [< ' ('0'..'9' as c); s >] -> number (store len c) s | [< >] -> len -let escape len c = store len c - let rec string in_comments bp len = parser | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] -> if esc then string in_comments bp (store len '"') s else len + | [< ''('; s >] -> + (parser + | [< ''*'; s >] -> + string (Option.map succ in_comments) bp (store (store len '(') '*') s + | [< >] -> + string in_comments bp (store len '(') s) s | [< ''*'; s >] -> (parser | [< '')'; s >] -> - if in_comments then + if in_comments = Some 0 then msg_warning (str "Not interpreting \"*)\" as the end of current non-terminated comment because it occurs in a non-terminated string of the comment."); - string in_comments bp (store (store len '*') ')') s + let in_comments = Option.map pred in_comments in + string in_comments bp (store (store len '*') ')') s | [< >] -> string in_comments bp (store len '*') s) s | [< 'c; s >] -> string in_comments bp (store len c) s @@ -348,7 +372,7 @@ let rec comment bp = parser bp2 | [< s >] -> real_push_char '*'; comment bp s >] -> () | [< ''"'; s >] -> if Flags.do_beautify() then (push_string"\"";comm_string bp2 s) - else ignore (string true bp2 0 s); + else ignore (string (Some 0) bp2 0 s); comment bp s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment | [< 'z; s >] -> real_push_char z; comment bp s @@ -394,61 +418,68 @@ let find_keyword id s = let tt = ttree_find !token_tree id in match progress_further tt.node 0 tt s with | None -> raise Not_found - | Some c -> c + | Some c -> KEYWORD c (* Must be a special token *) let process_chars bp c cs = let t = progress_from_byte None (-1) !token_tree cs c in let ep = Stream.count cs in match t with - | Some t -> (("", t), (bp, ep)) + | Some t -> (KEYWORD t, (bp, ep)) | None -> let ep' = bp + utf8_char_size cs c in njunk (ep' - ep) cs; err (bp, ep') Undefined_token -let parse_after_dollar bp = - parser - | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] -> - ("METAIDENT", get_buff len) - | [< s >] -> - match lookup_utf8 s with - | Utf8Token (UnicodeLetter, n) -> - ("METAIDENT", get_buff (ident_tail (nstore n 0 s) s)) - | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '$' s) +let token_of_special c s = match c with + | '$' -> METAIDENT s + | '.' -> FIELD s + | _ -> assert false -(* Parse what follows a dot *) -let parse_after_dot bp c = +(* Parse what follows a dot / a dollar *) + +let parse_after_special c bp = parser - | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] -> - ("FIELD", get_buff len) + | [< ' ('a'..'z' | 'A'..'Z' | '_' as d); len = ident_tail (store 0 d) >] -> + token_of_special c (get_buff len) | [< s >] -> match lookup_utf8 s with | Utf8Token (UnicodeLetter, n) -> - ("FIELD", get_buff (ident_tail (nstore n 0 s) s)) - | AsciiChar | Utf8Token _ | EmptyStream -> - fst (process_chars bp c s) + token_of_special c (get_buff (ident_tail (nstore n 0 s) s)) + | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp c s) (* Parse what follows a question mark *) + let parse_after_qmark bp s = match Stream.peek s with - |Some ('a'..'z' | 'A'..'Z' | '_') -> ("LEFTQMARK", "") - |None -> ("","?") + | Some ('a'..'z' | 'A'..'Z' | '_') -> LEFTQMARK + | None -> KEYWORD "?" | _ -> match lookup_utf8 s with - | Utf8Token (UnicodeLetter, _) -> ("LEFTQMARK", "") + | Utf8Token (UnicodeLetter, _) -> LEFTQMARK | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '?' s) +let blank_or_eof cs = + match Stream.peek cs with + | None -> true + | Some (' ' | '\t' | '\n' |'\r') -> true + | _ -> false (* Parse a token in a char stream *) + let rec next_token = parser bp | [< '' ' | '\t' | '\n' |'\r' as c; s >] -> comm_loc bp; push_char c; next_token s - | [< ''$'; t = parse_after_dollar bp >] ep -> + | [< ''$' as c; t = parse_after_special c bp >] ep -> comment_stop bp; (t, (ep, bp)) - | [< ''.' as c; t = parse_after_dot bp c >] ep -> + | [< ''.' as c; t = parse_after_special c bp; s >] ep -> comment_stop bp; - if Flags.do_beautify() & t=("",".") then between_com := true; + (* We enforce that "." should either be part of a larger keyword, + for instance ".(", or followed by a blank or eof. *) + if t = KEYWORD "." then begin + if not (blank_or_eof s) then err (bp,ep+1) Undefined_token; + if Flags.do_beautify() then between_com := true; + end; (t, (bp,ep)) | [< ''?'; s >] ep -> let t = parse_after_qmark bp s in comment_stop bp; (t, (ep, bp)) @@ -456,13 +487,13 @@ let rec next_token = parser bp len = ident_tail (store 0 c); s >] ep -> let id = get_buff len in comment_stop bp; - (try ("", find_keyword id s) with Not_found -> ("IDENT", id)), (bp, ep) + (try find_keyword id s with Not_found -> IDENT id), (bp, ep) | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep -> comment_stop bp; - (("INT", get_buff len), (bp, ep)) - | [< ''\"'; len = string false bp 0 >] ep -> + (INT (get_buff len), (bp, ep)) + | [< ''\"'; len = string None bp 0 >] ep -> comment_stop bp; - (("STRING", get_buff len), (bp, ep)) + (STRING (get_buff len), (bp, ep)) | [< ' ('(' as c); t = parser | [< ''*'; s >] -> @@ -479,62 +510,53 @@ let rec next_token = parser bp let id = get_buff len in let ep = Stream.count s in comment_stop bp; - (try ("",find_keyword id s) with Not_found -> ("IDENT",id)), (bp, ep) + (try find_keyword id s with Not_found -> IDENT id), (bp, ep) | AsciiChar | Utf8Token ((UnicodeSymbol | UnicodeIdentPart), _) -> let t = process_chars bp (Stream.next s) s in comment_stop bp; t | EmptyStream -> - comment_stop bp; (("EOI", ""), (bp, bp + 1)) + comment_stop bp; (EOI, (bp, bp + 1)) + +(* (* Debug: uncomment this for tracing tokens seen by coq...*) +let next_token s = + let (t,(bp,ep)) = next_token s in Printf.eprintf "[%s]\n%!" (Tok.to_string t); + (t,(bp,ep)) +*) (* Location table system for creating tables associating a token count to its location in a char stream (the source) *) let locerr () = invalid_arg "Lexer: location function" -let tsz = 256 (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *) - -let loct_create () = ref [| [| |] |] +let loct_create () = Hashtbl.create 207 let loct_func loct i = - match - if i < 0 || i/tsz >= Array.length !loct then None - else if !loct.(i/tsz) = [| |] then None - else !loct.(i/tsz).(i mod tsz) - with - | Some loc -> Util.make_loc loc - | _ -> locerr () - -let loct_add loct i loc = - while i/tsz >= Array.length !loct do - let new_tmax = Array.length !loct * 2 in - let new_loct = Array.make new_tmax [| |] in - Array.blit !loct 0 new_loct 0 (Array.length !loct); - loct := new_loct; - done; - if !loct.(i/tsz) = [| |] then !loct.(i/tsz) <- Array.make tsz None; - !loct.(i/tsz).(i mod tsz) <- Some loc - -let current_location_table = ref (ref [| [| |] |]) - -let location_function n = - loct_func !current_location_table n + try Hashtbl.find loct i with Not_found -> locerr () -let func cs = - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token cs in - loct_add loct i loc; Some tok) - in - current_location_table := loct; - (ts, loct_func loct) +let loct_add loct i loc = Hashtbl.add loct i loc + +let current_location_table = ref (loct_create ()) -type location_table = (int * int) option array array ref +type location_table = (int, loc) Hashtbl.t let location_table () = !current_location_table let restore_location_table t = current_location_table := t +let location_function n = loct_func !current_location_table n -(* Names of tokens, for this lexer, used in Grammar error messages *) +(** {6 The lexer of Coq} *) + +(** Note: removing a token. + We do nothing because [remove_token] is called only when removing a grammar + rule with [Grammar.delete_rule]. The latter command is called only when + unfreezing the state of the grammar entries (see GRAMMAR summary, file + env/metasyntax.ml). Therefore, instead of removing tokens one by one, + we unfreeze the state of the lexer. This restores the behaviour of the + lexer. B.B. *) + +IFDEF CAMLP5 THEN + +type te = Tok.t + +(** Names of tokens, for this lexer, used in Grammar error messages *) let token_text = function | ("", t) -> "'" ^ t ^ "'" @@ -547,43 +569,65 @@ let token_text = function | (con, "") -> con | (con, prm) -> con ^ " \"" ^ prm ^ "\"" -(* The lexer of Coq *) - -(* Note: removing a token. - We do nothing because [remove_token] is called only when removing a grammar - rule with [Grammar.delete_rule]. The latter command is called only when - unfreezing the state of the grammar entries (see GRAMMAR summary, file - env/metasyntax.ml). Therefore, instead of removing tokens one by one, - we unfreeze the state of the lexer. This restores the behaviour of the - lexer. B.B. *) - -IFDEF CAMLP5 THEN +let func cs = + let loct = loct_create () in + let ts = + Stream.from + (fun i -> + let (tok, loc) = next_token cs in + loct_add loct i (make_loc loc); Some tok) + in + current_location_table := loct; + (ts, loct_func loct) let lexer = { Token.tok_func = func; - Token.tok_using = add_token; + Token.tok_using = + (fun pat -> match Tok.of_pattern pat with + | KEYWORD s -> add_keyword s + | _ -> ()); Token.tok_removing = (fun _ -> ()); - Token.tok_match = default_match; + Token.tok_match = Tok.match_pattern; Token.tok_comm = None; Token.tok_text = token_text } -ELSE - -let lexer = { - Token.func = func; - Token.using = add_token; - Token.removing = (fun _ -> ()); - Token.tparse = (fun _ -> None); - Token.text = token_text } +ELSE (* official camlp4 for ocaml >= 3.10 *) + +module M_ = Camlp4.ErrorHandler.Register (Error) + +module Loc = Loc +module Token = struct + include Tok (* Cf. tok.ml *) + module Loc = Loc + module Error = Camlp4.Struct.EmptyError + module Filter = struct + type token_filter = (Tok.t * Loc.t) Stream.t -> (Tok.t * Loc.t) Stream.t + type t = unit + let mk _is_kwd = () + let keyword_added () kwd _ = add_keyword kwd + let keyword_removed () _ = () + let filter () x = x + let define_filter () _ = () + end +end + +let mk () _init_loc(*FIXME*) cs = + let loct = loct_create () in + let rec self = + parser i + [< (tok, loc) = next_token; s >] -> + let loc = make_loc loc in + loct_add loct i loc; + [< '(tok, loc); self s >] + | [< >] -> [< >] + in current_location_table := loct; self cs END -(* Terminal symbols interpretation *) +(** Terminal symbols interpretation *) let is_ident_not_keyword s = - match s.[0] with - | 'a'..'z' | 'A'..'Z' | '_' -> not (is_keyword s) - | _ -> false + is_ident s && not (is_keyword s) let is_number s = let rec aux i = @@ -613,6 +657,6 @@ let strip s = let terminal s = let s = strip s in if s = "" then failwith "empty token"; - if is_ident_not_keyword s then ("IDENT", s) - else if is_number s then ("INT", s) - else ("", s) + if is_ident_not_keyword s then IDENT s + else if is_number s then INT s + else KEYWORD s diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 93fc4231..1899f7f4 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -1,37 +1,27 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: lexer.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pp open Util -type error = - | Illegal_character - | Unterminated_comment - | Unterminated_string - | Undefined_token - | Bad_token of string - -exception Error of error - -val add_token : string * string -> unit +val add_keyword : string -> unit val remove_keyword : string -> unit val is_keyword : string -> bool val location_function : int -> loc -(* for coqdoc *) +(** for coqdoc *) type location_table val location_table : unit -> location_table val restore_location_table : location_table -> unit val check_ident : string -> unit +val is_ident : string -> bool val check_keyword : string -> unit type frozen_t @@ -45,8 +35,8 @@ val restore_com_state: com_state -> unit val set_xml_output_comment : (string -> unit) -> unit -val terminal : string -> string * string +val terminal : string -> Tok.t -(* The lexer of Coq *) +(** The lexer of Coq: *) -val lexer : Compat.lexer +include Compat.LexerSig diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib index c0c1817d..84a08d54 100644 --- a/parsing/parsing.mllib +++ b/parsing/parsing.mllib @@ -6,7 +6,6 @@ G_xml Ppconstr Printer Pptactic -Ppdecl_proof Tactic_printer Printmod Prettyp diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index ff5213ef..075440f1 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -1,77 +1,96 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo pa_macro.cmo" i*) - -(*i $Id: pcoq.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pp +open Compat +open Tok open Util open Names open Extend open Libnames -open Rawterm +open Glob_term open Topconstr open Genarg open Tacexpr open Extrawit open Ppextend -(* The parser of Coq *) +(** The parser of Coq *) + +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 G +END -module L = - struct - type te = string * string - let lexer = Lexer.lexer - end +(** Compatibility with Camlp5 6.x *) -module G = Grammar.GMake(L) +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 -module L = - struct - let lexer = Lexer.lexer - end +let gram_token_of_string s = gram_token_of_token (Lexer.terminal s) -module G = Grammar.Make(L) +let camlp4_verbosity silent f x = + let a = !warning_verbose in + warning_verbose := silent; + f x; + warning_verbose := a -END +let camlp4_verbose f x = camlp4_verbosity (Flags.is_verbose ()) f x -let grammar_delete e pos reinit rls = - List.iter - (fun (n,ass,lev) -> - (* Caveat: deletion is not the converse of extension: when an - empty level is extended, deletion removes the level instead - of keeping it empty. This has an effect on the empty levels 8, - 99 and 200. We didn't find a good solution to this problem - (e.g. using G.extend to know if the level exists results in a - printed error message as side effect). As a consequence an - extension at 99 or 8 (and for pattern 200 too) inside a section - corrupts the parser. *) +(** General entry keys *) - List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) - (List.rev rls); - if reinit <> None then - let lev = match pos with Some (Gramext.Level n) -> n | _ -> assert false in - let pos = - if lev = "200" then Gramext.First - else Gramext.After (string_of_int (int_of_string lev + 1)) in - G.extend e (Some pos) [Some lev,reinit,[]]; +(** 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 G.internal_entry + | Aentry of string * string + +(** [grammar_object] is the superclass of all grammar entries *) -(* grammar_object is the superclass of all grammar entries *) module type Gramobj = sig type grammar_object - val weaken_entry : 'a G.Entry.e -> grammar_object G.Entry.e + val weaken_entry : 'a G.entry -> grammar_object G.entry end module Gramobj : Gramobj = @@ -80,9 +99,11 @@ struct 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.e +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 @@ -91,8 +112,8 @@ let weaken_entry x = Gramobj.weaken_entry x module type Gramtypes = sig open Decl_kinds - val inGramObj : 'a raw_abstract_argument_type -> 'a G.Entry.e -> typed_entry - val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.Entry.e + 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 = @@ -107,82 +128,107 @@ end open Gramtypes -type camlp4_rule = - Compat.token Gramext.g_symbol list * Gramext.g_action +(** 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] -type camlp4_entry_rules = - (* first two parameters are name and assoc iff a level is created *) - string option * Gramext.g_assoc option * camlp4_rule list + In [single_extend_statement], first two parameters are name and + assoc iff a level is created *) type ext_kind = | ByGrammar of - grammar_object G.Entry.e * Gramext.position option * - camlp4_entry_rules list * Gramext.g_assoc option - | ByGEXTEND of (unit -> unit) * (unit -> unit) + grammar_object G.entry + * gram_assoc option (** for reinitialization if ever needed *) + * G.extend_statment + | ByEXTEND of (unit -> unit) * (unit -> unit) + +(** The list of extensions *) let camlp4_state = ref [] -(* The apparent parser of Coq; encapsulate G to keep track of the - extensions. *) +(** Deletion + + Caveat: deletion is not the converse of extension: when an + empty level is extended, deletion removes the level instead + of keeping it empty. This has an effect on the empty levels 8, + 99 and 200. We didn't find a good solution to this problem + (e.g. using G.extend to know if the level exists results in a + printed error message as side effect). As a consequence an + extension at 99 or 8 (and for pattern 200 too) inside a section + corrupts the parser. *) + +let grammar_delete e reinit (pos,rls) = + List.iter + (fun (n,ass,lev) -> + List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) + (List.rev rls); + if reinit <> None then + let lev = match pos with Some (Level n) -> n | _ -> assert false in + let pos = + if lev = "200" then First + else After (string_of_int (int_of_string lev + 1)) in + maybe_uncurry (G.extend e) (Some pos, [Some lev,reinit,[]]) + +(** The apparent parser of Coq; encapsulate G to keep track + of the extensions. *) + module Gram = struct include G - let extend e pos rls = - camlp4_state := - (ByGEXTEND ((fun () -> grammar_delete e pos None rls), - (fun () -> G.extend e pos rls))) - :: !camlp4_state; - G.extend e pos rls + 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 - ByGEXTEND provides just the framework we need to allow this in section. + 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 -IFDEF CAMLP5_6_02_1 THEN -let entry_print x = Gram.Entry.print !Pp_control.std_ft x -ELSE -let entry_print = Gram.Entry.print -END +(** This extension command is used by the Grammar constr *) -let camlp4_verbosity silent f x = - let a = !Gramext.warning_verbose in - Gramext.warning_verbose := silent; - f x; - Gramext.warning_verbose := a - -(* This extension command is used by the Grammar constr *) +let grammar_extend e reinit ext = + camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state; + camlp4_verbose (maybe_uncurry (G.extend e)) ext -let grammar_extend te pos reinit rls = - camlp4_state := ByGrammar (weaken_entry te,pos,rls,reinit) :: !camlp4_state; - camlp4_verbosity (Flags.is_verbose ()) (G.extend te pos) rls +(** Remove extensions -(* n is the number of extended entries (not the number of Grammar commands!) + [n] is the number of extended entries (not the number of Grammar commands!) to remove. *) + let rec remove_grammars n = if n>0 then (match !camlp4_state with | [] -> anomaly "Pcoq.remove_grammars: too many rules to remove" - | ByGrammar(g,pos,rls,reinit)::t -> - grammar_delete g pos reinit rls; + | ByGrammar(g,reinit,ext)::t -> + grammar_delete g reinit ext; camlp4_state := t; remove_grammars (n-1) - | ByGEXTEND (undo,redo)::t -> + | ByEXTEND (undo,redo)::t -> undo(); camlp4_state := t; remove_grammars n; redo(); - camlp4_state := ByGEXTEND (undo,redo) :: !camlp4_state) + camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state) + +(** An entry that checks we reached the end of the input. *) -(* 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 e = Gram.entry_create ((Gram.Entry.name en) ^ "_eoi") in GEXTEND Gram e: [ [ x = en; EOI -> x ] ] ; @@ -190,7 +236,7 @@ let eoi_entry en = e let map_entry f en = - let e = Gram.Entry.create ((Gram.Entry.name en) ^ "_map") in + let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in GEXTEND Gram e: [ [ x = en -> f x ] ] ; @@ -201,7 +247,7 @@ let map_entry f en = (use eoi_entry) *) let parse_string f x = - let strm = Stream.of_string x in Gram.Entry.parse f (Gram.parsable strm) + let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm) type gram_universe = string * (string, typed_entry) Hashtbl.t @@ -228,17 +274,10 @@ let get_univ s = let get_entry (u, utab) s = Hashtbl.find utab s -let get_entry_type (u, utab) s = - try - type_of_typed_entry (get_entry (u, utab) s) - with Not_found -> - errorlabstrm "Pcoq.get_entry" - (str "Unknown grammar entry " ++ str u ++ str ":" ++ str s ++ str ".") - 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 + let e = in_typed_entry etyp (Gram.entry_create ename) in Hashtbl.add utab s e; e let create_entry (u, utab) s etyp = @@ -257,10 +296,10 @@ 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 *) +(* 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 e = Gram.entry_create (u ^ ":" ^ s) in Hashtbl.add univ s (inGramObj rawwit e); e (* Initial grammar entries *) @@ -269,44 +308,43 @@ module Prim = struct let gec_gen x = make_gen_entry uprim x - (* Entries that can be refered via the string -> Gram.Entry.e table *) + (* Entries that can be refered via the string -> Gram.entry table *) (* Typically for tactic or vernac extensions *) let preident = gec_gen rawwit_pre_ident "preident" let ident = gec_gen rawwit_ident "ident" let natural = gec_gen rawwit_int "natural" let integer = gec_gen rawwit_int "integer" - let bigint = Gram.Entry.create "Prim.bigint" + let bigint = Gram.entry_create "Prim.bigint" let string = gec_gen rawwit_string "string" let reference = make_gen_entry uprim rawwit_ref "reference" - let by_notation = Gram.Entry.create "by_notation" - let smart_global = Gram.Entry.create "smart_global" + let by_notation = Gram.entry_create "by_notation" + let smart_global = Gram.entry_create "smart_global" (* parsed like ident but interpreted as a term *) let var = gec_gen rawwit_var "var" - let name = Gram.Entry.create "Prim.name" - let identref = Gram.Entry.create "Prim.identref" + let name = Gram.entry_create "Prim.name" + let identref = Gram.entry_create "Prim.identref" let pattern_ident = gec_gen rawwit_pattern_ident "pattern_ident" - let pattern_identref = Gram.Entry.create "pattern_identref" + 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 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 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" + 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_constr - let gec_constr_list = make_gen_entry uconstr (wit_list0 rawwit_constr) - (* Entries that can be refered via the string -> Gram.Entry.e table *) + (* Entries that can be refered via the string -> Gram.entry table *) let constr = gec_constr "constr" let operconstr = gec_constr "operconstr" let constr_eoi = eoi_entry constr @@ -315,31 +353,31 @@ module Constr = let ident = make_gen_entry uconstr rawwit_ident "ident" let global = make_gen_entry uconstr rawwit_ref "global" let sort = make_gen_entry uconstr rawwit_sort "sort" - let pattern = Gram.Entry.create "constr:pattern" + let 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" + 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" + 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" + let simple_tactic = Gram.entry_create "tactic:simple_tactic" - (* Entries that can be refered via the string -> Gram.Entry.e table *) + (* Entries that can be refered via the string -> Gram.entry table *) (* Typically for tactic user extensions *) let open_constr = make_gen_entry utactic (rawwit_open_constr_gen false) "open_constr" @@ -358,9 +396,9 @@ module Tactic = make_gen_entry utactic rawwit_intro_pattern "simple_intropattern" (* 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_arg = Gram.entry_create "tactic:tactic_arg" + let tactic_expr = Gram.entry_create "tactic:tactic_expr" + let binder_tactic = Gram.entry_create "tactic:binder_tactic" let tactic = make_gen_entry utactic (rawwit_tactic tactic_main_level) "tactic" @@ -371,7 +409,7 @@ module Tactic = module Vernac_ = struct - let gec_vernac s = Gram.Entry.create ("vernac:" ^ s) + let gec_vernac s = Gram.entry_create ("vernac:" ^ s) (* The different kinds of vernacular commands *) let gallina = gec_vernac "gallina" @@ -379,12 +417,11 @@ module Vernac_ = let command = gec_vernac "command" let syntax = gec_vernac "syntax_command" let vernac = gec_vernac "Vernac.vernac" - let proof_instr = Gram.Entry.create "proofmode:instr" - 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 main_entry = Gram.entry_create "vernac" + GEXTEND Gram main_entry: [ [ a = vernac -> Some (loc,a) | EOI -> None ] ] @@ -411,23 +448,24 @@ let main_entry = Vernac_.main_entry let constr_level = string_of_int let default_levels = - [200,Gramext.RightA,false; - 100,Gramext.RightA,false; - 99,Gramext.RightA,true; - 90,Gramext.RightA,false; - 10,Gramext.RightA,false; - 9,Gramext.RightA,false; - 8,Gramext.RightA,true; - 1,Gramext.LeftA,false; - 0,Gramext.RightA,false] + [200,RightA,false; + 100,RightA,false; + 99,RightA,true; + 90,RightA,false; + 10,RightA,false; + 9,RightA,false; + 8,RightA,true; + 1,LeftA,false; + 0,RightA,false] let default_pattern_levels = - [200,Gramext.RightA,true; - 100,Gramext.RightA,false; - 99,Gramext.RightA,true; - 10,Gramext.LeftA,false; - 1,Gramext.LeftA,false; - 0,Gramext.RightA,false] + [200,RightA,true; + 100,RightA,false; + 99,RightA,true; + 10,LeftA,false; + 9,RightA,false; + 1,LeftA,false; + 0,RightA,false] let level_stack = ref [(default_levels, default_pattern_levels)] @@ -438,19 +476,19 @@ let level_stack = open Ppextend let admissible_assoc = function - | Gramext.LeftA, Some (Gramext.RightA | Gramext.NonA) -> false - | Gramext.RightA, Some Gramext.LeftA -> false + | LeftA, Some (RightA | NonA) -> false + | RightA, Some LeftA -> false | _ -> true let create_assoc = function - | None -> Gramext.RightA + | None -> RightA | Some a -> a let error_level_assoc p current expected = let pr_assoc = function - | Gramext.LeftA -> str "left" - | Gramext.RightA -> str "right" - | Gramext.NonA -> str "non" in + | LeftA -> str "left" + | RightA -> str "right" + | 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 " ++ @@ -484,18 +522,18 @@ let find_position_gen forpat ensure assoc lev = let assoc = create_assoc assoc in if !init = None then (* Create the entry *) - (if !after = None then Some Gramext.First - else Some (Gramext.After (constr_level (Option.get !after)))), + (if !after = None then Some First + else Some (After (constr_level (Option.get !after)))), Some assoc, Some (constr_level n), None else (* The reinit flag has been updated *) - Some (Gramext.Level (constr_level n)), None, None, !init + Some (Level (constr_level n)), None, None, !init with (* Nothing has changed *) Exit -> level_stack := current :: !level_stack; (* Just inherit the existing associativity and name (None) *) - Some (Gramext.Level (constr_level n)), None, None, None + Some (Level (constr_level n)), None, None, None let remove_levels n = level_stack := list_skipn n !level_stack @@ -524,8 +562,8 @@ let synchronize_level_positions () = (* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *) let camlp4_assoc = function - | Some Gramext.NonA | Some Gramext.RightA -> Gramext.RightA - | None | Some Gramext.LeftA -> Gramext.LeftA + | Some NonA | Some RightA -> RightA + | None | Some LeftA -> LeftA (* [adjust_level assoc from prod] where [assoc] and [from] are the name and associativity of the level where to add the rule; the meaning of @@ -540,20 +578,20 @@ let adjust_level assoc from = function | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true)) (* Compute production name on the right side *) (* If NonA or LeftA on the right-hand side, set to NEXT *) - | (NumLevel n,BorderProd (Right,Some (Gramext.NonA|Gramext.LeftA))) -> + | (NumLevel n,BorderProd (Right,Some (NonA|LeftA))) -> Some None (* If RightA on the right-hand side, set to the explicit (current) level *) - | (NumLevel n,BorderProd (Right,Some Gramext.RightA)) -> + | (NumLevel n,BorderProd (Right,Some 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 Gramext.NonA)) -> None + | (NumLevel n,BorderProd (Left,Some NonA)) -> None (* If the expected assoc is the current one, set to SELF *) | (NumLevel n,BorderProd (Left,Some a)) when a = camlp4_assoc assoc -> None (* Otherwise, force the level, n or n-1, according to expected assoc *) | (NumLevel n,BorderProd (Left,Some a)) -> - if a = Gramext.LeftA then Some (Some (n,true)) else Some None + if a = LeftA then Some (Some (n,true)) else Some None (* None means NEXT *) | (NextLevel,_) -> Some None (* Compute production name elsewhere *) @@ -604,7 +642,7 @@ let interp_constr_prod_entry_key ass from forpat en = let is_self from e = match from, e with ETConstr(n,()), ETConstr(NumLevel n', - BorderProd(Right, _ (* Some(Gramext.NonA|Gramext.LeftA) *))) -> false + BorderProd(Right, _ (* Some(NonA|LeftA) *))) -> false | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> n=n' | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint | ETPattern, ETPattern) -> true @@ -618,69 +656,73 @@ let is_binder_level from e = | _ -> false let make_sep_rules tkl = - Gramext.srules - [List.map (fun x -> Gramext.Stoken x) tkl, - List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl - (Gramext.action (fun loc -> ()))] + 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 - Gramext.Snterml (Gram.Entry.obj Constr.pattern,"200") + Snterml (Gram.Entry.obj Constr.pattern,"200") else - Gramext.Snterml (Gram.Entry.obj Constr.operconstr,"200") + Snterml (Gram.Entry.obj Constr.operconstr,"200") else if is_self from typ then - Gramext.Sself + Sself else match typ with | ETConstrList (typ',[]) -> - Gramext.Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) + Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) | ETConstrList (typ',tkl) -> - Compat.slist1sep + slist1sep (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) (make_sep_rules tkl) | ETBinderList (false,[]) -> - Gramext.Slist1 + Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) | ETBinderList (false,tkl) -> - Compat.slist1sep + 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,_) -> Gramext.Snterm (Gram.Entry.obj eobj) - | (eobj,Some None,_) -> Gramext.Snext + | (eobj,None,_) -> Snterm (Gram.Entry.obj eobj) + | (eobj,Some None,_) -> Snext | (eobj,Some (Some (lev,cur)),_) -> - Gramext.Snterml (Gram.Entry.obj eobj,constr_level lev) + Snterml (Gram.Entry.obj eobj,constr_level lev) -(**********************************************************************) -(* Binding general entry keys to symbol *) +(** Binding general entry keys to symbol *) let rec symbol_of_prod_entry_key = function - | Alist1 s -> Gramext.Slist1 (symbol_of_prod_entry_key s) + | Alist1 s -> Slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> - Compat.slist1sep (symbol_of_prod_entry_key s) (Gramext.Stoken ("", sep)) - | Alist0 s -> Gramext.Slist0 (symbol_of_prod_entry_key s) + slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string sep) + | Alist0 s -> Slist0 (symbol_of_prod_entry_key s) | Alist0sep (s,sep) -> - Compat.slist0sep (symbol_of_prod_entry_key s) (Gramext.Stoken ("", sep)) - | Aopt s -> Gramext.Sopt (symbol_of_prod_entry_key s) + slist0sep (symbol_of_prod_entry_key s) (gram_token_of_string sep) + | Aopt s -> Sopt (symbol_of_prod_entry_key s) | Amodifiers s -> - Gramext.srules - [([], Gramext.action(fun _loc -> [])); - ([Gramext.Stoken ("", "("); - Compat.slist1sep (symbol_of_prod_entry_key s) (Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action (fun _ l _ _loc -> l))] - | Aself -> Gramext.Sself - | Anext -> Gramext.Snext - | Atactic 5 -> Gramext.Snterm (Gram.Entry.obj Tactic.binder_tactic) + Gram.srules' + [([], Gram.action (fun _loc -> [])); + ([gram_token_of_string "("; + 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) | Atactic n -> - Gramext.Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) - | Agram s -> Gramext.Snterm s + Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) + | Agram s -> Snterm s | Aentry (u,s) -> - Gramext.Snterm (Gram.Entry.obj + Snterm (Gram.Entry.obj (object_of_typed_entry (get_entry (get_univ u) s))) +let level_of_snterml = function + | Snterml (_,l) -> int_of_string l + | _ -> failwith "level_of_snterml" + (**********************************************************************) (* Interpret entry names of the form "ne_constr_list" as entry keys *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 61d8f4f6..bba0e560 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -1,32 +1,28 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pcoq.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Util open Names -open Rawterm +open Glob_term open Extend open Vernacexpr open Genarg open Topconstr open Tacexpr open Libnames +open Compat -(**********************************************************************) -(* The parser of Coq *) +(** The parser of Coq *) -module Gram : Grammar.S with type te = Compat.token +module Gram : GrammarSig -val entry_print : 'a Gram.Entry.e -> unit +(** The parser of Coq is built from three kinds of rule declarations: -(**********************************************************************) -(* The parser of Coq is built from three kinds of rule declarations: - dynamic rules declared at the evaluation of Coq files (using e.g. Notation, Infix, or Tactic Notation) - static rules explicitly defined in files g_*.ml4 @@ -34,7 +30,7 @@ val entry_print : 'a Gram.Entry.e -> unit VERNAC EXTEND (see e.g. file extratactics.ml4) *) -(* Dynamic extension of rules +(** Dynamic extension of rules For constr notations, dynamic addition of new rules is done in several steps: @@ -100,54 +96,49 @@ val entry_print : 'a Gram.Entry.e -> unit *) -(* The superclass of all grammar entries *) -type grammar_object - -type camlp4_rule = - Compat.token Gramext.g_symbol list * Gramext.g_action +val gram_token_of_token : Tok.t -> Gram.symbol +val gram_token_of_string : string -> Gram.symbol -type camlp4_entry_rules = - (* first two parameters are name and assoc iff a level is created *) - string option * Gramext.g_assoc option * camlp4_rule list +(** The superclass of all grammar entries *) +type grammar_object -(* Add one extension at some camlp4 position of some camlp4 entry *) +(** Add one extension at some camlp4 position of some camlp4 entry *) val grammar_extend : - grammar_object Gram.Entry.e -> Gramext.position option -> - (* for reinitialization if ever needed: *) Gramext.g_assoc option -> - camlp4_entry_rules list -> unit + grammar_object Gram.entry -> + gram_assoc option (** for reinitialization if ever needed *) -> + Gram.extend_statment -> unit -(* Remove the last n extensions *) +(** Remove the last n extensions *) val remove_grammars : int -> unit -(* The type of typed grammar objects *) +(** The type of typed grammar objects *) type typed_entry -(* The possible types for extensible grammars *) +(** 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.e -val weaken_entry : 'a Gram.Entry.e -> grammar_object Gram.Entry.e +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 *) +(** Temporary activate camlp4 verbosity *) val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit -(* Parse a string *) +(** Parse a string *) -val parse_string : 'a Gram.Entry.e -> string -> 'a -val eoi_entry : 'a Gram.Entry.e -> 'a Gram.Entry.e -val map_entry : ('a -> 'b) -> 'a Gram.Entry.e -> 'b Gram.Entry.e +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 *) +(** Table of Coq statically defined grammar entries *) type gram_universe -(* There are four predefined universes: "prim", "constr", "tactic", "vernac" *) +(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *) val get_univ : string -> gram_universe @@ -156,142 +147,156 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe -(* -val get_entry : gram_universe -> string -> typed_entry -val get_entry_type : gram_universe -> string -> entry_type -*) - val create_entry : gram_universe -> string -> entry_type -> typed_entry val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> - 'a Gram.Entry.e + 'a Gram.entry module Prim : sig open Util open Names open Libnames - val preident : string Gram.Entry.e - val ident : identifier Gram.Entry.e - val name : name located Gram.Entry.e - val identref : identifier located Gram.Entry.e - val pattern_ident : identifier Gram.Entry.e - val pattern_identref : identifier located Gram.Entry.e - val base_ident : identifier Gram.Entry.e - val natural : int Gram.Entry.e - val bigint : Bigint.bigint Gram.Entry.e - val integer : int Gram.Entry.e - val string : string Gram.Entry.e - val qualid : qualid located Gram.Entry.e - val fullyqualid : identifier list located Gram.Entry.e - val reference : reference Gram.Entry.e - val by_notation : (loc * string * string option) Gram.Entry.e - val smart_global : reference or_by_notation Gram.Entry.e - val dirpath : dir_path Gram.Entry.e - val ne_string : string Gram.Entry.e - val ne_lstring : string located Gram.Entry.e - val var : identifier located Gram.Entry.e + val preident : string Gram.entry + val ident : identifier Gram.entry + val name : name located Gram.entry + val identref : identifier located Gram.entry + val pattern_ident : identifier Gram.entry + val pattern_identref : identifier located Gram.entry + val base_ident : identifier Gram.entry + val natural : int Gram.entry + val bigint : Bigint.bigint Gram.entry + val integer : int Gram.entry + val string : string Gram.entry + val qualid : qualid located Gram.entry + val fullyqualid : identifier list located Gram.entry + val reference : reference Gram.entry + val by_notation : (loc * string * string option) Gram.entry + val smart_global : reference or_by_notation Gram.entry + val dirpath : dir_path Gram.entry + val ne_string : string Gram.entry + val ne_lstring : string located Gram.entry + val var : identifier located Gram.entry end module Constr : sig - val constr : constr_expr Gram.Entry.e - val constr_eoi : constr_expr Gram.Entry.e - val lconstr : constr_expr Gram.Entry.e - val binder_constr : constr_expr Gram.Entry.e - val operconstr : constr_expr Gram.Entry.e - val ident : identifier Gram.Entry.e - val global : reference Gram.Entry.e - val sort : rawsort Gram.Entry.e - val pattern : cases_pattern_expr Gram.Entry.e - val constr_pattern : constr_expr Gram.Entry.e - val lconstr_pattern : constr_expr Gram.Entry.e - val closed_binder : local_binder list Gram.Entry.e - val binder : local_binder list Gram.Entry.e (* closed_binder or variable *) - val binders : local_binder list Gram.Entry.e - val open_binders : local_binder list Gram.Entry.e - val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e - val typeclass_constraint : (name located * bool * constr_expr) Gram.Entry.e - val record_declaration : constr_expr Gram.Entry.e - val appl_arg : (constr_expr * explicitation located option) Gram.Entry.e + val constr : constr_expr Gram.entry + val constr_eoi : constr_expr Gram.entry + val lconstr : constr_expr Gram.entry + val binder_constr : constr_expr Gram.entry + val operconstr : constr_expr Gram.entry + val ident : identifier Gram.entry + val global : reference Gram.entry + val sort : glob_sort Gram.entry + val pattern : cases_pattern_expr Gram.entry + val constr_pattern : constr_expr Gram.entry + val lconstr_pattern : constr_expr Gram.entry + val closed_binder : local_binder list Gram.entry + val binder : local_binder list Gram.entry (* closed_binder or variable *) + val binders : local_binder list Gram.entry (* list of binder *) + val open_binders : local_binder list Gram.entry + val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.entry + val typeclass_constraint : (name located * bool * constr_expr) Gram.entry + val record_declaration : constr_expr Gram.entry + val appl_arg : (constr_expr * explicitation located option) Gram.entry end module Module : sig - val module_expr : module_ast Gram.Entry.e - val module_type : module_ast Gram.Entry.e + val module_expr : module_ast Gram.entry + val module_type : module_ast Gram.entry end module Tactic : sig - open Rawterm - val open_constr : open_constr_expr Gram.Entry.e - val casted_open_constr : open_constr_expr Gram.Entry.e - val constr_with_bindings : constr_expr with_bindings Gram.Entry.e - val bindings : constr_expr bindings Gram.Entry.e - val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.Entry.e - val quantified_hypothesis : quantified_hypothesis Gram.Entry.e - val int_or_var : int or_var Gram.Entry.e - val red_expr : raw_red_expr Gram.Entry.e - val simple_tactic : raw_atomic_tactic_expr Gram.Entry.e - val simple_intropattern : Genarg.intro_pattern_expr located Gram.Entry.e - val tactic_arg : raw_tactic_arg Gram.Entry.e - val tactic_expr : raw_tactic_expr Gram.Entry.e - val binder_tactic : raw_tactic_expr Gram.Entry.e - val tactic : raw_tactic_expr Gram.Entry.e - val tactic_eoi : raw_tactic_expr Gram.Entry.e + open Glob_term + val open_constr : open_constr_expr Gram.entry + val casted_open_constr : open_constr_expr Gram.entry + val constr_with_bindings : constr_expr with_bindings Gram.entry + val bindings : constr_expr bindings Gram.entry + val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry + val quantified_hypothesis : quantified_hypothesis Gram.entry + val int_or_var : int or_var Gram.entry + val red_expr : raw_red_expr Gram.entry + val simple_tactic : raw_atomic_tactic_expr Gram.entry + val simple_intropattern : Genarg.intro_pattern_expr located Gram.entry + val tactic_arg : raw_tactic_arg Gram.entry + val tactic_expr : raw_tactic_expr Gram.entry + val binder_tactic : raw_tactic_expr Gram.entry + val tactic : raw_tactic_expr Gram.entry + val tactic_eoi : raw_tactic_expr Gram.entry end module Vernac_ : sig open Decl_kinds - val gallina : vernac_expr Gram.Entry.e - val gallina_ext : vernac_expr Gram.Entry.e - val command : vernac_expr Gram.Entry.e - val syntax : vernac_expr Gram.Entry.e - val vernac : vernac_expr Gram.Entry.e - val vernac_eoi : vernac_expr Gram.Entry.e - val proof_instr : Decl_expr.raw_proof_instr Gram.Entry.e + 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 : vernac_expr Gram.entry + val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry + val vernac_eoi : vernac_expr Gram.entry end -(* The main entry: reads an optional vernac command *) -val main_entry : (loc * vernac_expr) option Gram.Entry.e +(** The main entry: reads an optional vernac command *) +val main_entry : (loc * vernac_expr) option Gram.entry -(**********************************************************************) -(* Mapping formal entries into concrete ones *) +(** Mapping formal entries into concrete ones *) -(* Binding constr entry keys to entries and symbols *) +(** 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.e * int option +val interp_constr_entry_key : bool (** true for cases_pattern *) -> + constr_entry_key -> grammar_object Gram.entry * int option -val symbol_of_constr_prod_entry_key : Gramext.g_assoc option -> +val symbol_of_constr_prod_entry_key : gram_assoc option -> constr_entry_key -> bool -> constr_prod_entry_key -> - Compat.token Gramext.g_symbol + Gram.symbol + +(** General entry keys *) -(* Binding general entry keys to symbols *) +(** 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 Gram.internal_entry + | Aentry of string * string + +(** Binding general entry keys to symbols *) val symbol_of_prod_entry_key : - Gram.te prod_entry_key -> Gram.te Gramext.g_symbol + prod_entry_key -> Gram.symbol -(**********************************************************************) -(* Interpret entry names of the form "ne_constr_list" as entry keys *) +(** 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 * Gram.te prod_entry_key +val interp_entry_name : bool (** true to fail on unknown entry *) -> + int option -> string -> string -> entry_type * prod_entry_key -(**********************************************************************) -(* Registering/resetting the level of a constr entry *) +(** Registering/resetting the level of a constr entry *) val find_position : - bool (* true if for creation in pattern entry; false if in constr entry *) -> - Gramext.g_assoc option -> int option -> - Gramext.position option * Gramext.g_assoc option * string option * - (* for reinitialization: *) Gramext.g_assoc option + bool (** true if for creation in pattern entry; false if in constr entry *) -> + gram_assoc option -> int option -> + gram_position option * gram_assoc option * string option * + (** for reinitialization: *) gram_assoc option val synchronize_level_positions : unit -> unit val register_empty_levels : bool -> int list -> - (Gramext.position option * Gramext.g_assoc option * - string option * Gramext.g_assoc option) list + (gram_position option * gram_assoc option * + string option * gram_assoc option) list val remove_levels : int -> unit + +val level_of_snterml : Gram.symbol -> int diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index bcca937b..4970ca13 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ppconstr.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - (*i*) open Util open Pp @@ -19,19 +17,15 @@ open Ppextend open Topconstr open Term open Pattern -open Rawterm +open Glob_term open Constrextern open Termops (*i*) -let sep_p = fun _ -> str"." let sep_v = fun _ -> str"," ++ spc() -let sep_pp = fun _ -> str":" -let sep_bar = fun _ -> spc() ++ str"| " let pr_tight_coma () = str "," ++ cut () let latom = 0 -let lannot = 100 let lprod = 200 let llambda = 200 let lif = 200 @@ -110,18 +104,14 @@ let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp) let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c) -let pr_optc pr = function - | None -> mt () - | Some x -> pr_sep_com spc pr x - let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" let pr_universe = Univ.pr_uni -let pr_rawsort = function - | RProp Term.Null -> str "Prop" - | RProp Term.Pos -> str "Set" - | RType u -> hov 0 (str "Type" ++ pr_opt (pr_in_comment pr_universe) u) +let pr_glob_sort = function + | GProp Term.Null -> str "Prop" + | GProp Term.Pos -> str "Set" + | GType u -> hov 0 (str "Type" ++ pr_opt (pr_in_comment pr_universe) u) let pr_id = pr_id let pr_name = pr_name @@ -187,6 +177,8 @@ let rec pr_patt sep inh p = | CPatCstr (_,c,[]) -> pr_reference c, latom | CPatCstr (_,c,args) -> pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp + | CPatCstrExpl (_,c,args) -> + str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp | CPatAtom (_,None) -> str "_", latom | CPatAtom (_,Some r) -> pr_reference r, latom | CPatOr (_,pl) -> @@ -315,85 +307,6 @@ let split_product na' = function rename na na' t (CProdN(loc,(nal,bk,t)::bl,c)) | _ -> anomaly "ill-formed fixpoint body" -let merge_binders (na1,bk1,ty1) cofun (na2,bk2,ty2) codom = - let na = - match snd na1, snd na2 with - Anonymous, Name id -> - if occur_var_constr_expr id cofun then - failwith "avoid capture" - else na2 - | Name id, Anonymous -> - if occur_var_constr_expr id codom then - failwith "avoid capture" - else na1 - | Anonymous, Anonymous -> na1 - | Name id1, Name id2 -> - if id1 <> id2 then failwith "not same name" else na1 in - let ty = - match ty1, ty2 with - CHole _, _ -> ty2 - | _, CHole _ -> ty1 - | _ -> - Constrextern.check_same_type ty1 ty2; - ty2 in - (LocalRawAssum ([na],bk1,ty), codom) - -let rec strip_domain bvar cofun c = - match c with - | CArrow(loc,a,b) -> - merge_binders bvar cofun ((dummy_loc,Anonymous),default_binder_kind,a) b - | CProdN(loc,[([na],bk,ty)],c') -> - merge_binders bvar cofun (na,bk,ty) c' - | CProdN(loc,([na],bk,ty)::bl,c') -> - merge_binders bvar cofun (na,bk,ty) (CProdN(loc,bl,c')) - | CProdN(loc,(na::nal,bk,ty)::bl,c') -> - merge_binders bvar cofun (na,bk,ty) (CProdN(loc,(nal,bk,ty)::bl,c')) - | _ -> failwith "not a product" - -(* Note: binder sharing is lost *) -let rec strip_domains (nal,bk,ty) cofun c = - match nal with - [] -> assert false - | [na] -> - let bnd, c' = strip_domain (na,bk,ty) cofun c in - ([bnd],None,c') - | na::nal -> - let f = CLambdaN(dummy_loc,[(nal,bk,ty)],cofun) in - let bnd, c1 = strip_domain (na,bk,ty) f c in - (try - let bl, rest, c2 = strip_domains (nal,bk,ty) cofun c1 in - (bnd::bl, rest, c2) - with Failure _ -> ([bnd],Some (nal,bk,ty), c1)) - -(* Re-share binders *) -let rec factorize_binders = function - | ([] | [_] as l) -> l - | LocalRawAssum (nal,k,ty) as d :: (LocalRawAssum (nal',k',ty')::l as l') -> - (try - let _ = Constrextern.check_same_type ty ty' in - factorize_binders (LocalRawAssum (nal@nal',k,ty)::l) - with _ -> - d :: factorize_binders l') - | d :: l -> d :: factorize_binders l - -(* Extract lambdas when a type constraint occurs *) -let rec extract_def_binders c ty = - match c with - | CLambdaN(loc,bvar::lams,b) -> - (try - let f = CLambdaN(loc,lams,b) in - let bvar', rest, ty' = strip_domains bvar f ty in - let c' = - match rest, lams with - None,[] -> b - | None, _ -> f - | Some bvar,_ -> CLambdaN(loc,bvar::lams,b) in - let (bl,c2,ty2) = extract_def_binders c' ty' in - (factorize_binders (bvar'@bl), c2, ty2) - with Failure _ -> - ([],c,ty)) - | _ -> ([],c,ty) - let rec split_fix n typ def = if n = 0 then ([],typ,def) else @@ -436,21 +349,6 @@ let pr_recursive pr_decl id = function (pr_decl true) dl ++ fnl() ++ str "for " ++ pr_id id -let is_var id = function - | CRef (Ident (_,id')) when id=id' -> true - | _ -> false - -let tm_clash = function - | (CRef (Ident (_,id)), Some (CApp (_,_,nal))) - when List.exists (function CRef (Ident (_,id')),_ -> id=id' | _ -> false) - nal - -> Some id - | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal))) - when List.exists (function CRef (Ident (_,id')) -> id=id' | _ -> false) - nal - -> Some id - | _ -> None - let pr_asin pr (na,indnalopt) = (match na with (* Decision of printing "_" or not moved to constrextern.ml *) | Some na -> spc () ++ str "as " ++ pr_lname na @@ -468,8 +366,6 @@ let pr_case_type pr po = | Some p -> spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimple) p) -let pr_return_type pr po = pr_case_type pr po - let pr_simple_return_type pr na po = (match na with | Some (_,Name id) -> @@ -621,9 +517,9 @@ let pr pr sep inherited a = | CHole _ -> str "_", latom | CEvar (_,n,l) -> pr_evar (pr mt) n l, latom | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom - | CSort (_,s) -> pr_rawsort s, latom + | CSort (_,s) -> pr_glob_sort s, latom | CCast (_,a,CastConv (k,b)) -> - let s = match k with VMcast -> "<:" | DEFAULTcast -> ":" in + let s = match k with VMcast -> "<:" | DEFAULTcast | REVERTcast -> ":" in hv 0 (pr mt (lcast,L) a ++ cut () ++ str s ++ pr mt (-lcast,E) b), lcast | CCast (_,a,CastCoerce) -> @@ -636,44 +532,11 @@ let pr pr sep inherited a = | CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt lsimple c), latom | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1 - | CDynamic _ -> str "<dynamic>", latom in let loc = constr_loc a in pr_with_comments loc (sep() ++ if prec_less prec inherited then strm else surround strm) - -let rec strip_context n iscast t = - if n = 0 then - [], if iscast then match t with CCast (_,c,_) -> c | _ -> t else t - else match t with - | CLambdaN (loc,(nal,bk,t)::bll,c) -> - let n' = List.length nal in - if n' > n then - let nal1,nal2 = list_chop n nal in - [LocalRawAssum (nal1,bk,t)], CLambdaN (loc,(nal2,bk,t)::bll,c) - else - let bl', c = strip_context (n-n') iscast - (if bll=[] then c else CLambdaN (loc,bll,c)) in - LocalRawAssum (nal,bk,t) :: bl', c - | CProdN (loc,(nal,bk,t)::bll,c) -> - let n' = List.length nal in - if n' > n then - let nal1,nal2 = list_chop n nal in - [LocalRawAssum (nal1,bk,t)], CProdN (loc,(nal2,bk,t)::bll,c) - else - let bl', c = strip_context (n-n') iscast - (if bll=[] then c else CProdN (loc,bll,c)) in - LocalRawAssum (nal,bk,t) :: bl', c - | CArrow (loc,t,c) -> - let bl', c = strip_context (n-1) iscast c in - LocalRawAssum ([loc,Anonymous],default_binder_kind,t) :: bl', c - | CCast (_,c,_) -> strip_context n false c - | CLetIn (_,na,b,c) -> - let bl', c = strip_context (n-1) iscast c in - LocalRawDef (na,b) :: bl', c - | _ -> anomaly "strip_context" - type term_pr = { pr_constr_expr : constr_expr -> std_ppcmds; pr_lconstr_expr : constr_expr -> std_ppcmds; diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli index d27b318a..f9ed3af0 100644 --- a/parsing/ppconstr.mli +++ b/parsing/ppconstr.mli @@ -1,19 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ppconstr.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pp open Environ open Term open Libnames open Pcoq -open Rawterm +open Glob_term open Topconstr open Names open Util @@ -23,9 +21,6 @@ val extract_lam_binders : constr_expr -> local_binder list * constr_expr val extract_prod_binders : constr_expr -> local_binder list * constr_expr -val extract_def_binders : - constr_expr -> constr_expr -> - local_binder list * constr_expr * constr_expr val split_fix : int -> constr_expr -> constr_expr -> local_binder list * constr_expr * constr_expr @@ -61,7 +56,7 @@ val pr_may_eval : ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('c -> std_ppcmds) -> ('a,'b,'c) may_eval -> std_ppcmds -val pr_rawsort : rawsort -> std_ppcmds +val pr_glob_sort : glob_sort -> std_ppcmds val pr_binders : local_binder list -> std_ppcmds val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds @@ -80,7 +75,7 @@ type term_pr = { val set_term_pr : term_pr -> unit val default_term_pr : term_pr -(* The modular constr printer. +(** The modular constr printer. [modular_constr_pr pr s p t] prints the head of the term [t] and calls [pr] on its subterms. [s] is typically {!Pp.mt} and [p] is [lsimple] for "constr" printers and [ltop] @@ -89,7 +84,7 @@ val default_term_pr : term_pr for instance if we want to build a printer which prints "Prop" as "Omega" instead we can proceed as follows: let my_modular_constr_pr pr s p = function - | CSort (_,RProp Null) -> str "Omega" + | CSort (_,GProp Null) -> str "Omega" | t -> modular_constr_pr pr s p t Which has the same type. We can turn a modular printer into a printer by taking its fixpoint. *) diff --git a/parsing/ppdecl_proof.ml b/parsing/ppdecl_proof.ml deleted file mode 100644 index c0eddcc5..00000000 --- a/parsing/ppdecl_proof.ml +++ /dev/null @@ -1,190 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ppdecl_proof.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - -open Util -open Pp -open Decl_expr -open Names -open Nameops - -let pr_constr = Printer.pr_constr_env -let pr_tac = Pptactic.pr_glob_tactic -let pr_pat mpat = Ppconstr.pr_cases_pattern_expr mpat.pat_expr - -let pr_label = function - Anonymous -> mt () - | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () - -let pr_justification_items env = function - Some [] -> mt () - | Some (_::_ as l) -> - spc () ++ str "by" ++ spc () ++ - prlist_with_sep (fun () -> str ",") (pr_constr env) l - | None -> spc () ++ str "by *" - -let pr_justification_method env = function - None -> mt () - | Some tac -> - spc () ++ str "using" ++ spc () ++ pr_tac env tac - -let pr_statement pr_it env st = - pr_label st.st_label ++ pr_it env st.st_it - -let pr_or_thesis pr_this env = function - Thesis Plain -> str "thesis" - | Thesis (For id) -> - str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id - | This c -> pr_this env c - -let pr_cut pr_it env c = - hov 1 (pr_it env c.cut_stat) ++ - pr_justification_items env c.cut_by ++ - pr_justification_method env c.cut_using - -let type_or_thesis = function - Thesis _ -> Term.mkProp - | This c -> c - -let _I x = x - -let rec print_hyps pconstr gtyp env sep _be _have hyps = - let pr_sep = if sep then str "and" ++ spc () else mt () in - match hyps with - (Hvar _ ::_) as rest -> - spc () ++ pr_sep ++ str _have ++ - print_vars pconstr gtyp env false _be _have rest - | Hprop st :: rest -> - begin - let nenv = - match st.st_label with - Anonymous -> env - | Name id -> Environ.push_named (id,None,gtyp st.st_it) env in - spc() ++ pr_sep ++ pr_statement pconstr env st ++ - print_hyps pconstr gtyp nenv true _be _have rest - end - | [] -> mt () - -and print_vars pconstr gtyp env sep _be _have vars = - match vars with - Hvar st :: rest -> - begin - let nenv = - match st.st_label with - Anonymous -> anomaly "anonymous variable" - | Name id -> Environ.push_named (id,None,st.st_it) env in - let pr_sep = if sep then pr_comma () else mt () in - spc() ++ pr_sep ++ - pr_statement pr_constr env st ++ - print_vars pconstr gtyp nenv true _be _have rest - end - | (Hprop _ :: _) as rest -> - let _st = if _be then - str "be such that" - else - str "such that" in - spc() ++ _st ++ print_hyps pconstr gtyp env false _be _have rest - | [] -> mt () - -let pr_suffices_clause env (hyps,c) = - print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++ - str "to show" ++ spc () ++ pr_or_thesis pr_constr env c - -let pr_elim_type = function - ET_Case_analysis -> str "cases" - | ET_Induction -> str "induction" - -let pr_casee env =function - Real c -> str "on" ++ spc () ++ pr_constr env c - | Virtual cut -> str "of" ++ spc () ++ pr_cut (pr_statement pr_constr) env cut - -let pr_side = function - Lhs -> str "=~" - | Rhs -> str "~=" - -let rec pr_bare_proof_instr _then _thus env = function - | Pescape -> str "escape" - | Pthen i -> pr_bare_proof_instr true _thus env i - | Pthus i -> pr_bare_proof_instr _then true env i - | Phence i -> pr_bare_proof_instr true true env i - | Pcut c -> - begin - match _then,_thus with - false,false -> str "have" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - | false,true -> str "thus" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - | true,false -> str "then" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - | true,true -> str "hence" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - end - | Psuffices c -> - str "suffices" ++ pr_cut pr_suffices_clause env c - | Prew (sid,c) -> - (if _thus then str "thus" else str " ") ++ spc () ++ - pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c - | Passume hyps -> - str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps - | Plet hyps -> - str "let" ++ print_vars pr_constr _I env false true "let" hyps - | Pclaim st -> - str "claim" ++ spc () ++ pr_statement pr_constr env st - | Pfocus st -> - str "focus on" ++ spc () ++ pr_statement pr_constr env st - | Pconsider (id,hyps) -> - str "consider" ++ print_vars pr_constr _I env false false "consider" hyps - ++ spc () ++ str "from " ++ pr_constr env id - | Pgiven hyps -> - str "given" ++ print_vars pr_constr _I env false false "given" hyps - | Ptake witl -> - str "take" ++ spc () ++ - prlist_with_sep pr_comma (pr_constr env) witl - | Pdefine (id,args,body) -> - str "define" ++ spc () ++ pr_id id ++ spc () ++ - prlist_with_sep spc - (fun st -> str "(" ++ - pr_statement pr_constr env st ++ str ")") args ++ spc () ++ - str "as" ++ (pr_constr env body) - | Pcast (id,typ) -> - str "reconsider" ++ spc () ++ - pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ - str "as" ++ spc () ++ (pr_constr env typ) - | Psuppose hyps -> - str "suppose" ++ - print_hyps pr_constr _I env false false "we have" hyps - | Pcase (params,pat,hyps) -> - str "suppose it is" ++ spc () ++ pr_pat pat ++ - (if params = [] then mt () else - (spc () ++ str "with" ++ spc () ++ - prlist_with_sep spc - (fun st -> str "(" ++ - pr_statement pr_constr env st ++ str ")") params ++ spc ())) - ++ - (if hyps = [] then mt () else - (spc () ++ str "and" ++ - print_hyps (pr_or_thesis pr_constr) type_or_thesis - env false false "we have" hyps)) - | Pper (et,c) -> - str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ - pr_casee env c - | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et - | _ -> anomaly "unprintable instruction" - -let pr_emph = function - 0 -> str " " - | 1 -> str "* " - | 2 -> str "** " - | 3 -> str "*** " - | _ -> anomaly "unknown emphasis" - -let pr_proof_instr env instr = - pr_emph instr.emph ++ spc () ++ - pr_bare_proof_instr false false env instr.instr - diff --git a/parsing/ppdecl_proof.mli b/parsing/ppdecl_proof.mli deleted file mode 100644 index fd6fb663..00000000 --- a/parsing/ppdecl_proof.mli +++ /dev/null @@ -1,2 +0,0 @@ - -val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index f63d6659..3305acb7 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -1,19 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pptactic.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pp open Names open Namegen open Util open Tacexpr -open Rawterm +open Glob_term open Topconstr open Genarg open Libnames @@ -21,7 +19,6 @@ open Pattern open Ppextend open Ppconstr open Printer -open Termops let pr_global x = Nametab.pr_global_env Idset.empty x @@ -42,8 +39,8 @@ type 'a raw_extra_genarg_printer = 'a -> std_ppcmds type 'a glob_extra_genarg_printer = - (rawconstr_and_expr -> std_ppcmds) -> - (rawconstr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds @@ -92,8 +89,6 @@ let pr_quantified_hypothesis = function | AnonHyp n -> int n | NamedHyp id -> pr_id id -let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h - let pr_binding prc = function | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) @@ -132,11 +127,6 @@ let pr_fresh_ids = prlist (fun s -> spc() ++ pr_or_var qs s) let with_evars ev s = if ev then "e" ^ s else s -let out_bindings = function - | ImplicitBindings l -> ImplicitBindings (List.map snd l) - | ExplicitBindings l -> ExplicitBindings (List.map (fun (loc,id,c) -> (loc,id,snd c)) l) - | NoBindings -> NoBindings - let if_pattern_ident b pr c = (if b then str "?" else mt()) ++ pr c let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = @@ -150,7 +140,7 @@ let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generi | IdentArgType b -> if_pattern_ident b pr_id (out_gen rawwit_ident x) | VarArgType -> pr_located pr_id (out_gen rawwit_var x) | RefArgType -> prref (out_gen rawwit_ref x) - | SortArgType -> pr_rawsort (out_gen rawwit_sort x) + | SortArgType -> pr_glob_sort (out_gen rawwit_sort x) | ConstrArgType -> prc (out_gen rawwit_constr x) | ConstrMayEvalArgType -> pr_may_eval prc prlc (pr_or_by_notation prref) prpat @@ -193,7 +183,7 @@ let rec pr_glob_generic prc prlc prtac prpat x = | IdentArgType b -> if_pattern_ident b pr_id (out_gen globwit_ident x) | VarArgType -> pr_located pr_id (out_gen globwit_var x) | RefArgType -> pr_or_var (pr_located pr_global) (out_gen globwit_ref x) - | SortArgType -> pr_rawsort (out_gen globwit_sort x) + | SortArgType -> pr_glob_sort (out_gen globwit_sort x) | ConstrArgType -> prc (out_gen globwit_constr x) | ConstrMayEvalArgType -> pr_may_eval prc prlc @@ -296,8 +286,6 @@ let pr_extend prc prlc prtac prpat = (**********************************************************************) (* The tactic printer *) -let sep_v = fun _ -> str"," ++ spc() - let strip_prod_binders_expr n ty = let rec strip_ty acc n ty = match ty with @@ -318,8 +306,6 @@ let pr_ltac_or_var pr = function | ArgArg x -> pr x | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) -let pr_arg pr x = spc () ++ pr x - let pr_ltac_constant sp = pr_qualid (Nametab.shortest_qualid_of_tactic sp) @@ -328,12 +314,6 @@ let pr_evaluable_reference_env env = function | EvalConstRef sp -> Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp) -let pr_quantified_hypothesis = function - | AnonHyp n -> int n - | NamedHyp id -> pr_id id - -let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h - let pr_esubst prc l = let pr_qhyp = function (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" @@ -358,10 +338,6 @@ let pr_bindings prlc prc = pr_bindings_gen false prlc prc let pr_with_bindings prlc prc (c,bl) = hov 1 (prc c ++ pr_bindings prlc prc bl) -let pr_with_constr prc = function - | None -> mt () - | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c) - let pr_with_induction_names = function | None, None -> mt () | eqpat, ipat -> @@ -411,11 +387,11 @@ let pr_by_tactic prt = function | tac -> spc() ++ str "by " ++ prt tac let pr_hyp_location pr_id = function - | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs - | occs, InHypTypeOnly -> + | occs, Termops.InHyp -> spc () ++ pr_with_occurrences pr_id occs + | occs, Termops.InHypTypeOnly -> spc () ++ pr_with_occurrences (fun id -> str "(type of " ++ pr_id id ++ str ")") occs - | occs, InHypValueOnly -> + | occs, Termops.InHypValueOnly -> spc () ++ pr_with_occurrences (fun id -> str "(value of " ++ pr_id id ++ str ")") occs @@ -443,15 +419,6 @@ let pr_clauses default_is_concl pr_id = function (if occs = no_occurrences_expr then mt () else pr_with_occurrences (fun () -> str" |- *") (occs,()))) -let pr_clause_pattern pr_id = function - | (None, []) -> mt () - | (glopt,l) -> - str " in" ++ - prlist - (fun (id,nl) -> prlist (pr_arg int) nl - ++ spc () ++ pr_id id) l ++ - pr_opt (fun nl -> prlist_with_sep spc int nl ++ str " Goal") glopt - let pr_orient b = if b then mt () else str " <-" let pr_multi = function @@ -512,7 +479,7 @@ let pr_funvar = function let pr_let_clause k pr (id,(bl,t)) = hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++ - str " :=" ++ brk (1,1) ++ pr (TacArg t)) + str " :=" ++ brk (1,1) ++ pr (TacArg (dummy_loc,t))) let pr_let_clauses recflag pr = function | hd::tl -> @@ -548,20 +515,6 @@ let pr_auto_using prc = function | l -> spc () ++ hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_comma prc l) -let pr_autoarg_adding = function - | [] -> mt () - | l -> - spc () ++ str "adding [" ++ - hv 0 (prlist_with_sep spc pr_reference l) ++ str "]" - -let pr_autoarg_destructing = function - | true -> spc () ++ str "destructing" - | false -> mt () - -let pr_autoarg_usingTDB = function - | true -> spc () ++ str "using tdb" - | false -> mt () - let pr_then () = str ";" let ltop = (5,E) @@ -835,7 +788,7 @@ and pr_atom1 = function | TacAnyConstructor (ev,None) as t -> pr_atom0 t | TacConstructor (ev,n,l) -> hov 1 (str (with_evars ev "constructor") ++ - pr_or_metaid pr_intarg n ++ pr_bindings l) + pr_or_var pr_intarg n ++ pr_bindings l) (* Conversion *) | TacReduce (r,h) -> @@ -935,6 +888,10 @@ let rec pr_tac inherited tac = hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ pr_tac (ltactical,E) t), ltactical + | TacTimeout (n,t) -> + hov 1 (str "timeout " ++ pr_or_var int n ++ spc () ++ + pr_tac (ltactical,E) t), + ltactical | TacRepeat t -> hov 1 (str "repeat" ++ spc () ++ pr_tac (ltactical,E) t), ltactical @@ -949,8 +906,8 @@ let rec pr_tac inherited tac = pr_tac (lorelse,E) t2), lorelse | TacFail (n,l) -> - str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++ - prlist (pr_arg (pr_message_token pr_ident)) l, latom + hov 1 (str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++ + prlist (pr_arg (pr_message_token pr_ident)) l), latom | TacFirst tl -> str "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet | TacSolve tl -> @@ -965,20 +922,20 @@ let rec pr_tac inherited tac = latom | TacAtom (loc,t) -> pr_with_comments loc (hov 1 (pr_atom1 t)), ltatom - | TacArg(Tacexp e) -> pr_tac_level (latom,E) e, latom - | TacArg(ConstrMayEval (ConstrTerm c)) -> + | TacArg(_,Tacexp e) -> pr_tac_level (latom,E) e, latom + | TacArg(_,ConstrMayEval (ConstrTerm c)) -> str "constr:" ++ pr_constr c, latom - | TacArg(ConstrMayEval c) -> + | TacArg(_,ConstrMayEval c) -> pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c, leval - | TacArg(TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom - | TacArg(Integer n) -> int n, latom - | TacArg(TacCall(loc,f,[])) -> pr_ref f, latom - | TacArg(TacCall(loc,f,l)) -> + | TacArg(_,TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom + | TacArg(_,Integer n) -> int n, latom + | TacArg(_,TacCall(loc,f,[])) -> pr_ref f, latom + | TacArg(_,TacCall(loc,f,l)) -> pr_with_comments loc (hov 1 (pr_ref f ++ spc () ++ prlist_with_sep spc pr_tacarg l)), lcall - | TacArg a -> pr_tacarg a, latom + | TacArg (_,a) -> pr_tacarg a, latom in if prec_less prec inherited then strm else str"(" ++ strm ++ str")" @@ -997,15 +954,15 @@ and pr_tacarg = function str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++ spc() ++ prlist_with_sep spc pr_tacarg la | (TacCall _|Tacexp _|Integer _) as a -> - str "ltac:" ++ pr_tac (latom,E) (TacArg a) + str "ltac:" ++ pr_tac (latom,E) (TacArg (dummy_loc,a)) in (pr_tac, pr_match_rule) -let strip_prod_binders_rawterm n (ty,_) = +let strip_prod_binders_glob_constr n (ty,_) = let rec strip_ty acc n ty = if n=0 then (List.rev acc, (ty,None)) else match ty with - Rawterm.RProd(loc,na,Explicit,a,b) -> + Glob_term.GProd(loc,na,Explicit,a,b) -> strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b | _ -> error "Cannot translate fix tactic: not enough products" in strip_ty [] n ty @@ -1039,33 +996,27 @@ let rec raw_printers = and pr_raw_tactic_level env n (t:raw_tactic_expr) = fst (make_pr_tac raw_printers env) n t -and pr_raw_match_rule env t = - snd (make_pr_tac raw_printers env) t - let pr_and_constr_expr pr (c,_) = pr c let pr_pat_and_constr_expr b (c,_) = - pr_and_constr_expr ((if b then pr_lrawconstr_env else pr_rawconstr_env) + pr_and_constr_expr ((if b then pr_lglob_constr_env else pr_glob_constr_env) (Global.env())) c let rec glob_printers = (pr_glob_tactic_level, - (fun env -> pr_and_constr_expr (pr_rawconstr_env env)), - (fun env -> pr_and_constr_expr (pr_lrawconstr_env env)), + (fun env -> pr_and_constr_expr (pr_glob_constr_env env)), + (fun env -> pr_and_constr_expr (pr_lglob_constr_env env)), pr_pat_and_constr_expr, (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))), (fun env -> pr_or_var (pr_inductive env)), pr_ltac_or_var (pr_located pr_ltac_constant), pr_lident, pr_glob_extend, - strip_prod_binders_rawterm) + strip_prod_binders_glob_constr) and pr_glob_tactic_level env n (t:glob_tactic_expr) = fst (make_pr_tac glob_printers env) n t -and pr_glob_match_rule env t = - snd (make_pr_tac glob_printers env) t - let pr_constr_or_lconstr_pattern b = if b then pr_lconstr_pattern else pr_constr_pattern diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli index 40880f58..d85f1ec3 100644 --- a/parsing/pptactic.mli +++ b/parsing/pptactic.mli @@ -1,20 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pptactic.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pp open Genarg open Tacexpr open Pretyping open Proof_type open Topconstr -open Rawterm +open Glob_term open Pattern open Ppextend open Environ @@ -32,8 +30,8 @@ type 'a raw_extra_genarg_printer = 'a -> std_ppcmds type 'a glob_extra_genarg_printer = - (rawconstr_and_expr -> std_ppcmds) -> - (rawconstr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds @@ -43,7 +41,7 @@ type 'a extra_genarg_printer = (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds - (* if the boolean is false then the extension applies only to old syntax *) + (** if the boolean is false then the extension applies only to old syntax *) val declare_extra_genarg_pprule : ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) -> ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) -> @@ -51,7 +49,7 @@ val declare_extra_genarg_pprule : type grammar_terminals = string option list - (* if the boolean is false then the extension applies only to old syntax *) + (** if the boolean is false then the extension applies only to old syntax *) val declare_extra_tactic_pprule : string * argument_type list * (int * grammar_terminals) -> unit @@ -72,9 +70,9 @@ val pr_raw_extend: string -> raw_generic_argument list -> std_ppcmds val pr_glob_extend: - (rawconstr_and_expr -> std_ppcmds) -> (rawconstr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (rawconstr_pattern_and_expr -> std_ppcmds) -> int -> + (glob_constr_pattern_and_expr -> std_ppcmds) -> int -> string -> glob_generic_argument list -> std_ppcmds val pr_extend : diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml index 44ac445d..c858439e 100644 --- a/parsing/ppvernac.ml +++ b/parsing/ppvernac.ml @@ -1,23 +1,22 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ppvernac.ml 14657 2011-11-16 08:46:33Z herbelin $ *) - open Pp open Names open Nameops open Nametab +open Compat open Util open Extend open Vernacexpr open Ppconstr open Pptactic -open Rawterm +open Glob_term open Genarg open Pcoq open Libnames @@ -25,6 +24,7 @@ open Ppextend open Topconstr open Decl_kinds open Tacinterp +open Declaremods let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr @@ -85,27 +85,12 @@ let rec match_vernac_rule tys = function else match_vernac_rule tys rls let sep = fun _ -> spc() -let sep_p = fun _ -> str"." -let sep_v = fun _ -> str"," let sep_v2 = fun _ -> str"," ++ spc() -let sep_pp = fun _ -> str":" let pr_ne_sep sep pr = function [] -> mt() | l -> sep() ++ pr l -let pr_entry_prec = function - | Some Gramext.LeftA -> str"LEFTA " - | Some Gramext.RightA -> str"RIGHTA " - | Some Gramext.NonA -> str"NONA " - | None -> mt() - -let pr_prec = function - | Some Gramext.LeftA -> str", left associativity" - | Some Gramext.RightA -> str", right associativity" - | Some Gramext.NonA -> str", no associativity" - | None -> mt() - let pr_set_entry_type = function | ETName -> str"ident" | ETReference -> str"global" @@ -169,11 +154,6 @@ let pr_explanation (e,b,f) = let a = if f then str"!" ++ a else a in if b then str "[" ++ a ++ str "]" else a -let pr_class_rawexpr = function - | FunClass -> str"Funclass" - | SortClass -> str"Sortclass" - | RefClass qid -> pr_smart_global qid - let pr_option_ref_value = function | QualidRefValue id -> pr_reference id | StringRefValue s -> qs s @@ -184,7 +164,9 @@ let pr_printoption table b = let pr_set_option a b = let pr_opt_value = function - | IntValue n -> spc() ++ int n + | IntValue None -> assert false + (* This should not happen because of the grammar *) + | IntValue (Some n) -> spc() ++ int n | StringValue s -> spc() ++ str s | BoolValue b -> mt() in pr_printoption a None ++ pr_opt_value b @@ -238,18 +220,31 @@ let pr_with_declaration pr_c = function let rec pr_module_ast pr_c = function | CMident qid -> spc () ++ pr_located pr_qualid qid - | CMwith (mty,decl) -> + | CMwith (_,mty,decl) -> let m = pr_module_ast pr_c mty in let p = pr_with_declaration pr_c decl in m ++ spc() ++ str"with" ++ spc() ++ p - | CMapply (me1,(CMident _ as me2)) -> + | CMapply (_,me1,(CMident _ as me2)) -> pr_module_ast pr_c me1 ++ spc() ++ pr_module_ast pr_c me2 - | CMapply (me1,me2) -> + | CMapply (_,me1,me2) -> pr_module_ast pr_c me1 ++ spc() ++ hov 1 (str"(" ++ pr_module_ast pr_c me2 ++ str")") -let pr_module_ast_inl pr_c (mast,b) = - (if b then mt () else str "!") ++ pr_module_ast pr_c mast +let pr_annot { ann_inline = ann; ann_scope_subst = scl } = + let sep () = if scl=[] then mt () else str "," in + if ann = DefaultInline && scl = [] then mt () + else + str " [" ++ + (match ann with + | DefaultInline -> mt () + | NoInline -> str "no inline" ++ sep () + | InlineAt i -> str "inline at level " ++ int i ++ sep ()) ++ + prlist_with_sep (fun () -> str ", ") + (fun (sc1,sc2) -> str ("scope "^sc1^" to "^sc2)) scl ++ + str "]" + +let pr_module_ast_inl pr_c (mast,ann) = + pr_module_ast pr_c mast ++ pr_annot ann let pr_of_module_type prc = function | Enforce mty -> str ":" ++ pr_module_ast_inl prc mty @@ -267,7 +262,7 @@ let pr_module_vardecls pr_c (export,idl,(mty,inl)) = let lib_dir = Lib.library_dp() in List.iter (fun (_,id) -> Declaremods.process_module_bindings [id] - [make_mbid lib_dir (string_of_id id), + [make_mbid lib_dir id, (Modintern.interp_modtype (Global.env()) mty, inl)]) idl; (* Builds the stream *) spc() ++ @@ -291,9 +286,6 @@ let pr_decl_notation prc ((loc,ntn),c,scopt) = fnl () ++ str "where " ++ qs ntn ++ str " := " ++ prc c ++ pr_opt (fun sc -> str ": " ++ str sc) scopt -let pr_vbinders l = - hv 0 (pr_binders l) - let pr_binders_arg = pr_ne_sep spc pr_binders @@ -331,7 +323,7 @@ let pr_onescheme (idop,schem) = ) ++ hov 0 ((if dep then str"Induction for" else str"Minimality for") ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (str"Sort" ++ spc() ++ pr_rawsort s) + hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s) | CaseScheme (dep,ind,s) -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() @@ -339,7 +331,7 @@ let pr_onescheme (idop,schem) = ) ++ hov 0 ((if dep then str"Elimination for" else str"Case for") ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (str"Sort" ++ spc() ++ pr_rawsort s) + hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s) | EqualityScheme ind -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() @@ -402,9 +394,9 @@ let pr_syntax_modifier = function prlist_with_sep sep_v2 str l ++ spc() ++ str"at level" ++ spc() ++ int n | SetLevel n -> str"at level" ++ spc() ++ int n - | SetAssoc Gramext.LeftA -> str"left associativity" - | SetAssoc Gramext.RightA -> str"right associativity" - | SetAssoc Gramext.NonA -> str"no associativity" + | SetAssoc LeftA -> str"left associativity" + | SetAssoc RightA -> str"right associativity" + | SetAssoc NonA -> str"no associativity" | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ | SetOnlyParsing -> str"only parsing" | SetFormat s -> str"format " ++ pr_located qs s @@ -422,21 +414,6 @@ let pr_grammar_tactic_rule n (_,pil,t) = hov 0 (prlist_with_sep sep pr_production_item pil ++ spc() ++ str":=" ++ spc() ++ pr_raw_tactic t)) -let pr_box b = let pr_boxkind = function - | PpHB n -> str"h" ++ spc() ++ int n - | PpVB n -> str"v" ++ spc() ++ int n - | PpHVB n -> str"hv" ++ spc() ++ int n - | PpHOVB n -> str"hov" ++ spc() ++ int n - | PpTB -> str"t" -in str"<" ++ pr_boxkind b ++ str">" - -let pr_paren_reln_or_extern = function - | None,L -> str"L" - | None,E -> str"E" - | Some pprim,Any -> qs pprim - | Some pprim,Prec p -> qs pprim ++ spc() ++ str":" ++ spc() ++ int p - | _ -> mt() - let pr_statement head (id,(bl,c,guard)) = assert (id<>None); hov 1 @@ -453,22 +430,27 @@ let make_pr_vernac pr_constr pr_lconstr = let pr_constrarg c = spc () ++ pr_constr c in let pr_lconstrarg c = spc () ++ pr_lconstr c in let pr_intarg n = spc () ++ int n in -(* let pr_lident_constr sep (i,c) = pr_lident i ++ sep ++ pr_constrarg c in *) -let pr_record_field (x, ntn) = +let pr_oc = function + None -> str" :" + | Some true -> str" :>" + | Some false -> str" :>>" +in +let pr_record_field ((x, pri), ntn) = let prx = match x with | (oc,AssumExpr (id,t)) -> hov 1 (pr_lname id ++ - (if oc then str" :>" else str" :") ++ spc() ++ - pr_lconstr_expr t) + pr_oc oc ++ spc() ++ + pr_lconstr_expr t) | (oc,DefExpr(id,b,opt)) -> (match opt with | Some t -> hov 1 (pr_lname id ++ - (if oc then str" :>" else str" :") ++ spc() ++ - pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b) + pr_oc oc ++ spc() ++ + pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b) | None -> hov 1 (pr_lname id ++ str" :=" ++ spc() ++ pr_lconstr b)) in - prx ++ prlist (pr_decl_notation pr_constr) ntn + let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in + prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn in let pr_record_decl b c fs = pr_opt pr_lident c ++ str"{" ++ @@ -490,16 +472,13 @@ let rec pr_vernac = function | VernacBacktrack (i,j,k) -> str "Backtrack" ++ spc() ++ prlist_with_sep sep int [i;j;k] | VernacFocus i -> str"Focus" ++ pr_opt int i - | VernacGo g -> - let pr_goable = function - | GoTo i -> int i - | GoTop -> str"top" - | GoNext -> str"next" - | GoPrev -> str"prev" - in str"Go" ++ spc() ++ pr_goable g | VernacShow s -> + let pr_goal_reference = function + | OpenSubgoals -> mt () + | NthGoal n -> spc () ++ int n + | GoalId n -> spc () ++ str n in let pr_showable = function - | ShowGoal n -> str"Show" ++ pr_opt int n + | ShowGoal n -> str"Show" ++ pr_goal_reference n | ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n | ShowProof -> str"Show Proof" | ShowNode -> str"Show Node" @@ -510,8 +489,6 @@ let rec pr_vernac = function | ShowIntros b -> str"Show " ++ (if b then str"Intros" else str"Intro") | ShowMatch id -> str"Show Match " ++ pr_lident id | ShowThesis -> str "Show Thesis" - | ExplainProof l -> str"Explain Proof" ++ spc() ++ prlist_with_sep sep int l - | ExplainTree l -> str"Explain Proof Tree" ++ spc() ++ prlist_with_sep sep int l in pr_showable s | VernacCheckGuard -> str"Guarded" @@ -655,7 +632,7 @@ let rec pr_vernac = function (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) - | VernacFixpoint (recs,b) -> + | VernacFixpoint recs -> let pr_onerec = function | ((loc,id),ro,bl,type_,def),ntn -> let annot = pr_guard_annot bl ro in @@ -664,19 +641,17 @@ let rec pr_vernac = function ++ pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn in - let start = if b then "Boxed Fixpoint" else "Fixpoint" in - hov 0 (str start ++ spc() ++ + hov 0 (str "Fixpoint" ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onerec recs) - | VernacCoFixpoint (corecs,b) -> + | VernacCoFixpoint corecs -> let pr_onecorec (((loc,id),bl,c,def),ntn) = pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ spc() ++ pr_lconstr_expr c ++ pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn in - let start = if b then "Boxed CoFixpoint" else "CoFixpoint" in - hov 0 (str start ++ spc() ++ + hov 0 (str "CoFixpoint" ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs) | VernacScheme l -> hov 2 (str"Scheme" ++ spc() ++ @@ -721,7 +696,7 @@ let rec pr_vernac = function (* str"Class" ++ spc () ++ pr_lident id ++ *) (* (\* prlist_with_sep (spc) (pr_lident_constr (spc() ++ str ":" ++ spc())) par ++ *\) *) (* pr_and_type_binders_arg par ++ *) -(* (match ar with Some ar -> spc () ++ str":" ++ spc() ++ pr_rawsort (snd ar) | None -> mt()) ++ *) +(* (match ar with Some ar -> spc () ++ str":" ++ spc() ++ pr_glob_sort (snd ar) | None -> mt()) ++ *) (* spc () ++ str":=" ++ spc () ++ *) (* prlist_with_sep (fun () -> str";" ++ spc()) *) (* (fun (lid,oc,c) -> pr_lident_constr ((if oc then str" :>" else str" :") ++ spc()) (lid,c)) props ) *) @@ -735,8 +710,9 @@ let rec pr_vernac = function str"=>" ++ spc () ++ (match snd instid with Name id -> pr_lident (fst instid, id) ++ spc () ++ str":" ++ spc () | Anonymous -> mt ()) ++ pr_constr_expr cl ++ spc () ++ - spc () ++ str":=" ++ spc () ++ - pr_constr_expr props) + (match props with + | Some p -> spc () ++ str":=" ++ spc () ++ pr_constr_expr p + | None -> mt())) | VernacContext l -> hov 1 ( @@ -744,9 +720,10 @@ let rec pr_vernac = function pr_and_type_binders_arg l ++ spc () ++ str "]") - | VernacDeclareInstance (glob, id) -> + | VernacDeclareInstances (glob, ids) -> hov 1 (pr_non_locality (not glob) ++ - str"Existing" ++ spc () ++ str"Instance" ++ spc () ++ pr_reference id) + str"Existing" ++ spc () ++ str(plural (List.length ids) "Instance") ++ + spc () ++ prlist_with_sep spc pr_reference ids) | VernacDeclareClass id -> hov 1 (str"Existing" ++ spc () ++ str"Class" ++ spc () ++ pr_reference id) @@ -780,20 +757,12 @@ let rec pr_vernac = function | VernacSolve (i,tac,deftac) -> (if i = 1 then mt() else int i ++ str ": ") ++ pr_raw_tactic tac - ++ (try if deftac & Pfedit.get_end_tac() <> None then str ".." else mt () - with UserError _|Stdpp.Exc_located _ -> mt()) + ++ (try if deftac then str ".." else mt () + with UserError _|Loc.Exc_located _ -> mt()) | VernacSolveExistential (i,c) -> str"Existential " ++ int i ++ pr_lconstrarg c - (* MMode *) - - | VernacProofInstr instr -> anomaly "Not implemented" - | VernacDeclProof -> str "proof" - | VernacReturn -> str "return" - - (* /MMode *) - (* Auxiliary file and library management *) | VernacRequireFrom (exp,spe,f) -> hov 2 (str"Require" ++ spc() ++ pr_require_token exp ++ @@ -838,8 +807,12 @@ let rec pr_vernac = function (pr_locality local ++ str "Ltac " ++ prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l) | VernacCreateHintDb (local,dbname,b) -> - hov 1 (pr_locality local ++ str "Create " ++ str "HintDb " ++ + hov 1 (pr_locality local ++ str "Create HintDb " ++ str dbname ++ (if b then str" discriminated" else mt ())) + | VernacRemoveHints (local, dbnames, ids) -> + hov 1 (pr_locality local ++ str "Remove Hints " ++ + prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ + pr_opt_hintbases dbnames) | VernacHints (local,dbnames,h) -> pr_hints local dbnames h pr_constr pr_constr_pattern_expr | VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) -> @@ -856,6 +829,32 @@ let rec pr_vernac = function prlist_with_sep spc (fun imps -> str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]") impls) + | VernacArguments (local, q, impl, nargs, mods) -> + hov 2 (pr_section_locality local ++ str"Arguments" ++ spc() ++ + pr_smart_global q ++ + let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in + let pr_if b x = if b then x else str "" in + let pr_br imp max x = match imp, max with + | true, false -> str "[" ++ x ++ str "]" + | true, true -> str "{" ++ x ++ str "}" + | _ -> x in + let rec aux n l = + match n, l with + | 0, l -> spc () ++ str"/" ++ aux ~-1 l + | _, [] -> mt() + | n, (id,k,s,imp,max) :: tl -> + spc() ++ pr_br imp max (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++ + aux (n-1) tl in + prlist_with_sep (fun () -> str", ") (aux nargs) impl ++ + if mods <> [] then str" : " else str"" ++ + prlist_with_sep (fun () -> str", " ++ spc()) (function + | `SimplDontExposeCase -> str "simpl nomatch" + | `SimplNeverUnfold -> str "simpl never" + | `DefaultImplicits -> str "default implicits" + | `Rename -> str "rename" + | `ClearImplicits -> str "clear implicits" + | `ClearScopes -> str "clear scopes") + mods) | VernacReserve bl -> let n = List.length (List.flatten (List.map fst bl)) in hov 2 (str"Implicit Type" ++ @@ -933,7 +932,7 @@ let rec pr_vernac = function | PrintHintDb -> str"Print Hint *" | PrintHintDbName s -> str"Print HintDb" ++ spc() ++ str s | PrintRewriteHintDbName s -> str"Print Rewrite HintDb" ++ spc() ++ str s - | PrintUniverses fopt -> str"Dump Universes" ++ pr_opt str fopt + | PrintUniverses (b, fopt) -> Printf.ksprintf str "Print %sUniverses" (if b then "Sorted " else "") ++ pr_opt str fopt | PrintName qid -> str"Print" ++ spc() ++ pr_smart_global qid | PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid | PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid @@ -967,8 +966,21 @@ let rec pr_vernac = function (* For extension *) | VernacExtend (s,c) -> pr_extend s c - | VernacProof (Tacexpr.TacId _) -> str "Proof" - | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te + | VernacProof (None, None) -> str "Proof" + | VernacProof (None, Some l) -> str "Proof using" ++spc()++ prlist pr_lident l + | VernacProof (Some te, None) -> str "Proof with" ++ spc() ++ pr_raw_tactic te + | VernacProof (Some te, Some l) -> + str "Proof using" ++spc()++ prlist pr_lident l ++ spc() ++ + str "with" ++ spc() ++pr_raw_tactic te + | VernacProofMode s -> str ("Proof Mode "^s) + | VernacBullet b -> begin match b with + | Dash -> str"-" + | Star -> str"*" + | Plus -> str"+" + end ++ spc() + | VernacSubproof None -> str "BeginSubproof" + | VernacSubproof (Some i) -> str "BeginSubproof " ++ pr_int i + | VernacEndSubproof -> str "EndSubproof" and pr_extend s cl = let pr_arg a = diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli index e63cf7b0..7801de6a 100644 --- a/parsing/ppvernac.mli +++ b/parsing/ppvernac.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ppvernac.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pp open Genarg open Vernacexpr @@ -17,7 +15,7 @@ open Nametab open Util open Ppconstr open Pptactic -open Rawterm +open Glob_term open Pcoq open Libnames open Ppextend diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index ea97a198..e30979bf 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,8 +10,6 @@ * on May-June 2006 for implementation of abstraction of pretty-printing of objects. *) -(* $Id: prettyp.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pp open Util open Names @@ -41,7 +39,6 @@ type object_pr = { print_module : bool -> Names.module_path -> std_ppcmds; print_modtype : module_path -> std_ppcmds; print_named_decl : identifier * constr option * types -> std_ppcmds; - print_leaf_entry : bool -> Libnames.object_name * Libobject.obj -> Pp.std_ppcmds; print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; print_typed_value_in_env : Environ.env -> Term.constr * Term.types -> Pp.std_ppcmds; @@ -122,6 +119,11 @@ let print_impargs_list prefix l = then print_one_impargs_list imps else [str "No implicit arguments"]))])]) l) +let print_renames_list prefix l = + if l = [] then [] else + [add_colon prefix ++ str "Arguments are renamed to " ++ + hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map pr_name l))] + let need_expansion impl ref = let typ = Global.type_of_global ref in let ctx = (prod_assum typ) in @@ -154,6 +156,45 @@ let print_argument_scopes prefix = function str "]")] | _ -> [] +(*****************************) +(** Printing simpl behaviour *) + +let print_simpl_behaviour ref = + match Tacred.get_simpl_behaviour ref with + | None -> [] + | Some (recargs, nargs, flags) -> + let never = List.mem `SimplNeverUnfold flags in + let nomatch = List.mem `SimplDontExposeCase flags in + let pp_nomatch = spc() ++ if nomatch then + str "avoiding to expose match constructs" else str"" in + let pp_recargs = spc() ++ str "when the " ++ + let rec aux = function + | [] -> mt() + | [x] -> str (ordinal (x+1)) + | [x;y] -> str (ordinal (x+1)) ++ str " and " ++ str (ordinal (y+1)) + | x::tl -> str (ordinal (x+1)) ++ str ", " ++ aux tl in + aux recargs ++ str (plural (List.length recargs) " argument") ++ + str (plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++ + str " to a constructor" in + let pp_nargs = + spc() ++ str "when applied to " ++ int nargs ++ + str (plural nargs " argument") in + [hov 2 (str "The simpl tactic " ++ + match recargs, nargs, never with + | _,_, true -> str "never unfolds " ++ pr_global ref + | [], 0, _ -> str "always unfolds " ++ pr_global ref + | _::_, n, _ when n < 0 -> + str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch + | _::_, n, _ when n > List.fold_left max 0 recargs -> + str "unfolds " ++ pr_global ref ++ pp_recargs ++ + str " and" ++ pp_nargs ++ pp_nomatch + | _::_, _, _ -> + str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch + | [], n, _ when n > 0 -> + str "unfolds " ++ pr_global ref ++ pp_nargs ++ pp_nomatch + | _ -> str "unfolds " ++ pr_global ref ++ pp_nomatch )] +;; + (*********************) (** Printing Opacity *) @@ -166,10 +207,11 @@ let opacity env = function Some(TransparentMaybeOpacified (Conv_oracle.get_strategy(VarKey v))) | ConstRef cst -> let cb = Environ.lookup_constant cst env in - if cb.const_body = None then None - else if cb.const_opaque then Some FullyOpaque - else Some - (TransparentMaybeOpacified (Conv_oracle.get_strategy(ConstKey cst))) + (match cb.const_body with + | Undef _ -> None + | OpaqueDef _ -> Some FullyOpaque + | Def _ -> Some + (TransparentMaybeOpacified (Conv_oracle.get_strategy(ConstKey cst)))) | _ -> None let print_opacity ref = @@ -194,6 +236,8 @@ let print_opacity ref = let print_name_infos ref = let impls = implicits_of_global ref in let scopes = Notation.find_arguments_scope ref in + let renames = + try List.hd (Arguments_renaming.arguments_names ref) with Not_found -> [] in let type_info_for_implicit = if need_expansion (select_impargs_size 0 impls) ref then (* Need to reduce since implicits are computed with products flattened *) @@ -202,6 +246,7 @@ let print_name_infos ref = else [] in type_info_for_implicit @ + print_renames_list (mt()) renames @ print_impargs_list (mt()) impls @ print_argument_scopes (mt()) scopes @@ -226,6 +271,12 @@ let print_inductive_implicit_args = implicits_of_global (fun l -> positions_of_implicits l <> []) print_impargs_list +let print_inductive_renames = + print_args_data_of_inductive_ids + (fun r -> try List.hd (Arguments_renaming.arguments_names r) with _ -> []) + ((<>) Anonymous) + print_renames_list + let print_inductive_argument_scopes = print_args_data_of_inductive_ids Notation.find_arguments_scope ((<>) None) print_argument_scopes @@ -337,89 +388,14 @@ let assumptions_for_print lna = (*********************) (* *) -let print_params env params = - if params = [] then mt () else pr_rel_context env params ++ brk(1,2) - -let print_constructors envpar names types = - let pc = - prlist_with_sep (fun () -> brk(1,0) ++ str "| ") - (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c) - (Array.to_list (array_map2 (fun n t -> (n,t)) names types)) - in - hv 0 (str " " ++ pc) - -let build_inductive sp tyi = - let (mib,mip) = Global.lookup_inductive (sp,tyi) in - let params = mib.mind_params_ctxt in - let args = extended_rel_list 0 params in - let env = Global.env() in - let fullarity = match mip.mind_arity with - | Monomorphic ar -> ar.mind_user_arity - | Polymorphic ar -> - it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt in - let arity = hnf_prod_applist env fullarity args in - let cstrtypes = type_of_constructors env (sp,tyi) in - let cstrtypes = - Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in - let cstrnames = mip.mind_consnames in - (IndRef (sp,tyi), params, arity, cstrnames, cstrtypes) - -let print_one_inductive (sp,tyi) = - let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in - let env = Global.env () in - let envpar = push_rel_context params env in - hov 0 ( - pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ print_params env params ++ - str ": " ++ pr_lconstr_env envpar arity ++ str " :=") ++ - brk(0,2) ++ print_constructors envpar cstrnames cstrtypes - -let pr_mutual_inductive finite indl = - hov 0 ( - str (if finite then "Inductive " else "CoInductive ") ++ - prlist_with_sep (fun () -> fnl () ++ str" with ") - print_one_inductive indl) - -let get_fields = - let rec prodec_rec l subst c = - match kind_of_term c with - | Prod (na,t,c) -> - let id = match na with Name id -> id | Anonymous -> id_of_string "_" in - prodec_rec ((id,true,substl subst t)::l) (mkVar id::subst) c - | LetIn (na,b,_,c) -> - let id = match na with Name id -> id | Anonymous -> id_of_string "_" in - prodec_rec ((id,false,substl subst b)::l) (mkVar id::subst) c - | _ -> List.rev l - in - prodec_rec [] [] - -let pr_record (sp,tyi) = - let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in - let env = Global.env () in - let envpar = push_rel_context params env in - let fields = get_fields cstrtypes.(0) in - hov 0 ( - hov 0 ( - str "Record " ++ pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ - print_params env params ++ - str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++ - str ":= " ++ pr_id cstrnames.(0)) ++ - brk(1,2) ++ - hv 2 (str "{ " ++ - prlist_with_sep (fun () -> str ";" ++ brk(2,0)) - (fun (id,b,c) -> - pr_id id ++ str (if b then " : " else " := ") ++ - pr_lconstr_env envpar c) fields) ++ str" }") - let gallina_print_inductive sp = - let (mib,mip) = Global.lookup_inductive (sp,0) in + let env = Global.env() in + let mib = Environ.lookup_mind sp env in let mipv = mib.mind_packets in - let names = list_tabulate (fun x -> (sp,x)) (Array.length mipv) in - (if mib.mind_record & not !Flags.raw_print then - pr_record (List.hd names) - else - pr_mutual_inductive mib.mind_finite names) ++ fnl () ++ + pr_mutual_inductive_body env sp mib ++ fnl () ++ with_line_skip - (print_inductive_implicit_args sp mipv @ + (print_inductive_renames sp mipv @ + print_inductive_implicit_args sp mipv @ print_inductive_argument_scopes sp mipv) let print_named_decl id = @@ -442,7 +418,7 @@ let ungeneralized_type_of_constant_type = function let print_constant with_values sep sp = let cb = Global.lookup_constant sp in - let val_0 = cb.const_body in + let val_0 = body_of_constant cb in let typ = ungeneralized_type_of_constant_type cb.const_type in hov 0 ( match val_0 with @@ -462,13 +438,13 @@ let gallina_print_constant_with_infos sp = let gallina_print_syntactic_def kn = let qid = Nametab.shortest_qualid_of_syndef Idset.empty kn and (vars,a) = Syntax_def.search_syntactic_definition kn in - let c = Topconstr.rawconstr_of_aconstr dummy_loc a in + let c = Topconstr.glob_constr_of_aconstr dummy_loc a in hov 2 (hov 4 (str "Notation " ++ pr_qualid qid ++ prlist (fun id -> spc () ++ pr_id id) (List.map fst vars) ++ spc () ++ str ":=") ++ - spc () ++ Constrextern.without_symbols pr_rawconstr c) ++ fnl () + spc () ++ Constrextern.without_symbols pr_glob_constr c) ++ fnl () let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) = let sep = if with_values then " = " else " : " @@ -508,18 +484,9 @@ let gallina_print_library_entry with_values ent = Some (str " >>>>>>> Module " ++ pr_name oname) | (oname,Lib.ClosedModule _) -> Some (str " >>>>>>> Closed Module " ++ pr_name oname) - | (oname,Lib.OpenedModtype _) -> - Some (str " >>>>>>> Module Type " ++ pr_name oname) - | (oname,Lib.ClosedModtype _) -> - Some (str " >>>>>>> Closed Module Type " ++ pr_name oname) | (_,Lib.FrozenState _) -> None -let gallina_print_leaf_entry with_values c = - match gallina_print_leaf_entry with_values c with - | None -> mt () - | Some pp -> pp ++ fnl() - let gallina_print_context with_values = let rec prec n = function | h::rest when n = None or Option.get n > 0 -> @@ -545,7 +512,6 @@ let default_object_pr = { print_module = gallina_print_module; print_modtype = gallina_print_modtype; print_named_decl = gallina_print_named_decl; - print_leaf_entry = gallina_print_leaf_entry; print_library_entry = gallina_print_library_entry; print_context = gallina_print_context; print_typed_value_in_env = gallina_print_typed_value_in_env; @@ -562,7 +528,6 @@ let print_syntactic_def x = !object_pr.print_syntactic_def x let print_module x = !object_pr.print_module x let print_modtype x = !object_pr.print_modtype x let print_named_decl x = !object_pr.print_named_decl x -let print_leaf_entry x = !object_pr.print_leaf_entry x let print_library_entry x = !object_pr.print_library_entry x let print_context x = !object_pr.print_context x let print_typed_value_in_env x = !object_pr.print_typed_value_in_env x @@ -596,31 +561,28 @@ let print_full_pure_context () = | ((_,kn),Lib.Leaf lobj)::rest -> let pp = match object_tag lobj with | "CONSTANT" -> - let con = Global.constant_of_delta (constant_of_kn kn) in + let con = Global.constant_of_delta_kn kn in let cb = Global.lookup_constant con in - let val_0 = cb.const_body in let typ = ungeneralized_type_of_constant_type cb.const_type in hov 0 ( - match val_0 with - | None -> - str (if cb.const_opaque then "Axiom " else "Parameter ") ++ + match cb.const_body with + | Undef _ -> + str "Parameter " ++ print_basename con ++ str " : " ++ cut () ++ pr_ltype typ - | Some v -> - if cb.const_opaque then - str "Theorem " ++ print_basename con ++ cut () ++ - str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++ - str "Proof " ++ print_body val_0 - else - str "Definition " ++ print_basename con ++ cut () ++ - str " : " ++ pr_ltype typ ++ cut () ++ str " := " ++ - print_body val_0) ++ str "." ++ fnl () ++ fnl () + | OpaqueDef lc -> + str "Theorem " ++ print_basename con ++ cut () ++ + str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++ + str "Proof " ++ pr_lconstr (Declarations.force_opaque lc) + | Def c -> + str "Definition " ++ print_basename con ++ cut () ++ + str " : " ++ pr_ltype typ ++ cut () ++ str " := " ++ + pr_lconstr (Declarations.force c)) + ++ str "." ++ fnl () ++ fnl () | "INDUCTIVE" -> - let mind = Global.mind_of_delta (mind_of_kn kn) in - let (mib,mip) = Global.lookup_inductive (mind,0) in - let mipv = mib.mind_packets in - let names = list_tabulate (fun x -> (mind,x)) (Array.length mipv) in - pr_mutual_inductive mib.mind_finite names ++ str "." ++ - fnl () ++ fnl () + let mind = Global.mind_of_delta_kn kn in + let mib = Global.lookup_mind mind in + pr_mutual_inductive_body (Global.env()) mind mib ++ + str "." ++ fnl () ++ fnl () | "MODULE" -> (* TODO: make it reparsable *) let (mp,_,l) = repr_kn kn in @@ -641,16 +603,6 @@ let print_full_pure_context () = assume that the declaration of constructors and eliminations follows the definition of the inductive type *) -let list_filter_vec f vec = - let rec frec n lf = - if n < 0 then lf - else if f vec.(n) then - frec (n-1) (vec.(n)::lf) - else - frec (n-1) lf - in - frec (Array.length vec -1) [] - (* This is designed to print the contents of an opened section *) let read_sec_context r = let loc,qid = qualid_of_reference r in @@ -708,7 +660,7 @@ let print_opaque_name qid = match global qid with | ConstRef cst -> let cb = Global.lookup_constant cst in - if cb.const_body <> None then + if constant_has_body cb then print_constant_with_infos cst else error "Not a defined constant." @@ -727,6 +679,7 @@ let print_about_any k = pr_infos_list ([print_ref false ref; blankline] @ print_name_infos ref @ + print_simpl_behaviour ref @ print_opacity ref @ [hov 0 (str "Expands to: " ++ pr_located_qualid k)]) | Syntactic kn -> @@ -744,15 +697,6 @@ let print_about = function | Genarg.AN ref -> print_about_any (locate_any_name ref) -let unfold_head_fconst = - let rec unfrec k = match kind_of_term k with - | Const cst -> constant_value (Global.env ()) cst - | Lambda (na,t,b) -> mkLambda (na,t,unfrec b) - | App (f,v) -> appvect (unfrec f,v) - | _ -> k - in - unfrec - (* for debug *) let inspect depth = print_context false (Some depth) (Lib.contents_after None) diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli index fef66a63..6d9c6ecc 100644 --- a/parsing/prettyp.mli +++ b/parsing/prettyp.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: prettyp.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - -(*i*) open Pp open Util open Names @@ -19,9 +16,8 @@ open Reductionops open Libnames open Nametab open Genarg -(*i*) -(* A Pretty-Printer for the Calculus of Inductive Constructions. *) +(** A Pretty-Printer for the Calculus of Inductive Constructions. *) val assumptions_for_print : name list -> Termops.names_context @@ -37,29 +33,27 @@ val print_judgment : env -> unsafe_judgment -> std_ppcmds val print_safe_judgment : env -> Safe_typing.judgment -> std_ppcmds val print_eval : reduction_function -> env -> Evd.evar_map -> Topconstr.constr_expr -> unsafe_judgment -> std_ppcmds -(* This function is exported for the graphical user-interface pcoq *) -val build_inductive : mutual_inductive -> int -> - global_reference * rel_context * types * identifier array * types array + val print_name : reference or_by_notation -> std_ppcmds val print_opaque_name : reference -> std_ppcmds val print_about : reference or_by_notation -> std_ppcmds val print_impargs : reference or_by_notation -> std_ppcmds -(* Pretty-printing functions for classes and coercions *) +(** Pretty-printing functions for classes and coercions *) val print_graph : unit -> std_ppcmds val print_classes : unit -> std_ppcmds val print_coercions : unit -> std_ppcmds val print_path_between : Classops.cl_typ -> Classops.cl_typ -> std_ppcmds val print_canonical_projections : unit -> std_ppcmds -(* Pretty-printing functions for type classes and instances *) +(** Pretty-printing functions for type classes and instances *) val print_typeclasses : unit -> std_ppcmds val print_instances : global_reference -> std_ppcmds val print_all_instances : unit -> std_ppcmds val inspect : int -> std_ppcmds -(* Locate *) +(** Locate *) val print_located_qualid : reference -> std_ppcmds type object_pr = { @@ -70,7 +64,6 @@ type object_pr = { print_module : bool -> Names.module_path -> std_ppcmds; print_modtype : module_path -> std_ppcmds; print_named_decl : identifier * constr option * types -> std_ppcmds; - print_leaf_entry : bool -> Libnames.object_name * Libobject.obj -> Pp.std_ppcmds; print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; print_typed_value_in_env : Environ.env -> Term.constr * Term.types -> Pp.std_ppcmds; diff --git a/parsing/printer.ml b/parsing/printer.ml index 75cdead9..0b9ce918 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -1,19 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: printer.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pp open Util open Names open Nameops open Term -open Termops open Sign open Environ open Global @@ -22,18 +19,18 @@ open Libnames open Nametab open Evd open Proof_type -open Decl_mode open Refiner open Pfedit open Ppconstr open Constrextern open Tacexpr -let emacs_str s alts = - match !Flags.print_emacs, !Flags.print_emacs_safechar with - | true, true -> alts - | true , false -> s - | false,_ -> "" +open Store.Field + +let emacs_str s = + if !Flags.print_emacs then s else "" +let delayed_emacs_cmd s = + if !Flags.print_emacs then s () else str "" (**********************************************************************) (** Terms *) @@ -63,7 +60,7 @@ let pr_constr_under_binders_env_gen pr env (ids,c) = (* we also need to preserve the actual names of the patterns *) (* So what to do? *) let assums = List.map (fun id -> (Name id,(* dummy *) mkProp)) ids in - pr (push_rels_assum assums env) c + pr (Termops.push_rels_assum assums env) c let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_constr_env let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_lconstr_env @@ -88,30 +85,30 @@ let pr_ljudge_env env j = let pr_ljudge j = pr_ljudge_env (Global.env()) j -let pr_lrawconstr_env env c = - pr_lconstr_expr (extern_rawconstr (vars_of_env env) c) -let pr_rawconstr_env env c = - pr_constr_expr (extern_rawconstr (vars_of_env env) c) +let pr_lglob_constr_env env c = + pr_lconstr_expr (extern_glob_constr (Termops.vars_of_env env) c) +let pr_glob_constr_env env c = + pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c) -let pr_lrawconstr c = - pr_lconstr_expr (extern_rawconstr Idset.empty c) -let pr_rawconstr c = - pr_constr_expr (extern_rawconstr Idset.empty c) +let pr_lglob_constr c = + pr_lconstr_expr (extern_glob_constr Idset.empty c) +let pr_glob_constr c = + pr_constr_expr (extern_glob_constr Idset.empty c) let pr_cases_pattern t = pr_cases_pattern_expr (extern_cases_pattern Idset.empty t) let pr_lconstr_pattern_env env c = - pr_lconstr_pattern_expr (extern_constr_pattern (names_of_rel_context env) c) + pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) c) let pr_constr_pattern_env env c = - pr_constr_pattern_expr (extern_constr_pattern (names_of_rel_context env) c) + pr_constr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) c) let pr_lconstr_pattern t = - pr_lconstr_pattern_expr (extern_constr_pattern empty_names_context t) + pr_lconstr_pattern_expr (extern_constr_pattern Termops.empty_names_context t) let pr_constr_pattern t = - pr_constr_pattern_expr (extern_constr_pattern empty_names_context t) + pr_constr_pattern_expr (extern_constr_pattern Termops.empty_names_context t) -let pr_sort s = pr_rawsort (extern_sort s) +let pr_sort s = pr_glob_sort (extern_sort s) let _ = Termops.set_print_constr pr_lconstr_env @@ -121,7 +118,7 @@ let _ = Termops.set_print_constr pr_lconstr_env let pr_global_env = pr_global_env let pr_global = pr_global_env Idset.empty -let pr_constant env cst = pr_global_env (vars_of_env env) (ConstRef cst) +let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) let pr_existential env ev = pr_lconstr_env env (mkEvar ev) let pr_inductive env ind = pr_lconstr_env env (mkInd ind) let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr) @@ -129,8 +126,8 @@ let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr) let pr_evaluable_reference ref = pr_global (Tacred.global_of_evaluable_reference ref) -(*let pr_rawterm t = - pr_lconstr (Constrextern.extern_rawconstr Idset.empty t)*) +(*let pr_glob_constr t = + pr_lconstr (Constrextern.extern_glob_constr Idset.empty t)*) (*open Pattern @@ -222,7 +219,7 @@ let pr_context_limit n env = else let pidt = pr_var_decl env d in (i+1, (pps ++ fnl () ++ - str (emacs_str (String.make 1 (Char.chr 253)) "") ++ + str (emacs_str "") ++ pidt))) env ~init:(0,(mt ())) in @@ -231,7 +228,7 @@ let pr_context_limit n env = (fun env d pps -> let pnat = pr_rel_decl env d in (pps ++ fnl () ++ - str (emacs_str (String.make 1 (Char.chr 253)) "") ++ + str (emacs_str "") ++ pnat)) env ~init:(mt ()) in @@ -243,18 +240,6 @@ let pr_context_of env = match Flags.print_hyps_limit () with (* display goal parts (Proof mode) *) -let pr_restricted_named_context among env = - hv 0 (fold_named_context - (fun env ((id,_,_) as d) pps -> - if true || Idset.mem id among then - pps ++ - fnl () ++ str (emacs_str (String.make 1 (Char.chr 253)) "") ++ - pr_var_decl env d - else - pps) - env ~init:(mt ())) - - let pr_predicate pr_elt (b, elts) = let pr_elts = prlist_with_sep spc pr_elt elts in if b then @@ -270,39 +255,34 @@ let pr_transparent_state (ids, csts) = hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++ str"CONSTANTS: " ++ pr_cpred csts ++ fnl ()) -let pr_subgoal_metas metas env= - let pr_one (meta,typ) = - str "?" ++ int meta ++ str " : " ++ - hov 0 (pr_ltype_env_at_top env typ) ++ fnl () ++ - str (emacs_str (String.make 1 (Char.chr 253)) "") in - hv 0 (prlist_with_sep mt pr_one metas) - (* display complete goal *) -let default_pr_goal g = - let env = evar_unfiltered_env g in +let default_pr_goal gs = + let (g,sigma) = Goal.V82.nf_evar (project gs) (sig_it gs) in + let env = Goal.V82.unfiltered_env sigma g in let preamb,thesis,penv,pc = - if g.evar_extra = None then - mt (), mt (), - pr_context_of env, - pr_ltype_env_at_top env g.evar_concl - else - (str " *** Declarative Mode ***" ++ fnl ()++fnl ()), - (str "thesis := " ++ fnl ()), - pr_context_of env, - pr_ltype_env_at_top env g.evar_concl + mt (), mt (), + pr_context_of env, + pr_ltype_env_at_top env (Goal.V82.concl sigma g) in preamb ++ str" " ++ hv 0 (penv ++ fnl () ++ - str (emacs_str (String.make 1 (Char.chr 253)) "") ++ + str (emacs_str "") ++ str "============================" ++ fnl () ++ thesis ++ str " " ++ pc) ++ fnl () +(* display a goal tag *) +let pr_goal_tag g = + let s = " (ID " ^ Goal.uid g ^ ")" in + str (emacs_str s) + (* display the conclusion of a goal *) -let pr_concl n g = - let env = evar_env g in - let pc = pr_ltype_env_at_top env g.evar_concl in - str (emacs_str (String.make 1 (Char.chr 253)) "") ++ - str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" " ++ pc +let pr_concl n sigma g = + let (g,sigma) = Goal.V82.nf_evar sigma g in + let env = Goal.V82.env sigma g in + let pc = pr_ltype_env_at_top env (Goal.V82.concl sigma g) in + str (emacs_str "") ++ + str "subgoal " ++ int n ++ pr_goal_tag g ++ + str " is:" ++ cut () ++ str" " ++ pc (* display evar type: a context and a type *) let pr_evgl_sign gl = @@ -316,6 +296,12 @@ let pr_evgl_sign gl = let pc = pr_lconstr gl.evar_concl in hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]" ++ spc () ++ warn) +(* Print an existential variable *) + +let pr_evar (ev, evd) = + let pegl = pr_evgl_sign evd in + (hov 0 (str (string_of_existential ev) ++ str " : " ++ pegl)) + (* Print an enumerated list of existential variables *) let rec pr_evars_int i = function | [] -> (mt ()) @@ -326,20 +312,42 @@ let rec pr_evars_int i = function str (string_of_existential ev) ++ str " : " ++ pegl)) ++ fnl () ++ pei -let default_pr_subgoal n = +let default_pr_subgoal n sigma = let rec prrec p = function | [] -> error "No such goal." | g::rest -> if p = 1 then - let pg = default_pr_goal g in - v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg) + let pg = default_pr_goal { sigma=sigma ; it=g } in + v 0 (str "subgoal " ++ int n ++ pr_goal_tag g + ++ str " is:" ++ cut () ++ pg) else prrec (p-1) rest in prrec n +let emacs_print_dependent_evars sigma seeds = + let evars () = + let evars = Evarutil.evars_of_evars_in_types_of_list sigma seeds in + let evars = + Intmap.fold begin fun e i s -> + let e' = str (string_of_existential e) in + match i with + | None -> s ++ str" " ++ e' ++ str " open," + | Some i -> + s ++ str " " ++ e' ++ str " using " ++ + Intset.fold begin fun d s -> + str (string_of_existential d) ++ str " " ++ s + end i (str ",") + end evars (str "") + in + cut () ++ + str "(dependent evars:" ++ evars ++ str ")" ++ fnl () + in + delayed_emacs_cmd evars + (* Print open subgoals. Checks for uninstantiated existential variables *) -let default_pr_subgoals close_cmd sigma = function +(* spiwack: [seeds] is for printing dependent evars in emacs mode. *) +let default_pr_subgoals close_cmd sigma seeds = function | [] -> begin match close_cmd with @@ -349,37 +357,45 @@ let default_pr_subgoals close_cmd sigma = function | None -> let exl = Evarutil.non_instantiated sigma in if exl = [] then - (str"Proof completed." ++ fnl ()) + (str"No more subgoals." ++ fnl () + ++ emacs_print_dependent_evars sigma seeds) else let pei = pr_evars_int 1 exl in (str "No more subgoals but non-instantiated existential " ++ - str "variables:" ++ fnl () ++ (hov 0 pei)) + str "variables:" ++ fnl () ++ (hov 0 pei) + ++ emacs_print_dependent_evars sigma seeds) end | [g] -> - let pg = default_pr_goal g in - v 0 (str ("1 "^"subgoal") ++cut () ++ pg) + let pg = default_pr_goal { it = g ; sigma = sigma } in + v 0 ( + str ("1 "^"subgoal") ++ pr_goal_tag g ++ cut () ++ pg + ++ emacs_print_dependent_evars sigma seeds + ) | g1::rest -> let rec pr_rec n = function | [] -> (mt ()) | g::rest -> - let pc = pr_concl n g in + let pc = pr_concl n sigma g in let prest = pr_rec (n+1) rest in (cut () ++ pc ++ prest) in - let pg1 = default_pr_goal g1 in + let pg1 = default_pr_goal { it = g1 ; sigma = sigma } in let prest = pr_rec 2 rest in - v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () - ++ pg1 ++ prest ++ fnl ()) - + v 0 ( + int(List.length rest+1) ++ str" subgoals" ++ + str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut () + ++ pg1 ++ prest ++ fnl () + ++ emacs_print_dependent_evars sigma seeds + ) (**********************************************************************) (* Abstraction layer *) type printer_pr = { - pr_subgoals : string option -> evar_map -> goal list -> std_ppcmds; - pr_subgoal : int -> goal list -> std_ppcmds; - pr_goal : goal -> std_ppcmds; + pr_subgoals : string option -> evar_map -> evar list -> goal list -> std_ppcmds; + pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; + pr_goal : goal sigma -> std_ppcmds; } let default_printer_pr = { @@ -400,25 +416,41 @@ let pr_goal x = !printer_pr.pr_goal x (**********************************************************************) let pr_open_subgoals () = - let pfts = get_pftreestate () in - let gls = fst (frontier (proof_of_pftreestate pfts)) in - match focus() with - | 0 -> - let sigma = (top_goal_of_pftreestate pfts).sigma in - let close_cmd = Decl_mode.get_end_command pfts in - pr_subgoals close_cmd sigma gls - | n -> - assert (n > List.length gls); - if List.length gls < 2 then - pr_subgoal n gls - else - (* LEM TODO: this way of saying how many subgoals has to be abstracted out*) - v 0 (int(List.length gls) ++ str" subgoals" ++ cut () ++ - pr_subgoal n gls) + let p = Proof_global.give_me_the_proof () in + let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in + let seeds = Proof.V82.top_evars p in + begin match goals with + | [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in + begin match bgoals with + | [] -> pr_subgoals None sigma seeds goals + | _ -> pr_subgoals None bsigma seeds bgoals ++ fnl () ++ fnl () ++ + str"This subproof is complete, but there are still unfocused goals:" + (* spiwack: to stay compatible with the proof general and coqide, + I use print the message after the goal. It would be better to have + something like: + str"This subproof is complete, but there are still unfocused goals:" + ++ fnl () ++ fnl () ++ pr_subgoals None bsigma bgoals + instead. But it doesn't quite work. + *) + end + | _ -> pr_subgoals None sigma seeds goals + end let pr_nth_open_subgoal n = - let pf = proof_of_pftreestate (get_pftreestate ()) in - pr_subgoal n (fst (frontier pf)) + let pf = get_pftreestate () in + let { it=gls ; sigma=sigma } = Proof.V82.subgoals pf in + pr_subgoal n sigma gls + +let pr_goal_by_id id = + let p = Proof_global.give_me_the_proof () in + let g = Goal.get_by_uid id in + let pr gs = + v 0 (str ("goal / evar " ^ id ^ " is:") ++ cut () + ++ pr_goal gs) + in + try + Proof.in_proof p (fun sigma -> pr {it=g;sigma=sigma}) + with Not_found -> error "Invalid goal identifier." (* Elementary tactics *) @@ -458,7 +490,7 @@ let pr_prim_rule = function | [] -> mt () in (str"cofix " ++ pr_id f ++ str" with " ++ print_mut others) | Refine c -> - str(if occur_meta c then "refine " else "exact ") ++ + str(if Termops.occur_meta c then "refine " else "exact ") ++ Constrextern.with_meta_as_hole pr_constr c | Convert_concl (c,_) -> @@ -570,3 +602,90 @@ let pr_instance_gmap insts = prlist_with_sep fnl (fun (gr, insts) -> prlist_with_sep fnl pr_instance (cmap_to_list insts)) (Gmap.to_list insts) + +(** Inductive declarations *) + +open Declarations +open Termops +open Reduction +open Inductive +open Inductiveops + +let print_params env params = + if params = [] then mt () else pr_rel_context env params ++ brk(1,2) + +let print_constructors envpar names types = + let pc = + prlist_with_sep (fun () -> brk(1,0) ++ str "| ") + (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c) + (Array.to_list (array_map2 (fun n t -> (n,t)) names types)) + in + hv 0 (str " " ++ pc) + +let build_ind_type env mip = + match mip.mind_arity with + | Monomorphic ar -> ar.mind_user_arity + | Polymorphic ar -> + it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt + +let print_one_inductive env mib ((_,i) as ind) = + let mip = mib.mind_packets.(i) in + let params = mib.mind_params_ctxt in + let args = extended_rel_list 0 params in + let arity = hnf_prod_applist env (build_ind_type env mip) args in + let cstrtypes = Inductive.type_of_constructors ind (mib,mip) in + let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in + let envpar = push_rel_context params env in + hov 0 ( + pr_id mip.mind_typename ++ brk(1,4) ++ print_params env params ++ + str ": " ++ pr_lconstr_env envpar arity ++ str " :=") ++ + brk(0,2) ++ print_constructors envpar mip.mind_consnames cstrtypes + +let print_mutual_inductive env mind mib = + let inds = list_tabulate (fun x -> (mind,x)) (Array.length mib.mind_packets) + in + hov 0 ( + str (if mib.mind_finite then "Inductive " else "CoInductive ") ++ + prlist_with_sep (fun () -> fnl () ++ str" with ") + (print_one_inductive env mib) inds) + +let get_fields = + let rec prodec_rec l subst c = + match kind_of_term c with + | Prod (na,t,c) -> + let id = match na with Name id -> id | Anonymous -> id_of_string "_" in + prodec_rec ((id,true,substl subst t)::l) (mkVar id::subst) c + | LetIn (na,b,_,c) -> + let id = match na with Name id -> id | Anonymous -> id_of_string "_" in + prodec_rec ((id,false,substl subst b)::l) (mkVar id::subst) c + | _ -> List.rev l + in + prodec_rec [] [] + +let print_record env mind mib = + let mip = mib.mind_packets.(0) in + let params = mib.mind_params_ctxt in + let args = extended_rel_list 0 params in + let arity = hnf_prod_applist env (build_ind_type env mip) args in + let cstrtypes = Inductive.type_of_constructors (mind,0) (mib,mip) in + let cstrtype = hnf_prod_applist env cstrtypes.(0) args in + let fields = get_fields cstrtype in + let envpar = push_rel_context params env in + hov 0 ( + hov 0 ( + str "Record " ++ pr_id mip.mind_typename ++ brk(1,4) ++ + print_params env params ++ + str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++ + str ":= " ++ pr_id mip.mind_consnames.(0)) ++ + brk(1,2) ++ + hv 2 (str "{ " ++ + prlist_with_sep (fun () -> str ";" ++ brk(2,0)) + (fun (id,b,c) -> + pr_id id ++ str (if b then " : " else " := ") ++ + pr_lconstr_env envpar c) fields) ++ str" }") + +let pr_mutual_inductive_body env mind mib = + if mib.mind_record & not !Flags.raw_print then + print_record env mind mib + else + print_mutual_inductive env mind mib diff --git a/parsing/printer.mli b/parsing/printer.mli index 99ab3ca3..2d437c20 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -1,33 +1,29 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: printer.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - -(*i*) open Pp open Names open Libnames open Term open Sign open Environ -open Rawterm +open Glob_term open Pattern open Nametab open Termops open Evd open Proof_type -open Rawterm +open Glob_term open Tacexpr -(*i*) -(* These are the entry points for printing terms, context, tac, ... *) +(** These are the entry points for printing terms, context, tac, ... *) -(* Terms *) +(** Terms *) val pr_lconstr_env : env -> constr -> std_ppcmds val pr_lconstr_env_at_top : env -> constr -> std_ppcmds @@ -58,11 +54,11 @@ val pr_type : types -> std_ppcmds val pr_ljudge_env : env -> unsafe_judgment -> std_ppcmds * std_ppcmds val pr_ljudge : unsafe_judgment -> std_ppcmds * std_ppcmds -val pr_lrawconstr_env : env -> rawconstr -> std_ppcmds -val pr_lrawconstr : rawconstr -> std_ppcmds +val pr_lglob_constr_env : env -> glob_constr -> std_ppcmds +val pr_lglob_constr : glob_constr -> std_ppcmds -val pr_rawconstr_env : env -> rawconstr -> std_ppcmds -val pr_rawconstr : rawconstr -> std_ppcmds +val pr_glob_constr_env : env -> glob_constr -> std_ppcmds +val pr_glob_constr : glob_constr -> std_ppcmds val pr_lconstr_pattern_env : env -> constr_pattern -> std_ppcmds val pr_lconstr_pattern : constr_pattern -> std_ppcmds @@ -74,7 +70,7 @@ val pr_cases_pattern : cases_pattern -> std_ppcmds val pr_sort : sorts -> std_ppcmds -(* Printing global references using names as short as possible *) +(** Printing global references using names as short as possible *) val pr_global_env : Idset.t -> global_reference -> std_ppcmds val pr_global : global_reference -> std_ppcmds @@ -85,7 +81,7 @@ val pr_constructor : env -> constructor -> std_ppcmds val pr_inductive : env -> inductive -> std_ppcmds val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds -(* Contexts *) +(** Contexts *) val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds @@ -98,47 +94,56 @@ val pr_rel_context : env -> rel_context -> std_ppcmds val pr_rel_context_of : env -> std_ppcmds val pr_context_of : env -> std_ppcmds -(* Predicates *) +(** Predicates *) val pr_predicate : ('a -> std_ppcmds) -> (bool * 'a list) -> std_ppcmds val pr_cpred : Cpred.t -> std_ppcmds val pr_idpred : Idpred.t -> std_ppcmds val pr_transparent_state : transparent_state -> std_ppcmds -(* Proofs *) +(** Proofs *) -val pr_goal : goal -> std_ppcmds -val pr_subgoals : string option -> evar_map -> goal list -> std_ppcmds -val pr_subgoal : int -> goal list -> std_ppcmds +val pr_goal : goal sigma -> std_ppcmds +val pr_subgoals : string option -> evar_map -> evar list -> goal list -> std_ppcmds +val pr_subgoal : int -> evar_map -> goal list -> std_ppcmds +val pr_concl : int -> evar_map -> goal -> std_ppcmds val pr_open_subgoals : unit -> std_ppcmds val pr_nth_open_subgoal : int -> std_ppcmds +val pr_evar : (evar * evar_info) -> std_ppcmds val pr_evars_int : int -> (evar * evar_info) list -> std_ppcmds val pr_prim_rule : prim_rule -> std_ppcmds -(* Emacs/proof general support *) -(* (emacs_str s alts) outputs - - s if emacs mode & unicode allowed, - - alts if emacs mode and & unicode not allowed - - nothing otherwise *) -val emacs_str : string -> string -> string +(** Emacs/proof general support + (emacs_str s) outputs + - s if emacs mode, + - nothing otherwise. + This function was previously used to insert special chars like + [(String.make 1 (Char.chr 253))] to parenthesize sub-parts of the + proof context for proof by pointing. This part of the code is + removed for now because it interacted badly with utf8. We may put + it back some day using some xml-like tags instead of special + chars. See for example the <prompt> tag in the prompt when in + emacs mode. *) +val emacs_str : string -> string -(* Backwards compatibility *) +(** Backwards compatibility *) -val prterm : constr -> std_ppcmds (* = pr_lconstr *) +val prterm : constr -> std_ppcmds (** = pr_lconstr *) -(* spiwack: printer function for sets of Environ.assumption. +(** spiwack: printer function for sets of Environ.assumption. It is used primarily by the Print Assumption command. *) val pr_assumptionset : env -> Term.types Assumptions.ContextObjectMap.t ->std_ppcmds +val pr_goal_by_id : string -> std_ppcmds type printer_pr = { - pr_subgoals : string option -> evar_map -> goal list -> std_ppcmds; - pr_subgoal : int -> goal list -> std_ppcmds; - pr_goal : goal -> std_ppcmds; + pr_subgoals : string option -> evar_map -> evar list -> goal list -> std_ppcmds; + pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; + pr_goal : goal sigma -> std_ppcmds; };; val set_printer_pr : printer_pr -> unit @@ -147,3 +152,8 @@ val default_printer_pr : printer_pr val pr_instance_gmap : (global_reference, Typeclasses.instance Names.Cmap.t) Gmap.t -> Pp.std_ppcmds + +(** Inductive declarations *) + +val pr_mutual_inductive_body : + env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds diff --git a/parsing/printmod.ml b/parsing/printmod.ml index 6339ed8f..9cf76585 100644 --- a/parsing/printmod.ml +++ b/parsing/printmod.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,6 +12,27 @@ open Names open Declarations open Nameops open Libnames +open Goptions + +(** Note: there is currently two modes for printing modules. + - The "short" one, that just prints the names of the fields. + - The "rich" one, that also tries to print the types of the fields. + The short version used to be the default behavior, but now we print + types by default. The following option allows to change this. + Technically, the environments in this file are either None in + the "short" mode or (Some env) in the "rich" one. +*) + +let short = ref false + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "short module printing"; + optkey = ["Short";"Module";"Printing"]; + optread = (fun () -> !short) ; + optwrite = ((:=) short) } let get_new_id locals id = let rec get_id l id = @@ -47,92 +68,141 @@ let print_kn locals kn = with Not_found -> print_modpath locals kn -let rec flatten_app mexpr l = match mexpr with - | SEBapply (mexpr,marg,_) -> flatten_app mexpr (marg::l) - | mexpr -> mexpr::l +let nametab_register_dir mp = + let id = id_of_string "FAKETOP" in + let fp = Libnames.make_path empty_dirpath id in + let dir = make_dirpath [id] in + Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath))); + fp -let rec print_module name locals with_body mb = - let body = match with_body, mb.mod_expr with - | false, _ - | true, None -> mt() - | true, Some mexpr -> - spc () ++ str ":= " ++ print_modexpr locals mexpr - in +(** Nota: the [global_reference] we register in the nametab below + might differ from internal ones, since we cannot recreate here + the canonical part of constant and inductive names, but only + the user names. This works nonetheless since we search now + [Nametab.the_globrevtab] modulo user name. *) - let modtype = - match mb.mod_type with - | t -> spc () ++ str": " ++ - print_modtype locals t +let nametab_register_body mp fp (l,body) = + let push id ref = + Nametab.push (Nametab.Until 1) (make_path (dirpath fp) id) ref in - hv 2 (str "Module " ++ name ++ modtype ++ body) + match body with + | SFBmodule _ -> () (* TODO *) + | SFBmodtype _ -> () (* TODO *) + | SFBconst _ -> + push (id_of_label l) (ConstRef (make_con mp empty_dirpath l)) + | SFBmind mib -> + let mind = make_mind mp empty_dirpath l in + Array.iteri + (fun i mip -> + push mip.mind_typename (IndRef (mind,i)); + Array.iteri (fun j id -> push id (ConstructRef ((mind,i),j+1))) + mip.mind_consnames) + mib.mind_packets + +let print_body is_impl env mp (l,body) = + let name = str (string_of_label l) in + hov 2 (match body with + | SFBmodule _ -> str "Module " ++ name + | SFBmodtype _ -> str "Module Type " ++ name + | SFBconst cb -> + (match cb.const_body with + | Def _ -> str "Definition " + | OpaqueDef _ when is_impl -> str "Theorem " + | _ -> str "Parameter ") ++ name ++ + (match env with + | None -> mt () + | Some env -> + str " :" ++ spc () ++ + hov 0 (Printer.pr_ltype_env env + (Typeops.type_of_constant_type env cb.const_type)) ++ + (match cb.const_body with + | Def l when is_impl -> + spc () ++ + hov 2 (str ":= " ++ + Printer.pr_lconstr_env env (Declarations.force l)) + | _ -> mt ()) ++ + str ".") + | SFBmind mib -> + try + let env = Option.get env in + Printer.pr_mutual_inductive_body env (make_mind mp empty_dirpath l) mib + with _ -> + (if mib.mind_finite then str "Inductive " else str "CoInductive") + ++ name) + +let print_struct is_impl env mp struc = + begin + (* If [mp] is a globally visible module, we simply import it *) + try Declaremods.really_import_module mp + with _ -> + (* Otherwise we try to emulate an import by playing with nametab *) + let fp = nametab_register_dir mp in + List.iter (nametab_register_body mp fp) struc + end; + prlist_with_sep spc (print_body is_impl env mp) struc -and print_modtype locals mty = +let rec flatten_app mexpr l = match mexpr with + | SEBapply (mexpr, SEBident arg,_) -> flatten_app mexpr (arg::l) + | SEBident mp -> mp::l + | _ -> assert false + +let rec print_modtype env mp locals mty = match mty with | SEBident kn -> print_kn locals kn | SEBfunctor (mbid,mtb1,mtb2) -> - (* let env' = Modops.add_module (MPbid mbid) - (Modops.body_of_type mtb) env - in *) - let locals' = (mbid, get_new_id locals (id_of_mbid mbid)) - ::locals in - hov 2 (str "Funsig" ++ spc () ++ str "(" ++ - pr_id (id_of_mbid mbid) ++ str " : " ++ - print_modtype locals mtb1.typ_expr ++ - str ")" ++ spc() ++ print_modtype locals' mtb2) - | SEBstruct (sign) -> - hv 2 (str "Sig" ++ spc () ++ print_sig locals sign ++ brk (1,-2) ++ str "End") - | SEBapply (mexpr,marg,_) -> - let lapp = flatten_app mexpr [marg] in + let mp1 = MPbound mbid in + let env' = Option.map + (Modops.add_module (Modops.module_body_of_type mp1 mtb1)) env in + let seb1 = Option.default mtb1.typ_expr mtb1.typ_expr_alg in + let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals + in + (try Declaremods.process_module_seb_binding mbid seb1 with _ -> ()); + hov 2 (str "Funsig" ++ spc () ++ str "(" ++ + pr_id (id_of_mbid mbid) ++ str ":" ++ + print_modtype env mp1 locals seb1 ++ + str ")" ++ spc() ++ print_modtype env' mp locals' mtb2) + | SEBstruct (sign) -> + let env' = Option.map + (Modops.add_signature mp sign Mod_subst.empty_delta_resolver) env in + hv 2 (str "Sig" ++ spc () ++ print_struct false env' mp sign ++ + brk (1,-2) ++ str "End") + | SEBapply _ -> + let lapp = flatten_app mty [] in let fapp = List.hd lapp in let mapp = List.tl lapp in - hov 3 (str"(" ++ (print_modtype locals fapp) ++ spc () ++ - prlist_with_sep spc (print_modexpr locals) mapp ++ str")") + hov 3 (str"(" ++ (print_kn locals fapp) ++ spc () ++ + prlist_with_sep spc (print_modpath locals) mapp ++ str")") | SEBwith(seb,With_definition_body(idl,cb))-> + let env' = None in (* TODO: build a proper environment if env <> None *) let s = (String.concat "." (List.map string_of_id idl)) in - hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ + hov 2 (print_modtype env' mp locals seb ++ spc() ++ str "with" ++ spc() ++ str "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) | SEBwith(seb,With_module_body(idl,mp))-> let s =(String.concat "." (List.map string_of_id idl)) in - hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ + hov 2 (print_modtype env mp locals seb ++ spc() ++ str "with" ++ spc() ++ str "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) -and print_sig locals sign = - let print_spec (l,spec) = (match spec with - | SFBconst {const_body=Some _; const_opaque=false} -> str "Definition " - | SFBconst {const_body=None} - | SFBconst {const_opaque=true} -> str "Parameter " - | SFBmind _ -> str "Inductive " - | SFBmodule _ -> str "Module " - | SFBmodtype _ -> str "Module Type ") ++ str (string_of_label l) - in - prlist_with_sep spc print_spec sign - -and print_struct locals struc = - let print_body (l,body) = (match body with - | SFBconst {const_body=Some _; const_opaque=false} -> str "Definition " - | SFBconst {const_body=Some _; const_opaque=true} -> str "Theorem " - | SFBconst {const_body=None} -> str "Parameter " - | SFBmind _ -> str "Inductive " - | SFBmodule _ -> str "Module " - | SFBmodtype _ -> str "Module Type ") ++ str (string_of_label l) - in - prlist_with_sep spc print_body struc - -and print_modexpr locals mexpr = match mexpr with +let rec print_modexpr env mp locals mexpr = match mexpr with | SEBident mp -> print_modpath locals mp | SEBfunctor (mbid,mty,mexpr) -> -(* let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env - in *) + let mp' = MPbound mbid in + let env' = Option.map + (Modops.add_module (Modops.module_body_of_type mp' mty)) env in + let typ = Option.default mty.typ_expr mty.typ_expr_alg in let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in + (try Declaremods.process_module_seb_binding mbid typ with _ -> ()); hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++ - str ":" ++ print_modtype locals mty.typ_expr ++ - str ")" ++ spc () ++ print_modexpr locals' mexpr) - | SEBstruct ( struc) -> - hv 2 (str "Struct" ++ spc () ++ print_struct locals struc ++ brk (1,-2) ++ str "End") - | SEBapply (mexpr,marg,_) -> - let lapp = flatten_app mexpr [marg] in - hov 3 (str"(" ++ prlist_with_sep spc (print_modexpr locals) lapp ++ str")") - | SEBwith (_,_)-> anomaly "Not avaible yet" + str ":" ++ print_modtype env mp' locals typ ++ + str ")" ++ spc () ++ print_modexpr env' mp locals' mexpr) + | SEBstruct struc -> + let env' = Option.map + (Modops.add_signature mp struc Mod_subst.empty_delta_resolver) env in + hv 2 (str "Struct" ++ spc () ++ print_struct true env' mp struc ++ + brk (1,-2) ++ str "End") + | SEBapply _ -> + let lapp = flatten_app mexpr [] in + hov 3 (str"(" ++ prlist_with_sep spc (print_modpath locals) lapp ++ str")") + | SEBwith (_,_)-> anomaly "Not available yet" let rec printable_body dir = @@ -146,13 +216,43 @@ let rec printable_body dir = with Not_found -> true +(** Since we might play with nametab above, we should reset to prior + state after the printing *) -let print_module with_body mp = +let print_modexpr' env mp mexpr = + States.with_state_protection (print_modexpr env mp []) mexpr +let print_modtype' env mp mty = + States.with_state_protection (print_modtype env mp []) mty + +let print_module' env mp with_body mb = let name = print_modpath [] mp in - print_module name [] with_body (Global.lookup_module mp) ++ fnl () + let body = match with_body, mb.mod_expr with + | false, _ + | true, None -> mt() + | true, Some mexpr -> + spc () ++ str ":= " ++ print_modexpr' env mp mexpr + in + let modtype = brk (1,1) ++ str": " ++ print_modtype' env mp mb.mod_type + in + hv 0 (str "Module " ++ name ++ modtype ++ body) + +exception ShortPrinting + +let print_module with_body mp = + let me = Global.lookup_module mp in + try + if !short then raise ShortPrinting; + print_module' (Some (Global.env ())) mp with_body me ++ fnl () + with _ -> + print_module' None mp with_body me ++ fnl () let print_modtype kn = let mtb = Global.lookup_modtype kn in let name = print_kn [] kn in - str "Module Type " ++ name ++ str " = " ++ - print_modtype [] mtb.typ_expr ++ fnl () + hv 1 + (str "Module Type " ++ name ++ str " =" ++ spc () ++ + (try + if !short then raise ShortPrinting; + print_modtype' (Some (Global.env ())) kn mtb.typ_expr + with _ -> + print_modtype' None kn mtb.typ_expr)) diff --git a/parsing/printmod.mli b/parsing/printmod.mli index 77ff34f1..a45bdb98 100644 --- a/parsing/printmod.mli +++ b/parsing/printmod.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,7 @@ open Pp open Names -(* false iff the module is an element of an open module type *) +(** false iff the module is an element of an open module type *) val printable_body : dir_path -> bool val print_module : bool -> module_path -> std_ppcmds diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4 index 3d203dbe..60543269 100644 --- a/parsing/q_constr.ml4 +++ b/parsing/q_constr.ml4 @@ -1,41 +1,41 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) +(*i camlp4deps: "tools/compat5b.cmo" i*) -(* $Id: q_constr.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - -open Rawterm +open Glob_term open Term open Names open Pattern open Q_util open Util +open Compat open Pcaml +open PcamlSig let loc = dummy_loc let dloc = <:expr< Util.dummy_loc >> let apply_ref f l = <:expr< - Rawterm.RApp ($dloc$, Rawterm.RRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$) + Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$) >> EXTEND GLOBAL: expr; expr: [ [ "PATTERN"; "["; c = constr; "]" -> - <:expr< snd (Pattern.pattern_of_rawconstr $c$) >> ] ] + <:expr< snd (Pattern.pattern_of_glob_constr $c$) >> ] ] ; sort: - [ [ "Set" -> RProp Pos - | "Prop" -> RProp Null - | "Type" -> RType None ] ] + [ [ "Set" -> GProp Pos + | "Prop" -> GProp Null + | "Type" -> GType None ] ] ; ident: [ [ s = string -> <:expr< Names.id_of_string $str:s$ >> ] ] @@ -44,24 +44,24 @@ EXTEND [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ] ; string: - [ [ UIDENT | LIDENT ] ] + [ [ s = UIDENT -> s | s = LIDENT -> s ] ] ; constr: [ "200" RIGHTA [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr -> - <:expr< Rawterm.RProd ($dloc$,Name $id$,Rawterm.Explicit,$c1$,$c2$) >> + <:expr< Glob_term.GProd ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >> | "fun"; id = ident; ":"; c1 = constr; "=>"; c2 = constr -> - <:expr< Rawterm.RLambda ($dloc$,Name $id$,Rawterm.Explicit,$c1$,$c2$) >> + <:expr< Glob_term.GLambda ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >> | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr -> - <:expr< Rawterm.RLetin ($dloc$,Name $id$,$c1$,$c2$) >> + <:expr< Glob_term.RLetin ($dloc$,Name $id$,$c1$,$c2$) >> (* fix todo *) ] | "100" RIGHTA [ c1 = constr; ":"; c2 = SELF -> - <:expr< Rawterm.RCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ] + <:expr< Glob_term.GCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ] | "90" RIGHTA [ c1 = constr; "->"; c2 = SELF -> - <:expr< Rawterm.RProd ($dloc$,Anonymous,Rawterm.Explicit,$c1$,$c2$) >> ] + <:expr< Glob_term.GProd ($dloc$,Anonymous,Glob_term.Explicit,$c1$,$c2$) >> ] | "75" RIGHTA [ "~"; c = constr -> apply_ref <:expr< coq_not_ref >> [c] ] @@ -71,15 +71,15 @@ EXTEND | "10" LEFTA [ f = constr; args = LIST1 NEXT -> let args = mlexpr_of_list (fun x -> x) args in - <:expr< Rawterm.RApp ($dloc$,$f$,$args$) >> ] + <:expr< Glob_term.GApp ($dloc$,$f$,$args$) >> ] | "0" - [ s = sort -> <:expr< Rawterm.RSort ($dloc$,s) >> - | id = ident -> <:expr< Rawterm.RVar ($dloc$,$id$) >> - | "_" -> <:expr< Rawterm.RHole ($dloc$, QuestionMark (Define False)) >> - | "?"; id = ident -> <:expr< Rawterm.RPatVar($dloc$,(False,$id$)) >> + [ s = sort -> <:expr< Glob_term.GSort ($dloc$,s) >> + | id = ident -> <:expr< Glob_term.GVar ($dloc$,$id$) >> + | "_" -> <:expr< Glob_term.GHole ($dloc$, QuestionMark (Define False)) >> + | "?"; id = ident -> <:expr< Glob_term.GPatVar($dloc$,(False,$id$)) >> | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" -> apply_ref <:expr< coq_sumbool_ref >> [c1;c2] - | "%"; e = string -> <:expr< Rawterm.RRef ($dloc$,Lazy.force $lid:e$) >> + | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$) >> | c = match_constr -> c | "("; c = constr LEVEL "200"; ")" -> c ] ] ; @@ -87,7 +87,7 @@ EXTEND [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type; "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> let br = mlexpr_of_list (fun x -> x) br in - <:expr< Rawterm.RCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> + <:expr< Glob_term.GCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> ] ] ; match_type: @@ -108,13 +108,13 @@ EXTEND [ [ "%"; e = string; lip = LIST0 patvar -> let lp = mlexpr_of_list (fun (_,x) -> x) lip in let lid = List.flatten (List.map fst lip) in - lid, <:expr< Rawterm.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >> + lid, <:expr< Glob_term.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >> | p = patvar -> p | "("; p = pattern; ")" -> p ] ] ; patvar: - [ [ "_" -> [], <:expr< Rawterm.PatVar ($dloc$,Anonymous) >> - | id = ident -> [id], <:expr< Rawterm.PatVar ($dloc$,Name $id$) >> + [ [ "_" -> [], <:expr< Glob_term.PatVar ($dloc$,Anonymous) >> + | id = ident -> [id], <:expr< Glob_term.PatVar ($dloc$,Name $id$) >> ] ] ; END;; diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index d612dd55..7df97a07 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -1,19 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "q_MLast.cmo pa_macro.cmo" i*) - -(* $Id: q_coqast.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Util open Names open Libnames open Q_util +open Compat let is_meta s = String.length s > 0 && s.[0] == '$' @@ -21,21 +18,8 @@ let purge_str s = if String.length s == 0 || s.[0] <> '$' then s else String.sub s 1 (String.length s - 1) -IFDEF OCAML308 THEN DEFINE NOP END -IFDEF OCAML309 THEN DEFINE NOP END -IFDEF CAMLP5 THEN DEFINE NOP END - let anti loc x = - let e = - let loc = - IFDEF NOP THEN - loc - ELSE - (1, snd loc - fst loc) - END - in <:expr< $lid:purge_str x$ >> - in - <:expr< $anti:e$ >> + expl_anti loc <:expr< $lid:purge_str x$ >> (* We don't give location for tactic quotation! *) let loc = dummy_loc @@ -88,12 +72,12 @@ let mlexpr_of_or_metaid f = function | Tacexpr.MetaId (_,id) -> <:expr< Tacexpr.AI $anti loc id$ >> let mlexpr_of_quantified_hypothesis = function - | Rawterm.AnonHyp n -> <:expr< Rawterm.AnonHyp $mlexpr_of_int n$ >> - | Rawterm.NamedHyp id -> <:expr< Rawterm.NamedHyp $mlexpr_of_ident id$ >> + | Glob_term.AnonHyp n -> <:expr< Glob_term.AnonHyp $mlexpr_of_int n$ >> + | Glob_term.NamedHyp id -> <:expr< Glob_term.NamedHyp $mlexpr_of_ident id$ >> let mlexpr_of_or_var f = function - | Rawterm.ArgArg x -> <:expr< Rawterm.ArgArg $f x$ >> - | Rawterm.ArgVar id -> <:expr< Rawterm.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >> + | Glob_term.ArgArg x -> <:expr< Glob_term.ArgArg $f x$ >> + | Glob_term.ArgVar id -> <:expr< Glob_term.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >> let mlexpr_of_hyp = mlexpr_of_or_metaid (mlexpr_of_located mlexpr_of_ident) @@ -118,17 +102,17 @@ let mlexpr_of_clause cl = Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >> let mlexpr_of_red_flags { - Rawterm.rBeta = bb; - Rawterm.rIota = bi; - Rawterm.rZeta = bz; - Rawterm.rDelta = bd; - Rawterm.rConst = l + Glob_term.rBeta = bb; + Glob_term.rIota = bi; + Glob_term.rZeta = bz; + Glob_term.rDelta = bd; + Glob_term.rConst = l } = <:expr< { - Rawterm.rBeta = $mlexpr_of_bool bb$; - Rawterm.rIota = $mlexpr_of_bool bi$; - Rawterm.rZeta = $mlexpr_of_bool bz$; - Rawterm.rDelta = $mlexpr_of_bool bd$; - Rawterm.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$ + Glob_term.rBeta = $mlexpr_of_bool bb$; + Glob_term.rIota = $mlexpr_of_bool bi$; + Glob_term.rZeta = $mlexpr_of_bool bz$; + Glob_term.rDelta = $mlexpr_of_bool bd$; + Glob_term.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$ } >> let mlexpr_of_explicitation = function @@ -136,8 +120,8 @@ let mlexpr_of_explicitation = function | Topconstr.ExplByPos (n,_id) -> <:expr< Topconstr.ExplByPos $mlexpr_of_int n$ >> let mlexpr_of_binding_kind = function - | Rawterm.Implicit -> <:expr< Rawterm.Implicit >> - | Rawterm.Explicit -> <:expr< Rawterm.Explicit >> + | Glob_term.Implicit -> <:expr< Glob_term.Implicit >> + | Glob_term.Explicit -> <:expr< Glob_term.Explicit >> let mlexpr_of_binder_kind = function | Topconstr.Default b -> <:expr< Topconstr.Default $mlexpr_of_binding_kind b$ >> @@ -174,25 +158,25 @@ let mlexpr_of_occ_constr = mlexpr_of_occurrences mlexpr_of_constr let mlexpr_of_red_expr = function - | Rawterm.Red b -> <:expr< Rawterm.Red $mlexpr_of_bool b$ >> - | Rawterm.Hnf -> <:expr< Rawterm.Hnf >> - | Rawterm.Simpl o -> <:expr< Rawterm.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >> - | Rawterm.Cbv f -> - <:expr< Rawterm.Cbv $mlexpr_of_red_flags f$ >> - | Rawterm.Lazy f -> - <:expr< Rawterm.Lazy $mlexpr_of_red_flags f$ >> - | Rawterm.Unfold l -> + | Glob_term.Red b -> <:expr< Glob_term.Red $mlexpr_of_bool b$ >> + | Glob_term.Hnf -> <:expr< Glob_term.Hnf >> + | Glob_term.Simpl o -> <:expr< Glob_term.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >> + | Glob_term.Cbv f -> + <:expr< Glob_term.Cbv $mlexpr_of_red_flags f$ >> + | Glob_term.Lazy f -> + <:expr< Glob_term.Lazy $mlexpr_of_red_flags f$ >> + | Glob_term.Unfold l -> let f1 = mlexpr_of_by_notation mlexpr_of_reference in let f = mlexpr_of_list (mlexpr_of_occurrences f1) in - <:expr< Rawterm.Unfold $f l$ >> - | Rawterm.Fold l -> - <:expr< Rawterm.Fold $mlexpr_of_list mlexpr_of_constr l$ >> - | Rawterm.Pattern l -> + <:expr< Glob_term.Unfold $f l$ >> + | Glob_term.Fold l -> + <:expr< Glob_term.Fold $mlexpr_of_list mlexpr_of_constr l$ >> + | Glob_term.Pattern l -> let f = mlexpr_of_list mlexpr_of_occ_constr in - <:expr< Rawterm.Pattern $f l$ >> - | Rawterm.CbvVm -> <:expr< Rawterm.CbvVm >> - | Rawterm.ExtraRedExpr s -> - <:expr< Rawterm.ExtraRedExpr $mlexpr_of_string s$ >> + <:expr< Glob_term.Pattern $f l$ >> + | Glob_term.CbvVm -> <:expr< Glob_term.CbvVm >> + | Glob_term.ExtraRedExpr s -> + <:expr< Glob_term.ExtraRedExpr $mlexpr_of_string s$ >> let rec mlexpr_of_argtype loc = function | Genarg.BoolArgType -> <:expr< Genarg.BoolArgType >> @@ -222,25 +206,25 @@ let rec mlexpr_of_argtype loc = function | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >> let rec mlexpr_of_may_eval f = function - | Rawterm.ConstrEval (r,c) -> - <:expr< Rawterm.ConstrEval $mlexpr_of_red_expr r$ $f c$ >> - | Rawterm.ConstrContext ((loc,id),c) -> + | Glob_term.ConstrEval (r,c) -> + <:expr< Glob_term.ConstrEval $mlexpr_of_red_expr r$ $f c$ >> + | Glob_term.ConstrContext ((loc,id),c) -> let id = mlexpr_of_ident id in - <:expr< Rawterm.ConstrContext (loc,$id$) $f c$ >> - | Rawterm.ConstrTypeOf c -> - <:expr< Rawterm.ConstrTypeOf $mlexpr_of_constr c$ >> - | Rawterm.ConstrTerm c -> - <:expr< Rawterm.ConstrTerm $mlexpr_of_constr c$ >> + <:expr< Glob_term.ConstrContext (loc,$id$) $f c$ >> + | Glob_term.ConstrTypeOf c -> + <:expr< Glob_term.ConstrTypeOf $mlexpr_of_constr c$ >> + | Glob_term.ConstrTerm c -> + <:expr< Glob_term.ConstrTerm $mlexpr_of_constr c$ >> let mlexpr_of_binding_kind = function - | Rawterm.ExplicitBindings l -> + | Glob_term.ExplicitBindings l -> let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in - <:expr< Rawterm.ExplicitBindings $l$ >> - | Rawterm.ImplicitBindings l -> + <:expr< Glob_term.ExplicitBindings $l$ >> + | Glob_term.ImplicitBindings l -> let l = mlexpr_of_list mlexpr_of_constr l in - <:expr< Rawterm.ImplicitBindings $l$ >> - | Rawterm.NoBindings -> - <:expr< Rawterm.NoBindings >> + <:expr< Glob_term.ImplicitBindings $l$ >> + | Glob_term.NoBindings -> + <:expr< Glob_term.NoBindings >> let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr @@ -397,7 +381,7 @@ let rec mlexpr_of_atomic_tactic = function | Tacexpr.TacAnyConstructor (ev,t) -> <:expr< Tacexpr.TacAnyConstructor $mlexpr_of_bool ev$ $mlexpr_of_option mlexpr_of_tactic t$>> | Tacexpr.TacConstructor (ev,n,l) -> - let n = mlexpr_of_or_metaid mlexpr_of_int n in + let n = mlexpr_of_or_var mlexpr_of_int n in <:expr< Tacexpr.TacConstructor $mlexpr_of_bool ev$ $n$ $mlexpr_of_binding_kind l$>> (* Conversion *) @@ -425,12 +409,6 @@ let rec mlexpr_of_atomic_tactic = function let lems = mlexpr_of_list mlexpr_of_constr lems in <:expr< Tacexpr.TacTrivial $lems$ $l$ >> -(* - | Tacexpr.TacExtend (s,l) -> - let l = mlexpr_of_list mlexpr_of_tactic_arg l in - let $dloc$ = MLast.loc_of_expr l in - <:expr< Tacexpr.TacExtend $mlexpr_of_string s$ $l$ >> -*) | _ -> failwith "Quotation of atomic tactic expressions: TODO" and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function @@ -450,6 +428,8 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function <:expr< Tacexpr.TacOrelse $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >> | Tacexpr.TacDo (n,t) -> <:expr< Tacexpr.TacDo $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> + | Tacexpr.TacTimeout (n,t) -> + <:expr< Tacexpr.TacTimeout $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> | Tacexpr.TacRepeat t -> <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >> | Tacexpr.TacProgress t -> @@ -485,9 +465,9 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function <:expr< Tacexpr.TacFun ($mlexpr_of_list mlexpr_of_ident_option idol$, $mlexpr_of_tactic body$) >> - | Tacexpr.TacArg (Tacexpr.MetaIdArg (_,true,id)) -> anti loc id - | Tacexpr.TacArg t -> - <:expr< Tacexpr.TacArg $mlexpr_of_tactic_arg t$ >> + | Tacexpr.TacArg (_,Tacexpr.MetaIdArg (_,true,id)) -> anti loc id + | Tacexpr.TacArg (_,t) -> + <:expr< Tacexpr.TacArg $dloc$ $mlexpr_of_tactic_arg t$ >> | Tacexpr.TacComplete t -> <:expr< Tacexpr.TacComplete $mlexpr_of_tactic t$ >> | _ -> failwith "Quotation of tactic expressions: TODO" @@ -495,7 +475,7 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function and mlexpr_of_tactic_arg = function | Tacexpr.MetaIdArg (loc,true,id) -> anti loc id | Tacexpr.MetaIdArg (loc,false,id) -> - <:expr< Tacexpr.ConstrMayEval (Rawterm.ConstrTerm $anti loc id$) >> + <:expr< Tacexpr.ConstrMayEval (Glob_term.ConstrTerm $anti loc id$) >> | Tacexpr.TacCall (loc,t,tl) -> <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>> | Tacexpr.Tacexp t -> @@ -506,18 +486,47 @@ and mlexpr_of_tactic_arg = function <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >> | _ -> failwith "mlexpr_of_tactic_arg: TODO" + +IFDEF CAMLP5 THEN + +let not_impl x = + let desc = + if Obj.is_block (Obj.repr x) then + "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) + else "int_val = " ^ string_of_int (Obj.magic x) + in + failwith ("<Q_coqast.patt_of_expt, not impl: " ^ desc) + +(* The following function is written without quotation + in order to be parsable even by camlp4. The version with + quotation can be found in revision <= 12972 of [q_util.ml4] *) + +open MLast + +let rec patt_of_expr e = + let loc = loc_of_expr e in + match e with + | ExAcc (_, e1, e2) -> PaAcc (loc, patt_of_expr e1, patt_of_expr e2) + | ExApp (_, e1, e2) -> PaApp (loc, patt_of_expr e1, patt_of_expr e2) + | ExLid (_, x) when x = vala "loc" -> PaAny loc + | ExLid (_, s) -> PaLid (loc, s) + | ExUid (_, s) -> PaUid (loc, s) + | ExStr (_, s) -> PaStr (loc, s) + | ExAnt (_, e) -> PaAnt (loc, patt_of_expr e) + | _ -> not_impl e + let fconstr e = let ee s = - mlexpr_of_constr (Pcoq.Gram.Entry.parse e - (Pcoq.Gram.parsable (Stream.of_string s))) + mlexpr_of_constr (Pcoq.Gram.entry_parse e + (Pcoq.Gram.parsable (Stream.of_string s))) in let ep s = patt_of_expr (ee s) in Quotation.ExAst (ee, ep) let ftac e = let ee s = - mlexpr_of_tactic (Pcoq.Gram.Entry.parse e - (Pcoq.Gram.parsable (Stream.of_string s))) + mlexpr_of_tactic (Pcoq.Gram.entry_parse e + (Pcoq.Gram.parsable (Stream.of_string s))) in let ep s = patt_of_expr (ee s) in Quotation.ExAst (ee, ep) @@ -526,3 +535,23 @@ let _ = Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi); Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi); Quotation.default := "constr" + +ELSE + +open Pcaml + +let expand_constr_quot_expr loc _loc_name_opt contents = + mlexpr_of_constr + (Pcoq.Gram.parse_string Pcoq.Constr.constr_eoi loc contents) + +let expand_tactic_quot_expr loc _loc_name_opt contents = + mlexpr_of_tactic + (Pcoq.Gram.parse_string Pcoq.Tactic.tactic_eoi loc contents) + +let _ = + (* FIXME: for the moment, we add quotations in expressions only, not pattern *) + Quotation.add "constr" Quotation.DynAst.expr_tag expand_constr_quot_expr; + Quotation.add "tactic" Quotation.DynAst.expr_tag expand_tactic_quot_expr; + Quotation.default := "constr" + +END diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4 index a41824d0..91ab29f1 100644 --- a/parsing/q_util.ml4 +++ b/parsing/q_util.ml4 @@ -1,41 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "q_MLast.cmo" i*) - -(* $Id: q_util.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - (* This file defines standard combinators to build ml expressions *) -open Util open Extrawit -open Pcoq - -let not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else - "int_val = " ^ string_of_int (Obj.magic x) - in - failwith ("<Q_util." ^ name ^ ", not impl: " ^ desc) - -let rec patt_of_expr e = - let loc = MLast.loc_of_expr e in - match e with - | <:expr< $e1$.$e2$ >> -> <:patt< $patt_of_expr e1$.$patt_of_expr e2$ >> - | <:expr< $e1$ $e2$ >> -> <:patt< $patt_of_expr e1$ $patt_of_expr e2$ >> - | <:expr< loc >> -> <:patt< _ >> - | <:expr< $lid:s$ >> -> <:patt< $lid:s$ >> - | <:expr< $uid:s$ >> -> <:patt< $uid:s$ >> - | <:expr< $str:s$ >> -> <:patt< $str:s$ >> - | <:expr< $anti:e$ >> -> <:patt< $anti:patt_of_expr e$ >> - | _ -> not_impl "patt_of_expr" e +open Compat +open Util let mlexpr_of_list f l = List.fold_right @@ -77,19 +52,18 @@ let mlexpr_of_option f = function | Some e -> <:expr< Some $f e$ >> open Vernacexpr -open Pcoq open Genarg let rec mlexpr_of_prod_entry_key = function - | Extend.Alist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key s$ >> - | Extend.Alist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Extend.Alist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key s$ >> - | Extend.Alist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Extend.Aopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key s$ >> - | Extend.Amodifiers s -> <:expr< Extend.Amodifiers $mlexpr_of_prod_entry_key s$ >> - | Extend.Aself -> <:expr< Extend.Aself >> - | Extend.Anext -> <:expr< Extend.Anext >> - | Extend.Atactic n -> <:expr< Extend.Atactic $mlexpr_of_int n$ >> - | Extend.Agram s -> anomaly "Agram not supported" - | Extend.Aentry ("",s) -> <:expr< Extend.Agram (Gram.Entry.obj $lid:s$) >> - | Extend.Aentry (u,s) -> <:expr< Extend.Aentry $str:u$ $str:s$ >> + | Pcoq.Alist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >> + | Pcoq.Alist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> + | Pcoq.Alist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >> + | Pcoq.Alist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> + | Pcoq.Aopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key s$ >> + | Pcoq.Amodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >> + | Pcoq.Aself -> <:expr< Pcoq.Aself >> + | Pcoq.Anext -> <:expr< Pcoq.Anext >> + | Pcoq.Atactic n -> <:expr< Pcoq.Atactic $mlexpr_of_int n$ >> + | Pcoq.Agram s -> Util.anomaly "Agram not supported" + | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Agram (Pcoq.Gram.Entry.obj $lid:s$) >> + | Pcoq.Aentry (u,s) -> <:expr< Pcoq.Aentry $str:u$ $str:s$ >> diff --git a/parsing/q_util.mli b/parsing/q_util.mli index 878adba6..5d56c456 100644 --- a/parsing/q_util.mli +++ b/parsing/q_util.mli @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: q_util.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - -val patt_of_expr : MLast.expr -> MLast.patt +open Compat val mlexpr_of_list : ('a -> MLast.expr) -> 'a list -> MLast.expr @@ -32,4 +30,4 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr -val mlexpr_of_prod_entry_key : Pcoq.Gram.te Extend.prod_entry_key -> MLast.expr +val mlexpr_of_prod_entry_key : Pcoq.prod_entry_key -> MLast.expr diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 index 0d7a9cfe..2fe1fdda 100644 --- a/parsing/tacextend.ml4 +++ b/parsing/tacextend.ml4 @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) - -(* $Id: tacextend.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) +(*i camlp4deps: "tools/compat5b.cmo" i*) open Util open Genarg @@ -18,6 +16,7 @@ open Argextend open Pcoq open Extrawit open Egrammar +open Compat let rec make_patt = function | [] -> <:patt< [] >> @@ -43,20 +42,9 @@ let rec make_let e = function let loc = join_loc loc (MLast.loc_of_expr e) in let e = make_let e l in let v = <:expr< Genarg.out_gen $make_wit loc t$ $lid:p$ >> in - let v = - (* Special case for tactics which must be stored in algebraic - form to avoid marshalling closures and to be reprinted *) - if is_tactic_genarg t then - <:expr< ($v$, Tacinterp.eval_tactic $v$) >> - else v in <:expr< let $lid:p$ = $v$ in $e$ >> | _::l -> make_let e l -let add_clause s (pt,e) l = - let p = make_patt pt in - let w = Some (make_when (MLast.loc_of_expr e) pt) in - (p, <:vala< w >>, make_let e pt)::l - let rec extract_signature = function | [] -> [] | GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l @@ -69,12 +57,14 @@ let check_unicity s l = ("Two distinct rules of tactic entry "^s^" have the same\n"^ "non-terminals in the same order: put them in distinct tactic entries") -let make_clauses s l = +let make_clause (pt,e) = + (make_patt pt, + vala (Some (make_when (MLast.loc_of_expr e) pt)), + make_let e pt) + +let make_fun_clauses loc s l = check_unicity s l; - let default = - (<:patt< _ >>,<:vala<None>>, - <:expr< failwith "Tactic extension: cannot occur" >>) in - List.fold_right (add_clause s) l [default] + Compat.make_fun loc (List.map make_clause l) let rec make_args = function | [] -> <:expr< [] >> @@ -89,9 +79,7 @@ let rec make_eval_tactic e = function let p = Names.string_of_id p in let loc = join_loc loc (MLast.loc_of_expr e) in let e = make_eval_tactic e l in - (* Special case for tactics which must be stored in algebraic - form to avoid marshalling closures and to be reprinted *) - <:expr< let $lid:p$ = ($lid:p$,Tacinterp.eval_tactic $lid:p$) in $e$ >> + <:expr< let $lid:p$ = $lid:p$ in $e$ >> | _::l -> make_eval_tactic e l let rec make_fun e = function @@ -165,30 +153,28 @@ let declare_tactic loc s cl = let atomic_tactics = mlexpr_of_list mlexpr_of_string (List.flatten (List.map (fun (al,_) -> is_atomic al) cl)) in - <:str_item< - declare - open Pcoq; - open Extrawit; - declare $list:hidden$ end; + declare_str_items loc + (hidden @ + [ <:str_item< do { try - let _=Tacinterp.add_tactic $se$ (fun [ $list:make_clauses s cl$ ]) in + let _=Tacinterp.add_tactic $se$ $make_fun_clauses loc s cl$ in List.iter (fun s -> Tacinterp.add_primitive_tactic s (Tacexpr.TacAtom($default_loc$, Tacexpr.TacExtend($default_loc$,s,[])))) $atomic_tactics$ - with e -> Pp.pp (Cerrors.explain_exn e); + with e -> Pp.pp (Errors.print e); Egrammar.extend_tactic_grammar $se$ $gl$; - List.iter Pptactic.declare_extra_tactic_pprule $pp$; - end - >> + List.iter Pptactic.declare_extra_tactic_pprule $pp$; } >> + ]) open Pcaml +open PcamlSig EXTEND GLOBAL: str_item; str_item: - [ [ "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ]; + [ [ "TACTIC"; "EXTEND"; s = tac_name; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> declare_tactic loc s l ] ] @@ -214,5 +200,10 @@ EXTEND GramTerminal s ] ] ; + tac_name: + [ [ s = LIDENT -> s + | s = UIDENT -> s + ] ] + ; END diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml index 45816856..83dae3dc 100644 --- a/parsing/tactic_printer.ml +++ b/parsing/tactic_printer.ml @@ -1,41 +1,33 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tactic_printer.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pp open Util open Sign open Evd open Tacexpr open Proof_type -open Proof_trees -open Decl_expr open Logic open Printer let pr_tactic = function - | TacArg (Tacexp t) -> + | TacArg (_,Tacexp t) -> (*top tactic from tacinterp*) Pptactic.pr_glob_tactic (Global.env()) t | t -> Pptactic.pr_tactic (Global.env()) t -let pr_proof_instr instr = - Ppdecl_proof.pr_proof_instr (Global.env()) instr - let pr_rule = function | Prim r -> hov 0 (pr_prim_rule r) | Nested(cmpd,_) -> begin match cmpd with | Tactic (texp,_) -> hov 0 (pr_tactic texp) - | Proof_instr (_,instr) -> hov 0 (pr_proof_instr instr) end | Daimon -> str "<Daimon>" | Decl_proof _ -> str "proof" @@ -62,33 +54,23 @@ let pr_rule_dot_fnl = function exception Different -(* We remove from the var context of env what is already in osign *) -let thin_sign osign sign = - Sign.fold_named_context - (fun (id,c,ty as d) sign -> - try - if Sign.lookup_named id osign = (id,c,ty) then sign - else raise Different - with Not_found | Different -> Environ.push_named_context_val d sign) - sign ~init:Environ.empty_named_context_val - -let rec print_proof _sigma osign pf = - let hyps = Environ.named_context_of_val pf.goal.evar_hyps in - let hyps' = thin_sign osign hyps in +let rec print_proof sigma osign pf = + (* spiwack: [osign] is currently ignored, not sure if this function is even used. *) + let hyps = Environ.named_context_of_val (Goal.V82.hyps sigma pf.goal) in match pf.ref with | None -> - hov 0 (pr_goal {pf.goal with evar_hyps=hyps'}) + hov 0 (pr_goal {sigma = sigma; it=pf.goal }) | Some(r,spfl) -> hov 0 - (hov 0 (pr_goal {pf.goal with evar_hyps=hyps'}) ++ + (hov 0 (pr_goal {sigma = sigma; it=pf.goal }) ++ spc () ++ str" BY " ++ hov 0 (pr_rule r) ++ fnl () ++ str" " ++ - hov 0 (prlist_with_sep pr_fnl (print_proof _sigma hyps) spfl)) + hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl)) -let pr_change gl = +let pr_change sigma gl = str"change " ++ - pr_lconstr_env (Global.env_of_context gl.evar_hyps) gl.evar_concl ++ str"." + pr_lconstr_env (Goal.V82.env sigma gl) (Goal.V82.concl sigma gl) ++ str"." let print_decl_script tac_printer ?(nochange=true) sigma pf = let rec print_prf pf = @@ -97,36 +79,10 @@ let print_decl_script tac_printer ?(nochange=true) sigma pf = (if nochange then (str"<Your Proof Text here>") else - pr_change pf.goal) + pr_change sigma pf.goal) ++ fnl () | Some (Daimon,[]) -> str "(* Some proof has been skipped here *)" | Some (Prim Change_evars,[subpf]) -> print_prf subpf - | Some (Nested(Proof_instr (opened,instr),_) as rule,subprfs) -> - begin - match instr.instr,subprfs with - Pescape,[{ref=Some(_,subsubprfs)}] -> - hov 7 - (pr_rule_dot_fnl rule ++ - prlist_with_sep pr_fnl tac_printer subsubprfs) ++ fnl () ++ - if opened then mt () else str "return." - | Pclaim _,[body;cont] -> - hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ fnl () ++ - (if opened then mt () else str "end claim." ++ fnl ()) ++ - print_prf cont - | Pfocus _,[body;cont] -> - hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ - fnl () ++ - (if opened then mt () else str "end focus." ++ fnl ()) ++ - print_prf cont - | (Psuppose _ |Pcase (_,_,_)),[body;cont] -> - hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ fnl () ++ - print_prf cont - | _,[next] -> - pr_rule_dot_fnl rule ++ print_prf next - | _,[] -> - pr_rule_dot rule - | _,_ -> anomaly "unknown branching instruction" - end | _ -> anomaly "Not Applicable" in print_prf pf @@ -137,12 +93,12 @@ let print_script ?(nochange=true) sigma pf = (if nochange then (str"<Your Tactic Text here>") else - pr_change pf.goal) + pr_change sigma pf.goal) ++ fnl () | Some(Decl_proof opened,script) -> assert (List.length script = 1); begin - if nochange then (mt ()) else (pr_change pf.goal ++ fnl ()) + if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ()) end ++ begin hov 0 (str "proof." ++ fnl () ++ @@ -153,10 +109,10 @@ let print_script ?(nochange=true) sigma pf = if opened then mt () else (str "end proof." ++ fnl ()) end | Some(Daimon,spfl) -> - ((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++ + ((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++ prlist_with_sep pr_fnl print_prf spfl ) | Some(rule,spfl) -> - ((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++ + ((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++ pr_rule_dot_fnl rule ++ prlist_with_sep pr_fnl print_prf spfl ) in print_prf pf @@ -168,13 +124,12 @@ let print_treescript ?(nochange=true) sigma pf = match pf.ref with | None -> if nochange then - if pf.goal.evar_extra=None then str"<Your Tactic Text here>" - else str"<Your Proof Text here>" - else pr_change pf.goal + str"<Your Proof Text here>" + else pr_change sigma pf.goal | Some(Decl_proof opened,script) -> assert (List.length script = 1); begin - if nochange then mt () else pr_change pf.goal ++ fnl () + if nochange then mt () else pr_change sigma pf.goal ++ fnl () end ++ hov 0 begin str "proof." ++ fnl () ++ @@ -184,16 +139,16 @@ let print_treescript ?(nochange=true) sigma pf = if opened then mt () else (str "end proof." ++ fnl ()) end | Some(Daimon,spfl) -> - (if nochange then mt () else pr_change pf.goal ++ fnl ()) ++ + (if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++ prlist_with_sep pr_fnl (print_script ~nochange sigma) spfl | Some(r,spfl) -> let indent = if List.length spfl >= 2 then 1 else 0 in - (if nochange then mt () else pr_change pf.goal ++ fnl ()) ++ + (if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++ hv indent (pr_rule_dot_fnl r ++ prlist_with_sep fnl print_prf spfl) in hov 0 (print_prf pf) let rec print_info_script sigma osign pf = - let {evar_hyps=sign; evar_concl=cl} = pf.goal in + let sign = Goal.V82.hyps sigma pf.goal in match pf.ref with | None -> (mt ()) | Some(r,spfl) -> @@ -214,12 +169,4 @@ let rec print_info_script sigma osign pf = let format_print_info_script sigma osign pf = hov 0 (print_info_script sigma osign pf) -let print_subscript sigma sign pf = - if is_tactic_proof pf then - format_print_info_script sigma sign (subproof_of_proof pf) - else - format_print_info_script sigma sign pf - -let _ = Refiner.set_info_printer print_subscript -let _ = Refiner.set_proof_printer print_proof diff --git a/parsing/tactic_printer.mli b/parsing/tactic_printer.mli index 05ba20e9..5ea57910 100644 --- a/parsing/tactic_printer.mli +++ b/parsing/tactic_printer.mli @@ -1,27 +1,22 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tactic_printer.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - -(*i*) open Pp open Sign open Evd open Tacexpr open Proof_type -(*i*) -(* These are the entry points for tactics, proof trees, ... *) +(** These are the entry points for tactics, proof trees, ... *) val print_proof : evar_map -> named_context -> proof_tree -> std_ppcmds val pr_rule : rule -> std_ppcmds val pr_tactic : tactic_expr -> std_ppcmds -val pr_proof_instr : Decl_expr.proof_instr -> Pp.std_ppcmds val print_script : ?nochange:bool -> evar_map -> proof_tree -> std_ppcmds val print_treescript : diff --git a/parsing/tok.ml b/parsing/tok.ml new file mode 100644 index 00000000..bd7645c2 --- /dev/null +++ b/parsing/tok.ml @@ -0,0 +1,90 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** The type of token for the Coq lexer and parser *) + +type t = + | KEYWORD of string + | METAIDENT of string + | PATTERNIDENT of string + | IDENT of string + | FIELD of string + | INT of string + | STRING of string + | LEFTQMARK + | EOI + +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 + | LEFTQMARK -> "?" + | EOI -> "" + +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 + | STRING s -> Format.sprintf "STRING %S" s + | LEFTQMARK -> "LEFTQMARK" + | EOI -> "EOI" + +let match_keyword kwd = function + | KEYWORD kwd' when kwd = kwd' -> true + | _ -> false + +let print ppf tok = Format.fprintf ppf "%s" (to_string tok) + +(** For camlp5, conversion from/to [Plexing.pattern], + and a match function analoguous to [Plexing.default_match] *) + +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 + | "STRING", s -> STRING s + | "LEFTQMARK", _ -> LEFTQMARK + | "EOI", _ -> EOI + | _ -> failwith "Tok.of_pattern: not a constructor" + +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 + | STRING s -> "STRING", s + | LEFTQMARK -> "LEFTQMARK", "" + | EOI -> "EOI", "" + +let match_pattern = + let err () = raise Stream.Failure in + 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 ()) + | "STRING", "" -> (function STRING s -> s | _ -> err ()) + | "LEFTQMARK", "" -> (function LEFTQMARK -> "" | _ -> err ()) + | "EOI", "" -> (function EOI -> "" | _ -> err ()) + | pat -> + let tok = of_pattern pat in + function tok' -> if tok = tok' then snd pat else err () diff --git a/parsing/tok.mli b/parsing/tok.mli new file mode 100644 index 00000000..9a1edec5 --- /dev/null +++ b/parsing/tok.mli @@ -0,0 +1,29 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** The type of token for the Coq lexer and parser *) + +type t = + | KEYWORD of string + | METAIDENT of string + | PATTERNIDENT of string + | IDENT of string + | FIELD of string + | INT of string + | STRING of string + | LEFTQMARK + | EOI + +val extract_string : t -> string +val to_string : t -> string +val print : Format.formatter -> t -> unit +val match_keyword : string -> t -> bool +(** for camlp5 *) +val of_pattern : string*string -> t +val to_pattern : t -> string*string +val match_pattern : string*string -> t -> string diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index 3f60aafa..88a75079 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) - -(* $Id: vernacextend.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) +(*i camlp4deps: "tools/compat5b.cmo" i*) open Util open Genarg @@ -18,6 +16,7 @@ open Argextend open Tacextend open Pcoq open Egrammar +open Compat let rec make_let e = function | [] -> e @@ -28,11 +27,6 @@ let rec make_let e = function <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> | _::l -> make_let e l -let add_clause s (_,pt,e) l = - let p = make_patt pt in - let w = Some (make_when (MLast.loc_of_expr e) pt) in - (p, <:vala<w>>, make_let e pt)::l - let check_unicity s l = let l' = List.map (fun (_,l,_) -> extract_signature l) l in if not (Util.list_distinct l') then @@ -40,31 +34,32 @@ let check_unicity s l = ("Two distinct rules of entry "^s^" have the same\n"^ "non-terminals in the same order: put them in distinct vernac entries") -let make_clauses s l = +let make_clause (_,pt,e) = + (make_patt pt, + vala (Some (make_when (MLast.loc_of_expr e) pt)), + make_let e pt) + +let make_fun_clauses loc s l = check_unicity s l; - let default = - (<:patt< _ >>,<:vala<None>>, - <:expr< failwith "Vernac extension: cannot occur" >>) in - List.fold_right (add_clause s) l [default] + Compat.make_fun loc (List.map make_clause l) let mlexpr_of_clause = mlexpr_of_list - (fun (a,b,c) -> mlexpr_of_list make_prod_item (GramTerminal a::b)) + (fun (a,b,c) -> mlexpr_of_list make_prod_item + (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b)) -let declare_command loc s cl = +let declare_command loc s nt cl = let gl = mlexpr_of_clause cl in - let icl = make_clauses s cl in - <:str_item< - declare - open Pcoq; - open Extrawit; - try Vernacinterp.vinterp_add $mlexpr_of_string s$ (fun [ $list:icl$ ]) - with e -> Pp.pp (Cerrors.explain_exn e); - Egrammar.extend_vernac_command_grammar $mlexpr_of_string s$ $gl$; - end - >> + let funcl = make_fun_clauses loc s cl in + declare_str_items loc + [ <:str_item< do { + try Vernacinterp.vinterp_add $mlexpr_of_string s$ $funcl$ + with e -> Pp.pp (Errors.print e); + Egrammar.extend_vernac_command_grammar $mlexpr_of_string s$ $nt$ $gl$ + } >> ] open Pcaml +open PcamlSig EXTEND GLOBAL: str_item; @@ -72,13 +67,22 @@ EXTEND [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT; OPT "|"; l = LIST1 rule SEP "|"; "END" -> - declare_command loc s l ] ] + declare_command loc s <:expr<None>> l + | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT; + OPT "|"; l = LIST1 rule SEP "|"; + "END" -> + declare_command loc s <:expr<Some $lid:nt$>> l ] ] ; + (* spiwack: comment-by-guessing: it seems that the isolated string (which + otherwise could have been another argument) is not passed to the + VernacExtend interpreter function to discriminate between the clauses. *) rule: [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]" -> if s = "" then Util.user_err_loc (loc,"",Pp.str"Command name is empty."); - (s,l,<:expr< fun () -> $e$ >>) + (Some s,l,<:expr< fun () -> $e$ >>) + | "[" ; "-" ; l = LIST1 args ; "]" ; "->" ; "[" ; e = Pcaml.expr ; "]" -> + (None,l,<:expr< fun () -> $e$ >>) ] ] ; args: |