tuned;
authorwenzelm
Mon, 11 Apr 2016 11:48:24 +0200
changeset 62952 85c6c2a1952d
parent 62947 3374f3ffb2ec
child 62953 48d935524988
tuned;
src/HOL/Tools/code_evaluation.ML
src/Pure/Isar/class_declaration.ML
src/Pure/Syntax/syntax_phases.ML
--- a/src/HOL/Tools/code_evaluation.ML	Sun Apr 10 23:15:34 2016 +0200
+++ b/src/HOL/Tools/code_evaluation.ML	Mon Apr 11 11:48:24 2016 +0200
@@ -165,9 +165,9 @@
       | NONE => NONE)
   | subst_termify t = subst_termify_app (strip_comb t) 
 
-fun check_termify _ ts = the_default ts (map_default subst_termify ts);
+fun check_termify ts = the_default ts (map_default subst_termify ts);
 
-val _ = Context.>> (Syntax_Phases.term_check 0 "termify" check_termify);
+val _ = Context.>> (Syntax_Phases.term_check 0 "termify" (K check_termify));
 
 
 (** evaluation **)
--- a/src/Pure/Isar/class_declaration.ML	Sun Apr 10 23:15:34 2016 +0200
+++ b/src/Pure/Isar/class_declaration.ML	Mon Apr 11 11:48:24 2016 +0200
@@ -107,7 +107,6 @@
 
 fun prep_class_elems prep_decl thy sups raw_elems =
   let
-
     (* user space type system: only permits 'a type variable, improves towards 'a *)
     val algebra = Sign.classes_of thy;
     val inter_sort = curry (Sorts.inter_sort algebra);
@@ -118,7 +117,7 @@
     val base_constraints = (map o apsnd)
       (map_type_tfree (K (TVar ((Name.aT, 0), proto_base_sort))) o fst o fst o snd)
         (Class.these_operations thy sups);
-    fun singleton_fixateT Ts =
+    val singleton_fixate = burrow_types (fn Ts =>
       let
         val tfrees = fold Term.add_tfreesT Ts [];
         val inferred_sort =
@@ -140,9 +139,8 @@
       in
         (map o map_atyps)
           (fn T as TVar (xi, _) => if Type_Infer.is_param xi then fixateT else T | T => T) Ts
-      end;
-    fun singleton_fixate _ ts = burrow_types singleton_fixateT ts;
-    fun unify_params ctxt ts =
+      end);
+    fun unify_params ts =
       let
         val param_Ts = (fold o fold_aterms)
           (fn Free (v, T) => if is_param v then fold_atyps (insert (op =)) T else I | _ => I) ts [];
@@ -162,10 +160,10 @@
     val init_class_body =
       fold (Proof_Context.add_const_constraint o apsnd SOME) base_constraints
       #> Class.redeclare_operations thy sups
-      #> Context.proof_map (Syntax_Phases.term_check 0 "singleton_fixate" singleton_fixate);
+      #> Context.proof_map (Syntax_Phases.term_check 0 "singleton_fixate" (K singleton_fixate));
     val ((raw_supparams, _, raw_inferred_elems, _), _) =
       Proof_Context.init_global thy
-      |> Context.proof_map (Syntax_Phases.term_check 0 "unify_params" unify_params)
+      |> Context.proof_map (Syntax_Phases.term_check 0 "unify_params" (K unify_params))
       |> prep_decl raw_supexpr init_class_body raw_elems;
     fun filter_element (Element.Fixes []) = NONE
       | filter_element (e as Element.Fixes _) = SOME e
--- a/src/Pure/Syntax/syntax_phases.ML	Sun Apr 10 23:15:34 2016 +0200
+++ b/src/Pure/Syntax/syntax_phases.ML	Mon Apr 11 11:48:24 2016 +0200
@@ -970,18 +970,7 @@
 end;
 
 
-(* standard phases *)
-
-val _ = Context.>>
- (typ_check 0 "standard" Proof_Context.standard_typ_check #>
-  term_check 0 "standard"
-    (fn ctxt => Type_Infer_Context.infer_types ctxt #> map (Proof_Context.expand_abbrevs ctxt)) #>
-  term_check 100 "standard_finish" Proof_Context.standard_term_check_finish #>
-  term_uncheck 0 "standard" Proof_Context.standard_term_uncheck);
-
-
-
-(** install operations **)
+(* install operations *)
 
 val _ =
   Theory.setup
@@ -1000,3 +989,13 @@
       uncheck_terms = uncheck_terms});
 
 end;
+
+
+(* standard phases *)
+
+val _ = Context.>>
+ (Syntax_Phases.typ_check 0 "standard" Proof_Context.standard_typ_check #>
+  Syntax_Phases.term_check 0 "standard"
+    (fn ctxt => Type_Infer_Context.infer_types ctxt #> map (Proof_Context.expand_abbrevs ctxt)) #>
+  Syntax_Phases.term_check 100 "standard_finish" Proof_Context.standard_term_check_finish #>
+  Syntax_Phases.term_uncheck 0 "standard" Proof_Context.standard_term_uncheck);