src/Pure/Isar/code.ML
changeset 35304 57b6cc52c14c
parent 35299 4f4d5bf4ea08
child 35370 997a23ae1aa0
equal deleted inserted replaced
35303:816e48d60b13 35304:57b6cc52c14c
  1099       case these (Symtab.lookup ((the_types o the_exec) thy) tyco)
  1099       case these (Symtab.lookup ((the_types o the_exec) thy) tyco)
  1100        of (_, (_, Constructors cos)) :: _ => (map fst cos, NONE)
  1100        of (_, (_, Constructors cos)) :: _ => (map fst cos, NONE)
  1101         | (_, (_, Abstractor (_, (co, _)))) :: _ => ([], SOME co)
  1101         | (_, (_, Abstractor (_, (co, _)))) :: _ => ([], SOME co)
  1102         | [] => ([], NONE)
  1102         | [] => ([], NONE)
  1103     val outdated_funs = case some_old_proj
  1103     val outdated_funs = case some_old_proj
  1104      of NONE => []
  1104      of NONE => old_constrs
  1105       | SOME old_proj => Symtab.fold
  1105       | SOME old_proj => Symtab.fold
  1106           (fn (c, ((_, spec), _)) => if member (op =) (the_list (associated_abstype spec)) tyco
  1106           (fn (c, ((_, spec), _)) => if member (op =) (the_list (associated_abstype spec)) tyco
  1107             then insert (op =) c else I)
  1107             then insert (op =) c else I)
  1108             ((the_functions o the_exec) thy) [old_proj];
  1108             ((the_functions o the_exec) thy) (old_proj :: old_constrs);
  1109     fun drop_outdated_cases cases = fold Symtab.delete_safe
  1109     fun drop_outdated_cases cases = fold Symtab.delete_safe
  1110       (Symtab.fold (fn (c, (_, (_, cos))) =>
  1110       (Symtab.fold (fn (c, (_, (_, cos))) =>
  1111         if exists (member (op =) old_constrs) cos
  1111         if exists (member (op =) old_constrs) cos
  1112           then insert (op =) c else I) cases []) cases;
  1112           then insert (op =) c else I) cases []) cases;
  1113   in
  1113   in
  1149 fun add_abstype proto_abs proto_rep thy =
  1149 fun add_abstype proto_abs proto_rep thy =
  1150   let
  1150   let
  1151     val (abs, rep) = pairself (unoverload_const_typ thy) (proto_abs, proto_rep);
  1151     val (abs, rep) = pairself (unoverload_const_typ thy) (proto_abs, proto_rep);
  1152     val (tyco, (vs, (abs_ty as (abs, ty), (rep, cert_prop)))) = abstype_cert thy abs (fst rep);
  1152     val (tyco, (vs, (abs_ty as (abs, ty), (rep, cert_prop)))) = abstype_cert thy abs (fst rep);
  1153     fun after_qed [[cert]] = ProofContext.theory
  1153     fun after_qed [[cert]] = ProofContext.theory
  1154       (register_type (tyco, (vs, Abstractor (abs_ty, (rep, cert))))
  1154       (del_eqns abs
       
  1155       #> register_type (tyco, (vs, Abstractor (abs_ty, (rep, cert))))
  1155       #> change_fun_spec false rep ((K o Proj)
  1156       #> change_fun_spec false rep ((K o Proj)
  1156         (map_types Logic.varifyT (mk_proj tyco vs ty abs rep), tyco))
  1157         (map_types Logic.varifyT (mk_proj tyco vs ty abs rep), tyco))
  1157       #> Abstype_Interpretation.data (tyco, serial ()));
  1158       #> Abstype_Interpretation.data (tyco, serial ()));
  1158   in
  1159   in
  1159     thy
  1160     thy