misc tuning and clarification;
authorwenzelm
Fri, 17 Jan 2025 17:01:43 +0100
changeset 81861 1ba251e1847e
parent 81860 dab84266c85a
child 81862 c712ecb51474
misc tuning and clarification;
src/HOL/Import/import_rule.ML
--- a/src/HOL/Import/import_rule.ML	Fri Jan 17 16:49:01 2025 +0100
+++ b/src/HOL/Import/import_rule.ML	Fri Jan 17 17:01:43 2025 +0100
@@ -70,9 +70,8 @@
     val t2c = Thm.dest_arg (strip_imp_concl (Thm.cprop_of th2))
     val (cf, cg) = Thm.dest_binop t1c
     val (cx, cy) = Thm.dest_binop t2c
-    val [fd, fr] = Thm.dest_ctyp (Thm.ctyp_of_cterm cf)
-    val i1 = Thm.instantiate' [SOME fd, SOME fr]
-      [SOME cf, SOME cg, SOME cx, SOME cy] @{thm cong}
+    val [A, B] = Thm.dest_ctyp (Thm.ctyp_of_cterm cf)
+    val i1 = Thm.instantiate' [SOME A, SOME B] [SOME cf, SOME cg, SOME cx, SOME cy] @{thm cong}
     val i2 = meta_mp i1 th1
   in
     meta_mp i2 th2
@@ -190,30 +189,25 @@
   | NONE => error ("Constant mapped, but no definition: " ^ quote name)
 
 fun def c rhs thy =
-  case Import_Data.get_const_def thy c of
-    SOME _ =>
-      let
-        val () = warning ("Const mapped, but def provided: " ^ quote c)
-      in
-        (mdef thy c, thy)
-      end
-  | NONE => def' c (Thm.term_of rhs) thy
+  if is_some (Import_Data.get_const_def thy c) then
+    (warning ("Const mapped, but def provided: " ^ quote c); (mdef thy c, thy))
+  else def' c (Thm.term_of rhs) thy
 
-fun typedef_hol2hollight nty oty rep abs pred a r =
-  Thm.instantiate' [SOME nty, SOME oty] [SOME rep, SOME abs, SOME pred, SOME a, SOME r]
+fun typedef_hol2hollight A B rep abs pred a r =
+  Thm.instantiate' [SOME A, SOME B] [SOME rep, SOME abs, SOME pred, SOME a, SOME r]
     @{lemma "type_definition Rep Abs (Collect P) \<Longrightarrow> Abs (Rep a) = a \<and> P r = (Rep (Abs r) = r)"
         by (metis type_definition.Rep_inverse type_definition.Abs_inverse
               type_definition.Rep mem_Collect_eq)}
 
-fun typedef_hollight thy th =
+fun typedef_hollight th =
   let
     val (th_s, cn) = Thm.dest_comb (Thm.dest_arg (Thm.cprop_of th))
     val (th_s, abst) = Thm.dest_comb th_s
     val rept = Thm.dest_arg th_s
     val P = Thm.dest_arg cn
-    val [nty, oty] = Thm.dest_ctyp (Thm.ctyp_of_cterm rept)
+    val [A, B] = Thm.dest_ctyp (Thm.ctyp_of_cterm rept)
   in
-    typedef_hol2hollight nty oty rept abst P (Thm.free ("a", nty)) (Thm.free ("r", oty))
+    typedef_hol2hollight A B rept abst P (Thm.free ("a", A)) (Thm.free ("r", B))
   end
 
 fun tydef' tycname abs_name rep_name cP ct td_th thy =
@@ -239,19 +233,17 @@
        (SOME typedef_bindings) (fn ctxt => resolve_tac ctxt [th2] 1)) thy
     val aty = Thm.global_ctyp_of thy' (#abs_type (#1 typedef_info))
     val th = freezeT thy' (#type_definition (#2 typedef_info))
-    val (th_s, _) = Thm.dest_comb (Thm.dest_arg (Thm.cprop_of th))
-    val (th_s, abst) = Thm.dest_comb th_s
-    val rept = Thm.dest_arg th_s
-    val [nty, oty] = Thm.dest_ctyp (Thm.ctyp_of_cterm rept)
-    val typedef_th =
-      typedef_hol2hollight nty oty rept abst cP (Thm.free ("a", aty)) (Thm.free ("r", ctT))
+    val (th_s, abs) = Thm.dest_comb (#1 (Thm.dest_comb (Thm.dest_arg (Thm.cprop_of th))))
+    val rep = Thm.dest_arg th_s
+    val [A, B] = Thm.dest_ctyp (Thm.ctyp_of_cterm rep)
+    val typedef_th = typedef_hol2hollight A B rep abs cP (Thm.free ("a", aty)) (Thm.free ("r", ctT))
   in
     (typedef_th OF [#type_definition (#2 typedef_info)], thy')
   end
 
 fun mtydef thy name =
   case Import_Data.get_typ_def thy name of
-    SOME thn => meta_mp (typedef_hollight thy thn) thn
+    SOME thn => meta_mp (typedef_hollight thn) thn
   | NONE => error ("Type mapped, but no tydef thm registered: " ^ quote name)
 
 fun tydef tycname abs_name rep_name P t td_th thy =