author  wenzelm 
Mon, 25 May 1998 21:24:27 +0200  
changeset 4963  38aa2d56e28c 
parent 4933  c85b339accfe 
child 5000  9271b89c7e2c 
permissions  rwrr 
3987  1 
(* Title: Pure/pure_thy.ML 
2 
ID: $Id$ 

3 
Author: Markus Wenzel, TU Muenchen 

4 

4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

5 
Theorem database, derived theory operations, and the Pure theories. 
3987  6 
*) 
7 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

8 
signature BASIC_PURE_THY = 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

9 
sig 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

10 
val get_thm: theory > xstring > thm 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

11 
val get_thms: theory > xstring > thm list 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

12 
val thms_of: theory > (string * thm) list 
4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

13 
val global_names: bool ref 
4853  14 
end; 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

15 

3987  16 
signature PURE_THY = 
17 
sig 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

18 
include BASIC_PURE_THY 
4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

19 
val thms_closure: theory > xstring > tthm list option 
4783  20 
val get_tthm: theory > xstring > tthm 
21 
val get_tthms: theory > xstring > tthm list 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

22 
val thms_containing: theory > string list > (string * thm) list 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

23 
val smart_store_thm: (bstring * thm) > thm 
4853  24 
val add_tthms: ((bstring * tthm) * theory attribute list) list > theory > theory 
25 
val add_tthmss: ((bstring * tthm list) * theory attribute list) list > theory > theory 

26 
val add_axioms: ((bstring * string) * theory attribute list) list > theory > theory 

27 
val add_axioms_i: ((bstring * term) * theory attribute list) list > theory > theory 

4933  28 
val add_axioms_x: ((bstring * string) * tag list) list > theory > theory 
4853  29 
val add_axiomss: ((bstring * string list) * theory attribute list) list > theory > theory 
30 
val add_axiomss_i: ((bstring * term list) * theory attribute list) list > theory > theory 

31 
val add_defs: ((bstring * string) * theory attribute list) list > theory > theory 

32 
val add_defs_i: ((bstring * term) * theory attribute list) list > theory > theory 

4933  33 
val add_defs_x: ((bstring * string) * tag list) list > theory > theory 
4853  34 
val add_defss: ((bstring * string list) * theory attribute list) list > theory > theory 
35 
val add_defss_i: ((bstring * term list) * theory attribute list) list > theory > theory 

4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

36 
val get_name: theory > string 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

37 
val put_name: string > theory > theory 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

38 
val global_path: theory > theory 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

39 
val local_path: theory > theory 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

40 
val begin_theory: string > theory list > theory 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

41 
val end_theory: theory > theory 
4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

42 
val add_typedecls: (bstring * string list * mixfix) list > theory > theory 
3987  43 
val proto_pure: theory 
44 
val pure: theory 

45 
val cpure: theory 

46 
end; 

47 

48 
structure PureThy: PURE_THY = 

49 
struct 

50 

51 

4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

52 
(*** theorem database ***) 
3987  53 

4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

54 
(** data kind 'Pure/theorems' **) 
3987  55 

4783  56 
val theoremsK = "Pure/theorems"; 
3987  57 

58 
exception Theorems of 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

59 
{space: NameSpace.T, 
4783  60 
thms_tab: tthm list Symtab.table, 
61 
const_idx: int * (int * tthm) list Symtab.table} ref; 

3987  62 

63 

64 
(* methods *) 

65 

66 
local 

4853  67 
fun mk_empty _ = 
68 
Theorems (ref {space = NameSpace.empty, 

69 
thms_tab = Symtab.empty, const_idx = (0, Symtab.empty)}); 

3987  70 

4853  71 
fun print sg (Theorems (ref {space, thms_tab, const_idx = _})) = 
72 
let 

73 
val prt_thm = Attribute.pretty_tthm o apfst (Thm.transfer_sg sg); 

74 
fun prt_thms (name, [th]) = 

75 
Pretty.block [Pretty.str (name ^ ":"), Pretty.brk 1, prt_thm th] 

