clarified standardization of variables, with proper treatment of local variables;
authorwenzelm
Thu, 20 Sep 2018 22:39:39 +0200
changeset 69023 cef000855cf4
parent 69019 a6ba77af6486
child 69024 287bb00371c1
clarified standardization of variables, with proper treatment of local variables; tuned signature; tuned;
src/Pure/Thy/export_theory.ML
src/Pure/Thy/export_theory.scala
src/Pure/drule.ML
src/Pure/logic.ML
src/Pure/term_subst.ML
--- a/src/Pure/Thy/export_theory.ML	Wed Sep 19 22:18:36 2018 +0200
+++ b/src/Pure/Thy/export_theory.ML	Thu Sep 20 22:39:39 2018 +0200
@@ -1,7 +1,7 @@
 (*  Title:      Pure/Thy/export_theory.ML
     Author:     Makarius
 
-Export foundational theory content.
+Export foundational theory content and locale/class structure.
 *)
 
 signature EXPORT_THEORY =
@@ -13,28 +13,63 @@
 structure Export_Theory: EXPORT_THEORY =
 struct
 
-(* names for bound variables *)
+(* standardization of variables: only frees and named bounds *)
 
 local
-  fun declare_names (Abs (_, _, b)) = declare_names b
-    | declare_names (t $ u) = declare_names t #> declare_names u
-    | declare_names (Const (c, _)) = Name.declare (Long_Name.base_name c)
-    | declare_names (Free (x, _)) = Name.declare x
-    | declare_names _ = I;
+
+fun declare_names (Abs (_, _, b)) = declare_names b
+  | declare_names (t $ u) = declare_names t #> declare_names u
+  | declare_names (Const (c, _)) = Name.declare (Long_Name.base_name c)
+  | declare_names (Free (x, _)) = Name.declare x
+  | declare_names _ = I;
+
+fun variant_abs bs (Abs (x, T, t)) =
+      let
+        val names = fold Name.declare bs (declare_names t Name.context);
+        val x' = #1 (Name.variant x names);
+        val t' = variant_abs (x' :: bs) t;
+      in Abs (x', T, t') end
+  | variant_abs bs (t $ u) = variant_abs bs t $ variant_abs bs u
+  | variant_abs _ t = t;
+
+in
+
+fun standard_vars used =
+  let
+    fun zero_var_indexes tm =
+      Term_Subst.instantiate (Term_Subst.zero_var_indexes_inst used [tm]) tm;
 
-  fun variant_abs bs (Abs (x, T, t)) =
-        let
-          val names = fold Name.declare bs (declare_names t Name.context);
-          val x' = #1 (Name.variant x names);
-          val t' = variant_abs (x' :: bs) t;
-        in Abs (x', T, t') end
-    | variant_abs bs (t $ u) = variant_abs bs t $ variant_abs bs u
-    | variant_abs _ t = t;
-in
-  val named_bounds = variant_abs [];
+    fun unvarifyT ty = ty |> Term.map_atyps
+      (fn TVar ((a, _), S) => TFree (a, S)
+        | T as TFree (a, _) =>
+            if Name.is_declared used a then T
+            else raise TYPE (Logic.bad_fixed a, [ty], []));
+
+    fun unvarify tm = tm |> Term.map_aterms
+      (fn Var ((x, _), T) => Free (x, T)
+        | t as Free (x, _) =>
+            if Name.is_declared used x then t
+            else raise TERM (Logic.bad_fixed x, [tm])
+        | t => t);
+
+  in zero_var_indexes #> map_types unvarifyT #> unvarify #> variant_abs [] end;
+
+val standard_vars_global = standard_vars Name.context;
+
 end;
 
 
+(* free variables: not declared in the context *)
+
+val is_free = not oo Name.is_declared;
+
+fun add_frees used =
+  fold_aterms (fn Free (x, T) => is_free used x ? insert (op =) (x, T) | _ => I);
+
+fun add_tfrees used =
+  (fold_types o fold_atyps) (fn TFree (a, S) => is_free used a ? insert (op =) (a, S) | _ => I);
+
+
 (* locale support *)
 
 fun locale_axioms thy loc =
@@ -141,55 +176,58 @@
     (* consts *)
 
     val encode_const =
-      let open XML.Encode Term_XML.Encode in
-        pair (option encode_infix) (pair (list string) (pair typ (option (term o named_bounds))))
-      end;
+      let open XML.Encode Term_XML.Encode
+      in pair (option encode_infix) (pair (list string) (pair typ (option term))) end;
 
     fun export_const c (T, abbrev) =
       let
         val syntax = get_infix_const thy_ctxt c;
         val T' = T |> Logic.unvarifyT_global |> Type.strip_sorts;
