200 val (out_ts', in_ts') = List.partition (is_constrt thy) out_ts; |
200 val (out_ts', in_ts') = List.partition (is_constrt thy) out_ts; |
201 val vTs = maps term_vTs out_ts'; |
201 val vTs = maps term_vTs out_ts'; |
202 val dupTs = map snd (duplicates (op =) vTs) @ |
202 val dupTs = map snd (duplicates (op =) vTs) @ |
203 map_filter (AList.lookup (op =) vTs) vs; |
203 map_filter (AList.lookup (op =) vTs) vs; |
204 in |
204 in |
205 terms_vs (in_ts @ in_ts') subset vs andalso |
205 gen_subset (op =) (terms_vs (in_ts @ in_ts'), vs) andalso |
206 forall (is_eqT o fastype_of) in_ts' andalso |
206 forall (is_eqT o fastype_of) in_ts' andalso |
207 term_vs t subset vs andalso |
207 gen_subset (op =) (term_vs t, vs) andalso |
208 forall is_eqT dupTs |
208 forall is_eqT dupTs |
209 end) |
209 end) |
210 (if is_set then [Mode (([], []), [], [])] |
210 (if is_set then [Mode (([], []), [], [])] |
211 else modes_of modes t handle Option => |
211 else modes_of modes t handle Option => |
212 error ("Bad predicate: " ^ Syntax.string_of_term_global thy t)) |
212 error ("Bad predicate: " ^ Syntax.string_of_term_global thy t)) |
213 | Sidecond t => if term_vs t subset vs then SOME (Mode (([], []), [], [])) |
213 | Sidecond t => if gen_subset (op =) (term_vs t, vs) then SOME (Mode (([], []), [], [])) |
214 else NONE) ps); |
214 else NONE) ps); |
215 |
215 |
216 fun check_mode_clause thy arg_vs modes (iss, is) (ts, ps) = |
216 fun check_mode_clause thy arg_vs modes (iss, is) (ts, ps) = |
217 let |
217 let |
218 val modes' = modes @ map_filter |
218 val modes' = modes @ map_filter |
220 (arg_vs ~~ iss); |
220 (arg_vs ~~ iss); |
221 fun check_mode_prems vs [] = SOME vs |
221 fun check_mode_prems vs [] = SOME vs |
222 | check_mode_prems vs ps = (case select_mode_prem thy modes' vs ps of |
222 | check_mode_prems vs ps = (case select_mode_prem thy modes' vs ps of |
223 NONE => NONE |
223 NONE => NONE |
224 | SOME (x, _) => check_mode_prems |
224 | SOME (x, _) => check_mode_prems |
225 (case x of Prem (us, _, _) => vs union terms_vs us | _ => vs) |
225 (case x of Prem (us, _, _) => gen_union (op =) (vs, terms_vs us) | _ => vs) |
226 (filter_out (equal x) ps)); |
226 (filter_out (equal x) ps)); |
227 val (in_ts, in_ts') = List.partition (is_constrt thy) (fst (get_args is 1 ts)); |
227 val (in_ts, in_ts') = List.partition (is_constrt thy) (fst (get_args is 1 ts)); |
228 val in_vs = terms_vs in_ts; |
228 val in_vs = terms_vs in_ts; |
229 val concl_vs = terms_vs ts |
229 val concl_vs = terms_vs ts |
230 in |
230 in |
231 forall is_eqT (map snd (duplicates (op =) (maps term_vTs in_ts))) andalso |
231 forall is_eqT (map snd (duplicates (op =) (maps term_vTs in_ts))) andalso |
232 forall (is_eqT o fastype_of) in_ts' andalso |
232 forall (is_eqT o fastype_of) in_ts' andalso |
233 (case check_mode_prems (arg_vs union in_vs) ps of |
233 (case check_mode_prems (gen_union (op =) (arg_vs, in_vs)) ps of |
234 NONE => false |
234 NONE => false |
235 | SOME vs => concl_vs subset vs) |
235 | SOME vs => gen_subset (op =) (concl_vs, vs)) |
236 end; |
236 end; |
237 |
237 |
238 fun check_modes_pred thy arg_vs preds modes (p, ms) = |
238 fun check_modes_pred thy arg_vs preds modes (p, ms) = |
239 let val SOME rs = AList.lookup (op =) preds p |
239 let val SOME rs = AList.lookup (op =) preds p |
240 in (p, List.filter (fn m => case find_index |
240 in (p, List.filter (fn m => case find_index |
480 fun prep_intrs intrs = map (rename_term o #prop o rep_thm o Drule.standard) intrs; |
480 fun prep_intrs intrs = map (rename_term o #prop o rep_thm o Drule.standard) intrs; |
481 |
481 |
482 fun constrain cs [] = [] |
482 fun constrain cs [] = [] |
483 | constrain cs ((s, xs) :: ys) = (s, case AList.lookup (op =) cs (s : string) of |
483 | constrain cs ((s, xs) :: ys) = (s, case AList.lookup (op =) cs (s : string) of |
484 NONE => xs |
484 NONE => xs |
485 | SOME xs' => xs inter xs') :: constrain cs ys; |
485 | SOME xs' => gen_inter (op =) (xs, xs')) :: constrain cs ys; |
486 |
486 |
487 fun mk_extra_defs thy defs gr dep names module ts = |
487 fun mk_extra_defs thy defs gr dep names module ts = |
488 Library.foldl (fn (gr, name) => |
488 Library.foldl (fn (gr, name) => |
489 if name mem names then gr |
489 if name mem names then gr |
490 else (case get_clauses thy name of |
490 else (case get_clauses thy name of |