permissive declaration attribute "relator_mono", e.g. relevant for Binomial-Heaps.BinomialHeap with -o export_theory;
authorwenzelm
Sun, 30 Sep 2018 12:50:28 +0200
changeset 69091 ce62fd14961a
parent 69090 1b656a2ec0ad
child 69092 854bd35cad49
permissive declaration attribute "relator_mono", e.g. relevant for Binomial-Heaps.BinomialHeap with -o export_theory;
src/HOL/Tools/Lifting/lifting_info.ML
--- a/src/HOL/Tools/Lifting/lifting_info.ML	Sun Sep 30 12:40:57 2018 +0200
+++ b/src/HOL/Tools/Lifting/lifting_info.ML	Sun Sep 30 12:50:28 2018 +0200
@@ -384,16 +384,22 @@
     val pol_mono_rule = introduce_polarities mono_rule
     val mono_ruleT_name = (fst o dest_Type o fst o relation_types o fst o relation_types o snd o
       dest_Const o head_of o HOLogic.dest_Trueprop o Thm.concl_of) pol_mono_rule
-    val _ = if Symtab.defined (get_relator_distr_data' ctxt) mono_ruleT_name
-      then error ("Monotonicity rule for type " ^ quote mono_ruleT_name ^ " is already_defined.")
-      else ()
-    val neg_mono_rule = negate_mono_rule pol_mono_rule
-    val relator_distr_data = {pos_mono_rule = pol_mono_rule, neg_mono_rule = neg_mono_rule,
-      pos_distr_rules = [], neg_distr_rules = []}
   in
-    ctxt
-    |> Data.map (map_relator_distr_data (Symtab.update (mono_ruleT_name, relator_distr_data)))
-    |> add_reflexivity_rules mono_rule
+    if Symtab.defined (get_relator_distr_data' ctxt) mono_ruleT_name
+    then
+      (if Context_Position.is_visible_generic ctxt then
+        warning ("Monotonicity rule for type " ^ quote mono_ruleT_name ^ " is already_defined.")
+       else (); ctxt)
+    else
+      let
+        val neg_mono_rule = negate_mono_rule pol_mono_rule
+        val relator_distr_data = {pos_mono_rule = pol_mono_rule, neg_mono_rule = neg_mono_rule,
+          pos_distr_rules = [], neg_distr_rules = []}
+      in
+        ctxt
+        |> Data.map (map_relator_distr_data (Symtab.update (mono_ruleT_name, relator_distr_data)))
+        |> add_reflexivity_rules mono_rule
+      end
   end;
 
 local