author  ballarin 
Tue, 25 Nov 2008 18:06:21 +0100  
changeset 28885  6f6bf52e75bb 
parent 28879  db2816a37a34 
child 28895  4e2914c2f8c5 
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 
ID: $Id$ 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

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

4 

28795  5 
New locale development  experimental. 
28697
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 

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

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

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

10 
datatype 'term map = Positional of 'term option list  Named of (string * 'term) list; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

11 
type 'term expr = (string * (string * 'term map)) list; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

12 
type expression = string expr * (Name.binding * string option * mixfix) list; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

13 
type expression_i = term expr * (Name.binding * typ option * mixfix) list; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

14 

28879  15 
(* Processing of locale statements *) 
16 
val read_statement: Element.context list > (string * string list) list list > 

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

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

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

20 

28795  21 
(* Declaring locales *) 
22 
val add_locale: string > bstring > expression > Element.context list > theory > 

23 
string * Proof.context 

24 
val add_locale_i: string > bstring > expression_i > Element.context_i list > theory > 

25 
string * Proof.context 

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

26 

28795  27 
(* Debugging and development *) 
28 
val parse_expression: OuterParse.token list > expression * OuterParse.token list 

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

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

30 

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

31 

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

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

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

34 

28795  35 
datatype ctxt = datatype Element.ctxt; 
36 

37 

38 
(*** Expressions ***) 

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

39 

28872  40 
datatype 'term map = 
41 
Positional of 'term option list  

42 
Named of (string * 'term) list; 

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

43 

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

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

45 

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

46 
type expression = string expr * (Name.binding * string option * mixfix) list; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

47 
type expression_i = term expr * (Name.binding * typ option * mixfix) list; 
28795  48 

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

49 

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

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

51 

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

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

53 

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

54 
structure P = OuterParse; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

55 

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

56 
val loc_keyword = P.$$$ "fixes"  P.$$$ "constrains"  P.$$$ "assumes"  
28795  57 
P.$$$ "defines"  P.$$$ "notes"; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

58 
fun plus1_unless test scan = 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

59 
scan ::: Scan.repeat (P.$$$ "+"  Scan.unless test (P.!!! scan)); 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

60 

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

61 
val prefix = P.name  P.$$$ ":"; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

62 
val named = P.name  (P.$$$ "="  P.term); 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

63 
val position = P.maybe P.term; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

64 
val instance = P.$$$ "where"  P.and_list1 named >> Named  
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

65 
Scan.repeat1 position >> Positional; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

66 

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

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

68 

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

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

71 
fun expr2 x = P.xname x; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

72 
fun expr1 x = (Scan.optional prefix ""  expr2  
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

73 
Scan.optional instance (Named []) >> (fn ((p, l), i) => (l, (p, i)))) x; 
28885
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

74 
fun expr0 x = (plus1_unless loc_keyword expr1) x; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

75 
in expr0  P.for_fixes end; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

76 

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

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

78 

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

79 
fun pretty_expr thy expr = 
28795  80 
let 
81 
fun pretty_pos NONE = Pretty.str "_" 

82 
 pretty_pos (SOME x) = Pretty.str x; 

83 
fun pretty_named (x, y) = [Pretty.str x, Pretty.brk 1, Pretty.str "=", 

84 
Pretty.brk 1, Pretty.str y] > Pretty.block; 

85 
fun pretty_ren (Positional ps) = take_suffix is_none ps > snd > 

86 
map pretty_pos > Pretty.breaks 

87 
 pretty_ren (Named []) = [] 

88 
 pretty_ren (Named ps) = Pretty.str "where" :: Pretty.brk 1 :: 

89 
(ps > map pretty_named > Pretty.separate "and"); 

90 
fun pretty_rename (loc, ("", ren)) = 

91 
Pretty.block (Pretty.str (NewLocale.extern thy loc) :: Pretty.brk 1 :: pretty_ren ren) 

92 
 pretty_rename (loc, (prfx, ren)) = 

93 
Pretty.block (Pretty.str prfx :: Pretty.brk 1 :: Pretty.str (NewLocale.extern thy loc) :: 

94 
Pretty.brk 1 :: pretty_ren ren); 

95 
in Pretty.separate "+" (map pretty_rename expr) > Pretty.block end; 

96 

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

97 
fun err_in_expr thy msg expr = 
28795  98 
let 
99 
val err_msg = 

100 
if null expr then msg 

101 
else msg ^ "\n" ^ Pretty.string_of (Pretty.block 

102 
[Pretty.str "The above error(s) occurred in expression:", Pretty.brk 1, 

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

103 
pretty_expr thy expr]) 
28795  104 
in error err_msg end; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

105 

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

106 

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

108 

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

109 
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

110 

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

111 

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

113 
Sanity check of instantiations. 
28795  114 
Positional instantiations are extended to match full length of parameter list. **) 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

