Source file `pConstraints.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
(************************************************************************)
(*         *      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 Univ
open Sorts

type t = ElimConstraints.t * UnivConstraints.t

type pconstraints = t

let make q u = (q, u)

let qualities = fst

let univs = snd

let add_quality q (qc, lc) = (ElimConstraints.add q qc, lc)

let add_univ u (qc, lc) = (qc, UnivConstraints.add u lc)

let of_qualities qc = make qc UnivConstraints.empty

let of_univs lc = make ElimConstraints.empty lc

let set_qualities qc (_,lc) = make qc lc

let set_univs lc (qc,_) = make qc lc

let empty = (ElimConstraints.empty, UnivConstraints.empty)

let is_empty (qc, lc) =
  ElimConstraints.is_empty qc && UnivConstraints.is_empty lc

let equal (qc, lc) (qc', lc') =
  ElimConstraints.equal qc qc' && UnivConstraints.equal lc lc'

let union (qc, lc) (qc', lc') =
  (ElimConstraints.union qc qc', UnivConstraints.union lc lc')

let fold (qf, lf) (qc, lc) (x, y) =
  (ElimConstraints.fold qf qc x, UnivConstraints.fold lf lc y)

let diff (qc, lc) (qc', lc') =
  (ElimConstraints.diff qc qc', UnivConstraints.diff lc lc')

let elements (qc, lc) =
  (ElimConstraints.elements qc, UnivConstraints.elements lc)

let filter_qualities f (qc, lc) =
  make (ElimConstraints.filter f qc) lc

let filter_univs f (qc, lc) =
  make qc @@ UnivConstraints.filter f lc

let pr prv prl (qc, lc) =
  let open Pp in
  let sep = if ElimConstraints.is_empty qc || UnivConstraints.is_empty lc
            then mt ()
            else pr_comma () in
  v 0 (ElimConstraints.pr prv qc ++ sep ++ UnivConstraints.pr prl lc)

module HPConstraints =
  Hashcons.Make(
    struct
      type t = pconstraints
      let hashcons (qf, uf) =
        let hqf, qf = ElimConstraints.hcons qf in
        let huf, uf = UnivConstraints.hcons uf in
        Hashset.Combine.(combine hqf huf), (qf, uf)
      let eq (qc, uc) (qc', uc') =
        qc == qc' && uc == uc'
    end)

let hcons =
  Hashcons.simple_hcons
    HPConstraints.generate
    HPConstraints.hcons ()

(** A value with universe constraints. *)
type 'a constrained = 'a * t

let constraints_of (_, cst) = cst

(** Constraints functions. *)

type 'a constraint_function = 'a -> 'a -> t -> t

let enforce_eq_univ u v c =
  (* We discard trivial constraints like u=u *)
  if Level.equal u v then c
  else add_univ (u, UnivConstraint.Eq, v) c

let enforce_leq_univ u v c =
  if Level.equal u v then c
  else add_univ (u, UnivConstraint.Le, v) c

let enforce_elim_to q1 q2 csts =
  if QGraph.ElimTable.eliminates_to q1 q2 then csts
  else add_quality (q1, ElimConstraint.ElimTo, q2) csts