src/HOL/Tools/inductive_codegen.ML
changeset 33037 b22e44496dc2
parent 32957 675c0c7e6a37
child 33038 8f9594c31de4
equal deleted inserted replaced
33015:575bd6548df9 33037:b22e44496dc2
   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