slightly more explicit/syntactic modelling of morphisms;
authorwenzelm
Fri Oct 28 15:38:41 2011 +0200 (2011-10-28)
changeset 4528925e9e7f527b4
parent 45288 fc3c7db5bb2f
child 45290 f599ac41e7f5
slightly more explicit/syntactic modelling of morphisms;
src/Pure/Isar/element.ML
src/Pure/Isar/expression.ML
src/Pure/assumption.ML
src/Pure/morphism.ML
src/Pure/variable.ML
     1.1 --- a/src/Pure/Isar/element.ML	Fri Oct 28 14:10:19 2011 +0200
     1.2 +++ b/src/Pure/Isar/element.ML	Fri Oct 28 15:38:41 2011 +0200
     1.3 @@ -397,10 +397,10 @@
     1.4  fun instT_morphism thy env =
     1.5    let val thy_ref = Theory.check_thy thy in
     1.6      Morphism.morphism
     1.7 -     {binding = I,
     1.8 -      typ = instT_type env,
     1.9 -      term = instT_term env,
    1.10 -      fact = map (fn th => instT_thm (Theory.deref thy_ref) env th)}
    1.11 +     {binding = [I],
    1.12 +      typ = [instT_type env],
    1.13 +      term = [instT_term env],
    1.14 +      fact = [map (fn th => instT_thm (Theory.deref thy_ref) env th)]}
    1.15    end;
    1.16  
    1.17  
    1.18 @@ -446,10 +446,10 @@
    1.19  fun inst_morphism thy envs =
    1.20    let val thy_ref = Theory.check_thy thy in
    1.21      Morphism.morphism
    1.22 -     {binding = I,
    1.23 -      typ = instT_type (#1 envs),
    1.24 -      term = inst_term envs,
    1.25 -      fact = map (fn th => inst_thm (Theory.deref thy_ref) envs th)}
    1.26 +     {binding = [],
    1.27 +      typ = [instT_type (#1 envs)],
    1.28 +      term = [inst_term envs],
    1.29 +      fact = [map (fn th => inst_thm (Theory.deref thy_ref) envs th)]}
    1.30    end;
    1.31  
    1.32  
    1.33 @@ -467,10 +467,10 @@
    1.34  (* rewriting with equalities *)
    1.35  
    1.36  fun eq_morphism thy thms = if null thms then NONE else SOME (Morphism.morphism
    1.37 - {binding = I,
    1.38 -  typ = I,
    1.39 -  term = Raw_Simplifier.rewrite_term thy thms [],
    1.40 -  fact = map (Raw_Simplifier.rewrite_rule thms)});
    1.41 + {binding = [],
    1.42 +  typ = [],
    1.43 +  term = [Raw_Simplifier.rewrite_term thy thms []],
    1.44 +  fact = [map (Raw_Simplifier.rewrite_rule thms)]});
    1.45  
    1.46  
    1.47  (* transfer to theory using closure *)
     2.1 --- a/src/Pure/Isar/expression.ML	Fri Oct 28 14:10:19 2011 +0200
     2.2 +++ b/src/Pure/Isar/expression.ML	Fri Oct 28 15:38:41 2011 +0200
     2.3 @@ -501,7 +501,8 @@
     2.4      val exp_fact = Drule.zero_var_indexes_list o map Thm.strip_shyps o Morphism.fact export;
     2.5      val exp_term = Term_Subst.zero_var_indexes o Morphism.term export;
     2.6      val exp_typ = Logic.type_map exp_term;
     2.7 -    val export' = Morphism.morphism {binding = I, typ = exp_typ, term = exp_term, fact = exp_fact};
     2.8 +    val export' =
     2.9 +      Morphism.morphism {binding = [], typ = [exp_typ], term = [exp_term], fact = [exp_fact]};
    2.10    in ((propss, deps, export'), goal_ctxt) end;
    2.11  
    2.12  in
     3.1 --- a/src/Pure/assumption.ML	Fri Oct 28 14:10:19 2011 +0200
     3.2 +++ b/src/Pure/assumption.ML	Fri Oct 28 15:38:41 2011 +0200
     3.3 @@ -124,6 +124,6 @@
     3.4      val thm = export false inner outer;
     3.5      val term = export_term inner outer;
     3.6      val typ = Logic.type_map term;
     3.7 -  in Morphism.morphism {binding = I, typ = typ, term = term, fact = map thm} end;
     3.8 +  in Morphism.morphism {binding = [], typ = [typ], term = [term], fact = [map thm]} end;
     3.9  
    3.10  end;
     4.1 --- a/src/Pure/morphism.ML	Fri Oct 28 14:10:19 2011 +0200
     4.2 +++ b/src/Pure/morphism.ML	Fri Oct 28 15:38:41 2011 +0200
     4.3 @@ -16,6 +16,7 @@
     4.4  signature MORPHISM =
     4.5  sig
     4.6    include BASIC_MORPHISM
     4.7 +  type 'a funs = ('a -> 'a) list
     4.8    val binding: morphism -> binding -> binding
     4.9    val typ: morphism -> typ -> typ
    4.10    val term: morphism -> term -> term
    4.11 @@ -23,10 +24,10 @@
    4.12    val thm: morphism -> thm -> thm
    4.13    val cterm: morphism -> cterm -> cterm
    4.14    val morphism:
    4.15 -   {binding: binding -> binding,
    4.16 -    typ: typ -> typ,
    4.17 -    term: term -> term,
    4.18 -    fact: thm list -> thm list} -> morphism
    4.19 +   {binding: binding funs,
    4.20 +    typ: typ funs,
    4.21 +    term: term funs,
    4.22 +    fact: thm list funs} -> morphism
    4.23    val binding_morphism: (binding -> binding) -> morphism
    4.24    val typ_morphism: (typ -> typ) -> morphism
    4.25    val term_morphism: (term -> term) -> morphism
    4.26 @@ -41,36 +42,39 @@
    4.27  structure Morphism: MORPHISM =
    4.28  struct
    4.29  
    4.30 +type 'a funs = ('a -> 'a) list;
    4.31 +fun apply fs = fold_rev (fn f => fn x => f x) fs;
    4.32 +
    4.33  datatype morphism = Morphism of
    4.34 - {binding: binding -> binding,
    4.35 -  typ: typ -> typ,
    4.36 -  term: term -> term,
    4.37 -  fact: thm list -> thm list};
    4.38 + {binding: binding funs,
    4.39 +  typ: typ funs,
    4.40 +  term: term funs,
    4.41 +  fact: thm list funs};
    4.42  
    4.43  type declaration = morphism -> Context.generic -> Context.generic;
    4.44  
    4.45 -fun binding (Morphism {binding, ...}) = binding;
    4.46 -fun typ (Morphism {typ, ...}) = typ;
    4.47 -fun term (Morphism {term, ...}) = term;
    4.48 -fun fact (Morphism {fact, ...}) = fact;
    4.49 +fun binding (Morphism {binding, ...}) = apply binding;
    4.50 +fun typ (Morphism {typ, ...}) = apply typ;
    4.51 +fun term (Morphism {term, ...}) = apply term;
    4.52 +fun fact (Morphism {fact, ...}) = apply fact;
    4.53  val thm = singleton o fact;
    4.54  val cterm = Drule.cterm_rule o thm;
    4.55  
    4.56  val morphism = Morphism;
    4.57  
    4.58 -fun binding_morphism binding = morphism {binding = binding, typ = I, term = I, fact = I};
    4.59 -fun typ_morphism typ = morphism {binding = I, typ = typ, term = I, fact = I};
    4.60 -fun term_morphism term = morphism {binding = I, typ = I, term = term, fact = I};
    4.61 -fun fact_morphism fact = morphism {binding = I, typ = I, term = I, fact = fact};
    4.62 -fun thm_morphism thm = morphism {binding = I, typ = I, term = I, fact = map thm};
    4.63 +fun binding_morphism binding = morphism {binding = [binding], typ = [], term = [], fact = []};
    4.64 +fun typ_morphism typ = morphism {binding = [], typ = [typ], term = [], fact = []};
    4.65 +fun term_morphism term = morphism {binding = [], typ = [], term = [term], fact = []};
    4.66 +fun fact_morphism fact = morphism {binding = [], typ = [], term = [], fact = [fact]};
    4.67 +fun thm_morphism thm = morphism {binding = [], typ = [], term = [], fact = [map thm]};
    4.68  
    4.69 -val identity = morphism {binding = I, typ = I, term = I, fact = I};
    4.70 +val identity = morphism {binding = [], typ = [], term = [], fact = []};
    4.71  
    4.72  fun compose
    4.73      (Morphism {binding = binding1, typ = typ1, term = term1, fact = fact1})
    4.74      (Morphism {binding = binding2, typ = typ2, term = term2, fact = fact2}) =
    4.75 -  morphism {binding = binding1 o binding2, typ = typ1 o typ2,
    4.76 -    term = term1 o term2, fact = fact1 o fact2};
    4.77 +  morphism {binding = binding1 @ binding2, typ = typ1 @ typ2,
    4.78 +    term = term1 @ term2, fact = fact1 @ fact2};
    4.79  
    4.80  fun phi1 $> phi2 = compose phi2 phi1;
    4.81  
     5.1 --- a/src/Pure/variable.ML	Fri Oct 28 14:10:19 2011 +0200
     5.2 +++ b/src/Pure/variable.ML	Fri Oct 28 15:38:41 2011 +0200
     5.3 @@ -456,7 +456,7 @@
     5.4      val fact = export inner outer;
     5.5      val term = singleton (export_terms inner outer);
     5.6      val typ = Logic.type_map term;
     5.7 -  in Morphism.morphism {binding = I, typ = typ, term = term, fact = fact} end;
     5.8 +  in Morphism.morphism {binding = [], typ = [typ], term = [term], fact = [fact]} end;
     5.9  
    5.10  
    5.11