76 
 prt_thms (name, ths) = Pretty.big_list (name ^ ":") (map prt_thm ths); 

3987  77 

4853  78 
fun extrn name = 
79 
if ! long_names then name else NameSpace.extern space name; 

80 
val thmss = sort_wrt fst (map (apfst extrn) (Symtab.dest thms_tab)); 

81 
in 

82 
Pretty.writeln (Display.pretty_name_space ("theorem name space", space)); 

83 
Pretty.writeln (Pretty.big_list "theorems:" (map prt_thms thmss)) 

84 
end; 

3987  85 
in 
4853  86 
val theorems_setup = Theory.init_data [(theoremsK, (mk_empty (), mk_empty, mk_empty, print))]; 
3987  87 
end; 
88 

89 

90 
(* get data record *) 

91 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

92 
fun get_theorems_sg sg = 
4049  93 
(case Sign.get_data sg theoremsK of 
3987  94 
Theorems r => r 
4792  95 
 _ => type_error theoremsK); 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

96 

4783  97 
val get_theorems = get_theorems_sg o Theory.sign_of; 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

98 

3987  99 

100 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

101 
(** retrieve theorems **) 
3987  102 

4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

103 
(* thms_closure *) 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

104 

03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

105 
(*note: we avoid life references to the theory, so users may safely 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

106 
keep thms_closure without too much space consumption*) 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

107 

4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

108 
fun thms_closure_aux thy = 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

109 
let val ref {space, thms_tab, ...} = get_theorems thy 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

110 
in fn name => Symtab.lookup (thms_tab, NameSpace.intern space name) end; 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

111 

03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

112 
fun thms_closure thy = 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

113 
let val closures = map thms_closure_aux (thy :: Theory.ancestors_of thy) 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

114 
in fn name => get_first (fn f => f name) closures end; 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

115 

3987  116 

4783  117 
(* get_thms etc. *) 
4037  118 

4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

119 
fun lookup_thms name thy = thms_closure_aux thy name; 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

120 

4783  121 
fun get_tthms thy name = 
4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

122 
(case get_first (lookup_thms name) (thy :: Theory.ancestors_of thy) of 
4590  123 
None => raise THEORY ("Unknown theorem(s) " ^ quote name, [thy]) 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

124 
 Some thms => thms); 
3987  125 

4783  126 
fun get_tthm thy name = 
127 
(case get_tthms thy name of 

3987  128 
[thm] => thm 
4590  129 
 _ => raise THEORY ("Single theorem expected " ^ quote name, [thy])); 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

130 

4783  131 
fun get_thms thy = map Attribute.thm_of o get_tthms thy; 
132 
fun get_thm thy = Attribute.thm_of o get_tthm thy; 

133 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

134 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

135 
(* thms_of *) 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

136 

4783  137 
fun attach_name (thm, _) = (Thm.name_of_thm thm, thm); 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

138 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

139 
fun thms_of thy = 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

140 
let val ref {thms_tab, ...} = get_theorems thy in 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

141 
map attach_name (flat (map snd (Symtab.dest thms_tab))) 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

142 
end; 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

143 

3987  144 

145 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

146 
(** theorems indexed by constants **) 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

147 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

148 
(* make index *) 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

149 

4037  150 
val ignore = ["Trueprop", "all", "==>", "=="]; 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

151 

4783  152 
fun add_const_idx ((next, table), tthm as (thm, _)) = 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

153 
let 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

154 
val {hyps, prop, ...} = Thm.rep_thm thm; 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

155 
val consts = 
4037  156 
foldr add_term_consts (hyps, add_term_consts (prop, [])) \\ ignore; 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

157 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

158 
fun add (tab, c) = 
4783  159 
Symtab.update ((c, (next, tthm) :: Symtab.lookup_multi (tab, c)), tab); 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

160 
in (next + 1, foldl add (table, consts)) end; 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

161 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

162 
fun make_const_idx thm_tab = 
4487  163 
foldl (foldl add_const_idx) ((0, Symtab.empty), map snd (Symtab.dest thm_tab)); 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

164 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

165 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

