316 val dummy_name = ""; |
316 val dummy_name = ""; |
317 val dummy_type = ITyVar dummy_name; |
317 val dummy_type = ITyVar dummy_name; |
318 val dummy_case_term = IVar dummy_name; |
318 val dummy_case_term = IVar dummy_name; |
319 (*assumption: dummy values are not relevant for serialization*) |
319 (*assumption: dummy values are not relevant for serialization*) |
320 val unitt = IConst (unit', (([], []), [])); |
320 val unitt = IConst (unit', (([], []), [])); |
321 fun dest_abs ((v, ty) `|-> t, _) = ((v, ty), t) |
321 fun dest_abs ((v, ty) `|=> t, _) = ((v, ty), t) |
322 | dest_abs (t, ty) = |
322 | dest_abs (t, ty) = |
323 let |
323 let |
324 val vs = Code_Thingol.fold_varnames cons t []; |
324 val vs = Code_Thingol.fold_varnames cons t []; |
325 val v = Name.variant vs "x"; |
325 val v = Name.variant vs "x"; |
326 val ty' = (hd o fst o Code_Thingol.unfold_fun) ty; |
326 val ty' = (hd o fst o Code_Thingol.unfold_fun) ty; |
335 and tr_bind'' t = case Code_Thingol.unfold_app t |
335 and tr_bind'' t = case Code_Thingol.unfold_app t |
336 of (IConst (c, (_, ty1 :: ty2 :: _)), [x1, x2]) => if c = bind' |
336 of (IConst (c, (_, ty1 :: ty2 :: _)), [x1, x2]) => if c = bind' |
337 then tr_bind' [(x1, ty1), (x2, ty2)] |
337 then tr_bind' [(x1, ty1), (x2, ty2)] |
338 else force t |
338 else force t |
339 | _ => force t; |
339 | _ => force t; |
340 in (dummy_name, dummy_type) `|-> ICase (((IVar dummy_name, dummy_type), |
340 in (dummy_name, dummy_type) `|=> ICase (((IVar dummy_name, dummy_type), |
341 [(unitt, tr_bind' ts)]), dummy_case_term) end |
341 [(unitt, tr_bind' ts)]), dummy_case_term) end |
342 and imp_monad_bind' bind' return' unit' (const as (c, (_, tys))) ts = if c = bind' then case (ts, tys) |
342 and imp_monad_bind' bind' return' unit' (const as (c, (_, tys))) ts = if c = bind' then case (ts, tys) |
343 of ([t1, t2], ty1 :: ty2 :: _) => imp_monad_bind'' bind' return' unit' [(t1, ty1), (t2, ty2)] |
343 of ([t1, t2], ty1 :: ty2 :: _) => imp_monad_bind'' bind' return' unit' [(t1, ty1), (t2, ty2)] |
344 | ([t1, t2, t3], ty1 :: ty2 :: _) => imp_monad_bind'' bind' return' unit' [(t1, ty1), (t2, ty2)] `$ t3 |
344 | ([t1, t2, t3], ty1 :: ty2 :: _) => imp_monad_bind'' bind' return' unit' [(t1, ty1), (t2, ty2)] `$ t3 |
345 | (ts, _) => imp_monad_bind bind' return' unit' (eta_expand 2 (const, ts)) |
345 | (ts, _) => imp_monad_bind bind' return' unit' (eta_expand 2 (const, ts)) |
347 and imp_monad_bind bind' return' unit' (IConst const) = imp_monad_bind' bind' return' unit' const [] |
347 and imp_monad_bind bind' return' unit' (IConst const) = imp_monad_bind' bind' return' unit' const [] |
348 | imp_monad_bind bind' return' unit' (t as IVar _) = t |
348 | imp_monad_bind bind' return' unit' (t as IVar _) = t |
349 | imp_monad_bind bind' return' unit' (t as _ `$ _) = (case unfold_app t |
349 | imp_monad_bind bind' return' unit' (t as _ `$ _) = (case unfold_app t |
350 of (IConst const, ts) => imp_monad_bind' bind' return' unit' const ts |
350 of (IConst const, ts) => imp_monad_bind' bind' return' unit' const ts |
351 | (t, ts) => imp_monad_bind bind' return' unit' t `$$ map (imp_monad_bind bind' return' unit') ts) |
351 | (t, ts) => imp_monad_bind bind' return' unit' t `$$ map (imp_monad_bind bind' return' unit') ts) |
352 | imp_monad_bind bind' return' unit' (v_ty `|-> t) = v_ty `|-> imp_monad_bind bind' return' unit' t |
352 | imp_monad_bind bind' return' unit' (v_ty `|=> t) = v_ty `|=> imp_monad_bind bind' return' unit' t |
353 | imp_monad_bind bind' return' unit' (ICase (((t, ty), pats), t0)) = ICase |
353 | imp_monad_bind bind' return' unit' (ICase (((t, ty), pats), t0)) = ICase |
354 (((imp_monad_bind bind' return' unit' t, ty), (map o pairself) (imp_monad_bind bind' return' unit') pats), imp_monad_bind bind' return' unit' t0); |
354 (((imp_monad_bind bind' return' unit' t, ty), (map o pairself) (imp_monad_bind bind' return' unit') pats), imp_monad_bind bind' return' unit' t0); |
355 |
355 |
356 fun imp_program naming = (Graph.map_nodes o map_terms_stmt) |
356 fun imp_program naming = (Graph.map_nodes o map_terms_stmt) |
357 (imp_monad_bind (lookup naming @{const_name bindM}) |
357 (imp_monad_bind (lookup naming @{const_name bindM}) |