-        val abbrev' = abbrev |> Option.map (Logic.unvarify_global #> map_types Type.strip_sorts);
+        val abbrev' = abbrev |> Option.map (standard_vars_global #> map_types Type.strip_sorts);
         val args = map (#1 o dest_TFree) (Consts.typargs (Sign.consts_of thy) (c, T'));
-      in SOME (encode_const (syntax, (args, (T', abbrev')))) end;
+      in encode_const (syntax, (args, (T', abbrev'))) end;
 
     val _ =
-      export_entities "consts" export_const Sign.const_space
+      export_entities "consts" (SOME oo export_const) Sign.const_space
         (#constants (Consts.dest (Sign.consts_of thy)));
 
 
     (* axioms and facts *)
 
-    fun standard_prop_of raw_thm =
+    fun prop_of raw_thm =
       let
         val thm = raw_thm
           |> Thm.transfer thy
           |> Thm.check_hyps (Context.Theory thy)
           |> Thm.strip_shyps;
         val prop = thm
-          |> Thm.full_prop_of
-          |> Term_Subst.zero_var_indexes;
+          |> Thm.full_prop_of;
       in (Thm.extra_shyps thm, prop) end;
 
-    fun encode_prop (Ss, prop) =
+    fun encode_prop used (Ss, raw_prop) =
       let
-        val prop' = Logic.unvarify_global (named_bounds prop);
-        val typargs = rev (Term.add_tfrees prop' []);
-        val sorts = Name.invent (Name.make_context (map #1 typargs)) Name.aT (length Ss) ~~ Ss;
-        val args = rev (Term.add_frees prop' []);
+        val prop = standard_vars used raw_prop;
+        val args = rev (add_frees used prop []);
+        val typargs = rev (add_tfrees used prop []);
+        val used' = fold (Name.declare o #1) typargs used;
+        val sorts = Name.invent used' Name.aT (length Ss) ~~ Ss;
       in
-        (sorts @ typargs, args, prop') |>
+        (sorts @ typargs, args, prop) |>
           let open XML.Encode Term_XML.Encode
           in triple (list (pair string sort)) (list (pair string typ)) term end
       end;
 
-    val encode_fact = XML.Encode.list encode_prop o map standard_prop_of;
+    fun encode_axiom used t = encode_prop used ([], t);
+
+    val encode_fact_single = encode_prop Name.context o prop_of;
+    val encode_fact_multi = XML.Encode.list (encode_prop Name.context) o map prop_of;
 
     val _ =
-      export_entities "axioms" (fn _ => fn t => SOME (encode_prop ([], t))) Theory.axiom_space
-        (Theory.axioms_of thy);
+      export_entities "axioms" (fn _ => fn t => SOME (encode_axiom Name.context t))
+        Theory.axiom_space (Theory.axioms_of thy);
     val _ =
-      export_entities "facts" (K (SOME o encode_fact)) (Facts.space_of o Global_Theory.facts_of)
+      export_entities "facts" (K (SOME o encode_fact_multi))
+        (Facts.space_of o Global_Theory.facts_of)
         (Facts.dest_static true [] (Global_Theory.facts_of thy));
 
 
@@ -197,13 +235,12 @@
 
     val encode_class =
       let open XML.Encode Term_XML.Encode
-      in pair (list (pair string typ)) (list (term o named_bounds)) end;
+      in pair (list (pair string typ)) (list encode_fact_single) end;
 
     fun export_class name =
       (case try (Axclass.get_info thy) name of
         NONE => ([], [])
-      | SOME {params, axioms, ...} =>
-          (params, map (Logic.unvarify_global o Thm.full_prop_of) axioms))
+      | SOME {params, axioms, ...} => (params, axioms))
       |> encode_class |> SOME;
 
     val _ =
@@ -231,18 +268,20 @@
 
     (* locales *)
 
-    fun encode_locale loc ({type_params, params, ...}: Locale.content) =
+    fun encode_locale used =
+      let open XML.Encode Term_XML.Encode
+      in triple (list (pair string sort)) (list (pair string typ)) (list (encode_axiom used)) end;
+
+    fun export_locale loc ({type_params, params, ...}: Locale.content) =
       let
         val axioms = locale_axioms thy loc;
         val args = map #1 params;
-        val typargs = type_params @ rev (fold Term.add_tfrees (map Free args @ axioms) []);
-        val encode =
-          let open XML.Encode Term_XML.Encode
-          in triple (list (pair string sort)) (list (pair string typ)) (list term) end;
-      in encode (typargs, args, axioms) end;
+        val typargs = rev (fold Term.add_tfrees (map Free args @ axioms) (rev type_params));
+        val used = fold Name.declare (map #1 typargs @ map #1 args) Name.context;
+      in encode_locale used (typargs, args, axioms) end;
 
     val _ =
-      export_entities "locales" (SOME oo encode_locale) Locale.locale_space
+      export_entities "locales" (SOME oo export_locale) Locale.locale_space
         (Locale.dest_locales thy);
 
 
--- a/src/Pure/Thy/export_theory.scala	Wed Sep 19 22:18:36 2018 +0200
+++ b/src/Pure/Thy/export_theory.scala	Thu Sep 20 22:39:39 2018 +0200
@@ -328,12 +328,12 @@
   /* type classes */
 
   sealed case class Class(
-    entity: Entity, params: List[(String, Term.Typ)], axioms: List[Term.Term])
+    entity: Entity, params: List[(String, Term.Typ)], axioms: List[Prop])
   {
     def cache(cache: Term.Cache): Class =
       Class(entity.cache(cache),
         params.map({ case (name, typ) => (cache.string(name), cache.typ(typ)) }),
-        axioms.map(cache.term(_)))
+        axioms.map(_.cache(cache)))
   }
 
   def read_classes(provider: Export.Provider): List[Class] =
@@ -344,7 +344,7 @@
         {
           import XML.Decode._
           import Term_XML.Decode._
-          pair(list(pair(string, typ)), list(term))(body)
+          pair(list(pair(string, typ)), list(decode_prop))(body)
         }
         Class(entity, params, axioms)
       })
@@ -356,13 +356,13 @@
     entity: Entity,
     typargs: List[(String, Term.Sort)],
     args: List[(String, Term.Typ)],
-    axioms: List[Term.Term])
+    axioms: List[Prop])
   {
     def cache(cache: Term.Cache): Locale =
       Locale(entity.cache(cache),
         typargs.map({ case (name, sort) => (cache.string(name), cache.sort(sort)) }),
         args.map({ case (name, typ) => (cache.string(name), cache.typ(typ)) }),
-        axioms.map(cache.term(_)))
+        axioms.map(_.cache(cache)))
   }
 
   def read_locales(provider: Export.Provider): List[Locale] =
