103 |
103 |
104 (* prepare specification *) |
104 (* prepare specification *) |
105 |
105 |
106 local |
106 local |
107 |
107 |
108 fun close_forms ctxt i As = |
108 fun close_forms ctxt auto_close i prems concls = |
109 let |
109 let |
110 val xs = rev (fold (Variable.add_free_names ctxt) As []); |
110 val xs = |
|
111 if auto_close then rev (fold (Variable.add_free_names ctxt) (concls @ prems) []) |
|
112 else []; |
111 val types = |
113 val types = |
112 map (Type_Infer.param i o rpair []) (Name.invent Name.context Name.aT (length xs)); |
114 map (Type_Infer.param i o rpair []) (Name.invent Name.context Name.aT (length xs)); |
113 val uniform_typing = AList.lookup (op =) (xs ~~ types); |
115 val uniform_typing = AList.lookup (op =) (xs ~~ types); |
114 val close = fold_rev (Logic.dependent_all_constraint uniform_typing) (xs ~~ xs); |
116 in map (Logic.close_prop_constraint uniform_typing (xs ~~ xs) prems) concls end; |
115 in map close As end; |
|
116 |
117 |
117 fun get_positions ctxt x = |
118 fun get_positions ctxt x = |
118 let |
119 let |
119 fun get Cs (Const ("_type_constraint_", C) $ t) = get (C :: Cs) t |
120 fun get Cs (Const ("_type_constraint_", C) $ t) = get (C :: Cs) t |
120 | get _ (t $ u) = get [] t @ get [] u |
121 | get _ (t $ u) = get [] t @ get [] u |
125 (T :: map (Type.constraint_type ctxt) Cs) |
126 (T :: map (Type.constraint_type ctxt) Cs) |
126 else [] |
127 else [] |
127 | get _ _ = []; |
128 | get _ _ = []; |
128 in get [] end; |
129 in get [] end; |
129 |
130 |
130 fun prepare prep_var parse_prop prep_att do_close raw_vars raw_specss ctxt = |
131 fun prepare prep_var parse_prop prep_att auto_close raw_vars raw_specss ctxt = |
131 let |
132 let |
132 val (vars, vars_ctxt) = ctxt |> fold_map prep_var raw_vars; |
133 val (vars, vars_ctxt) = ctxt |> fold_map prep_var raw_vars; |
133 val (xs, params_ctxt) = vars_ctxt |
134 val (xs, params_ctxt) = vars_ctxt |
134 |> Context_Position.set_visible false |
135 |> Context_Position.set_visible false |
135 |> Proof_Context.add_fixes vars |
136 |> Proof_Context.add_fixes vars |
137 val _ = |
138 val _ = |
138 Context_Position.reports params_ctxt |
139 Context_Position.reports params_ctxt |
139 (map (Binding.pos_of o #1) vars ~~ |
140 (map (Binding.pos_of o #1) vars ~~ |
140 map (Variable.markup_entity_def params_ctxt ##> Properties.remove Markup.kindN) xs); |
141 map (Variable.markup_entity_def params_ctxt ##> Properties.remove Markup.kindN) xs); |
141 |
142 |
142 val Asss = |
143 val Asss0 = |
143 (map o map) snd raw_specss |
144 (map o map) snd raw_specss |
144 |> (burrow o burrow) (grouped 10 Par_List.map_independent (parse_prop params_ctxt)); |
145 |> (burrow o burrow) (grouped 10 Par_List.map_independent (parse_prop params_ctxt)); |
145 val names = Variable.names_of (params_ctxt |> (fold o fold o fold) Variable.declare_term Asss) |
146 val names = |
|
147 Variable.names_of (params_ctxt |> (fold o fold o fold) Variable.declare_term Asss0) |
146 |> fold Name.declare xs; |
148 |> fold Name.declare xs; |
147 val Asss' = #1 ((fold_map o fold_map o fold_map) Term.free_dummy_patterns Asss names); |
149 |
148 val idx = (fold o fold o fold) Term.maxidx_term Asss' ~1 + 1; |
150 val (Asss1, _) = (fold_map o fold_map o fold_map) Term.free_dummy_patterns Asss0 names; |
149 |
151 val idx = (fold o fold o fold) Term.maxidx_term Asss1 ~1 + 1; |
150 val specs = |
152 |
151 (if do_close then |
153 val (Asss2, _) = |
152 #1 (fold_map |
154 fold_map (fn Ass => fn i => (burrow (close_forms params_ctxt auto_close i []) Ass, i + 1)) |
153 (fn Ass => fn i => (burrow (close_forms params_ctxt i) Ass, i + 1)) Asss' idx) |
155 Asss1 idx; |
154 else Asss') |
156 |
155 |> flat |> burrow (Syntax.check_props params_ctxt); |
157 val specs = burrow (Syntax.check_props params_ctxt) (flat Asss2); |
156 val specs_ctxt = params_ctxt |> (fold o fold) Variable.declare_term specs; |
158 val specs_ctxt = params_ctxt |> (fold o fold) Variable.declare_term specs; |
157 |
159 |
158 val ps = specs_ctxt |> fold_map Proof_Context.inferred_param xs |> fst; |
160 val ps = specs_ctxt |> fold_map Proof_Context.inferred_param xs |> fst; |
159 val params = map2 (fn (b, _, mx) => fn (_, T) => ((b, T), mx)) vars ps; |
161 val params = map2 (fn (b, _, mx) => fn (_, T) => ((b, T), mx)) vars ps; |
160 val name_atts: Attrib.binding list = |
162 val name_atts: Attrib.binding list = |
161 map (fn ((name, atts), _) => (name, map (prep_att ctxt) atts)) (flat raw_specss); |
163 map (fn ((name, atts), _) => (name, map (prep_att ctxt) atts)) (flat raw_specss); |
162 |
164 |
163 fun get_pos x = |
165 fun get_pos x = |
164 if do_close then Position.none |
166 (case (maps o maps o maps) (get_positions specs_ctxt x) Asss2 of |
165 else |
167 [] => Position.none |
166 (case (maps o maps o maps) (get_positions specs_ctxt x) Asss' of |
168 | pos :: _ => pos); |
167 [] => Position.none |
|
168 | pos :: _ => pos); |
|
169 in (((params, name_atts ~~ specs), get_pos), specs_ctxt) end; |
169 in (((params, name_atts ~~ specs), get_pos), specs_ctxt) end; |
170 |
170 |
171 |
171 |
172 fun single_spec (a, prop) = [(a, [prop])]; |
172 fun single_spec (a, prop) = [(a, [prop])]; |
173 fun the_spec (a, [prop]) = (a, prop); |
173 fun the_spec (a, [prop]) = (a, prop); |
174 |
174 |
175 fun prep_spec prep_var parse_prop prep_att do_close vars specs = |
175 fun prep_spec prep_var parse_prop prep_att auto_close vars specs = |
176 prepare prep_var parse_prop prep_att do_close |
176 prepare prep_var parse_prop prep_att auto_close |
177 vars (map single_spec specs) #>> (apfst o apsnd) (map the_spec); |
177 vars (map single_spec specs) #>> (apfst o apsnd) (map the_spec); |
178 |
178 |
179 in |
179 in |
180 |
180 |
181 fun check_free_spec vars specs = |
181 fun check_free_spec vars specs = |