166 
(* lookup index *) 
3987  167 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

168 
(*search locally*) 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

169 
fun containing [] thy = thms_of thy 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

170 
 containing consts thy = 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

171 
let 
4037  172 
fun int ([], _) = [] 
173 
 int (_, []) = [] 

174 
 int (xxs as ((x as (i:int, _)) :: xs), yys as ((y as (j, _)) :: ys)) = 

175 
if i = j then x :: int (xs, ys) 

176 
else if i > j then int (xs, yys) 

177 
else int (xxs, ys); 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

178 

4037  179 
fun ints [xs] = xs 
180 
 ints xss = if exists null xss then [] else foldl int (hd xss, tl xss); 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

181 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

182 
val ref {const_idx = (_, ctab), ...} = get_theorems thy; 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

183 
val ithmss = map (fn c => Symtab.lookup_multi (ctab, c)) consts; 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

184 
in 
4037  185 
map (attach_name o snd) (ints ithmss) 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

186 
end; 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

187 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

188 
(*search globally*) 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

189 
fun thms_containing thy consts = 
4037  190 
flat (map (containing (consts \\ ignore)) (thy :: Theory.ancestors_of thy)); 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

191 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

192 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

193 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

194 
(** store theorems **) (*DESTRUCTIVE*) 
3987  195 

4853  196 
(* naming *) 
197 

198 
fun gen_names len name = 

199 
map (fn i => name ^ "_" ^ string_of_int i) (1 upto len); 

200 

201 
fun name_single name x = [(name, x)]; 

202 
fun name_multi name xs = gen_names (length xs) name ~~ xs; 

203 

204 

205 
(* enter_tthmx *) 

206 

3987  207 
fun warn_overwrite name = 
208 
warning ("Replaced old copy of theorems " ^ quote name); 

209 

210 
fun warn_same name = 

4853  211 
warning ("Theorem database already contains a copy of " ^ quote name); 
3987  212 

4853  213 
fun enter_tthmx sg app_name (bname, tthmx) = 
3987  214 
let 
4853  215 
val name = Sign.full_name sg bname; 
216 
fun name_tthm (nm, (thm, tgs)) = (Thm.name_thm (nm, thm), tgs); 

217 
val named_tthms = map name_tthm (app_name name tthmx); 

3987  218 

4783  219 
fun eq_tthm ((th1, _), (th2, _)) = Thm.eq_thm (th1, th2); 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

220 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

221 
val r as ref {space, thms_tab, const_idx} = get_theorems_sg sg; 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

222 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

223 
val overwrite = 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

224 
(case Symtab.lookup (thms_tab, name) of 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

225 
None => false 
4783  226 
 Some tthms' => 
4853  227 
if length tthms' = length named_tthms andalso forall2 eq_tthm (tthms', named_tthms) then 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

228 
(warn_same name; false) 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

229 
else (warn_overwrite name; true)); 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

230 

4487  231 
val space' = NameSpace.extend (space, [name]); 
4783  232 
val thms_tab' = Symtab.update ((name, named_tthms), thms_tab); 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

233 
val const_idx' = 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

234 
if overwrite then make_const_idx thms_tab' 
4783  235 
else foldl add_const_idx (const_idx, named_tthms); 
3987  236 
in 
4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

