Source file `genintern.ml`

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
(************************************************************************)
(*         *      The Rocq Prover / The Rocq Development Team           *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

open Names
open Genarg

module Store = Store.Make ()

type ntnvar_status = {
  mutable ntnvar_used : bool list;
  mutable ntnvar_used_as_binder : bool;
  mutable ntnvar_scopes : Notation_term.subscopes option;
  mutable ntnvar_binding_ids : Notation_term.notation_var_binders option;
  ntnvar_typ : Notation_term.notation_var_internalization_type;
}

type intern_variable_status = {
  intern_ids : Id.Set.t;
  notation_variable_status : ntnvar_status Id.Map.t;
}

type glob_sign = {
  ltacvars : Id.Set.t;
  genv : Environ.env;
  extra : Store.t;
  intern_sign : intern_variable_status;
  strict_check : bool;
}

let empty_intern_sign = {
  intern_ids = Id.Set.empty;
  notation_variable_status = Id.Map.empty;
}

let empty_glob_sign ~strict env = {
  ltacvars = Id.Set.empty;
  genv = env;
  extra = Store.empty;
  intern_sign = empty_intern_sign;
  strict_check = strict;
}

(** In globalize tactics, we need to keep the initial [constr_expr] to recompute
   in the environment by the effective calls to Intro, Inversion, etc
   The [constr_expr] field is [None] in TacDef though *)
type glob_constr_and_expr = Glob_term.glob_constr * Constrexpr.constr_expr option
type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * Pattern.constr_pattern

type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb
type 'glb ntn_subst_fun = ntnvar_status Id.Map.t -> (Id.t -> Glob_term.glob_constr option) -> 'glb -> 'glb

module InternObj =
struct
  type ('raw, 'glb, 'top) obj = ('raw, 'glb) intern_fun
  let name = "intern"
  let default _ = None
end

module NtnSubstObj =
struct
  type ('raw, 'glb, 'top) obj = 'glb ntn_subst_fun
  let name = "notation_subst"
  let default _ = None
end

module Intern = Register (InternObj)
module NtnSubst = Register (NtnSubstObj)

let intern = Intern.obj
let register_intern0 = Intern.register0

let generic_intern ist (GenArg (Rawwit wit, v)) =
  let (ist, v) = intern wit ist v in
  (ist, in_gen (glbwit wit) v)

type ('raw,'glb) intern_pat_fun = ?loc:Loc.t -> ('raw,'glb) intern_fun

module InternPatObj = struct
  type ('raw, 'glb, 'top) obj = ('raw, 'glb) intern_pat_fun
  let name = "intern_pat"
  let default tag =
    Some (fun ?loc ->
        let name = Genarg.(ArgT.repr tag) in
        CErrors.user_err ?loc Pp.(str "This quotation is not supported in tactic patterns (" ++ str name ++ str ")"))
end

module InternPat = Register (InternPatObj)

let intern_pat = InternPat.obj

let register_intern_pat = InternPat.register0

let generic_intern_pat ?loc ist (GenArg (Rawwit wit, v)) =
  let (ist, v) = intern_pat wit ?loc ist v in
  (ist, in_gen (glbwit wit) v)

(** Notation substitution *)

let substitute_notation = NtnSubst.obj
let register_ntn_subst0 = NtnSubst.register0

let generic_substitute_notation avoid env (GenArg (Glbwit wit, v) as orig) =
  let v' = substitute_notation wit avoid env v in
  if v' == v then orig else in_gen (glbwit wit) v'

let with_used_ntnvars ntnvars f =
  let () = Id.Map.iter (fun _ status ->
      status.ntnvar_used <- false:: status.ntnvar_used)
      ntnvars
  in
  match f () with
  | v ->
    let used = Id.Map.fold (fun id status acc -> match status.ntnvar_used with
        | [] -> assert false
        | false :: rest -> status.ntnvar_used <- rest; acc
        | true :: rest ->
          let rest = match rest with
            | [] | true :: _ -> rest
            | false :: rest -> true :: rest
          in
          status.ntnvar_used <- rest;
          Id.Set.add id acc)
        ntnvars
        Id.Set.empty
    in
    used, v
  | exception e ->
    let e = Exninfo.capture e in
    let () = Id.Map.iter (fun _ status -> status.ntnvar_used <- List.tl status.ntnvar_used) ntnvars in
    Exninfo.iraise e