redundancy checkes includes eta-expansion
authorhaftmann
Fri, 10 Nov 2006 07:37:36 +0100
changeset 21284 36613fe4cf05
parent 21283 b15355b9a59d
child 21285 ee8cafbcb506
redundancy checkes includes eta-expansion
src/Pure/Tools/codegen_data.ML
--- a/src/Pure/Tools/codegen_data.ML	Fri Nov 10 07:37:35 2006 +0100
+++ b/src/Pure/Tools/codegen_data.ML	Fri Nov 10 07:37:36 2006 +0100
@@ -248,12 +248,16 @@
 fun add_drop_redundant thm thms =
   let
     val thy = Context.check_thy (Thm.theory_of_thm thm);
-    val pattern = (fst o Logic.dest_equals o Drule.plain_prop_of) thm;
-    fun matches thm' = if (curry (Pattern.matches thy) pattern o
-      fst o Logic.dest_equals o Drule.plain_prop_of) thm'
-      then (warning ("Dropping redundant function theorem\n" ^ string_of_thm thm'); true)
-      else false
-  in thm :: filter_out matches thms end;
+    val args_of = snd o strip_comb o fst o Logic.dest_equals o Drule.plain_prop_of;
+    val args = args_of thm;
+    fun matches [] _ = true
+      | matches (Var _ :: xs) [] = matches xs []
+      | matches (_ :: _) [] = false
+      | matches (x :: xs) (y :: ys) = Pattern.matches thy (x, y) andalso matches xs ys;
+    fun drop thm' = if matches args (args_of thm')
+      then (warning ("Dropping redundant function theorem\n" ^ string_of_thm thm'); false)
+      else true
+  in thm :: filter drop thms end;
 
 fun add_thm thm (sels, dels) =
   (Susp.value (add_drop_redundant thm (Susp.force sels)), remove eq_thm thm dels);