@@ -373,7 +373,7 @@
         {
           import XML.Decode._
           import Term_XML.Decode._
-          triple(list(pair(string, sort)), list(pair(string, typ)), list(term))(body)
+          triple(list(pair(string, sort)), list(pair(string, typ)), list(decode_prop))(body)
         }
         Locale(entity, typargs, args, axioms)
       })
--- a/src/Pure/drule.ML	Wed Sep 19 22:18:36 2018 +0200
+++ b/src/Pure/drule.ML	Thu Sep 20 22:39:39 2018 +0200
@@ -220,7 +220,8 @@
 fun zero_var_indexes_list [] = []
   | zero_var_indexes_list ths =
       let
-        val (instT, inst) = Term_Subst.zero_var_indexes_inst (map Thm.full_prop_of ths);
+        val (instT, inst) =
+          Term_Subst.zero_var_indexes_inst Name.context (map Thm.full_prop_of ths);
 
         val tvars = fold Thm.add_tvars ths [];
         fun the_tvar v = the (find_first (fn cT => v = dest_TVar (Thm.typ_of cT)) tvars);
--- a/src/Pure/logic.ML	Wed Sep 19 22:18:36 2018 +0200
+++ b/src/Pure/logic.ML	Thu Sep 20 22:39:39 2018 +0200
@@ -80,6 +80,8 @@
   val list_rename_params: string list -> term -> term
   val assum_pairs: int * term -> (term * term) list
   val assum_problems: int * term -> (term -> term) * term list * term
+  val bad_schematic: indexname -> string
+  val bad_fixed: string -> string
   val varifyT_global: typ -> typ
   val unvarifyT_global: typ -> typ
   val varify_types_global: term -> term
--- a/src/Pure/term_subst.ML	Wed Sep 19 22:18:36 2018 +0200
+++ b/src/Pure/term_subst.ML	Thu Sep 20 22:39:39 2018 +0200
@@ -29,7 +29,7 @@
   val instantiateT: ((indexname * sort) * typ) list -> typ -> typ
   val instantiate: ((indexname * sort) * typ) list * ((indexname * typ) * term) list ->
     term -> term
-  val zero_var_indexes_inst: term list ->
+  val zero_var_indexes_inst: Name.context -> term list ->
     ((indexname * sort) * typ) list * ((indexname * typ) * term) list
   val zero_var_indexes: term -> term
   val zero_var_indexes_list: term list -> term list
@@ -211,21 +211,21 @@
     val (x', used') = Name.variant (if Name.is_bound x then "u" else x) used;
   in if x = x' andalso i = 0 then (inst, used') else ((v, mk ((x', 0), X)) :: inst, used') end;
 
-fun zero_var_indexes_inst ts =
+fun zero_var_indexes_inst used ts =
   let
     val (instT, _) =
       TVars.fold (zero_var_inst TVar o #1)
         ((fold o fold_types o fold_atyps) (fn TVar v =>
           TVars.insert (K true) (v, ()) | _ => I) ts TVars.empty)
-        ([], Name.context);
+        ([], used);
     val (inst, _) =
       Vars.fold (zero_var_inst Var o #1)
         ((fold o fold_aterms) (fn Var (xi, T) =>
           Vars.insert (K true) ((xi, instantiateT instT T), ()) | _ => I) ts Vars.empty)
-        ([], Name.context);
+        ([], used);
   in (instT, inst) end;
 
-fun zero_var_indexes_list ts = map (instantiate (zero_var_indexes_inst ts)) ts;
+fun zero_var_indexes_list ts = map (instantiate (zero_var_indexes_inst Name.context ts)) ts;
 val zero_var_indexes = singleton zero_var_indexes_list;
 
 end;