115 

28859  116 
fun parameters_of thy (expr, fixed) = 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

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

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

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

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

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

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

123 

28795  124 
fun match_bind (n, b) = (n = Name.name_of b); 
125 
fun bind_eq (b1, b2) = (Name.name_of b1 = Name.name_of b2); 

126 
(* FIXME: cannot compare bindings for equality. *) 

127 

128 
fun params_loc loc = 

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

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

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

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

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

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

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

139 
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

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

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

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

145 

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

147 
val ps' = fold (fn (p, _) => fn ps => 
28795  148 
if AList.defined match_bind ps p then AList.delete match_bind p ps 
28859  149 
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

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

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

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

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

154 
let 
28795  155 
val (ps', i') = params_inst i; 
156 
val ps'' = AList.join bind_eq (fn p => fn (mx1, mx2) => 

157 
(* FIXME: should check for bindings being the same. 

158 
Instead we check for equal name and syntax. *) 

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

159 
if mx1 = mx2 then mx1 
28862  160 
else error ("Conflicting syntax for parameter" ^ quote (Name.display p) ^ 
28859  161 
" in expression.")) (ps, ps') 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

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

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

164 

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

166 

28859  167 
val parms' = map (#1 #> Name.name_of) parms; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

168 
val fixed' = map (#1 #> Name.name_of) fixed; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

169 
val _ = reject_dups "Duplicate fixed parameter(s): " fixed'; 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

170 
val _ = reject_dups "Parameter(s) declared simultaneously in expression and for clause: " (parms' @ fixed'); 
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

171 

28859  172 
in (expr', (map (fn (b, mx) => (b, NONE, mx)) parms @ fixed)) end; 
28697
140bfb63f893
Newstyle locale expressions with instantiation (new file expression.ML).
ballarin
parents:
diff
changeset

173 

28795  174 

175 
(** Read instantiation **) 

176 

28872  177 
(* Parse positional or named instantiation *) 
178 

28859  179 
local 
180 

28872  181 
fun prep_inst parse_term parms (Positional insts) ctxt = 
182 
(insts ~~ parms) > map (fn 

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

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

185 
 prep_inst parse_term parms (Named insts) ctxt = 

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

187 
SOME t => parse_term ctxt t  

188 
NONE => Syntax.parse_term ctxt p); 

189 

190 
in 

191 

192 
fun parse_inst x = prep_inst Syntax.parse_term x; 

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

194 

195 
end; 

196 

197 

198 
(* Instantiation morphism *) 

199 

200 
fun inst_morph (parm_names, parm_types) (prfx, insts') ctxt = 

28795  201 
let 
202 
(* parameters *) 

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

204 

205 
(* type inference and contexts *) 

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

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

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

209 
val res = Syntax.check_terms ctxt arg; 

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

28872  211 

28795  212 
(* instantiation *) 
213 
val (type_parms'', res') = chop (length type_parms) res; 

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

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

216 
inst => SOME inst); 

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

218 
val inst = Symtab.make insts''; 

219 
in 

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

221 
Morphism.name_morphism (Name.qualified prfx), ctxt') 

222 
end; 

28859  223 

28795  224 

225 
(*** Locale processing ***) 

226 

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

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

228 

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

229 
fun parse_elem prep_typ prep_term ctxt elem = 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

230 
Element.map_ctxt {name = I, var = I, typ = prep_typ ctxt, 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

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

232 

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

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

234 
(map o map) (fn (t, ps) => 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

235 
(prep_term ctxt, map (prep_term ctxt) ps)) concl; 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

236 

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

237 

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

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

239 

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

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

241 

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

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

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

244 
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

245 

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

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

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

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

249 

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

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

251 
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

252 

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

253 
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

254 
 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

255 
 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

256 
 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

257 
 extract_elem (Notes _) = []; 
28795  258 

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

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

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

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

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

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

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

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

266 
(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

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

268 
(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

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

270 

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

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

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

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

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

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

276 
((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

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

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

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

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

281 
(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

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

283 

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

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

285 

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

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

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

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

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

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

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

293 
(fold_burrow o fold_burrow) check (inst_cs :: elem_css @ [concl_cs]) ctxt; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

294 
(* Recheck to resolve bindings, elements and conclusion only *) 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

295 
val (css'', _) = (fold_burrow o fold_burrow) check css' ctxt'; 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

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

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

298 
(map restore_inst (insts ~~ inst_cs'), map restore_elem (elems ~~ elem_css''), 
6f6bf52e75bb
Expression types cleaned up, proper treatment of term patterns.
ballarin
parents:
28879
diff
changeset

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

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

301 

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

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

303 

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

304 

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

305 
(** Prepare locale elements **) 
28795  306 

307 
fun declare_elem prep_vars (Fixes fixes) ctxt = 

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

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

309 
in ctxt > ProofContext.add_fixes_i vars > snd end 
28795  310 
 declare_elem prep_vars (Constrains csts) ctxt = 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

311 
ctxt > prep_vars (map (fn (x, T) => (Name.binding x, SOME T, NoSyn)) csts) > snd 
28872  312 
 declare_elem _ (Assumes _) ctxt = ctxt 
313 
 declare_elem _ (Defines _) ctxt = ctxt 

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

314 
 declare_elem _ (Notes _) ctxt = ctxt; 
28795  315 

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

316 
(** Finish locale elements, extract specification text **) 
28795  317 

318 
val norm_term = Envir.beta_norm oo Term.subst_atomic; 

319 

320 
fun abstract_thm thy eq = 

321 
Thm.assume (Thm.cterm_of thy eq) > Drule.gen_all > Drule.abs_def; 

322 

323 
fun bind_def ctxt eq (xs, env, ths) = 

324 
let 

325 
val ((y, T), b) = LocalDefs.abs_def eq; 

326 
val b' = norm_term env b; 

327 
val th = abstract_thm (ProofContext.theory_of ctxt) eq; 

328 
fun err msg = error (msg ^ ": " ^ quote y); 

329 
in 

330 
exists (fn (x, _) => x = y) xs andalso 

331 
err "Attempt to define previously specified variable"; 

332 
exists (fn (Free (y', _), _) => y = y'  _ => false) env andalso 

333 
err "Attempt to redefine variable"; 

334 
(Term.add_frees b' xs, (Free (y, T), b') :: env, th :: ths) 

335 
end; 

336 

28872  337 
fun eval_text _ _ (Fixes _) text = text 
338 
 eval_text _ _ (Constrains _) text = text 

339 
 eval_text _ is_ext (Assumes asms) 

28795  340 
(((exts, exts'), (ints, ints')), (xs, env, defs)) = 
341 
let 

342 
val ts = maps (map #1 o #2) asms; 

343 
val ts' = map (norm_term env) ts; 

28872  344 
val spec' = 
345 
if is_ext then ((exts @ ts, exts' @ ts'), (ints, ints')) 

346 
else ((exts, exts'), (ints @ ts, ints' @ ts')); 

28795  347 
in (spec', (fold Term.add_frees ts' xs, env, defs)) end 
28872  348 
 eval_text ctxt _ (Defines defs) (spec, binds) = 
28795  349 
(spec, fold (bind_def ctxt o #1 o #2) defs binds) 
28872  350 
 eval_text _ _ (Notes _) text = text; 
28795  351 

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

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

353 
 closeup ctxt parms true elem = 
28795  354 
let 
355 
fun close_frees t = 

356 
let 

357 
val rev_frees = 

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

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

359 
if AList.defined (op =) parms x then I else insert (op =) (x, T)  _ => I) t []; 
28795  360 
in Term.list_all_free (rev rev_frees, t) end; 
361 

362 
fun no_binds [] = [] 

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

363 
 no_binds _ = error "Illegal term bindings in context element"; 
28795  364 
in 
365 
(case elem of 

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

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

368 
 Defines defs => Defines (defs > map (fn (a, (t, ps)) => 

369 
(a, (close_frees (#2 (LocalDefs.cert_def ctxt t)), no_binds ps)))) 

370 
 e => e) 

371 
end; 

372 

28872  373 
fun finish_primitive parms _ (Fixes fixes) = Fixes (map (fn (binding, _, mx) => 
28795  374 
let val x = Name.name_of binding 
375 
in (binding, AList.lookup (op =) parms x, mx) end) fixes) 

28872  376 
 finish_primitive _ _ (Constrains _) = Constrains [] 
377 
 finish_primitive _ close (Assumes asms) = close (Assumes asms) 

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

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

380 

381 
fun finish_inst ctxt parms do_close (loc, (prfx, inst)) text = 

382 
let 

383 
val thy = ProofContext.theory_of ctxt; 

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

385 
map (fn (b, SOME T, _) => (Name.name_of b, T)) > split_list; 

386 
val (asm, defs) = NewLocale.specification_of thy loc; 

387 
val (morph, _) = inst_morph (parm_names, parm_types) (prfx, inst) ctxt; 

388 
val asm' = Option.map (Morphism.term morph) asm; 

389 
val defs' = map (Morphism.term morph) defs; 

390 
val text' = text > 

391 
(if is_some asm 

392 
then eval_text ctxt false (Assumes [(Attrib.no_binding, [(the asm', [])])]) 

393 
else I) > 

394 
(if not (null defs) 

395 
then eval_text ctxt false (Defines (map (fn def => (Attrib.no_binding, (def, []))) defs')) 

396 
else I) 

397 
(* FIXME clone from new_locale.ML *) 

398 
in ((loc, morph), text') end; 

28795  399 

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

400 
fun finish_elem ctxt parms do_close elem text = 
28795  401 
let 
28872  402 
val elem' = finish_primitive parms (closeup ctxt parms do_close) elem; 
403 
val text' = eval_text ctxt true elem' text; 

28795  404 
in (elem', text') end 
405 

28872  406 
fun finish ctxt parms do_close insts elems text = 
407 
let 

408 
val (deps, text') = fold_map (finish_inst ctxt parms do_close) insts text; 

409 
val (elems', text'') = fold_map (finish_elem ctxt parms do_close) elems text'; 

410 
in (deps, elems', text'') end; 

28795  411 

412 

413 
local 

414 

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

415 
(* nice, but for now not needed 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

416 
fun fold_suffixes f [] y = f [] y 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

417 
 fold_suffixes f (x :: xs) y = f (x :: xs) (f xs y); 
28795  418 

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

419 
fun fold_prefixes f xs y = fold_suffixes (f o rev) (rev xs) y; 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

420 
*) 
28795  421 

28872  422 
fun prep_elems parse_typ parse_prop parse_inst prep_vars 
423 
do_close context fixed raw_insts raw_elems raw_concl = 

28795  424 
let 
28872  425 
val thy = ProofContext.theory_of context; 
426 

28879  427 
fun prep_inst (loc, (prfx, inst)) (i, marked, insts, ctxt) = 
28872  428 
let 
429 
val (parm_names, parm_types) = NewLocale.params_of thy loc > 

430 
map (fn (b, SOME T, _) => (Name.name_of b, T)) > split_list; 

431 
val inst' = parse_inst parm_names inst ctxt; 

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

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

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

436 
val (insts'', _, _, ctxt') = check_autofix insts' [] [] ctxt; 

437 
val inst''' = insts'' > List.last > snd > snd; 

438 
val (morph, _) = inst_morph (parm_names, parm_types) (prfx, inst''') ctxt; 

28879  439 
val (marked', ctxt'') = NewLocale.activate_declarations thy (loc, morph) (marked, ctxt); 
440 
in (i+1, marked', insts', ctxt'') end; 

28872  441 

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

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

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

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

445 
val elems' = elems @ [parse_elem parse_typ parse_prop ctxt' raw_elem]; 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

446 
(* FIXME term bindings *) 
28872  447 
val (_, _, _, ctxt'') = check_autofix insts elems' [] ctxt'; 
448 
in (insts, elems', ctxt') end; 

28795  449 

28872  450 
fun prep_concl raw_concl (insts, elems, ctxt) = 
28795  451 
let 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

452 
val concl = (map o map) (fn (t, ps) => 
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

453 
(parse_prop ctxt t, map (parse_prop ctxt) ps)) raw_concl; 
28872  454 
in check_autofix insts elems concl ctxt end; 
28795  455 

28872  456 
val fors = prep_vars fixed context > fst; 
457 
val ctxt = context > ProofContext.add_fixes_i fors > snd; 

458 
val (_, _, insts', ctxt') = fold prep_inst raw_insts (0, NewLocale.empty, [], ctxt); 

459 
val (_, elems'', ctxt'') = fold prep_elem raw_elems (insts', [], ctxt'); 

460 
val (insts, elems, concl, ctxt) = prep_concl raw_concl (insts', elems'', ctxt''); 

28795  461 

28872  462 
(* Retrieve parameter types *) 
28795  463 
val xs = fold (fn Fixes fixes => (fn ps => ps @ map (Name.name_of o #1) fixes)  
28872  464 
_ => fn ps => ps) (Fixes fors :: elems) []; 
28859  465 
val (Ts, ctxt') = fold_map ProofContext.inferred_param xs ctxt; 
28852
5ddea758679b
Type inference for elements through syntax module.
ballarin
parents:
28832
diff
changeset

466 
val parms = xs ~~ Ts; 
28795  467 

28872  468 
val Fixes fors' = finish_primitive parms I (Fixes fors); 
469 
val (deps, elems', text) = finish ctxt' parms do_close insts elems ((([], []), ([], [])), ([], [], [])); 

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

470 
(* text has the following structure: 
28795  471 
(((exts, exts'), (ints, ints')), (xs, env, defs)) 
472 
where 

28872  473 
exts: external assumptions (terms in assumes elements) 
28795  474 
exts': dito, normalised wrt. env 
28872  475 
ints: internal assumptions (terms in assumptions from insts) 
28795  476 
ints': dito, normalised wrt. env 
477 
xs: the free variables in exts' and ints' and rhss of definitions, 

478 
this includes parameters except defined parameters 

479 
env: list of term pairs encoding substitutions, where the first term 

480 
is a free variable; substitutions represent defines elements and 

481 
the rhs is normalised wrt. the previous env 

482 
defs: theorems representing the substitutions from defines elements 

483 
(thms are normalised wrt. env). 

484 
elems is an updated version of raw_elems: 

485 
 type info added to Fixes and modified in Constrains 

486 
 axiom and definition statement replaced by corresponding one 

487 
from proppss in Assumes and Defines 

488 
 Facts unchanged 

489 
*) 

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

490 

28872  491 
in ((parms, fors', deps, elems', concl), text) end 
28795  492 

493 
in 

494 

28872  495 
fun read_elems x = prep_elems Syntax.parse_typ Syntax.parse_prop parse_inst 
496 
ProofContext.read_vars x; 

28879  497 
fun cert_elems x = prep_elems (K I) (K I) make_inst 
28872  498 
ProofContext.cert_vars x; 
28795  499 

500 
end; 

501 

502 

503 
(* full context statements: import + elements + conclusion *) 

504 

505 
local 

506 

28879  507 
fun prep_context_statement prep_expr prep_elems activate_elems 
28795  508 
do_close imprt elements raw_concl context = 
509 
let 

510 
val thy = ProofContext.theory_of context; 

511 

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

512 
val (expr, fixed) = parameters_of thy (apfst (prep_expr thy) imprt); 
28872  513 
val ((parms, fors, deps, elems, concl), (spec, (_, _, defs))) = 
514 
prep_elems do_close context fixed expr elements raw_concl; 

28879  515 

516 
val (_, ctxt0) = ProofContext.add_fixes_i fors context; 

517 
val (_, ctxt) = fold (NewLocale.activate_facts thy) deps (NewLocale.empty, ctxt0); 

518 
val ((elems', _), ctxt') = activate_elems elems (ProofContext.set_stmt true ctxt); 

28795  519 
in 
28872  520 
(((fors, deps), (ctxt', elems'), (parms, spec, defs)), concl) 
28879  521 
end; 
522 

523 
fun prep_statement prep_ctxt elems concl ctxt = 

524 
let 

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

525 
val (((_, (ctxt', _), _)), concl) = prep_ctxt false ([], []) elems concl ctxt 
28879  526 
in (concl, ctxt') end; 
28795  527 

528 
in 

529 

28879  530 
fun read_statement body concl ctxt = 
531 
prep_statement (prep_context_statement intern read_elems Element.activate) body concl ctxt; 

532 
fun cert_statement body concl ctxt = 

533 
prep_statement (prep_context_statement (K I) cert_elems Element.activate_i) body concl ctxt; 

534 

28795  535 
fun read_context imprt body ctxt = 
28879  536 
#1 (prep_context_statement intern read_elems Element.activate true imprt body [] ctxt); 
28795  537 
fun cert_context imprt body ctxt = 
28879  538 
#1 (prep_context_statement (K I) cert_elems Element.activate_i true imprt body [] ctxt); 
539 

28795  540 
end; 
541 

542 

543 
(** Dependencies **) 

544 

545 

546 

547 
(*** Locale declarations ***) 

548 

549 
local 

550 

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

552 
delta predicates; 

553 
axiomsN: name of theorem set with destruct rules for locale predicates, 

554 
also name suffix of delta predicates. *) 

555 

556 
val introN = "intro"; 

557 
val axiomsN = "axioms"; 

558 

559 
fun atomize_spec thy ts = 

560 
let 

561 
val t = Logic.mk_conjunction_balanced ts; 

562 
val body = ObjectLogic.atomize_term thy t; 

563 
val bodyT = Term.fastype_of body; 

564 
in 

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

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

567 
end; 

568 

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

570 

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

572 
if length args = n then 

573 
Syntax.const "_aprop" $ 

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

575 
else raise Match); 

576 

577 
(* CB: define one predicate including its intro rule and axioms 

578 
 bname: predicate name 

579 
 parms: locale parameters 

580 
 defs: thms representing substitutions from defines elements 

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

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

583 
 thy: the theory 

584 
*) 

585 

586 
fun def_pred bname parms defs ts norm_ts thy = 

587 
let 

588 
val name = Sign.full_name thy bname; 

589 

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

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

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

593 
val Ts = map #2 xs; 

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

595 
> Library.sort_wrt #1 > map TFree; 

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

597 

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

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

600 
val statement = ObjectLogic.ensure_propT thy head; 

601 

602 
val ([pred_def], defs_thy) = 

603 
thy 

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

605 
> Sign.declare_const [] ((Name.binding bname, predT), NoSyn) > snd 

606 
> PureThy.add_defs false 

607 
[((Thm.def_name bname, Logic.mk_equals (head, body)), [Thm.kind_internal])]; 

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

609 

610 
val cert = Thm.cterm_of defs_thy; 

611 

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

613 
MetaSimplifier.rewrite_goals_tac [pred_def] THEN 

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

615 
Tactic.compose_tac (false, 

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

617 

618 
val conjuncts = 

619 
(Drule.equal_elim_rule2 OF [body_eq, 

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

621 
> Conjunction.elim_balanced (length ts); 

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

623 
Element.prove_witness defs_ctxt t 

624 
(MetaSimplifier.rewrite_goals_tac defs THEN 

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

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

627 

628 
in 

629 

630 
(* CB: main predicate definition function *) 

631 

632 
fun define_preds pname (parms, ((exts, exts'), (ints, ints')), defs) thy = 

633 
let 

634 
val (a_pred, a_intro, a_axioms, thy'') = 

635 
if null exts then (NONE, NONE, [], thy) 

636 
else 

637 
let 

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

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

640 
thy 

641 
> def_pred aname parms defs exts exts'; 

642 
val (_, thy'') = 

643 
thy' 

644 
> Sign.add_path aname 

645 
> Sign.no_base_names 

646 
> PureThy.note_thmss Thm.internalK [((Name.binding introN, []), [([intro], [])])] 

647 
> Sign.restore_naming thy'; 

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

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

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

651 
else 

652 
let 

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

654 
thy'' 

655 
> def_pred pname parms defs (ints @ the_list a_pred) (ints' @ the_list a_pred); 

656 
val (_, thy'''') = 

657 
thy''' 

658 
> Sign.add_path pname 

659 
> Sign.no_base_names 

660 
> PureThy.note_thmss Thm.internalK 

661 
[((Name.binding introN, []), [([intro], [])]), 

662 
((Name.binding axiomsN, []), 

663 
[(map (Drule.standard o Element.conclude_witness) axioms, [])])] 

664 
> Sign.restore_naming thy'''; 

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

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

667 

668 
end; 

669 

670 

671 
local 

672 

673 
fun assumes_to_notes (Assumes asms) axms = 

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

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

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

677 
> apfst (curry Notes Thm.assumptionK) 

678 
 assumes_to_notes e axms = (e, axms); 

679 

680 
fun defines_to_notes thy (Defines defs) defns = 

681 
let 

682 
val defs' = map (fn (_, (def, _)) => def) defs 

683 
val notes = map (fn (a, (def, _)) => 

684 
(a, [([assume (cterm_of thy def)], [])])) defs 

685 
in 

686 
(Notes (Thm.definitionK, notes), defns @ defs') 

687 
end 

688 
 defines_to_notes _ e defns = (e, defns); 

689 

28872  690 
fun gen_add_locale prep_context 
28795  691 
bname predicate_name raw_imprt raw_body thy = 
692 
let 

693 
val thy_ctxt = ProofContext.init thy; 

694 
val name = Sign.full_name thy bname; 

695 
val _ = NewLocale.test_locale thy name andalso 

696 
error ("Duplicate definition of locale " ^ quote name); 

697 

28872  698 
val ((fors, deps), (_, body_elems), text as (parms, ((_, exts'), _), defs)) = 
699 
prep_context raw_imprt raw_body thy_ctxt; 

700 
val ((a_statement, a_intro, a_axioms), (b_statement, b_intro, b_axioms), thy') = 

28795  701 
define_preds predicate_name text thy; 
702 

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

704 
val _ = if null extraTs then () 

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

706 

28872  707 
val satisfy = Element.satisfy_morphism b_axioms; 
708 
val params = fors @ 

709 
(body_elems > map_filter (fn Fixes fixes => SOME fixes  _ => NONE) > flat); 

28795  710 
val (body_elems', defns) = fold_map (defines_to_notes thy) body_elems []; 
711 

712 
val notes = body_elems' > 

28872  713 
(fn elems => fold_map assumes_to_notes elems (map Element.conclude_witness a_axioms)) > 
714 
fst > map (Element.morph_ctxt satisfy) > 

28795  715 
map_filter (fn Notes notes => SOME notes  _ => NONE); 
716 

28872  717 
val deps' = map (fn (l, morph) => (l, morph $> satisfy)) deps; 
718 

28795  719 
val loc_ctxt = thy' > 
28872  720 
NewLocale.register_locale name (extraTs, params) 
721 
(if is_some b_statement then b_statement else a_statement, map prop_of defs) ([], []) 

722 
(map (fn n => (n, stamp ())) notes > rev) (map (fn d => (d, stamp ())) deps' > rev) > 

28795  723 
NewLocale.init name 
724 
in (name, loc_ctxt) end; 

725 

726 
in 

727 

728 
val add_locale = gen_add_locale read_context; 

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

729 
val add_locale_i = gen_add_locale cert_context; 
28795  730 

731 
end; 

732 

733 
end; 