# HG changeset patch
# User haftmann
# Date 1255354000 -7200
# Node ID 5f7386f7cbe6fb31c5f98fc1c73deb40719ff5db
# Parent  0300f8dd63ea073e0088d0f66b862102ced531c7
dropped dist_ss

diff -r 0300f8dd63ea -r 5f7386f7cbe6 src/HOL/Tools/Datatype/datatype.ML
--- a/src/HOL/Tools/Datatype/datatype.ML	Mon Oct 12 13:40:28 2009 +0200
+++ b/src/HOL/Tools/Datatype/datatype.ML	Mon Oct 12 15:26:40 2009 +0200
@@ -20,6 +20,7 @@
     -> descr * (string * sort) list * string list
       * string * (string list * string list) * (typ list * typ list)
   val the_spec : theory -> string -> (string * sort) list * (string * typ list) list
+  val all_distincts : theory -> typ list -> thm list list
   val get_constrs : theory -> string -> (string * typ) list option
   val get_all : theory -> info Symtab.table
   val info_of_constr : theory -> string * typ -> info option
@@ -136,6 +137,13 @@
 
   in (descr, vs, tycos, prefix, (names, auxnames), (Ts, Us)) end;
 
+fun all_distincts thy Ts =
+  let
+    fun add_tycos (Type (tyco, Ts)) = insert (op =) tyco #> fold add_tycos Ts
+      | add_tycos _ = I;
+    val tycos = fold add_tycos Ts [];
+  in map_filter (Option.map #distinct o get_info thy) tycos end;
+
 fun get_constrs thy dtco =
   case try (the_spec thy) dtco
    of SOME (sorts, cos) =>
@@ -191,8 +199,6 @@
 val distinct_simproc =
   Simplifier.simproc @{theory HOL} distinctN ["s = t"] distinct_proc;
 
-val dist_ss = HOL_ss addsimprocs [distinct_simproc];
-
 val simproc_setup =
   Simplifier.map_simpset (fn ss => ss addsimprocs [distinct_simproc]);
 
@@ -328,13 +334,16 @@
     val new_type_names = map Long_Name.base_name (the_default dt_names alt_names);
     val _ = message config ("Deriving properties for datatype(s) " ^ commas_quote new_type_names);
 
+    val other_distincts = all_distincts thy2 (get_rec_types flat_descr sorts);
+
     val (exhaust, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names
       descr sorts induct (mk_case_names_exhausts flat_descr dt_names) thy2;
     val (nchotomys, thy4) = DatatypeAbsProofs.prove_nchotomys config new_type_names
       descr sorts exhaust thy3;
     val ((rec_names, rec_rewrites), thy5) = DatatypeAbsProofs.prove_primrec_thms
       config new_type_names descr sorts (#inject o the o Symtab.lookup (get_all thy4))
-      inject distinct (Simplifier.theory_context thy4 dist_ss) induct thy4;
+      inject distinct (Simplifier.theory_context thy4 (HOL_basic_ss addsimps (flat other_distincts)))
+      induct thy4;
     val ((case_rewrites, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
       config new_type_names descr sorts rec_names rec_rewrites thy5;
     val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names