671 case get_first (fn eqx => eqx (c, ty)) (get_eqextrs thy tabs) |
671 case get_first (fn eqx => eqx (c, ty)) (get_eqextrs thy tabs) |
672 of SOME (eq_thms, ty) => |
672 of SOME (eq_thms, ty) => |
673 let |
673 let |
674 val sortctxt = ClassPackage.extract_sortctxt thy ty; |
674 val sortctxt = ClassPackage.extract_sortctxt thy ty; |
675 fun dest_eqthm eq_thm = |
675 fun dest_eqthm eq_thm = |
676 eq_thm |
676 let |
677 |> prop_of |
677 val ((t, args), rhs) = (apfst strip_comb o Logic.dest_equals o prop_of) eq_thm; |
678 |> Logic.dest_equals |
678 in case t |
679 |> apfst (strip_comb #> snd); |
679 of Const (c', _) => if c' = c then (args, rhs) |
|
680 else error ("illegal function equation for " ^ quote c |
|
681 ^ ", actually defining " ^ quote c') |
|
682 | _ => error ("illegal function equation for " ^ quote c) |
|
683 end; |
680 fun mk_eq (args, rhs) trns = |
684 fun mk_eq (args, rhs) trns = |
681 trns |
685 trns |
682 |> fold_map (exprgen_term thy tabs o devarify_term) args |
686 |> fold_map (exprgen_term thy tabs o devarify_term) args |
683 ||>> (exprgen_term thy tabs o devarify_term) rhs |
687 ||>> (exprgen_term thy tabs o devarify_term) rhs |
684 |-> (fn (args, rhs) => pair (map ipat_of_iexpr args, rhs)) |
688 |-> (fn (args, rhs) => pair (map ipat_of_iexpr args, rhs)) |
1177 |> #target_data |
1181 |> #target_data |
1178 |> (fn data => (the oo Symtab.lookup) data target); |
1182 |> (fn data => (the oo Symtab.lookup) data target); |
1179 in (seri ( |
1183 in (seri ( |
1180 (Option.map fst oo Symtab.lookup o #syntax_tyco) target_data, |
1184 (Option.map fst oo Symtab.lookup o #syntax_tyco) target_data, |
1181 (Option.map fst oo Symtab.lookup o #syntax_const) target_data |
1185 (Option.map fst oo Symtab.lookup o #syntax_const) target_data |
1182 ) "Generated" cs module : unit; thy) end; |
1186 ) cs module : unit; thy) end; |
1183 in |
1187 in |
1184 thy |
1188 thy |
1185 |> generate_code raw_consts |
1189 |> generate_code raw_consts |
1186 |-> (fn cs => serialize cs) |
1190 |-> (fn cs => serialize cs) |
1187 end; |
1191 end; |
1189 structure P = OuterParse |
1193 structure P = OuterParse |
1190 and K = OuterKeyword |
1194 and K = OuterKeyword |
1191 |
1195 |
1192 in |
1196 in |
1193 |
1197 |
1194 val (classK, generateK, serializeK, |
1198 val (generateK, serializeK, |
1195 primclassK, primtycoK, primconstK, |
1199 primclassK, primtycoK, primconstK, |
1196 syntax_tycoK, syntax_constK, aliasK) = |
1200 syntax_tycoK, syntax_constK, aliasK) = |
1197 ("code_class", "code_generate", "code_serialize", |
1201 ("code_generate", "code_serialize", |
1198 "code_primclass", "code_primtyco", "code_primconst", |
1202 "code_primclass", "code_primtyco", "code_primconst", |
1199 "code_syntax_tyco", "code_syntax_const", "code_alias"); |
1203 "code_syntax_tyco", "code_syntax_const", "code_alias"); |
1200 val dependingK = |
1204 val dependingK = |
1201 ("depending_on"); |
1205 ("depending_on"); |
1202 |
1206 |
1203 val classP = |
|
1204 OuterSyntax.command classK "codegen data for classes" K.thy_decl ( |
|
1205 P.xname |
|
1206 -- ((P.$$$ "\\<Rightarrow>" || P.$$$ "=>") |-- (P.list1 P.name)) |
|
1207 -- (Scan.optional ((P.$$$ "\\<Rightarrow>" || P.$$$ "=>") |-- (P.list1 P.name)) []) |
|
1208 >> (fn ((name, tycos), consts) => (Toplevel.theory (ClassPackage.add_classentry name consts tycos))) |
|
1209 ) |
|
1210 |
|
1211 val generateP = |
1207 val generateP = |
1212 OuterSyntax.command generateK "generate executable code for constants" K.thy_decl ( |
1208 OuterSyntax.command generateK "generate executable code for constants" K.thy_decl ( |
1213 P.$$$ "(" |
1209 Scan.repeat1 (P.name -- Scan.option (P.$$$ "::" |-- P.typ)) |
1214 |-- Scan.repeat1 (P.name -- Scan.option (P.$$$ "::" |-- P.typ)) |
|
1215 --| P.$$$ ")" |
|
1216 >> (fn raw_consts => |
1210 >> (fn raw_consts => |
1217 Toplevel.theory (generate_code (SOME raw_consts) #> snd)) |
1211 Toplevel.theory (generate_code (SOME raw_consts) #> snd)) |
1218 ); |
1212 ); |
1219 |
1213 |
1220 val serializeP = |
1214 val serializeP = |
1221 OuterSyntax.command serializeK "serialize executable code for constants" K.thy_decl ( |
1215 OuterSyntax.command serializeK "serialize executable code for constants" K.thy_decl ( |
1222 P.name |
1216 P.name |
1223 -- Scan.option ( |
1217 -- Scan.option (Scan.repeat1 (P.name -- Scan.option (P.$$$ "::" |-- P.typ))) |
1224 P.$$$ "(" |
|
1225 |-- Scan.repeat1 (P.name -- Scan.option (P.$$$ "::" |-- P.typ)) |
|
1226 --| P.$$$ ")" |
|
1227 ) |
|
1228 #-> (fn (target, raw_consts) => |
1218 #-> (fn (target, raw_consts) => |
1229 get_serializer target |
1219 P.$$$ "(" |
|
1220 |-- get_serializer target |
|
1221 --| P.$$$ ")" |
1230 >> (fn seri => |
1222 >> (fn seri => |
1231 Toplevel.theory (serialize_code target seri raw_consts) |
1223 Toplevel.theory (serialize_code target seri raw_consts) |
1232 )) |
1224 )) |
1233 ); |
1225 ); |
1234 |
1226 |
1265 P.$$$ "(" |-- P.list1 P.name --| P.$$$ ")") [] |
1257 P.$$$ "(" |-- P.list1 P.name --| P.$$$ ")") [] |
1266 -- Scan.repeat1 (P.name -- P.text) |
1258 -- Scan.repeat1 (P.name -- P.text) |
1267 >> (fn ((raw_const, depends), primdefs) => |
1259 >> (fn ((raw_const, depends), primdefs) => |
1268 (Toplevel.theory oo fold) (add_prim_const raw_const depends) primdefs) |
1260 (Toplevel.theory oo fold) (add_prim_const raw_const depends) primdefs) |
1269 ); |
1261 ); |
1270 |
|
1271 val _ : OuterParse.token list -> (string -> string -> theory -> theory) * OuterParse.token list |
|
1272 = parse_syntax_tyco; |
|
1273 |
1262 |
1274 val syntax_tycoP = |
1263 val syntax_tycoP = |
1275 OuterSyntax.command syntax_tycoK "define code syntax for type constructor" K.thy_decl ( |
1264 OuterSyntax.command syntax_tycoK "define code syntax for type constructor" K.thy_decl ( |
1276 Scan.repeat1 ( |
1265 Scan.repeat1 ( |
1277 P.xname |
1266 P.xname |
1293 ) |
1282 ) |
1294 >> (Toplevel.theory oo fold) (fn (raw_c, syns) => |
1283 >> (Toplevel.theory oo fold) (fn (raw_c, syns) => |
1295 fold (fn (target, modifier) => modifier raw_c target) syns) |
1284 fold (fn (target, modifier) => modifier raw_c target) syns) |
1296 ); |
1285 ); |
1297 |
1286 |
1298 val _ = OuterSyntax.add_parsers [classP, generateP, serializeP, aliasP, |
1287 val _ = OuterSyntax.add_parsers [generateP, serializeP, aliasP, |
1299 primclassP, primtycoP, primconstP, syntax_tycoP, syntax_constP]; |
1288 primclassP, primtycoP, primconstP, syntax_tycoP, syntax_constP]; |
1300 val _ = OuterSyntax.add_keywords ["\\<Rightarrow>", "=>", dependingK]; |
1289 val _ = OuterSyntax.add_keywords [dependingK]; |
1301 |
1290 |
1302 |
1291 |
1303 |
1292 |
1304 (** theory setup **) |
1293 (** theory setup **) |
1305 |
1294 |
1306 val _ = Context.add_setup |
1295 val _ = Context.add_setup ( |
1307 (add_eqextr ("defs", eqextr_defs) #> |
1296 add_eqextr ("defs", eqextr_defs) |
1308 add_defgen ("clsdecl", defgen_clsdecl) #> |
1297 #> add_defgen ("funs", defgen_funs) |
1309 add_defgen ("funs", defgen_funs) #> |
1298 #> add_defgen ("clsdecl", defgen_clsdecl) |
1310 add_defgen ("clsmem", defgen_clsmem) #> |
1299 #> add_defgen ("clsmem", defgen_clsmem) |
1311 add_defgen ("datatypecons", defgen_datatypecons)); |
1300 #> add_defgen ("clsinst", defgen_clsinst) |
1312 |
1301 #> add_defgen ("datatypecons", defgen_datatypecons) |
1313 (* add_appconst_i ("op =", ((2, 2), appgen_eq)) *) |
1302 (* add_appconst_i ("op =", ((2, 2), appgen_eq)) *) |
1314 (* add_defgen ("clsinst", defgen_clsinst) *) |
1303 ); |
1315 |
1304 |
1316 end; (* local *) |
1305 end; (* local *) |
1317 |
1306 |
1318 end; (* struct *) |
1307 end; (* struct *) |