author  ballarin 
Thu, 18 Dec 2008 19:52:11 +0100  
changeset 29221  918687637307 
parent 29217  a1c992fb3184 
child 29241  3adc06d6504f 
permissions  rwrr 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

1 
(* Title: Pure/Isar/expression.ML 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

2 
Author: Clemens Ballarin, TU Muenchen 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

3 

28795  4 
New locale development  experimental. 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

5 
*) 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

6 

140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

7 
signature EXPRESSION = 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

8 
sig 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

9 
datatype 'term map = Positional of 'term option list  Named of (string * 'term) list; 
29214  10 
type 'term expr = (string * ((string * bool) * 'term map)) list; 
28965  11 
type expression = string expr * (Binding.T * string option * mixfix) list; 
12 
type expression_i = term expr * (Binding.T * typ option * mixfix) list; 

28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

13 

28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

14 
(* Processing of context statements *) 
28879  15 
val read_statement: Element.context list > (string * string list) list list > 
16 
Proof.context > (term * term list) list list * Proof.context; 

17 
val cert_statement: Element.context_i list > (term * term list) list list > 

18 
Proof.context > (term * term list) list list * Proof.context; 

19 

28795  20 
(* Declaring locales *) 
28902
2019bcc9d8bf
Ahere to modern naming conventions; proper treatment of internal vs external names.
ballarin
parents:
28898
diff
changeset

21 
val add_locale_cmd: string > bstring > expression > Element.context list > theory > 
29028
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

22 
(string * (string * (Attrib.binding * (thm list * Attrib.src list) list) list) list) * 
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

23 
Proof.context 
28902
2019bcc9d8bf
Ahere to modern naming conventions; proper treatment of internal vs external names.
ballarin
parents:
28898
diff
changeset

24 
val add_locale: string > bstring > expression_i > Element.context_i list > theory > 
29028
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

25 
(string * (string * (Attrib.binding * (thm list * Attrib.src list) list) list) list) * 
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

26 
Proof.context 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

27 

28895  28 
(* Interpretation *) 
28951
e89dde5f365c
Sublocale: removed public after_qed; identifiers private to NewLocale.
ballarin
parents:
28936
diff
changeset

29 
val sublocale_cmd: string > expression > theory > Proof.state; 
e89dde5f365c
Sublocale: removed public after_qed; identifiers private to NewLocale.
ballarin
parents:
28936
diff
changeset

30 
val sublocale: string > expression_i > theory > Proof.state; 
29211  31 
val interpretation_cmd: expression > (Attrib.binding * string) list > theory > Proof.state; 
32 
val interpretation: expression_i > (Attrib.binding * term) list > theory > Proof.state; 

29018  33 
val interpret_cmd: expression > bool > Proof.state > Proof.state; 
34 
val interpret: expression_i > bool > Proof.state > Proof.state; 

28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

35 
end; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

36 

140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

37 

28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

38 
structure Expression : EXPRESSION = 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

39 
struct 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

40 

28795  41 
datatype ctxt = datatype Element.ctxt; 
42 

43 

44 
(*** Expressions ***) 

28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

45 

28872  46 
datatype 'term map = 
47 
Positional of 'term option list  

48 
Named of (string * 'term) list; 

28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

49 

29214  50 
type 'term expr = (string * ((string * bool) * 'term map)) list; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

51 

28965  52 
type expression = string expr * (Binding.T * string option * mixfix) list; 
53 
type expression_i = term expr * (Binding.T * typ option * mixfix) list; 

28795  54 

28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

55 

28859  56 
(** Internalise locale names in expr **) 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

57 

28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

58 
fun intern thy instances = map (apfst (NewLocale.intern thy)) instances; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

59 

140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

60 

28859  61 
(** Parameters of expression. 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

62 

28895  63 
Sanity check of instantiations and extraction of implicit parameters. 
64 
The latter only occurs iff strict = false. 

65 
Positional instantiations are extended to match full length of parameter list 

66 
of instantiated locale. **) 

67 

68 
fun parameters_of thy strict (expr, fixed) = 

28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

69 
let 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

70 
fun reject_dups message xs = 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

71 
let val dups = duplicates (op =) xs 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

72 
in 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

73 
if null dups then () else error (message ^ commas dups) 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

74 
end; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

75 

29006  76 
fun match_bind (n, b) = (n = Binding.base_name b); 
29030
0ea94f540548
Order of implicit parameters in locale expression.
ballarin
parents:
29028
diff
changeset

77 
fun parm_eq ((b1, mx1), (b2, mx2)) = 
0ea94f540548
Order of implicit parameters in locale expression.
ballarin
parents:
29028
diff
changeset

78 
(* FIXME: cannot compare bindings for equality, instead check for equal name and syntax *) 
0ea94f540548
Order of implicit parameters in locale expression.
ballarin
parents:
29028
diff
changeset

79 
(Binding.base_name b1 = Binding.base_name b2) andalso 
0ea94f540548
Order of implicit parameters in locale expression.
ballarin
parents:
29028
diff
changeset

80 
(if mx1 = mx2 then true 
0ea94f540548
Order of implicit parameters in locale expression.
ballarin
parents:
29028
diff
changeset

81 
else error ("Conflicting syntax for parameter" ^ quote (Binding.display b1) ^ 
0ea94f540548
Order of implicit parameters in locale expression.
ballarin
parents:
29028
diff
changeset

82 
" in expression.")); 
0ea94f540548
Order of implicit parameters in locale expression.
ballarin
parents:
29028
diff
changeset

83 

29006  84 
fun bind_eq (b1, b2) = (Binding.base_name b1 = Binding.base_name b2); 
28795  85 
(* FIXME: cannot compare bindings for equality. *) 
86 

87 
fun params_loc loc = 

28859  88 
(NewLocale.params_of thy loc > map (fn (p, _, mx) => (p, mx)), loc); 
28795  89 
fun params_inst (expr as (loc, (prfx, Positional insts))) = 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

90 
let 
28795  91 
val (ps, loc') = params_loc loc; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

92 
val d = length ps  length insts; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

93 
val insts' = 
28879  94 
if d < 0 then error ("More arguments than parameters in instantiation of locale " ^ 
95 
quote (NewLocale.extern thy loc)) 

28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

96 
else insts @ replicate d NONE; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

97 
val ps' = (ps ~~ insts') > 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

98 
map_filter (fn (p, NONE) => SOME p  (_, SOME _) => NONE); 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

