misc tuning and clarification;
authorwenzelm
Fri, 11 Oct 2019 21:23:06 +0200
changeset 70836 44efbf252525
parent 70835 2d991e01a671
child 70837 874092c031c3
misc tuning and clarification;
src/Pure/Proof/extraction.ML
src/Pure/Proof/proof_rewrite_rules.ML
--- a/src/Pure/Proof/extraction.ML	Fri Oct 11 19:35:59 2019 +0200
+++ b/src/Pure/Proof/extraction.ML	Fri Oct 11 21:23:06 2019 +0200
@@ -529,7 +529,7 @@
       Logic.mk_of_sort (TVar (ixn, []), Sign.defaultS thy)) tye;
 
     fun mk_sprfs cs tye = maps (fn (_, T) =>
-      ProofRewriteRules.mk_of_sort_proof thy' (map SOME cs)
+      ProofRewriteRules.expand_of_sort_proof thy' (map SOME cs)
         (T, Sign.defaultS thy)) tye;
 
     fun find (vs: string list) = Option.map snd o find_first (curry (eq_set (op =)) vs o fst);
--- a/src/Pure/Proof/proof_rewrite_rules.ML	Fri Oct 11 19:35:59 2019 +0200
+++ b/src/Pure/Proof/proof_rewrite_rules.ML	Fri Oct 11 21:23:06 2019 +0200
@@ -14,7 +14,7 @@
   val elim_vars : (typ -> term) -> Proofterm.proof -> Proofterm.proof
   val hhf_proof : term -> term -> Proofterm.proof -> Proofterm.proof
   val un_hhf_proof : term -> term -> Proofterm.proof -> Proofterm.proof
-  val mk_of_sort_proof : theory -> term option list -> typ * sort -> Proofterm.proof list
+  val expand_of_sort_proof : theory -> term option list -> typ * sort -> Proofterm.proof list
   val expand_of_class : theory -> typ list -> term option list -> Proofterm.proof ->
     (Proofterm.proof * Proofterm.proof) option
 end;
@@ -342,33 +342,32 @@
 
 (**** expand OfClass proofs ****)
 
-fun mk_of_sort_proof thy hs (T, S) =
+fun expand_of_sort_proof thy hyps (T, S) =
   let
-    val hs' = map
-      (fn SOME t => (SOME (Logic.dest_of_class t) handle TERM _ => NONE)
-        | NONE => NONE) hs;
-    val sorts = AList.coalesce (op =) (rev (map_filter I hs'));
+    val of_class_hyps = map (fn SOME t => try Logic.dest_of_class t | NONE => NONE) hyps;
+    fun of_class_index p =
+      (case find_index (fn SOME h => h = p | NONE => false) of_class_hyps of
+        ~1 => raise Fail "expand_of_class_proof: missing class hypothesis"
+      | i => PBound i);
+
+    val sorts = AList.coalesce (op =) (rev (map_filter I of_class_hyps));
     fun get_sort T = the_default [] (AList.lookup (op =) sorts T);
     val subst = map_atyps
-      (fn T as TVar (ixn, _) => TVar (ixn, get_sort T)
-        | T as TFree (s, _) => TFree (s, get_sort T));
-    fun hyp T_c = case find_index (equal (SOME T_c)) hs' of
-        ~1 => error "expand_of_class: missing class hypothesis"
-      | i => PBound i;
-    fun reconstruct prf prop = prf |>
-      Proofterm.reconstruct_proof thy prop |>
-      Proofterm.expand_proof thy [("", NONE)] |>
-      Same.commit (Proofterm.map_proof_same Same.same Same.same hyp)
+      (fn T as TVar (ai, _) => TVar (ai, get_sort T)
+        | T as TFree (a, _) => TFree (a, get_sort T));
+
+    fun reconstruct prop =
+      Proofterm.reconstruct_proof thy prop #>
+      Proofterm.expand_proof thy [("", NONE)] #>
+      Same.commit (Proofterm.map_proof_same Same.same Same.same of_class_index);
   in
-    map2 reconstruct
+    map2 reconstruct (Logic.mk_of_sort (T, S))
       (Proofterm.of_sort_proof (Sign.classes_of thy) (Thm.classrel_proof thy) (Thm.arity_proof thy)
         (OfClass o apfst Type.strip_sorts) (subst T, S))
-      (Logic.mk_of_sort (T, S))
   end;
 
-fun expand_of_class thy Ts hs (OfClass (T, c)) =
-      mk_of_sort_proof thy hs (T, [c]) |>
-      hd |> rpair Proofterm.no_skel |> SOME
-  | expand_of_class thy Ts hs _ = NONE;
+fun expand_of_class thy (_: typ list) hs (OfClass (T, c)) =
+      SOME (expand_of_sort_proof thy hs (T, [c]) |> hd, Proofterm.no_skel)
+  | expand_of_class _ _ _ _ = NONE;
 
 end;