aboutsummaryrefslogtreecommitdiffhomepage
path: root/toplevel/libtypes.ml
blob: 7a065ae0287edcd2c266d818b0becf7894576401 (plain)
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
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

open Term
open Summary
open Libobject
open Libnames
open Names
(*
 * Module construction
 *)

let reduce c = Reductionops.head_unfold_under_prod
  (Auto.Hint_db.transparent_state (Auto.searchtable_map "typeclass_instances"))
  (Global.env()) Evd.empty c

module TypeDnet = Term_dnet.Make
  (struct
     type t = Libnames.global_reference
     let compare = RefOrdered.compare
     let subst s gr = fst (Libnames.subst_global s gr)
     let constr_of = Global.type_of_global
   end)
  (struct let reduce = reduce
	  let direction = false
   end)

type result = Libnames.global_reference * (constr*existential_key) * Termops.subst

let all_types = ref TypeDnet.empty
let defined_types = ref TypeDnet.empty

(*
 * Bookeeping & States
 *)

let freeze () =
  (!all_types,!defined_types)

let unfreeze (lt,dt) =
  all_types := lt;
  defined_types := dt

let init () =
  all_types := TypeDnet.empty;
  defined_types := TypeDnet.empty

let _ =
  declare_summary "type-library-state"
    { freeze_function = freeze;
      unfreeze_function = unfreeze;
      init_function = init }

let load (_,d) =
(*  Profile.print_logical_stats !all_types;
  Profile.print_logical_stats d;*)
  all_types := TypeDnet.union d !all_types

let subst s t = TypeDnet.subst s t
(*
let subst_key = Profile.declare_profile "subst"
let subst a b = Profile.profile2 subst_key TypeDnet.subst a b

let load_key = Profile.declare_profile "load"
let load a = Profile.profile1 load_key load a
*)
let (input,output) =
  declare_object
    { (default_object "LIBTYPES") with
	load_function = (fun _ -> load);
	subst_function = (fun (s,t) -> subst s t);
	classify_function = (fun x -> Substitute x)
    }

let update () = Lib.add_anonymous_leaf (input !defined_types)

(*
 * Search interface
 *)

let search_pattern pat = TypeDnet.search_pattern !all_types pat
let search_concl pat = TypeDnet.search_concl !all_types pat
let search_head_concl pat = TypeDnet.search_head_concl !all_types pat
let search_eq_concl eq pat = TypeDnet.search_eq_concl !all_types eq pat

let add typ gr =
  defined_types := TypeDnet.add typ gr !defined_types;
  all_types := TypeDnet.add typ gr !all_types
(*
let add_key = Profile.declare_profile "add"
let add a b = Profile.profile1 add_key add a b
*)

(*
 * Hooks declaration
 *)

let _ = Declare.add_cache_hook
  ( fun sp ->
      let gr = Nametab.global_of_path sp in
      let ty = Global.type_of_global gr in
      add ty gr )

let _ = Declaremods.set_end_library_hook update