1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
|
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
open Pattern
open Pp
open Genredexpr
open Glob_term
open Tacred
open Errors
open Util
open Names
open Nameops
open Libnames
open Globnames
open Nametab
open Smartlocate
open Constrexpr
open Termops
open Tacexpr
open Genarg
open Constrarg
open Misctypes
open Locus
(** Globalization of tactic expressions :
Conversion from [raw_tactic_expr] to [glob_tactic_expr] *)
let dloc = Loc.ghost
let error_global_not_found_loc (loc,qid) =
error_global_not_found_loc loc qid
let error_syntactic_metavariables_not_allowed loc =
user_err_loc
(loc,"out_ident",
str "Syntactic metavariables allowed only in quotations.")
let error_tactic_expected loc =
user_err_loc (loc,"",str "Tactic expected.")
(** Generic arguments *)
type glob_sign = Genintern.glob_sign = {
ltacvars : Id.Set.t;
(* ltac variables and the subset of vars introduced by Intro/Let/... *)
genv : Environ.env }
let fully_empty_glob_sign =
{ ltacvars = Id.Set.empty; genv = Environ.empty_env }
let make_empty_glob_sign () =
{ fully_empty_glob_sign with genv = Global.env () }
(* We have identifier <| global_reference <| constr *)
let find_ident id ist =
Id.Set.mem id ist.ltacvars ||
Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv))
(* a "var" is a ltac var or a var introduced by an intro tactic *)
let find_var id ist = Id.Set.mem id ist.ltacvars
let find_hyp id ist =
Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv))
(* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *)
(* be fresh in which case it is binding later on *)
let intern_ident s ist id =
(* We use identifier both for variables and new names; thus nothing to do *)
if not (find_ident id ist) then s := Id.Set.add id !s;
id
let intern_name l ist = function
| Anonymous -> Anonymous
| Name id -> Name (intern_ident l ist id)
let strict_check = ref false
let adjust_loc loc = if !strict_check then dloc else loc
(* Globalize a name which must be bound -- actually just check it is bound *)
let intern_hyp ist (loc,id as locid) =
if not !strict_check then
locid
else if find_ident id ist then
(dloc,id)
else
Pretype_errors.error_var_not_found_loc loc id
let intern_or_var f ist = function
| ArgVar locid -> ArgVar (intern_hyp ist locid)
| ArgArg x -> ArgArg (f x)
let intern_int_or_var = intern_or_var (fun (n : int) -> n)
let intern_string_or_var = intern_or_var (fun (s : string) -> s)
let intern_global_reference ist = function
| Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
| r ->
let loc,_ as lqid = qualid_of_reference r in
try ArgArg (loc,locate_global_with_alias lqid)
with Not_found -> error_global_not_found_loc lqid
let intern_ltac_variable ist = function
| Ident (loc,id) ->
if find_var id ist then
(* A local variable of any type *)
ArgVar (loc,id)
else raise Not_found
| _ ->
raise Not_found
let intern_constr_reference strict ist = function
| Ident (_,id) as r when not strict && find_hyp id ist ->
GVar (dloc,id), Some (CRef (r,None))
| Ident (_,id) as r when find_var id ist ->
GVar (dloc,id), if strict then None else Some (CRef (r,None))
| r ->
let loc,_ as lqid = qualid_of_reference r in
GRef (loc,locate_global_with_alias lqid,None),
if strict then None else Some (CRef (r,None))
let intern_move_location ist = function
| MoveAfter id -> MoveAfter (intern_hyp ist id)
| MoveBefore id -> MoveBefore (intern_hyp ist id)
| MoveFirst -> MoveFirst
| MoveLast -> MoveLast
(* Internalize an isolated reference in position of tactic *)
let intern_isolated_global_tactic_reference r =
let (loc,qid) = qualid_of_reference r in
TacCall (loc,ArgArg (loc,locate_tactic qid),[])
let intern_isolated_tactic_reference strict ist r =
(* An ltac reference *)
try Reference (intern_ltac_variable ist r)
with Not_found ->
(* A global tactic *)
try intern_isolated_global_tactic_reference r
with Not_found ->
(* Tolerance for compatibility, allow not to use "constr:" *)
try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
with Not_found ->
(* Reference not found *)
error_global_not_found_loc (qualid_of_reference r)
(* Internalize an applied tactic reference *)
let intern_applied_global_tactic_reference r =
let (loc,qid) = qualid_of_reference r in
ArgArg (loc,locate_tactic qid)
let intern_applied_tactic_reference ist r =
(* An ltac reference *)
try intern_ltac_variable ist r
with Not_found ->
(* A global tactic *)
try intern_applied_global_tactic_reference r
with Not_found ->
(* Reference not found *)
error_global_not_found_loc (qualid_of_reference r)
(* Intern a reference parsed in a non-tactic entry *)
let intern_non_tactic_reference strict ist r =
(* An ltac reference *)
try Reference (intern_ltac_variable ist r)
with Not_found ->
(* A constr reference *)
try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
with Not_found ->
(* Tolerance for compatibility, allow not to use "ltac:" *)
try intern_isolated_global_tactic_reference r
with Not_found ->
(* By convention, use IntroIdentifier for unbound ident, when not in a def *)
match r with
| Ident (loc,id) when not strict ->
let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in
TacGeneric ipat
| _ ->
(* Reference not found *)
error_global_not_found_loc (qualid_of_reference r)
let intern_message_token ist = function
| (MsgString _ | MsgInt _ as x) -> x
| MsgIdent id -> MsgIdent (intern_hyp ist id)
let intern_message ist = List.map (intern_message_token ist)
let intern_quantified_hypothesis ist = function
| AnonHyp n -> AnonHyp n
| NamedHyp id ->
(* Uncomment to disallow "intros until n" in ltac when n is not bound *)
NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*))
let intern_binding_name ist x =
(* We use identifier both for variables and binding names *)
(* Todo: consider the body of the lemma to which the binding refer
and if a term w/o ltac vars, check the name is indeed quantified *)
x
let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c =
let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in
let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in
let ltacvars = {
Constrintern.ltac_vars = lfun;
ltac_bound = Id.Set.empty;
} in
let c' =
warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c
in
(c',if !strict_check then None else Some c)
let intern_constr = intern_constr_gen false false
let intern_type = intern_constr_gen false true
(* Globalize bindings *)
let intern_binding ist (loc,b,c) =
(loc,intern_binding_name ist b,intern_constr ist c)
let intern_bindings ist = function
| NoBindings -> NoBindings
| ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l)
| ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l)
let intern_constr_with_bindings ist (c,bl) =
(intern_constr ist c, intern_bindings ist bl)
let intern_constr_with_bindings_arg ist (clear,c) =
(clear,intern_constr_with_bindings ist c)
let rec intern_intro_pattern lf ist = function
| loc, IntroNaming pat ->
loc, IntroNaming (intern_intro_pattern_naming lf ist pat)
| loc, IntroAction pat ->
loc, IntroAction (intern_intro_pattern_action lf ist pat)
| loc, IntroForthcoming _ as x -> x
and intern_intro_pattern_naming lf ist = function
| IntroIdentifier id ->
IntroIdentifier (intern_ident lf ist id)
| IntroFresh id ->
IntroFresh (intern_ident lf ist id)
| IntroAnonymous as x -> x
and intern_intro_pattern_action lf ist = function
| IntroOrAndPattern l ->
IntroOrAndPattern (intern_or_and_intro_pattern lf ist l)
| IntroInjection l ->
IntroInjection (List.map (intern_intro_pattern lf ist) l)
| IntroWildcard | IntroRewrite _ as x -> x
| IntroApplyOn (c,pat) ->
IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat)
and intern_or_and_intro_pattern lf ist =
List.map (List.map (intern_intro_pattern lf ist))
let intern_or_and_intro_pattern_loc lf ist = function
| ArgVar (_,id) as x ->
if find_var id ist then x
else error "Disjunctive/conjunctive introduction pattern expected."
| ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l)
let intern_intro_pattern_naming_loc lf ist (loc,pat) =
(loc,intern_intro_pattern_naming lf ist pat)
(* TODO: catch ltac vars *)
let intern_induction_arg ist = function
| clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c)
| clear,ElimOnAnonHyp n as x -> x
| clear,ElimOnIdent (loc,id) ->
if !strict_check then
(* If in a defined tactic, no intros-until *)
match intern_constr ist (CRef (Ident (dloc,id), None)) with
| GVar (loc,id),_ -> clear,ElimOnIdent (loc,id)
| c -> clear,ElimOnConstr (c,NoBindings)
else
clear,ElimOnIdent (loc,id)
let short_name = function
| AN (Ident (loc,id)) when not !strict_check -> Some (loc,id)
| _ -> None
let intern_evaluable_global_reference ist r =
let lqid = qualid_of_reference r in
try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid)
with Not_found ->
match r with
| Ident (loc,id) when not !strict_check -> EvalVarRef id
| _ -> error_global_not_found_loc lqid
let intern_evaluable_reference_or_by_notation ist = function
| AN r -> intern_evaluable_global_reference ist r
| ByNotation (loc,ntn,sc) ->
evaluable_of_global_reference ist.genv
(Notation.interp_notation_as_global_reference loc
(function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)
(* Globalize a reduction expression *)
let intern_evaluable ist = function
| AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id)
| AN (Ident (loc,id)) when not !strict_check && find_hyp id ist ->
ArgArg (EvalVarRef id, Some (loc,id))
| r ->
let e = intern_evaluable_reference_or_by_notation ist r in
let na = short_name r in
ArgArg (e,na)
let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid)
let intern_flag ist red =
{ red with rConst = List.map (intern_evaluable ist) red.rConst }
let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c)
let intern_constr_pattern ist ~as_type ~ltacvars pc =
let ltacvars = {
Constrintern.ltac_vars = ltacvars;
ltac_bound = Id.Set.empty;
} in
let metas,pat = Constrintern.intern_constr_pattern
ist.genv ~as_type ~ltacvars pc
in
let c = intern_constr_gen true false ist pc in
metas,(c,pat)
let dummy_pat = PRel 0
let intern_typed_pattern ist p =
(* we cannot ensure in non strict mode that the pattern is closed *)
(* keeping a constr_expr copy is too complicated and we want anyway to *)
(* type it, so we remember the pattern as a glob_constr only *)
(intern_constr_gen true false ist p,dummy_pat)
let intern_typed_pattern_or_ref_with_occurrences ist (l,p) =
let interp_ref r =
try Inl (intern_evaluable ist r)
with e when Logic.catchable_exception e ->
(* Compatibility. In practice, this means that the code above
is useless. Still the idea of having either an evaluable
ref or a pattern seems interesting, with "head" reduction
in case of an evaluable ref, and "strong" reduction in the
subterm matched when a pattern *)
let loc = loc_of_smart_reference r in
let r = match r with
| AN r -> r
| _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in
let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in
let c = Constrintern.interp_reference sign r in
match c with
| GRef (_,r,None) ->
Inl (ArgArg (evaluable_of_global_reference ist.genv r,None))
| GVar (_,id) ->
let r = evaluable_of_global_reference ist.genv (VarRef id) in
Inl (ArgArg (r,None))
| _ ->
Inr ((c,None),dummy_pat) in
(l, match p with
| Inl r -> interp_ref r
| Inr (CAppExpl(_,(None,r,None),[])) ->
(* We interpret similarly @ref and ref *)
interp_ref (AN r)
| Inr c ->
Inr (intern_typed_pattern ist c))
(* This seems fairly hacky, but it's the first way I've found to get proper
globalization of [unfold]. --adamc *)
let dump_glob_red_expr = function
| Unfold occs -> List.iter (fun (_, r) ->
try
Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
(Smartlocate.smart_global r)
with e when Errors.noncritical e -> ()) occs
| Cbv grf | Lazy grf ->
List.iter (fun r ->
try
Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
(Smartlocate.smart_global r)
with e when Errors.noncritical e -> ()) grf.rConst
| _ -> ()
let intern_red_expr ist = function
| Unfold l -> Unfold (List.map (intern_unfold ist) l)
| Fold l -> Fold (List.map (intern_constr ist) l)
| Cbv f -> Cbv (intern_flag ist f)
| Cbn f -> Cbn (intern_flag ist f)
| Lazy f -> Lazy (intern_flag ist f)
| Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l)
| Simpl (f,o) ->
Simpl (intern_flag ist f,
Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
| CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
| CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
| (Red _ | Hnf | ExtraRedExpr _ as r ) -> r
let intern_in_hyp_as ist lf (id,ipat) =
(intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat)
let intern_hyp_list ist = List.map (intern_hyp ist)
let intern_inversion_strength lf ist = function
| NonDepInversion (k,idl,ids) ->
NonDepInversion (k,intern_hyp_list ist idl,
Option.map (intern_or_and_intro_pattern_loc lf ist) ids)
| DepInversion (k,copt,ids) ->
DepInversion (k, Option.map (intern_constr ist) copt,
Option.map (intern_or_and_intro_pattern_loc lf ist) ids)
| InversionUsing (c,idl) ->
InversionUsing (intern_constr ist c, intern_hyp_list ist idl)
(* Interprets an hypothesis name *)
let intern_hyp_location ist ((occs,id),hl) =
((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs,
intern_hyp ist id), hl)
(* Reads a pattern *)
let intern_pattern ist ?(as_type=false) ltacvars = function
| Subterm (b,ido,pc) ->
let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in
ido, metas, Subterm (b,ido,pc)
| Term pc ->
let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in
None, metas, Term pc
let intern_constr_may_eval ist = function
| ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c)
| ConstrContext (locid,c) ->
ConstrContext (intern_hyp ist locid,intern_constr ist c)
| ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c)
| ConstrTerm c -> ConstrTerm (intern_constr ist c)
let name_cons accu = function
| Anonymous -> accu
| Name id -> Id.Set.add id accu
let opt_cons accu = function
| None -> accu
| Some id -> Id.Set.add id accu
(* Reads the hypotheses of a "match goal" rule *)
let rec intern_match_goal_hyps ist lfun = function
| (Hyp ((_,na) as locna,mp))::tl ->
let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in
let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in
let lfun' = name_cons (opt_cons lfun ido) na in
lfun', metas1@metas2, Hyp (locna,pat)::hyps
| (Def ((_,na) as locna,mv,mp))::tl ->
let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in
let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in
let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in
let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in
lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps
| [] -> lfun, [], []
(* Utilities *)
let extract_let_names lrc =
let fold accu ((loc, name), _) =
if Id.Set.mem name accu then user_err_loc
(loc, "glob_tactic", str "This variable is bound several times.")
else Id.Set.add name accu
in
List.fold_left fold Id.Set.empty lrc
let clause_app f = function
{ onhyps=None; concl_occs=nl } ->
{ onhyps=None; concl_occs=nl }
| { onhyps=Some l; concl_occs=nl } ->
{ onhyps=Some(List.map f l); concl_occs=nl}
let map_raw wit f ist x =
in_gen (glbwit wit) (f ist (out_gen (rawwit wit) x))
(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *)
let rec intern_atomic lf ist x =
match (x:raw_atomic_tactic_expr) with
(* Basic tactics *)
| TacIntroPattern l ->
TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
| TacIntroMove (ido,hto) ->
TacIntroMove (Option.map (intern_ident lf ist) ido,
intern_move_location ist hto)
| TacExact c -> TacExact (intern_constr ist c)
| TacApply (a,ev,cb,inhyp) ->
TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb,
Option.map (intern_in_hyp_as ist lf) inhyp)
| TacElim (ev,cb,cbo) ->
TacElim (ev,intern_constr_with_bindings_arg ist cb,
Option.map (intern_constr_with_bindings ist) cbo)
| TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb)
| TacFix (idopt,n) -> TacFix (Option.map (intern_ident lf ist) idopt,n)
| TacMutualFix (id,n,l) ->
let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in
TacMutualFix (intern_ident lf ist id, n, List.map f l)
| TacCofix idopt -> TacCofix (Option.map (intern_ident lf ist) idopt)
| TacMutualCofix (id,l) ->
let f (id,c) = (intern_ident lf ist id,intern_type ist c) in
TacMutualCofix (intern_ident lf ist id, List.map f l)
| TacAssert (b,otac,ipat,c) ->
TacAssert (b,Option.map (intern_pure_tactic ist) otac,
Option.map (intern_intro_pattern lf ist) ipat,
intern_constr_gen false (not (Option.is_empty otac)) ist c)
| TacGeneralize cl ->
TacGeneralize (List.map (fun (c,na) ->
intern_constr_with_occurrences ist c,
intern_name lf ist na) cl)
| TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c)
| TacLetTac (na,c,cls,b,eqpat) ->
let na = intern_name lf ist na in
TacLetTac (na,intern_constr ist c,
(clause_app (intern_hyp_location ist) cls),b,
(Option.map (intern_intro_pattern_naming_loc lf ist) eqpat))
(* Derived basic tactics *)
| TacInductionDestruct (ev,isrec,(l,el)) ->
TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) ->
(intern_induction_arg ist c,
(Option.map (intern_intro_pattern_naming_loc lf ist) ipato,
Option.map (intern_or_and_intro_pattern_loc lf ist) ipats),
Option.map (clause_app (intern_hyp_location ist)) cls)) l,
Option.map (intern_constr_with_bindings ist) el))
| TacDoubleInduction (h1,h2) ->
let h1 = intern_quantified_hypothesis ist h1 in
let h2 = intern_quantified_hypothesis ist h2 in
TacDoubleInduction (h1,h2)
(* Context management *)
| TacClear (b,l) -> TacClear (b,List.map (intern_hyp ist) l)
| TacClearBody l -> TacClearBody (List.map (intern_hyp ist) l)
| TacMove (id1,id2) ->
TacMove (intern_hyp ist id1,intern_move_location ist id2)
| TacRename l ->
TacRename (List.map (fun (id1,id2) ->
intern_hyp ist id1,
intern_hyp ist id2) l)
(* Constructors *)
| TacSplit (ev,bll) -> TacSplit (ev,List.map (intern_bindings ist) bll)
(* Conversion *)
| TacReduce (r,cl) ->
dump_glob_red_expr r;
TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
| TacChange (None,c,cl) ->
let is_onhyps = match cl.onhyps with
| None | Some [] -> true
| _ -> false
in
let is_onconcl = match cl.concl_occs with
| AllOccurrences | NoOccurrences -> true
| _ -> false
in
TacChange (None,
(if is_onhyps && is_onconcl
then intern_type ist c else intern_constr ist c),
clause_app (intern_hyp_location ist) cl)
| TacChange (Some p,c,cl) ->
TacChange (Some (intern_typed_pattern ist p),intern_constr ist c,
clause_app (intern_hyp_location ist) cl)
(* Equivalence relations *)
| TacSymmetry idopt ->
TacSymmetry (clause_app (intern_hyp_location ist) idopt)
(* Equality and inversion *)
| TacRewrite (ev,l,cl,by) ->
TacRewrite
(ev,
List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l,
clause_app (intern_hyp_location ist) cl,
Option.map (intern_pure_tactic ist) by)
| TacInversion (inv,hyp) ->
TacInversion (intern_inversion_strength lf ist inv,
intern_quantified_hypothesis ist hyp)
and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac)
and intern_tactic_seq onlytac ist = function
| TacAtom (loc,t) ->
let lf = ref ist.ltacvars in
let t = intern_atomic lf ist t in
!lf, TacAtom (adjust_loc loc, t)
| TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun)
| TacLetIn (isrec,l,u) ->
let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in
let ist' = { ist with ltacvars } in
let l = List.map (fun (n,b) ->
(n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in
ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u)
| TacMatchGoal (lz,lr,lmr) ->
ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist lmr)
| TacMatch (lz,c,lmr) ->
ist.ltacvars,
TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr)
| TacId l -> ist.ltacvars, TacId (intern_message ist l)
| TacFail (g,n,l) ->
ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l)
| TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac)
| TacShowHyps tac -> ist.ltacvars, TacShowHyps (intern_pure_tactic ist tac)
| TacAbstract (tac,s) ->
ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s)
| TacThen (t1,t2) ->
let lfun', t1 = intern_tactic_seq onlytac ist t1 in
let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in
lfun'', TacThen (t1,t2)
| TacDispatch tl ->
ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl)
| TacExtendTac (tf,t,tl) ->
ist.ltacvars ,
TacExtendTac (Array.map (intern_pure_tactic ist) tf,
intern_pure_tactic ist t,
Array.map (intern_pure_tactic ist) tl)
| TacThens3parts (t1,tf,t2,tl) ->
let lfun', t1 = intern_tactic_seq onlytac ist t1 in
let ist' = { ist with ltacvars = lfun' } in
(* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2,
Array.map (intern_pure_tactic ist') tl)
| TacThens (t,tl) ->
let lfun', t = intern_tactic_seq true ist t in
let ist' = { ist with ltacvars = lfun' } in
(* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
lfun', TacThens (t, List.map (intern_pure_tactic ist') tl)
| TacDo (n,tac) ->
ist.ltacvars, TacDo (intern_int_or_var ist n,intern_pure_tactic ist tac)
| TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac)
| TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac)
| TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac)
| TacTimeout (n,tac) ->
ist.ltacvars, TacTimeout (intern_int_or_var ist n,intern_tactic onlytac ist tac)
| TacTime (s,tac) ->
ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac)
| TacOr (tac1,tac2) ->
ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
| TacOnce tac ->
ist.ltacvars, TacOnce (intern_pure_tactic ist tac)
| TacExactlyOnce tac ->
ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac)
| TacIfThenCatch (tac,tact,tace) ->
ist.ltacvars,
TacIfThenCatch (
intern_pure_tactic ist tac,
intern_pure_tactic ist tact,
intern_pure_tactic ist tace)
| TacOrelse (tac1,tac2) ->
ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
| TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l)
| TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l)
| TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac)
| TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a
(* For extensions *)
| TacAlias (loc,s,l) ->
let l = List.map (intern_tacarg !strict_check false ist) l in
ist.ltacvars, TacAlias (loc,s,l)
| TacML (loc,opn,l) ->
let _ignore = Tacenv.interp_ml_tactic opn in
ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l)
and intern_tactic_as_arg loc onlytac ist a =
match intern_tacarg !strict_check onlytac ist a with
| TacCall _ | Reference _
| TacGeneric _ as a -> TacArg (loc,a)
| Tacexp a -> a
| ConstrMayEval _ | UConstr _ | TacFreshId _ | TacPretype _ | TacNumgoals as a ->
if onlytac then error_tactic_expected loc else TacArg (loc,a)
| MetaIdArg _ -> assert false
and intern_tactic_or_tacarg ist = intern_tactic false ist
and intern_pure_tactic ist = intern_tactic true ist
and intern_tactic_fun ist (var,body) =
let lfun = List.fold_left opt_cons ist.ltacvars var in
(var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body)
and intern_tacarg strict onlytac ist = function
| Reference r -> intern_non_tactic_reference strict ist r
| ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c)
| UConstr c -> UConstr (intern_constr ist c)
| MetaIdArg (loc,istac,s) ->
(* $id can occur in Grammar tactic... *)
let id = Id.of_string s in
if find_var id ist then
if istac then Reference (ArgVar (adjust_loc loc,id))
else ConstrMayEval (ConstrTerm (GVar (adjust_loc loc,id), None))
else error_syntactic_metavariables_not_allowed loc
| TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f
| TacCall (loc,f,l) ->
TacCall (loc,
intern_applied_tactic_reference ist f,
List.map (intern_tacarg !strict_check false ist) l)
| TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x)
| TacPretype c -> TacPretype (intern_constr ist c)
| TacNumgoals -> TacNumgoals
| Tacexp t -> Tacexp (intern_tactic onlytac ist t)
| TacGeneric arg ->
let arg = intern_genarg ist arg in
TacGeneric arg
(* Reads the rules of a Match Context or a Match *)
and intern_match_rule onlytac ist = function
| (All tc)::tl ->
All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl)
| (Pat (rl,mp,tc))::tl ->
let {ltacvars=lfun; genv=env} = ist in
let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in
let ido,metas2,pat = intern_pattern ist lfun mp in
let fold accu x = Id.Set.add x accu in
let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in
let ltacvars = List.fold_left fold ltacvars metas2 in
let ist' = { ist with ltacvars } in
Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl)
| [] -> []
and intern_genarg ist x =
match genarg_tag x with
| ListArgType _ ->
let list_unpacker wit l =
let map x =
let ans = intern_genarg ist (in_gen (rawwit wit) x) in
out_gen (glbwit wit) ans
in
in_gen (glbwit (wit_list wit)) (List.map map (raw l))
in
list_unpack { list_unpacker } x
| OptArgType _ ->
let opt_unpacker wit o = match raw o with
| None -> in_gen (glbwit (wit_opt wit)) None
| Some x ->
let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in
in_gen (glbwit (wit_opt wit)) (Some s)
in
opt_unpack { opt_unpacker } x
| PairArgType _ ->
let pair_unpacker wit1 wit2 o =
let p, q = raw o in
let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in
let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in
in_gen (glbwit (wit_pair wit1 wit2)) (p, q)
in
pair_unpack { pair_unpacker } x
| ExtraArgType s ->
snd (Genintern.generic_intern ist x)
(** Other entry points *)
let glob_tactic x =
Flags.with_option strict_check
(intern_pure_tactic (make_empty_glob_sign ())) x
let glob_tactic_env l env x =
let ltacvars =
List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in
Flags.with_option strict_check
(intern_pure_tactic
{ ltacvars; genv = env })
x
let split_ltac_fun = function
| TacFun (l,t) -> (l,t)
| t -> ([],t)
let pr_ltac_fun_arg = function
| None -> spc () ++ str "_"
| Some id -> spc () ++ pr_id id
let print_ltac id =
try
let kn = Nametab.locate_tactic id in
let entries = Tacenv.ltac_entries () in
let tac = KNmap.find kn entries in
let filter mp =
try Some (Nametab.shortest_qualid_of_module mp)
with Not_found -> None
in
let mods = List.map_filter filter tac.Tacenv.tac_redef in
let redefined = match mods with
| [] -> mt ()
| mods ->
let redef = prlist_with_sep fnl pr_qualid mods in
fnl () ++ str "Redefined by:" ++ fnl () ++ redef
in
let l,t = split_ltac_fun tac.Tacenv.tac_body in
hv 2 (
hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++
prlist pr_ltac_fun_arg l ++ spc () ++ str ":=")
++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined
with
Not_found ->
errorlabstrm "print_ltac"
(pr_qualid id ++ spc() ++ str "is not a user defined tactic.")
(** Registering *)
let lift intern = (); fun ist x -> (ist, intern ist x)
let () =
let intern_intro_pattern ist pat =
let lf = ref Id.Set.empty in
let ans = intern_intro_pattern lf ist pat in
let ist = { ist with ltacvars = !lf } in
(ist, ans)
in
Genintern.register_intern0 wit_intro_pattern intern_intro_pattern
let () =
let intern_clause ist cl =
let ans = clause_app (intern_hyp_location ist) cl in
(ist, ans)
in
Genintern.register_intern0 wit_clause_dft_concl intern_clause
let intern_ident' ist id =
let lf = ref Id.Set.empty in
(ist, intern_ident lf ist id)
let () =
Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var);
Genintern.register_intern0 wit_ref (lift intern_global_reference);
Genintern.register_intern0 wit_ident intern_ident';
Genintern.register_intern0 wit_var (lift intern_hyp);
Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg);
Genintern.register_intern0 wit_sort (fun ist s -> (ist, s));
Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis);
Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c));
Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c));
Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c));
Genintern.register_intern0 wit_red_expr (lift intern_red_expr);
Genintern.register_intern0 wit_bindings (lift intern_bindings);
Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings);
Genintern.register_intern0 wit_constr_may_eval (lift intern_constr_may_eval);
()
(***************************************************************************)
(* Backwarding recursive needs of tactic glob/interp/eval functions *)
let _ =
let f l =
let ltacvars =
List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l
in
Flags.with_option strict_check
(intern_pure_tactic { (make_empty_glob_sign()) with ltacvars })
in
Hook.set Hints.extern_intern_tac f
|