86 in |
86 in |
87 if t aconv t' then raise Fail "dest_applied_map_or_ctr" |
87 if t aconv t' then raise Fail "dest_applied_map_or_ctr" |
88 else dest_map ctxt s (fst (dest_comb t')) |
88 else dest_map ctxt s (fst (dest_comb t')) |
89 end); |
89 end); |
90 |
90 |
|
91 fun map_partition f xs = |
|
92 fold_rev (fn x => fn (ys, (good, bad)) => |
|
93 case f x of SOME y => (y :: ys, (x :: good, bad)) | NONE => (ys, (good, x :: bad))) |
|
94 xs ([], ([], [])); |
|
95 |
91 (* TODO: test with sort constraints on As *) |
96 (* TODO: test with sort constraints on As *) |
92 (* TODO: use right sorting order for "fp_sort" w.r.t. original BNFs (?) -- treat new variables |
97 (* TODO: use right sorting order for "fp_sort" w.r.t. original BNFs (?) -- treat new variables |
93 as deads? *) |
98 as deads? *) |
94 fun mutualize_fp_sugars has_nested fp bs fpTs _ callssss fp_sugars0 no_defs_lthy0 = |
99 fun mutualize_fp_sugars has_nested fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 = |
95 if has_nested orelse has_duplicates (op =) fpTs then |
100 if has_nested orelse has_duplicates (op =) fpTs then |
96 let |
101 let |
97 val thy = Proof_Context.theory_of no_defs_lthy0; |
102 val thy = Proof_Context.theory_of no_defs_lthy0; |
98 |
103 |
99 val qsotm = quote o Syntax.string_of_term no_defs_lthy0; |
104 val qsotm = quote o Syntax.string_of_term no_defs_lthy0; |
|
105 |
|
106 fun incompatible_calls t1 t2 = |
|
107 error ("Incompatible " ^ co_prefix fp ^ "recursive calls: " ^ qsotm t1 ^ " vs. " ^ |
|
108 qsotm t2); |
100 |
109 |
101 val b_names = map Binding.name_of bs; |
110 val b_names = map Binding.name_of bs; |
102 val fp_b_names = map base_name_of_typ fpTs; |
111 val fp_b_names = map base_name_of_typ fpTs; |
103 |
112 |
104 val nn = length fpTs; |
113 val nn = length fpTs; |
131 (case find_index (curry (op =) T) fpTs of |
140 (case find_index (curry (op =) T) fpTs of |
132 ~1 => Type (s, map freeze_fp_default Ts) |
141 ~1 => Type (s, map freeze_fp_default Ts) |
133 | kk => nth Xs kk) |
142 | kk => nth Xs kk) |
134 | freeze_fp_default T = T; |
143 | freeze_fp_default T = T; |
135 |
144 |
136 fun freeze_fp_map callss s Ts = |
145 fun check_call_dead live_call call = |
137 Type (s, map2 freeze_fp (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) [] |
146 if null (get_indices call) then () else incompatible_calls live_call call; |
138 (transpose callss)) Ts) |
147 |
|
148 fun freeze_fp_map (callss, (live_call :: _, dead_calls)) s Ts = |
|
149 (List.app (check_call_dead live_call) dead_calls; |
|
150 Type (s, map2 freeze_fp (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) [] |
|
151 (transpose callss)) Ts)) |
139 and freeze_fp calls (T as Type (s, Ts)) = |
152 and freeze_fp calls (T as Type (s, Ts)) = |
140 (case map_filter (try (snd o dest_map no_defs_lthy s)) calls of |
153 (case map_partition (try (snd o dest_map no_defs_lthy s)) calls of |
141 [] => |
154 ([], _) => |
142 (case map_filter (try (snd o dest_abs_or_applied_map_or_ctr no_defs_lthy s)) calls of |
155 (case map_partition (try (snd o dest_abs_or_applied_map_or_ctr no_defs_lthy s)) calls of |
143 [] => freeze_fp_default T |
156 ([], _) => freeze_fp_default T |
144 | callss => freeze_fp_map callss s Ts) |
157 | callsp => freeze_fp_map callsp s Ts) |
145 | callss => freeze_fp_map callss s Ts) |
158 | callsp => freeze_fp_map callsp s Ts) |
146 | freeze_fp _ T = T; |
159 | freeze_fp _ T = T; |
147 |
160 |
148 val ctr_Tsss = map (map binder_types) ctr_Tss; |
161 val ctr_Tsss = map (map binder_types) ctr_Tss; |
149 val ctrXs_Tsss = map2 (map2 (map2 freeze_fp)) callssss ctr_Tsss; |
162 val ctrXs_Tsss = map2 (map2 (map2 freeze_fp)) callssss ctr_Tsss; |
150 val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss; |
163 val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss; |