summaryrefslogtreecommitdiff
path: root/parsing
diff options
context:
space:
mode:
authorGravatar Stephane Glondu <steph@glondu.net>2012-01-12 16:04:54 +0100
committerGravatar Stephane Glondu <steph@glondu.net>2012-01-12 16:04:54 +0100
commit39efc41237ec906226a3a53d7396d51173495204 (patch)
tree87cd58d72d43469d2a2a0a127c1060d7c9e0206b /parsing
parent5fe4ac437bed43547b3695664974f492b55cb553 (diff)
parent97fefe1fcca363a1317e066e7f4b99b9c1e9987b (diff)
Remove non-DFSG contentsupstream/8.4_beta+dfsg
Diffstat (limited to 'parsing')
-rw-r--r--parsing/argextend.ml4145
-rw-r--r--parsing/egrammar.ml100
-rw-r--r--parsing/egrammar.mli23
-rw-r--r--parsing/extend.ml45
-rw-r--r--parsing/extend.mli44
-rw-r--r--parsing/extrawit.ml4
-rw-r--r--parsing/extrawit.mli8
-rw-r--r--parsing/g_constr.ml497
-rw-r--r--parsing/g_decl_mode.ml4252
-rw-r--r--parsing/g_intsyntax.mli13
-rw-r--r--parsing/g_ltac.ml426
-rw-r--r--parsing/g_natsyntax.mli15
-rw-r--r--parsing/g_prim.ml412
-rw-r--r--parsing/g_proofs.ml455
-rw-r--r--parsing/g_tactic.ml4148
-rw-r--r--parsing/g_vernac.ml4370
-rw-r--r--parsing/g_xml.ml468
-rw-r--r--parsing/g_zsyntax.mli11
-rw-r--r--parsing/grammar.mllib6
-rw-r--r--parsing/highparsing.mllib1
-rw-r--r--parsing/lexer.ml4322
-rw-r--r--parsing/lexer.mli24
-rw-r--r--parsing/parsing.mllib1
-rw-r--r--parsing/pcoq.ml4432
-rw-r--r--parsing/pcoq.mli263
-rw-r--r--parsing/ppconstr.ml157
-rw-r--r--parsing/ppconstr.mli15
-rw-r--r--parsing/ppdecl_proof.ml190
-rw-r--r--parsing/ppdecl_proof.mli2
-rw-r--r--parsing/pptactic.ml113
-rw-r--r--parsing/pptactic.mli18
-rw-r--r--parsing/ppvernac.ml204
-rw-r--r--parsing/ppvernac.mli6
-rw-r--r--parsing/prettyp.ml228
-rw-r--r--parsing/prettyp.mli19
-rw-r--r--parsing/printer.ml317
-rw-r--r--parsing/printer.mli74
-rw-r--r--parsing/printmod.ml242
-rw-r--r--parsing/printmod.mli4
-rw-r--r--parsing/q_constr.ml452
-rw-r--r--parsing/q_coqast.ml4189
-rw-r--r--parsing/q_util.ml456
-rw-r--r--parsing/q_util.mli8
-rw-r--r--parsing/tacextend.ml459
-rw-r--r--parsing/tactic_printer.ml95
-rw-r--r--parsing/tactic_printer.mli9
-rw-r--r--parsing/tok.ml90
-rw-r--r--parsing/tok.mli29
-rw-r--r--parsing/vernacextend.ml460
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: