7 signature CODE_EVAL = |
7 signature CODE_EVAL = |
8 sig |
8 sig |
9 val target: string |
9 val target: string |
10 val eval: string option -> string * (unit -> 'a) option Unsynchronized.ref |
10 val eval: string option -> string * (unit -> 'a) option Unsynchronized.ref |
11 -> ((term -> term) -> 'a -> 'a) -> theory -> term -> string list -> 'a |
11 -> ((term -> term) -> 'a -> 'a) -> theory -> term -> string list -> 'a |
12 val evaluation_code: theory -> string -> string list -> string list |
|
13 -> string * ((string * string) list * (string * string) list) |
|
14 val setup: theory -> theory |
12 val setup: theory -> theory |
15 end; |
13 end; |
16 |
14 |
17 structure Code_Eval : CODE_EVAL = |
15 structure Code_Eval : CODE_EVAL = |
18 struct |
16 struct |
19 |
17 |
20 (** generic **) |
18 (** generic **) |
21 |
19 |
22 val target = "Eval"; |
20 val target = "Eval"; |
23 |
21 |
24 val eval_struct_name = "Code"; |
22 fun evaluation_code thy module_name tycos consts = |
25 |
|
26 fun evaluation_code thy struct_name_hint tycos consts = |
|
27 let |
23 let |
28 val (consts', (naming, program)) = Code_Thingol.consts_program thy false consts; |
24 val (consts', (naming, program)) = Code_Thingol.consts_program thy false consts; |
29 val tycos' = map (the o Code_Thingol.lookup_tyco naming) tycos; |
25 val tycos' = map (the o Code_Thingol.lookup_tyco naming) tycos; |
30 val struct_name = if struct_name_hint = "" then eval_struct_name |
|
31 else struct_name_hint; |
|
32 val (ml_code, target_names) = Code_Target.produce_code_for thy |
26 val (ml_code, target_names) = Code_Target.produce_code_for thy |
33 target NONE (SOME struct_name) [] naming program (consts' @ tycos'); |
27 target NONE (SOME module_name) [] naming program (consts' @ tycos'); |
34 val (consts'', tycos'') = chop (length consts') target_names; |
28 val (consts'', tycos'') = chop (length consts') target_names; |
35 val consts_map = map2 (fn const => fn NONE => |
29 val consts_map = map2 (fn const => fn NONE => |
36 error ("Constant " ^ (quote o Code.string_of_const thy) const |
30 error ("Constant " ^ (quote o Code.string_of_const thy) const |
37 ^ "\nhas a user-defined serialization") |
31 ^ "\nhas a user-defined serialization") |
38 | SOME const'' => (const, const'')) consts consts'' |
32 | SOME const'' => (const, const'')) consts consts'' |
67 |
61 |
68 (** instrumentalization by antiquotation **) |
62 (** instrumentalization by antiquotation **) |
69 |
63 |
70 local |
64 local |
71 |
65 |
72 structure CodeAntiqData = Proof_Data |
66 structure Code_Antiq_Data = Proof_Data |
73 ( |
67 ( |
74 type T = (string list * string list) * (bool * (string |
68 type T = (string list * string list) * (bool |
75 * (string * ((string * string) list * (string * string) list)) lazy)); |
69 * (string * ((string * string) list * (string * string) list)) lazy); |
76 fun init _ = (([], []), (true, ("", Lazy.value ("", ([], []))))); |
70 fun init _ = (([], []), (true, (Lazy.value ("", ([], []))))); |
77 ); |
71 ); |
78 |
72 |
79 val is_first_occ = fst o snd o CodeAntiqData.get; |
73 val is_first_occ = fst o snd o Code_Antiq_Data.get; |
80 |
74 |
81 fun register_code new_tycos new_consts ctxt = |
75 fun register_code new_tycos new_consts ctxt = |
82 let |
76 let |
83 val ((tycos, consts), (_, (struct_name, _))) = CodeAntiqData.get ctxt; |
77 val ((tycos, consts), _) = Code_Antiq_Data.get ctxt; |
84 val tycos' = fold (insert (op =)) new_tycos tycos; |
78 val tycos' = fold (insert (op =)) new_tycos tycos; |
85 val consts' = fold (insert (op =)) new_consts consts; |
79 val consts' = fold (insert (op =)) new_consts consts; |
86 val (struct_name', ctxt') = if struct_name = "" |
80 val acc_code = Lazy.lazy (fn () => |
87 then ML_Antiquote.variant eval_struct_name ctxt |
81 evaluation_code (ProofContext.theory_of ctxt) "Code" tycos' consts'); |
88 else (struct_name, ctxt); |
82 in Code_Antiq_Data.put ((tycos', consts'), (false, acc_code)) ctxt end; |
89 val acc_code = Lazy.lazy |
|
90 (fn () => evaluation_code (ProofContext.theory_of ctxt) eval_struct_name tycos' consts'); |
|
91 in CodeAntiqData.put ((tycos', consts'), (false, (struct_name', acc_code))) ctxt' end; |
|
92 |
83 |
93 fun register_const const = register_code [] [const]; |
84 fun register_const const = register_code [] [const]; |
94 |
85 |
95 fun register_datatype tyco constrs = register_code [tyco] constrs; |
86 fun register_datatype tyco constrs = register_code [tyco] constrs; |
96 |
87 |
97 fun print_const const all_struct_name tycos_map consts_map = |
88 fun print_const const all_struct_name tycos_map consts_map = |
98 (Long_Name.append all_struct_name o the o AList.lookup (op =) consts_map) const; |
89 (Long_Name.append all_struct_name o the o AList.lookup (op =) consts_map) const; |
99 |
90 |
100 fun print_code is_first print_it ctxt = |
91 fun print_code is_first print_it ctxt = |
101 let |
92 let |
102 val (_, (_, (struct_code_name, acc_code))) = CodeAntiqData.get ctxt; |
93 val (_, (_, acc_code)) = Code_Antiq_Data.get ctxt; |
103 val (ml_code, (tycos_map, consts_map)) = Lazy.force acc_code; |
94 val (ml_code, (tycos_map, consts_map)) = Lazy.force acc_code; |
104 val ml_code = if is_first then ml_code |
95 val ml_code = if is_first then ml_code |
105 else ""; |
96 else ""; |
106 val all_struct_name = "Isabelle." ^ struct_code_name; |
97 val all_struct_name = "Isabelle"; |
107 in (ml_code, print_it all_struct_name tycos_map consts_map) end; |
98 in (ml_code, print_it all_struct_name tycos_map consts_map) end; |
108 |
99 |
109 in |
100 in |
110 |
101 |
111 fun ml_code_antiq raw_const background = |
102 fun ml_code_antiq raw_const background = |