99 
in (ps', (loc', (prfx, Positional insts'))) end 
28795  100 
 params_inst (expr as (loc, (prfx, Named insts))) = 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

101 
let 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

102 
val _ = reject_dups "Duplicate instantiation of the following parameter(s): " 
28859  103 
(map fst insts); 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

104 

28795  105 
val (ps, loc') = params_loc loc; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

106 
val ps' = fold (fn (p, _) => fn ps => 
28795  107 
if AList.defined match_bind ps p then AList.delete match_bind p ps 
28859  108 
else error (quote p ^" not a parameter of instantiated expression.")) insts ps; 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

109 
in (ps', (loc', (prfx, Named insts))) end; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

110 
fun params_expr is = 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

111 
let 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

112 
val (is', ps') = fold_map (fn i => fn ps => 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

113 
let 
28795  114 
val (ps', i') = params_inst i; 
29030
0ea94f540548
Order of implicit parameters in locale expression.
ballarin
parents:
29028
diff
changeset

115 
val ps'' = distinct parm_eq (ps @ ps'); 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

116 
in (i', ps'') end) is [] 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

117 
in (ps', is') end; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

118 

28895  119 
val (implicit, expr') = params_expr expr; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

120 

29006  121 
val implicit' = map (#1 #> Binding.base_name) implicit; 
122 
val fixed' = map (#1 #> Binding.base_name) fixed; 

28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

123 
val _ = reject_dups "Duplicate fixed parameter(s): " fixed'; 
28895  124 
val implicit'' = if strict then [] 
125 
else let val _ = reject_dups 

126 
"Parameter(s) declared simultaneously in expression and for clause: " (implicit' @ fixed') 

127 
in map (fn (b, mx) => (b, NONE, mx)) implicit end; 

28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

128 

28895  129 
in (expr', implicit'' @ fixed) end; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

130 

28795  131 

132 
(** Read instantiation **) 

133 

28872  134 
(* Parse positional or named instantiation *) 
135 

28859  136 
local 
137 

28872  138 
fun prep_inst parse_term parms (Positional insts) ctxt = 
139 
(insts ~~ parms) > map (fn 

140 
(NONE, p) => Syntax.parse_term ctxt p  

141 
(SOME t, _) => parse_term ctxt t) 

142 
 prep_inst parse_term parms (Named insts) ctxt = 

143 
parms > map (fn p => case AList.lookup (op =) insts p of 

144 
SOME t => parse_term ctxt t  

145 
NONE => Syntax.parse_term ctxt p); 

146 

147 
in 

148 

149 
fun parse_inst x = prep_inst Syntax.parse_term x; 

150 
fun make_inst x = prep_inst (K I) x; 

151 

152 
end; 

153 

154 

155 
(* Instantiation morphism *) 

156 

29214  157 
fun inst_morph (parm_names, parm_types) ((prfx, strict), insts') ctxt = 
28795  158 
let 
159 
(* parameters *) 

160 
val type_parm_names = fold Term.add_tfreesT parm_types [] > map fst; 

161 

162 
(* type inference and contexts *) 

163 
val parm_types' = map (TypeInfer.paramify_vars o Logic.varifyT) parm_types; 

164 
val type_parms = fold Term.add_tvarsT parm_types' [] > map (Logic.mk_type o TVar); 

165 
val arg = type_parms @ map2 TypeInfer.constrain parm_types' insts'; 

166 
val res = Syntax.check_terms ctxt arg; 

167 
val ctxt' = ctxt > fold Variable.auto_fixes res; 

28872  168 

28795  169 
(* instantiation *) 
170 
val (type_parms'', res') = chop (length type_parms) res; 

171 
val insts'' = (parm_names ~~ res') > map_filter 

172 
(fn (inst as (x, Free (y, _))) => if x = y then NONE else SOME inst  

173 
inst => SOME inst); 

174 
val instT = Symtab.make (type_parm_names ~~ map Logic.dest_type type_parms''); 

175 
val inst = Symtab.make insts''; 

176 
in 

177 
(Element.inst_morphism (ProofContext.theory_of ctxt) (instT, inst) $> 

29214  178 
Morphism.binding_morphism (Binding.add_prefix strict prfx), ctxt') 
28795  179 
end; 
28859  180 

28795  181 

182 
(*** Locale processing ***) 

183 

28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

184 
(** Parsing **) 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

185 

5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

186 
fun parse_elem prep_typ prep_term ctxt elem = 
29215
f98862eb0591
Use correct mode when parsing elements and conclusion.
ballarin
parents:
29214
diff
changeset

187 
Element.map_ctxt' {binding = I, var = I, typ = prep_typ ctxt, 
f98862eb0591
Use correct mode when parsing elements and conclusion.
ballarin
parents:
29214
diff
changeset

188 
term = prep_term (ProofContext.set_mode ProofContext.mode_schematic ctxt), (* FIXME ?? *) 
f98862eb0591
Use correct mode when parsing elements and conclusion.
ballarin
parents:
29214
diff
changeset

189 
pat = prep_term (ProofContext.set_mode ProofContext.mode_pattern ctxt), 
f98862eb0591
Use correct mode when parsing elements and conclusion.
ballarin
parents:
29214
diff
changeset

190 
fact = I, attrib = I} elem; 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

191 

5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

192 
fun parse_concl prep_term ctxt concl = 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

193 
(map o map) (fn (t, ps) => 
29215
f98862eb0591
Use correct mode when parsing elements and conclusion.
ballarin
parents:
29214
diff
changeset

194 
(prep_term (ProofContext.set_mode ProofContext.mode_schematic ctxt) t, (* FIXME ?? *) 
f98862eb0591
Use correct mode when parsing elements and conclusion.
ballarin
parents:
29214
diff
changeset

195 
map (prep_term (ProofContext.set_mode ProofContext.mode_pattern ctxt)) ps)) concl; 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

196 

5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

197 

28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

198 
(** Simultaneous type inference: instantiations + elements + conclusion **) 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

199 

6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

200 
local 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

201 

6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

202 
fun mk_type T = (Logic.mk_type T, []); 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

203 
fun mk_term t = (t, []); 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

204 
fun mk_propp (p, pats) = (Syntax.type_constraint propT p, pats); 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

205 

28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

206 
fun dest_type (T, []) = Logic.dest_type T; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

207 
fun dest_term (t, []) = t; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

208 
fun dest_propp (p, pats) = (p, pats); 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

209 

6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

210 
fun extract_inst (_, (_, ts)) = map mk_term ts; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

211 
fun restore_inst ((l, (p, _)), cs) = (l, (p, map dest_term cs)); 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

212 

6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

213 
fun extract_elem (Fixes fixes) = map (#2 #> the_list #> map mk_type) fixes 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

214 
 extract_elem (Constrains csts) = map (#2 #> single #> map mk_type) csts 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

215 
 extract_elem (Assumes asms) = map (#2 #> map mk_propp) asms 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

216 
 extract_elem (Defines defs) = map (fn (_, (t, ps)) => [mk_propp (t, ps)]) defs 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

217 
 extract_elem (Notes _) = []; 
28795  218 

28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

219 
fun restore_elem (Fixes fixes, css) = 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

220 
(fixes ~~ css) > map (fn ((x, _, mx), cs) => 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

221 
(x, cs > map dest_type > try hd, mx)) > Fixes 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

222 
 restore_elem (Constrains csts, css) = 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

223 
(csts ~~ css) > map (fn ((x, _), cs) => 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

224 
(x, cs > map dest_type > hd)) > Constrains 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

225 
 restore_elem (Assumes asms, css) = 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

226 
(asms ~~ css) > map (fn ((b, _), cs) => (b, map dest_propp cs)) > Assumes 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

227 
 restore_elem (Defines defs, css) = 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

228 
(defs ~~ css) > map (fn ((b, _), [c]) => (b, dest_propp c)) > Defines 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

229 
 restore_elem (Notes notes, _) = Notes notes; 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

230 

28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

231 
fun check cs context = 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

232 
let 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

233 
fun prep (_, pats) (ctxt, t :: ts) = 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

234 
let val ctxt' = Variable.auto_fixes t ctxt 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

235 
in 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

236 
((t, Syntax.check_props (ProofContext.set_mode ProofContext.mode_pattern ctxt') pats), 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

237 
(ctxt', ts)) 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

238 
end 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

239 
val (cs', (context', _)) = fold_map prep cs 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

240 
(context, Syntax.check_terms 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

241 
(ProofContext.set_mode ProofContext.mode_schematic context) (map fst cs)); 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

242 
in (cs', context') end; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

243 

6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

244 
in 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

245 

28872  246 
fun check_autofix insts elems concl ctxt = 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

247 
let 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

248 
val inst_cs = map extract_inst insts; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

249 
val elem_css = map extract_elem elems; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

250 
val concl_cs = (map o map) mk_propp concl; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

251 
(* Type inference *) 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

252 
val (inst_cs' :: css', ctxt') = 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

253 
(fold_burrow o fold_burrow) check (inst_cs :: elem_css @ [concl_cs]) ctxt; 
28936
f1647bf418f5
No resolution of patterns within context statements.
ballarin
parents:
28903
diff
changeset

254 
val (elem_css', [concl_cs']) = chop (length elem_css) css'; 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

255 
in 
28936
f1647bf418f5
No resolution of patterns within context statements.
ballarin
parents:
28903
diff
changeset

256 
(map restore_inst (insts ~~ inst_cs'), map restore_elem (elems ~~ elem_css'), 
f1647bf418f5
No resolution of patterns within context statements.
ballarin
parents:
28903
diff
changeset

257 
concl_cs', ctxt') 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

258 
end; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

259 

6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

260 
end; 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

261 

5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

262 

5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

263 
(** Prepare locale elements **) 
28795  264 

265 
fun declare_elem prep_vars (Fixes fixes) ctxt = 

266 
let val (vars, _) = prep_vars fixes ctxt 

28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

267 
in ctxt > ProofContext.add_fixes_i vars > snd end 
28795  268 
 declare_elem prep_vars (Constrains csts) ctxt = 
28965  269 
ctxt > prep_vars (map (fn (x, T) => (Binding.name x, SOME T, NoSyn)) csts) > snd 
28872  270 
 declare_elem _ (Assumes _) ctxt = ctxt 
271 
 declare_elem _ (Defines _) ctxt = ctxt 

28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

272 
 declare_elem _ (Notes _) ctxt = ctxt; 
28795  273 

29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

274 
(** Finish locale elements **) 
28795  275 

28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

276 
fun closeup _ _ false elem = elem 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

277 
 closeup ctxt parms true elem = 
28795  278 
let 
279 
fun close_frees t = 

280 
let 

281 
val rev_frees = 

282 
Term.fold_aterms (fn Free (x, T) => 

28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

283 
if AList.defined (op =) parms x then I else insert (op =) (x, T)  _ => I) t []; 
29021
ce100fbc3c8e
Proper shape of assumptions generated from Defines elements.
ballarin
parents:
29020
diff
changeset

284 
in Term.list_all_free (rev rev_frees, t) end; (* FIXME use fold Logic.all *) 
29019  285 
(* FIXME consider closing in syntactic phase *) 
28795  286 

287 
fun no_binds [] = [] 

28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

288 
 no_binds _ = error "Illegal term bindings in context element"; 
28795  289 
in 
290 
(case elem of 

291 
Assumes asms => Assumes (asms > map (fn (a, propps) => 

292 
(a, map (fn (t, ps) => (close_frees t, no_binds ps)) propps))) 

29022  293 
 Defines defs => Defines (defs > map (fn ((name, atts), (t, ps)) => 
294 
let val ((c, _), t') = LocalDefs.cert_def ctxt (close_frees t) 

295 
in 

296 
((Binding.map_base (Thm.def_name_optional c) name, atts), (t', no_binds ps)) 

297 
end)) 

28795  298 
 e => e) 
299 
end; 

300 

28872  301 
fun finish_primitive parms _ (Fixes fixes) = Fixes (map (fn (binding, _, mx) => 
29006  302 
let val x = Binding.base_name binding 
28795  303 
in (binding, AList.lookup (op =) parms x, mx) end) fixes) 
28872  304 
 finish_primitive _ _ (Constrains _) = Constrains [] 
305 
 finish_primitive _ close (Assumes asms) = close (Assumes asms) 

306 
 finish_primitive _ close (Defines defs) = close (Defines defs) 

307 
 finish_primitive _ _ (Notes facts) = Notes facts; 

308 

29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

309 
fun finish_inst ctxt parms do_close (loc, (prfx, inst)) = 
28872  310 
let 
311 
val thy = ProofContext.theory_of ctxt; 

312 
val (parm_names, parm_types) = NewLocale.params_of thy loc > 

29006  313 
map (fn (b, SOME T, _) => (Binding.base_name b, T)) > split_list; 
28872  314 
val (morph, _) = inst_morph (parm_names, parm_types) (prfx, inst) ctxt; 
29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

315 
in (loc, morph) end; 
28795  316 

29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

317 
fun finish_elem ctxt parms do_close elem = 
28795  318 
let 
28872  319 
val elem' = finish_primitive parms (closeup ctxt parms do_close) elem; 
29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

320 
in elem' end 
28795  321 

29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

322 
fun finish ctxt parms do_close insts elems = 
28872  323 
let 
29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

324 
val deps = map (finish_inst ctxt parms do_close) insts; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

325 
val elems' = map (finish_elem ctxt parms do_close) elems; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

326 
in (deps, elems') end; 
28795  327 

328 

28895  329 
(** Process full context statement: instantiations + elements + conclusion **) 
330 

331 
(* Interleave incremental parsing and type inference over entire parsed stretch. *) 

332 

28795  333 
local 
334 

28895  335 
fun prep_full_context_statement parse_typ parse_prop parse_inst prep_vars prep_expr 
336 
strict do_close context raw_import raw_elems raw_concl = 

28795  337 
let 
28872  338 
val thy = ProofContext.theory_of context; 
339 

28895  340 
val (raw_insts, fixed) = parameters_of thy strict (apfst (prep_expr thy) raw_import); 
341 

28951
e89dde5f365c
Sublocale: removed public after_qed; identifiers private to NewLocale.
ballarin
parents:
28936
diff
changeset

342 
fun prep_inst (loc, (prfx, inst)) (i, insts, ctxt) = 
28872  343 
let 
344 
val (parm_names, parm_types) = NewLocale.params_of thy loc > 

29006  345 
map (fn (b, SOME T, _) => (Binding.base_name b, T)) > split_list; 
28872  346 
val inst' = parse_inst parm_names inst ctxt; 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

347 
val parm_types' = map (TypeInfer.paramify_vars o 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

348 
Term.map_type_tvar (fn ((x, _), S) => TVar ((x, i), S)) o Logic.varifyT) parm_types; 
28872  349 
val inst'' = map2 TypeInfer.constrain parm_types' inst'; 
350 
val insts' = insts @ [(loc, (prfx, inst''))]; 

28951
e89dde5f365c
Sublocale: removed public after_qed; identifiers private to NewLocale.
ballarin
parents:
28936
diff
changeset

351 
val (insts'', _, _, ctxt' (* FIXME not used *) ) = check_autofix insts' [] [] ctxt; 
28872  352 
val inst''' = insts'' > List.last > snd > snd; 
353 
val (morph, _) = inst_morph (parm_names, parm_types) (prfx, inst''') ctxt; 

28951
e89dde5f365c
Sublocale: removed public after_qed; identifiers private to NewLocale.
ballarin
parents:
28936
diff
changeset

354 
val ctxt'' = NewLocale.activate_declarations thy (loc, morph) ctxt; 
e89dde5f365c
Sublocale: removed public after_qed; identifiers private to NewLocale.
ballarin
parents:
28936
diff
changeset

355 
in (i+1, insts', ctxt'') end; 
28872  356 

357 
fun prep_elem raw_elem (insts, elems, ctxt) = 

28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

358 
let 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

359 
val ctxt' = declare_elem prep_vars raw_elem ctxt; 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

360 
val elems' = elems @ [parse_elem parse_typ parse_prop ctxt' raw_elem]; 
28872  361 
val (_, _, _, ctxt'') = check_autofix insts elems' [] ctxt'; 
362 
in (insts, elems', ctxt') end; 

28795  363 

28872  364 
fun prep_concl raw_concl (insts, elems, ctxt) = 
28795  365 
let 
29215
f98862eb0591
Use correct mode when parsing elements and conclusion.
ballarin
parents:
29214
diff
changeset

366 
val concl = parse_concl parse_prop ctxt raw_concl; 
28872  367 
in check_autofix insts elems concl ctxt end; 
28795  368 

28872  369 
val fors = prep_vars fixed context > fst; 
370 
val ctxt = context > ProofContext.add_fixes_i fors > snd; 

29206  371 
val (_, insts', ctxt') = fold prep_inst raw_insts (0, [], ctxt); 
28872  372 
val (_, elems'', ctxt'') = fold prep_elem raw_elems (insts', [], ctxt'); 
373 
val (insts, elems, concl, ctxt) = prep_concl raw_concl (insts', elems'', ctxt''); 

28795  374 

28872  375 
(* Retrieve parameter types *) 
29006  376 
val xs = fold (fn Fixes fixes => (fn ps => ps @ map (Binding.base_name o #1) fixes)  
28872  377 
_ => fn ps => ps) (Fixes fors :: elems) []; 
28859  378 
val (Ts, ctxt') = fold_map ProofContext.inferred_param xs ctxt; 
28895  379 
val parms = xs ~~ Ts; (* params from expression and elements *) 
28795  380 

28872  381 
val Fixes fors' = finish_primitive parms I (Fixes fors); 
29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

382 
val (deps, elems') = finish ctxt' parms do_close insts elems; 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

383 

29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

384 
in ((fors', deps, elems', concl), (parms, ctxt')) end 
28795  385 

386 
in 

387 

28895  388 
fun read_full_context_statement x = 
389 
prep_full_context_statement Syntax.parse_typ Syntax.parse_prop parse_inst 

390 
ProofContext.read_vars intern x; 

391 
fun cert_full_context_statement x = 

392 
prep_full_context_statement (K I) (K I) make_inst ProofContext.cert_vars (K I) x; 

28795  393 

394 
end; 

395 

396 

28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

397 
(* Context statement: elements + conclusion *) 
28795  398 

399 
local 

400 

28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

401 
fun prep_statement prep activate raw_elems raw_concl context = 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

402 
let 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

403 
val ((_, _, elems, concl), _) = prep true false context ([], []) raw_elems raw_concl; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

404 
val (_, context') = activate elems (ProofContext.set_stmt true context); 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

405 
in (concl, context') end; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

406 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

407 
in 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

408 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

409 
fun read_statement x = prep_statement read_full_context_statement Element.activate x; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

410 
fun cert_statement x = prep_statement cert_full_context_statement Element.activate_i x; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

411 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

412 
end; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

413 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

414 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

415 
(* Locale declaration: import + elements *) 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

416 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

417 
local 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

418 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

419 
fun prep_declaration prep activate raw_import raw_elems context = 
28795  420 
let 
29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

421 
val ((fixed, deps, elems, _), (parms, ctxt')) = prep false true context raw_import raw_elems []; 
28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

422 
(* Declare parameters and imported facts *) 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

423 
val context' = context > 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

424 
ProofContext.add_fixes_i fixed > snd > 
29206  425 
fold NewLocale.activate_local_facts deps; 
29217
a1c992fb3184
Finergrained activation so that facts from earlier elements are available.
ballarin
parents:
29215
diff
changeset

426 
val (elems', _) = activate elems (ProofContext.set_stmt true context'); 
29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

427 
in ((fixed, deps, elems'), (parms, ctxt')) end; 
28795  428 

429 
in 

430 

28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

431 
fun read_declaration x = prep_declaration read_full_context_statement Element.activate x; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

432 
fun cert_declaration x = prep_declaration cert_full_context_statement Element.activate_i x; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

433 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

434 
end; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

435 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

436 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

437 
(* Locale expression to set up a goal *) 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

438 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

439 
local 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

440 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

441 
fun props_of thy (name, morph) = 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

442 
let 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

443 
val (asm, defs) = NewLocale.specification_of thy name; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

444 
in 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

445 
(case asm of NONE => defs  SOME asm => asm :: defs) > map (Morphism.term morph) 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

446 
end; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

447 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

448 
fun prep_goal_expression prep expression context = 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

449 
let 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

450 
val thy = ProofContext.theory_of context; 
28879  451 

28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

452 
val ((fixed, deps, _, _), _) = prep true true context expression [] []; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

453 
(* proof obligations *) 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

454 
val propss = map (props_of thy) deps; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

455 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

456 
val goal_ctxt = context > 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

457 
ProofContext.add_fixes_i fixed > snd > 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

458 
(fold o fold) Variable.auto_fixes propss; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

459 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

460 
val export = Variable.export_morphism goal_ctxt context; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

461 
val exp_fact = Drule.zero_var_indexes_list o map Thm.strip_shyps o Morphism.fact export; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

462 
val exp_term = Drule.term_rule thy (singleton exp_fact); 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

463 
val exp_typ = Logic.type_map exp_term; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

464 
val export' = 
28965  465 
Morphism.morphism {binding = I, var = I, typ = exp_typ, term = exp_term, fact = exp_fact}; 
28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

466 
in ((propss, deps, export'), goal_ctxt) end; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

467 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

468 
in 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

469 

530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

470 
fun read_goal_expression x = prep_goal_expression read_full_context_statement x; 
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

471 
fun cert_goal_expression x = prep_goal_expression cert_full_context_statement x; 
28879  472 

28795  473 
end; 
474 

475 

476 
(*** Locale declarations ***) 

477 

29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

478 
(* extract specification text *) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

479 

918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

480 
val norm_term = Envir.beta_norm oo Term.subst_atomic; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

481 

918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

482 
fun bind_def ctxt eq (xs, env, eqs) = 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

483 
let 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

484 
val _ = LocalDefs.cert_def ctxt eq; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

485 
val ((y, T), b) = LocalDefs.abs_def eq; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

486 
val b' = norm_term env b; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

487 
fun err msg = error (msg ^ ": " ^ quote y); 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

488 
in 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

489 
exists (fn (x, _) => x = y) xs andalso 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

490 
err "Attempt to define previously specified variable"; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

491 
exists (fn (Free (y', _), _) => y = y'  _ => false) env andalso 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

492 
err "Attempt to redefine variable"; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

493 
(Term.add_frees b' xs, (Free (y, T), b') :: env, eq :: eqs) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

494 
end; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

495 

918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

496 
(* text has the following structure: 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

497 
(((exts, exts'), (ints, ints')), (xs, env, defs)) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

498 
where 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

499 
exts: external assumptions (terms in assumes elements) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

500 
exts': dito, normalised wrt. env 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

501 
ints: internal assumptions (terms in assumptions from insts) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

502 
ints': dito, normalised wrt. env 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

503 
xs: the free variables in exts' and ints' and rhss of definitions, 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

504 
this includes parameters except defined parameters 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

505 
env: list of term pairs encoding substitutions, where the first term 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

506 
is a free variable; substitutions represent defines elements and 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

507 
the rhs is normalised wrt. the previous env 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

508 
defs: the equations from the defines elements 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

509 
*) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

510 

918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

511 
fun eval_text _ _ (Fixes _) text = text 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

512 
 eval_text _ _ (Constrains _) text = text 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

513 
 eval_text _ is_ext (Assumes asms) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

514 
(((exts, exts'), (ints, ints')), (xs, env, defs)) = 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

515 
let 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

516 
val ts = maps (map #1 o #2) asms; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

517 
val ts' = map (norm_term env) ts; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

518 
val spec' = 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

519 
if is_ext then ((exts @ ts, exts' @ ts'), (ints, ints')) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

520 
else ((exts, exts'), (ints @ ts, ints' @ ts')); 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

521 
in (spec', (fold Term.add_frees ts' xs, env, defs)) end 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

522 
 eval_text ctxt _ (Defines defs) (spec, binds) = 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

523 
(spec, fold (bind_def ctxt o #1 o #2) defs binds) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

524 
 eval_text _ _ (Notes _) text = text; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

525 

918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

526 
fun eval_inst ctxt (loc, morph) text = 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

527 
let 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

528 
val thy = ProofContext.theory_of ctxt; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

529 
val (asm, defs) = NewLocale.specification_of thy loc; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

530 
val asm' = Option.map (Morphism.term morph) asm; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

531 
val defs' = map (Morphism.term morph) defs; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

532 
val text' = text > 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

533 
(if is_some asm 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

534 
then eval_text ctxt false (Assumes [(Attrib.empty_binding, [(the asm', [])])]) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

535 
else I) > 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

536 
(if not (null defs) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

537 
then eval_text ctxt false (Defines (map (fn def => (Attrib.empty_binding, (def, []))) defs')) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

538 
else I) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

539 
(* FIXME clone from new_locale.ML *) 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

540 
in text' end; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

541 

918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

542 
fun eval_elem ctxt elem text = 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

543 
let 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

544 
val text' = eval_text ctxt true elem text; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

545 
in text' end; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

546 

918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

547 
fun eval ctxt deps elems = 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

548 
let 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

549 
val text' = fold (eval_inst ctxt) deps ((([], []), ([], [])), ([], [], [])); 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

550 
val ((spec, (_, _, defs))) = fold (eval_elem ctxt) elems text'; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

551 
in (spec, defs) end; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

552 

28903
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

553 
(* axiomsN: name of theorem set with destruct rules for locale predicates, 
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

554 
also name suffix of delta predicates and assumptions. *) 
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

555 

b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

556 
val axiomsN = "axioms"; 
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

557 

28795  558 
local 
559 

560 
(* introN: name of theorems for introduction rules of locale and 

28903
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

561 
delta predicates *) 
28795  562 

563 
val introN = "intro"; 

564 

565 
fun atomize_spec thy ts = 

566 
let 

567 
val t = Logic.mk_conjunction_balanced ts; 

568 
val body = ObjectLogic.atomize_term thy t; 

569 
val bodyT = Term.fastype_of body; 

570 
in 

571 
if bodyT = propT then (t, propT, Thm.reflexive (Thm.cterm_of thy t)) 

572 
else (body, bodyT, ObjectLogic.atomize (Thm.cterm_of thy t)) 

573 
end; 

574 

575 
(* achieve plain syntax for locale predicates (without "PROP") *) 

576 

577 
fun aprop_tr' n c = (Syntax.constN ^ c, fn ctxt => fn args => 

578 
if length args = n then 

579 
Syntax.const "_aprop" $ 

580 
Term.list_comb (Syntax.free (Consts.extern (ProofContext.consts_of ctxt) c), args) 

581 
else raise Match); 

582 

28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

583 
(* define one predicate including its intro rule and axioms 
28795  584 
 bname: predicate name 
585 
 parms: locale parameters 

586 
 defs: thms representing substitutions from defines elements 

587 
 ts: terms representing locale assumptions (not normalised wrt. defs) 

588 
 norm_ts: terms representing locale assumptions (normalised wrt. defs) 

589 
 thy: the theory 

590 
*) 

591 

592 
fun def_pred bname parms defs ts norm_ts thy = 

593 
let 

28965  594 
val name = Sign.full_bname thy bname; 
28795  595 

596 
val (body, bodyT, body_eq) = atomize_spec thy norm_ts; 

597 
val env = Term.add_term_free_names (body, []); 

598 
val xs = filter (member (op =) env o #1) parms; 

599 
val Ts = map #2 xs; 

600 
val extraTs = (Term.term_tfrees body \\ fold Term.add_tfreesT Ts []) 

601 
> Library.sort_wrt #1 > map TFree; 

602 
val predT = map Term.itselfT extraTs > Ts > bodyT; 

603 

604 
val args = map Logic.mk_type extraTs @ map Free xs; 

605 
val head = Term.list_comb (Const (name, predT), args); 

606 
val statement = ObjectLogic.ensure_propT thy head; 

607 

608 
val ([pred_def], defs_thy) = 

609 
thy 

610 
> bodyT = propT ? Sign.add_advanced_trfuns ([], [], [aprop_tr' (length args) name], []) 

28965  611 
> Sign.declare_const [] ((Binding.name bname, predT), NoSyn) > snd 
28795  612 
> PureThy.add_defs false 
613 
[((Thm.def_name bname, Logic.mk_equals (head, body)), [Thm.kind_internal])]; 

614 
val defs_ctxt = ProofContext.init defs_thy > Variable.declare_term head; 

615 

616 
val cert = Thm.cterm_of defs_thy; 

617 

618 
val intro = Goal.prove_global defs_thy [] norm_ts statement (fn _ => 

619 
MetaSimplifier.rewrite_goals_tac [pred_def] THEN 

620 
Tactic.compose_tac (false, body_eq RS Drule.equal_elim_rule1, 1) 1 THEN 

621 
Tactic.compose_tac (false, 

622 
Conjunction.intr_balanced (map (Thm.assume o cert) norm_ts), 0) 1); 

623 

624 
val conjuncts = 

625 
(Drule.equal_elim_rule2 OF [body_eq, 

626 
MetaSimplifier.rewrite_rule [pred_def] (Thm.assume (cert statement))]) 

627 
> Conjunction.elim_balanced (length ts); 

628 
val axioms = ts ~~ conjuncts > map (fn (t, ax) => 

629 
Element.prove_witness defs_ctxt t 

630 
(MetaSimplifier.rewrite_goals_tac defs THEN 

631 
Tactic.compose_tac (false, ax, 0) 1)); 

632 
in ((statement, intro, axioms), defs_thy) end; 

633 

634 
in 

635 

636 
(* CB: main predicate definition function *) 

637 

29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

638 
fun define_preds pname parms (((exts, exts'), (ints, ints')), defs) thy = 
28795  639 
let 
29031
e74341997a48
Pass on defines in inheritance; reject illicit defines created by instantiation.
ballarin
parents:
29030
diff
changeset

640 
val defs' = map (cterm_of thy #> Assumption.assume #> Drule.gen_all #> Drule.abs_def) defs; 
e74341997a48
Pass on defines in inheritance; reject illicit defines created by instantiation.
ballarin
parents:
29030
diff
changeset

641 

28795  642 
val (a_pred, a_intro, a_axioms, thy'') = 
643 
if null exts then (NONE, NONE, [], thy) 

644 
else 

645 
let 

646 
val aname = if null ints then pname else pname ^ "_" ^ axiomsN; 

647 
val ((statement, intro, axioms), thy') = 

648 
thy 

29031
e74341997a48
Pass on defines in inheritance; reject illicit defines created by instantiation.
ballarin
parents:
29030
diff
changeset

649 
> def_pred aname parms defs' exts exts'; 
28795  650 
val (_, thy'') = 
651 
thy' 

652 
> Sign.add_path aname 

653 
> Sign.no_base_names 

28903
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

654 
> PureThy.note_thmss Thm.internalK 
28965  655 
[((Binding.name introN, []), [([intro], [NewLocale.unfold_attrib])])] 
28795  656 
> Sign.restore_naming thy'; 
657 
in (SOME statement, SOME intro, axioms, thy'') end; 

658 
val (b_pred, b_intro, b_axioms, thy'''') = 

659 
if null ints then (NONE, NONE, [], thy'') 

660 
else 

661 
let 

662 
val ((statement, intro, axioms), thy''') = 

663 
thy'' 

29031
e74341997a48
Pass on defines in inheritance; reject illicit defines created by instantiation.
ballarin
parents:
29030
diff
changeset

664 
> def_pred pname parms defs' (ints @ the_list a_pred) (ints' @ the_list a_pred); 
28795  665 
val (_, thy'''') = 
666 
thy''' 

667 
> Sign.add_path pname 

668 
> Sign.no_base_names 

669 
> PureThy.note_thmss Thm.internalK 

28965  670 
[((Binding.name introN, []), [([intro], [NewLocale.intro_attrib])]), 
671 
((Binding.name axiomsN, []), 

28795  672 
[(map (Drule.standard o Element.conclude_witness) axioms, [])])] 
673 
> Sign.restore_naming thy'''; 

674 
in (SOME statement, SOME intro, axioms, thy'''') end; 

675 
in ((a_pred, a_intro, a_axioms), (b_pred, b_intro, b_axioms), thy'''') end; 

676 

677 
end; 

678 

679 

680 
local 

681 

682 
fun assumes_to_notes (Assumes asms) axms = 

683 
fold_map (fn (a, spec) => fn axs => 

684 
let val (ps, qs) = chop (length spec) axs 

685 
in ((a, [(ps, [])]), qs) end) asms axms 

686 
> apfst (curry Notes Thm.assumptionK) 

687 
 assumes_to_notes e axms = (e, axms); 

688 

29031
e74341997a48
Pass on defines in inheritance; reject illicit defines created by instantiation.
ballarin
parents:
29030
diff
changeset

689 
fun defines_to_notes thy (Defines defs) = 
e74341997a48
Pass on defines in inheritance; reject illicit defines created by instantiation.
ballarin
parents:
29030
diff
changeset

690 
Notes (Thm.definitionK, map (fn (a, (def, _)) => 
e74341997a48
Pass on defines in inheritance; reject illicit defines created by instantiation.
ballarin
parents:
29030
diff
changeset

691 
(a, [([Assumption.assume (cterm_of thy def)], [])])) defs) 
e74341997a48
Pass on defines in inheritance; reject illicit defines created by instantiation.
ballarin
parents:
29030
diff
changeset

692 
 defines_to_notes _ e = e; 
28795  693 

28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

694 
fun gen_add_locale prep_decl 
28795  695 
bname predicate_name raw_imprt raw_body thy = 
696 
let 

28965  697 
val name = Sign.full_bname thy bname; 
28795  698 
val _ = NewLocale.test_locale thy name andalso 
699 
error ("Duplicate definition of locale " ^ quote name); 

700 

29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

701 
val ((fixed, deps, body_elems), (parms, ctxt')) = 
29021
ce100fbc3c8e
Proper shape of assumptions generated from Defines elements.
ballarin
parents:
29020
diff
changeset

702 
prep_decl raw_imprt raw_body (ProofContext.init thy); 
29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

703 
val text as (((_, exts'), _), defs) = eval ctxt' deps body_elems; 
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

704 

28872  705 
val ((a_statement, a_intro, a_axioms), (b_statement, b_intro, b_axioms), thy') = 
29221
918687637307
Refactored: evaluate specification text only in locale declarations.
ballarin
parents:
29217
diff
changeset

706 
define_preds predicate_name parms text thy; 
28795  707 

708 
val extraTs = fold Term.add_tfrees exts' [] \\ fold Term.add_tfreesT (map snd parms) []; 

709 
val _ = if null extraTs then () 

710 
else warning ("Additional type variable(s) in locale specification " ^ quote bname); 

711 

29035  712 
val a_satisfy = Element.satisfy_morphism a_axioms; 
713 
val b_satisfy = Element.satisfy_morphism b_axioms; 

28903
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

714 

28895  715 
val params = fixed @ 
28872  716 
(body_elems > map_filter (fn Fixes fixes => SOME fixes  _ => NONE) > flat); 
28903
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

717 
val asm = if is_some b_statement then b_statement else a_statement; 
29028
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

718 

29035  719 
(* These are added immediately. *) 
29028
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

720 
val notes = 
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

721 
if is_some asm 
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

722 
then [(Thm.internalK, [((Binding.name (bname ^ "_" ^ axiomsN), []), 
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

723 
[([Assumption.assume (cterm_of thy' (the asm))], 
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

724 
[(Attrib.internal o K) NewLocale.witness_attrib])])])] 
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

725 
else []; 
28795  726 

29035  727 
(* These will be added in the local theory. *) 
728 
val notes' = body_elems > 

729 
map (defines_to_notes thy') > 

730 
map (Element.morph_ctxt a_satisfy) > 

731 
(fn elems => fold_map assumes_to_notes elems (map Element.conclude_witness a_axioms)) > 

732 
fst > 

733 
map (Element.morph_ctxt b_satisfy) > 

734 
map_filter (fn Notes notes => SOME notes  _ => NONE); 

735 

736 
val deps' = map (fn (l, morph) => (l, morph $> b_satisfy)) deps; 

28872  737 

28795  738 
val loc_ctxt = thy' > 
28991  739 
NewLocale.register_locale bname (extraTs, params) 
29032  740 
(asm, rev defs) ([], []) 
28872  741 
(map (fn n => (n, stamp ())) notes > rev) (map (fn d => (d, stamp ())) deps' > rev) > 
29028
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

742 
NewLocale.init name; 
b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

743 

b5dad96c755a
When adding locales, delay notes until local theory is built.
ballarin
parents:
29022
diff
changeset

744 
in ((name, notes'), loc_ctxt) end; 
28795  745 

746 
in 

747 

28902
2019bcc9d8bf
Ahere to modern naming conventions; proper treatment of internal vs external names.
ballarin
parents:
28898
diff
changeset

748 
val add_locale_cmd = gen_add_locale read_declaration; 
2019bcc9d8bf
Ahere to modern naming conventions; proper treatment of internal vs external names.
ballarin
parents:
28898
diff
changeset

749 
val add_locale = gen_add_locale cert_declaration; 
28795  750 

751 
end; 

752 

28895  753 

754 
(*** Interpretation ***) 

755 

756 
(** Witnesses and goals **) 

757 

758 
fun prep_propp propss = propss > map (map (rpair [] o Element.mark_witness)); 

759 

760 
fun prep_result propps thmss = 

761 
ListPair.map (fn (props, thms) => map2 Element.make_witness props thms) (propps, thmss); 

762 

763 

764 
(** Interpretation between locales: declaring sublocale relationships **) 

765 

766 
local 

767 

28902
2019bcc9d8bf
Ahere to modern naming conventions; proper treatment of internal vs external names.
ballarin
parents:
28898
diff
changeset

768 
fun gen_sublocale prep_expr intern 
28951
e89dde5f365c
Sublocale: removed public after_qed; identifiers private to NewLocale.
ballarin
parents:
28936
diff
changeset

769 
raw_target expression thy = 
28895  770 
let 
28902
2019bcc9d8bf
Ahere to modern naming conventions; proper treatment of internal vs external names.
ballarin
parents:
28898
diff
changeset

771 
val target = intern thy raw_target; 
28895  772 
val target_ctxt = NewLocale.init target thy; 
773 

28903
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

774 
val ((propss, deps, export), goal_ctxt) = prep_expr expression target_ctxt; 
28898
530c7d28a962
Proper treatment of expressions with free arguments.
ballarin
parents:
28895
diff
changeset

775 

28902
2019bcc9d8bf
Ahere to modern naming conventions; proper treatment of internal vs external names.
ballarin
parents:
28898
diff
changeset

776 
fun store_dep ((name, morph), thms) = 
28903
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

777 
NewLocale.add_dependency target (name, morph $> Element.satisfy_morphism thms $> export); 
28895  778 

28993
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

779 
fun after_qed results = 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

780 
ProofContext.theory ( 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

781 
(* store dependencies *) 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

782 
fold store_dep (deps ~~ prep_result propss results) #> 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

783 
(* propagate registrations *) 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

784 
(fn thy => fold_rev (fn reg => NewLocale.activate_global_facts reg) 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

785 
(NewLocale.get_global_registrations thy) thy)); 
28895  786 
in 
787 
goal_ctxt > 

28951
e89dde5f365c
Sublocale: removed public after_qed; identifiers private to NewLocale.
ballarin
parents:
28936
diff
changeset

788 
Proof.theorem_i NONE after_qed (prep_propp propss) > 
28895  789 
Element.refine_witness > Seq.hd 
790 
end; 

791 

792 
in 

793 

28902
2019bcc9d8bf
Ahere to modern naming conventions; proper treatment of internal vs external names.
ballarin
parents:
28898
diff
changeset

794 
fun sublocale_cmd x = gen_sublocale read_goal_expression NewLocale.intern x; 
2019bcc9d8bf
Ahere to modern naming conventions; proper treatment of internal vs external names.
ballarin
parents:
28898
diff
changeset

795 
fun sublocale x = gen_sublocale cert_goal_expression (K I) x; 
28895  796 

28795  797 
end; 
28895  798 

29018  799 

28993
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

800 
(** Interpretation in theories **) 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

801 

829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

802 
local 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

803 

29211  804 
datatype goal = Reg of string * Morphism.morphism  Eqns of Attrib.binding list; 
805 

806 
fun gen_interpretation prep_expr parse_prop prep_attr 

29210
4025459e3f83
Interpretation in theories: first version with equations.
ballarin
parents:
29208
diff
changeset

807 
expression equations thy = 
28993
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

808 
let 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

809 
val ctxt = ProofContext.init thy; 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

810 

29211  811 
val ((propss, regs, export), expr_ctxt) = prep_expr expression ctxt; 
812 

813 
val eqns = map (parse_prop expr_ctxt o snd) equations > Syntax.check_terms expr_ctxt; 

814 
val eq_attns = map ((apsnd o map) (prep_attr thy) o fst) equations; 

815 
val goal_ctxt = fold Variable.auto_fixes eqns expr_ctxt; 

816 
val export' = Variable.export_morphism goal_ctxt expr_ctxt; 

29210
4025459e3f83
Interpretation in theories: first version with equations.
ballarin
parents:
29208
diff
changeset

817 

29211  818 
fun store (Reg (name, morph), thms) (regs, thy) = 
819 
let 

820 
val thms' = map (Element.morph_witness export') thms; 

821 
val morph' = morph $> Element.satisfy_morphism thms'; 

822 
val add = NewLocale.add_global_registration (name, (morph', export)); 

823 
in ((name, morph') :: regs, add thy) end 

824 
 store (Eqns [], []) (regs, thy) = 

825 
let val add = fold_rev (fn (name, morph) => 

826 
NewLocale.activate_global_facts (name, morph $> export)) regs; 

827 
in (regs, add thy) end 

828 
 store (Eqns attns, thms) (regs, thy) = 

829 
let 

830 
val thms' = thms > map (Element.conclude_witness #> 

831 
Morphism.thm (export' $> export) #> 

832 
LocalDefs.meta_rewrite_rule (ProofContext.init thy) #> 

833 
Drule.abs_def); 

834 
val eq_morph = 

835 
Morphism.term_morphism (MetaSimplifier.rewrite_term thy thms' []) $> 

836 
Morphism.thm_morphism (MetaSimplifier.rewrite_rule thms'); 

837 
val attns' = map ((apsnd o map) (Attrib.attribute_i thy)) attns; 

838 
val add = 

839 
fold_rev (fn (name, morph) => 

840 
NewLocale.amend_global_registration eq_morph (name, morph) #> 

841 
NewLocale.activate_global_facts (name, morph $> eq_morph $> export)) regs #> 

842 
PureThy.note_thmss Thm.lemmaK (attns' ~~ map (fn th => [([th], [])]) thms') #> 

843 
snd 

844 
in (regs, add thy) end; 

28993
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

845 

829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

846 
fun after_qed results = 
29211  847 
ProofContext.theory (fn thy => 
848 
fold store (map Reg regs @ [Eqns eq_attns] ~~ 

849 
prep_result (propss @ [eqns]) results) ([], thy) > snd); 

28993
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

850 
in 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

851 
goal_ctxt > 
29211  852 
Proof.theorem_i NONE after_qed (prep_propp (propss @ [eqns])) > 
28993
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

853 
Element.refine_witness > Seq.hd 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

854 
end; 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

855 

829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

856 
in 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

857 

29210
4025459e3f83
Interpretation in theories: first version with equations.
ballarin
parents:
29208
diff
changeset

858 
fun interpretation_cmd x = gen_interpretation read_goal_expression 
29211  859 
Syntax.parse_prop Attrib.intern_src x; 
860 
fun interpretation x = gen_interpretation cert_goal_expression (K I) (K I) x; 

28895  861 

862 
end; 

28903
b3fc3a62247a
Intro_locales_tac to simplify goals involving locale predicates.
ballarin
parents:
28902
diff
changeset

863 

29018  864 

865 
(** Interpretation in proof contexts **) 

866 

867 
local 

868 

869 
fun gen_interpret prep_expr 

870 
expression int state = 

871 
let 

872 
val _ = Proof.assert_forward_or_chain state; 

873 
val ctxt = Proof.context_of state; 

874 

875 
val ((propss, regs, export), goal_ctxt) = prep_expr expression ctxt; 

876 

877 
fun store_reg ((name, morph), thms) = 

878 
let 

879 
val morph' = morph $> Element.satisfy_morphism thms $> export; 

880 
in 

881 
NewLocale.activate_local_facts (name, morph') 

882 
end; 

883 

884 
fun after_qed results = 

885 
Proof.map_context (fold store_reg (regs ~~ prep_result propss results)) #> Seq.single; 

886 
in 

887 
state > Proof.map_context (K goal_ctxt) > 

888 
Proof.local_goal (ProofDisplay.print_results int) (K I) ProofContext.bind_propp_i 

889 
"interpret" NONE after_qed (map (pair (Binding.empty, [])) (prep_propp propss)) > 

890 
Element.refine_witness > Seq.hd 

891 
end; 

892 

893 
in 

894 

895 
fun interpret_cmd x = gen_interpret read_goal_expression x; 

896 
fun interpret x = gen_interpret cert_goal_expression x; 

897 

28993
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

898 
end; 
829e684b02ef
Interpretation in theories including interaction with subclass relation.
ballarin
parents:
28951
diff
changeset

899 

29018  900 
end; 
901 