55 typ list -> term -> term -> term -> term |
55 typ list -> term -> term -> term -> term |
56 val massage_direct_corec_call: Proof.context -> (term -> bool) -> (term -> term) -> typ -> term -> |
56 val massage_direct_corec_call: Proof.context -> (term -> bool) -> (term -> term) -> typ -> term -> |
57 term |
57 term |
58 val massage_indirect_corec_call: Proof.context -> (term -> bool) -> |
58 val massage_indirect_corec_call: Proof.context -> (term -> bool) -> |
59 (typ -> typ -> term -> term) -> typ list -> typ -> term -> term |
59 (typ -> typ -> term -> term) -> typ list -> typ -> term -> term |
|
60 val massage_corec_code_rhs: Proof.context -> (term -> bool) -> (term -> term list -> term) -> |
|
61 typ list -> typ -> term -> term |
60 val rec_specs_of: binding list -> typ list -> typ list -> (term -> int list) -> |
62 val rec_specs_of: binding list -> typ list -> typ list -> (term -> int list) -> |
61 ((term * term list list) list) list -> local_theory -> |
63 ((term * term list list) list) list -> local_theory -> |
62 (bool * rec_spec list * typ list * thm * thm list) * local_theory |
64 (bool * rec_spec list * typ list * thm * thm list) * local_theory |
63 val corec_specs_of: binding list -> typ list -> typ list -> (term -> int list) -> |
65 val corec_specs_of: binding list -> typ list -> typ list -> (term -> int list) -> |
64 ((term * term list list) list) list -> local_theory -> |
66 ((term * term list list) list) list -> local_theory -> |
124 |
126 |
125 fun ill_formed_rec_call ctxt t = |
127 fun ill_formed_rec_call ctxt t = |
126 error ("Ill-formed recursive call: " ^ quote (Syntax.string_of_term ctxt t)); |
128 error ("Ill-formed recursive call: " ^ quote (Syntax.string_of_term ctxt t)); |
127 fun ill_formed_corec_call ctxt t = |
129 fun ill_formed_corec_call ctxt t = |
128 error ("Ill-formed corecursive call: " ^ quote (Syntax.string_of_term ctxt t)); |
130 error ("Ill-formed corecursive call: " ^ quote (Syntax.string_of_term ctxt t)); |
129 fun ill_formed_corec_code_rhs ctxt t = |
|
130 error ("Ill-formed corecursive equation right-hand side: " ^ |
|
131 quote (Syntax.string_of_term ctxt t)); |
|
132 fun invalid_map ctxt t = |
131 fun invalid_map ctxt t = |
133 error ("Invalid map function in " ^ quote (Syntax.string_of_term ctxt t)); |
132 error ("Invalid map function in " ^ quote (Syntax.string_of_term ctxt t)); |
134 fun unexpected_rec_call ctxt t = |
133 fun unexpected_rec_call ctxt t = |
135 error ("Unexpected recursive call: " ^ quote (Syntax.string_of_term ctxt t)); |
134 error ("Unexpected recursive call: " ^ quote (Syntax.string_of_term ctxt t)); |
136 fun unexpected_corec_call ctxt t = |
135 fun unexpected_corec_call ctxt t = |
194 | massage_call t = if t = y then y_of_y' () else ill_formed_rec_call ctxt t; |
193 | massage_call t = if t = y then y_of_y' () else ill_formed_rec_call ctxt t; |
195 in |
194 in |
196 massage_call |
195 massage_call |
197 end; |
196 end; |
198 |
197 |
199 fun massage_let_and_if ctxt check_cond massage_leaf U = |
198 fun massage_let_and_if ctxt has_call massage_leaf U = |
200 let |
199 let |
|
200 val check_cond = ((not o has_call) orf unexpected_corec_call ctxt); |
201 fun massage_rec t = |
201 fun massage_rec t = |
202 (case Term.strip_comb t of |
202 (case Term.strip_comb t of |
203 (Const (@{const_name Let}, _), [arg1, arg2]) => massage_rec (betapply (arg2, arg1)) |
203 (Const (@{const_name Let}, _), [arg1, arg2]) => massage_rec (betapply (arg2, arg1)) |
204 | (Const (@{const_name If}, _), arg :: args) => |
204 | (Const (@{const_name If}, _), arg :: args) => |
205 list_comb (If_const U $ tap check_cond arg, map massage_rec args) |
205 list_comb (If_const U $ tap check_cond arg, map massage_rec args) |
244 else |
243 else |
245 massage_map U T t |
244 massage_map U T t |
246 handle AINT_NO_MAP _ => check_and_massage_unapplied_direct_call U T t; |
245 handle AINT_NO_MAP _ => check_and_massage_unapplied_direct_call U T t; |
247 |
246 |
248 fun massage_call U T = |
247 fun massage_call U T = |
249 massage_let_and_if ctxt ((not o has_call) orf unexpected_corec_call ctxt) |
248 massage_let_and_if ctxt has_call (fn t => |
250 (fn t => |
249 (case U of |
251 (case U of |
250 Type (s, Us) => |
252 Type (s, Us) => |
251 (case try (dest_ctr ctxt s) t of |
253 (case try (dest_ctr ctxt s) t of |
252 SOME (f, args) => |
254 SOME (f, args) => |
253 let val f' = mk_ctr Us f in |
255 let val f' = mk_ctr Us f in |
254 list_comb (f', map3 massage_call (binder_types (typof f')) (map typof args) args) |
256 list_comb (f', map3 massage_call (binder_types (typof f')) (map typof args) args) |
255 end |
257 end |
256 | NONE => |
258 | NONE => |
257 (case t of |
259 (case t of |
258 t1 $ t2 => |
260 t1 $ t2 => |
259 (if has_call t2 then |
261 (if has_call t2 then |
260 check_and_massage_direct_call U T t |
262 check_and_massage_direct_call U T t |
261 else |
263 else |
262 massage_map U T t1 $ t2 |
264 massage_map U T t1 $ t2 |
263 handle AINT_NO_MAP _ => check_and_massage_direct_call U T t) |
265 handle AINT_NO_MAP _ => check_and_massage_direct_call U T t) |
264 | _ => check_and_massage_direct_call U T t)) |
266 | _ => check_and_massage_direct_call U T t)) |
265 | _ => ill_formed_corec_call ctxt t)) U |
267 | _ => ill_formed_corec_call ctxt t)) |
|
268 U |
|
269 in |
266 in |
270 massage_call U (typof t) t |
267 massage_call U (typof t) t |
|
268 end; |
|
269 |
|
270 fun explode_ctr_term ctxt s Ts t = |
|
271 (case fp_sugar_of ctxt s of |
|
272 SOME fp_sugar => |
|
273 let |
|
274 val T = Type (s, Ts); |
|
275 val x = Bound 0; |
|
276 val {ctrs = ctrs0, discs = discs0, selss = selss0, ...} = of_fp_sugar #ctr_sugars fp_sugar; |
|
277 val ctrs = map (mk_ctr Ts) ctrs0; |
|
278 val discs = map (mk_disc_or_sel Ts) discs0; |
|
279 val selss = map (map (mk_disc_or_sel Ts)) selss0; |
|
280 val xdiscs = map (rapp x) discs; |
|
281 val xselss = map (map (rapp x)) selss; |
|
282 val xsel_ctrs = map2 (curry Term.list_comb) ctrs xselss; |
|
283 val xif = mk_IfN T xdiscs xsel_ctrs; |
|
284 in |
|
285 Const (@{const_name Let}, T --> (T --> T) --> T) $ t $ Abs (Name.uu, T, xif) |
|
286 end |
|
287 | NONE => raise Fail "explode_ctr_term"); |
|
288 |
|
289 fun massage_corec_code_rhs ctxt has_call massage_ctr bound_Ts U t = |
|
290 let val typof = curry fastype_of1 bound_Ts in |
|
291 (case typof t of |
|
292 T as Type (s, Ts) => |
|
293 massage_let_and_if ctxt has_call (fn t => |
|
294 (case try (dest_ctr ctxt s) t of |
|
295 SOME (f, args) => massage_ctr f args |
|
296 | NONE => massage_let_and_if ctxt has_call (uncurry massage_ctr o Term.strip_comb) T |
|
297 (explode_ctr_term ctxt s Ts t))) U t |
|
298 | _ => raise Fail "massage_corec_code_rhs") |
271 end; |
299 end; |
272 |
300 |
273 fun indexed xs h = let val h' = h + length xs in (h upto h' - 1, h') end; |
301 fun indexed xs h = let val h' = h + length xs in (h upto h' - 1, h') end; |
274 fun indexedd xss = fold_map indexed xss; |
302 fun indexedd xss = fold_map indexed xss; |
275 fun indexeddd xsss = fold_map indexedd xsss; |
303 fun indexeddd xsss = fold_map indexedd xsss; |