237 
r := {space = space', thms_tab = thms_tab', const_idx = const_idx'}; 
4783  238 
named_tthms 
3987  239 
end; 
240 

4853  241 

242 
(* add_tthms(s) *) 

243 

244 
fun add_tthmx app_name app_att ((bname, tthmx), atts) thy = 

245 
let val (thy', tthmx') = app_att ((thy, tthmx), atts) 

246 
in enter_tthmx (Theory.sign_of thy') app_name (bname, tthmx'); thy' end; 

247 

248 
val add_tthms = Theory.apply o map (add_tthmx name_single Attribute.apply); 

249 
val add_tthmss = Theory.apply o map (add_tthmx name_multi Attribute.applys); 

3987  250 

251 

4853  252 
(* smart_store_thm *) 
3987  253 

4012  254 
fun smart_store_thm (name, thm) = 
4853  255 
let val [(thm', _)] = enter_tthmx (Thm.sign_of_thm thm) name_single (name, Attribute.tthm_of thm) 
4783  256 
in thm' end; 
3987  257 

258 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

259 
(* store axioms as theorems *) 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

260 

4853  261 
local 
262 
fun add_ax app_name add ((name, axs), atts) thy = 

263 
let 

264 
val named_axs = app_name name axs; 

265 
val thy' = add named_axs thy; 

266 
val tthms = map (Attribute.tthm_of o Thm.get_axiom thy' o fst) named_axs; 

267 
in add_tthmss [((name, tthms), atts)] thy' end; 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

268 

4853  269 
fun add_axs app_name add = Theory.apply o map (add_ax app_name add); 
270 
in 

271 
val add_axioms = add_axs name_single Theory.add_axioms; 

272 
val add_axioms_i = add_axs name_single Theory.add_axioms_i; 

273 
val add_axiomss = add_axs name_multi Theory.add_axioms; 

274 
val add_axiomss_i = add_axs name_multi Theory.add_axioms_i; 

275 
val add_defs = add_axs name_single Theory.add_defs; 

276 
val add_defs_i = add_axs name_single Theory.add_defs_i; 

277 
val add_defss = add_axs name_multi Theory.add_defs; 

278 
val add_defss_i = add_axs name_multi Theory.add_defs_i; 

279 
end; 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

280 

4933  281 
fun add_axioms_x axms thy = add_axioms (map (apsnd (map (Attribute.global_attr thy))) axms) thy; 
282 
fun add_defs_x defs thy = add_defs (map (apsnd (map (Attribute.global_attr thy))) defs) thy; 

283 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

284 

3987  285 

4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

286 
(*** derived theory operations ***) 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

287 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

288 
(** theory management **) 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

289 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

290 
(* data kind 'Pure/theory' *) (* FIXME push down to sign.ML *) 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

291 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

292 
val theoryK = "Pure/theory"; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

293 
exception Theory of string; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

294 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

295 
local 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

296 
fun mk_empty _ = Theory ""; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

297 
fun print _ (Theory name) = writeln name; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

298 
in 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

299 
val theory_setup = Theory.init_data [(theoryK, (mk_empty (), mk_empty, mk_empty, print))]; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

300 
end; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

301 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

302 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

303 
(* get / put name *) 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

304 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

305 
fun get_name thy = 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

306 
(case Theory.get_data thy theoryK of 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

307 
Theory name => name 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

308 
 _ => type_error theoryK); 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

309 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

310 
fun put_name name = Theory.put_data (theoryK, Theory name); 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

311 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

312 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

313 
(* control prefixing of theory name *) 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

314 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

315 
(*compatibility flag, likely to disappear someday*) 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

316 
val global_names = ref false; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

317 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

318 
fun global_path thy = 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

319 
if ! global_names then thy else Theory.root_path thy; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

320 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

321 
fun local_path thy = 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

322 
if ! global_names then thy 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

323 
else thy > Theory.root_path > Theory.add_path (get_name thy); 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

324 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

325 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

326 
(* begin / end theory *) 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

327 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

328 
fun begin_theory name thys = 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

329 
Theory.prep_ext_merge thys 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

330 
> put_name name 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

331 
> local_path; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

332 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

333 
fun end_theory thy = Theory.add_name (get_name thy) thy; 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

334 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

335 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

336 

38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

337 
(** add logical types **) 
4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

338 

03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

339 
fun add_typedecls decls thy = 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

340 
let 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

341 
val full = Sign.full_name (Theory.sign_of thy); 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

342 

03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

343 
fun type_of (raw_name, vs, mx) = 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

344 
if null (duplicates vs) then (raw_name, length vs, mx) 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

345 
else error ("Duplicate parameters in type declaration: " ^ quote raw_name); 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

346 

03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

347 
fun arity_of (raw_name, len, mx) = 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

348 
(full (Syntax.type_name raw_name mx), replicate len logicS, logicS); 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

349 

03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

350 
val types = map type_of decls; 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

351 
val arities = map arity_of types; 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

352 
in 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

353 
thy 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

354 
> Theory.add_types types 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

355 
> Theory.add_arities_i arities 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

356 
end; 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

357 

03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

358 

03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

359 

03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

360 
(*** the Pure theories ***) 
3987  361 

362 
val proto_pure = 

363 
Theory.pre_pure 

4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

364 
> Theory.apply [Attribute.setup, theorems_setup, theory_setup] 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

365 
> put_name "ProtoPure" 
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

366 
> global_path 
3987  367 
> Theory.add_types 
4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

368 
[("fun", 2, NoSyn), 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

369 
("prop", 0, NoSyn), 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

370 
("itself", 1, NoSyn), 
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

371 
("dummy", 0, NoSyn)] 
3987  372 
> Theory.add_classes_i [(logicC, [])] 
373 
> Theory.add_defsort_i logicS 

374 
> Theory.add_arities_i 

375 
[("fun", [logicS, logicS], logicS), 

376 
("prop", [], logicS), 

377 
("itself", [logicS], logicS)] 

4922
03b81b6e1baa
added thms_closure: theory > xstring > tthm list option;
wenzelm
parents:
4853
diff
changeset

378 
> Theory.add_nonterminals Syntax.pure_nonterms 
3987  379 
> Theory.add_syntax Syntax.pure_syntax 
380 
> Theory.add_modesyntax ("symbols", true) Syntax.pure_sym_syntax 

381 
> Theory.add_trfuns Syntax.pure_trfuns 

382 
> Theory.add_trfunsT Syntax.pure_trfunsT 

383 
> Theory.add_syntax 

384 
[("==>", "[prop, prop] => prop", Delimfix "op ==>")] 

385 
> Theory.add_consts 

386 
[("==", "['a::{}, 'a] => prop", InfixrName ("==", 2)), 

387 
("=?=", "['a::{}, 'a] => prop", InfixrName ("=?=", 2)), 

388 
("==>", "[prop, prop] => prop", Mixfix ("(_/ ==> _)", [2, 1], 1)), 

389 
("all", "('a => prop) => prop", Binder ("!!", 0, 0)), 

4788  390 
("Goal", "prop => prop", Mixfix ("GOAL _", [999], 1000)), 
3987  391 
("TYPE", "'a itself", NoSyn)] 
4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

392 
> local_path 
4853  393 
> (add_defs o map Attribute.none) 
4788  394 
[("flexpair_def", "(t =?= u) == (t == u::'a::{})"), 
395 
("Goal_def", "GOAL (PROP A) == PROP A")] 

4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

396 
> end_theory; 
3987  397 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

398 
val pure = 
4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

399 
begin_theory "Pure" [proto_pure] 
3987  400 
> Theory.add_syntax Syntax.pure_appl_syntax 
4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

401 
> end_theory; 
3987  402 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

403 
val cpure = 
4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

404 
begin_theory "CPure" [proto_pure] 
3987  405 
> Theory.add_syntax Syntax.pure_applC_syntax 
4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

406 
> end_theory; 
3987  407 

408 

409 
end; 

410 

411 

4022
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

412 
structure BasicPureThy: BASIC_PURE_THY = PureThy; 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

413 
open BasicPureThy; 
0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

414 

0770a19c48d3
added ignored_consts, thms_containing, add_store_axioms(_i),
wenzelm
parents:
4013
diff
changeset

415 

3987  416 

4963
38aa2d56e28c
added get_name, put_name, global_path, local_path, begin_theory,
wenzelm
parents:
4933
diff
changeset

417 
(** Pure theory structures **) 
3987  418 

419 
structure ProtoPure = 

420 
struct 

421 
val thy = PureThy.proto_pure; 

422 
val flexpair_def = get_axiom thy "flexpair_def"; 

4788  423 
val Goal_def = get_axiom thy "Goal_def"; 
3987  424 
end; 
425 

426 
structure Pure = struct val thy = PureThy.pure end; 

427 
structure CPure = struct val thy = PureThy.cpure end; 