src/Pure/Isar/theory_target.ML
changeset 21570 f20f9304ab48
parent 21533 bada5ac1216a
child 21585 2444f1d1127b
equal deleted inserted replaced
21569:a0d0ea84521d 21570:f20f9304ab48
    70 
    70 
    71     val (abbrs, lthy') = lthy |> LocalTheory.theory_result (fold_map const decls);
    71     val (abbrs, lthy') = lthy |> LocalTheory.theory_result (fold_map const decls);
    72     val defs = abbrs |> map (fn (x, t) => (x, (("", []), t)));
    72     val defs = abbrs |> map (fn (x, t) => (x, (("", []), t)));
    73   in
    73   in
    74     lthy'
    74     lthy'
    75     |> K is_loc ? LocalTheory.abbrevs Syntax.default_mode abbrs
    75     |> is_loc ? LocalTheory.abbrevs Syntax.default_mode abbrs
    76     |> LocalDefs.add_defs defs |>> map (apsnd snd)
    76     |> LocalDefs.add_defs defs |>> map (apsnd snd)
    77   end;
    77   end;
    78 
    78 
    79 
    79 
    80 (* axioms *)
    80 (* axioms *)
   108 end;
   108 end;
   109 
   109 
   110 
   110 
   111 (* defs *)
   111 (* defs *)
   112 
   112 
       
   113 infix also;
       
   114 fun eq1 also eq2 =
       
   115   eq2 COMP (eq1 COMP (Drule.incr_indexes2 eq1 eq2 transitive_thm));
       
   116 
   113 local
   117 local
       
   118 
       
   119 fun expand_defs ctxt t =
       
   120   let
       
   121     val thy = ProofContext.theory_of ctxt;
       
   122     val thy_ctxt = ProofContext.init thy;
       
   123     val ct = Thm.cterm_of thy t;
       
   124     val (defs, ct') = LocalDefs.expand_defs ctxt thy_ctxt (Drule.mk_term ct) ||> Drule.dest_term;
       
   125   in (Thm.term_of ct', Tactic.rewrite true defs ct) end;
   114 
   126 
   115 fun add_def (name, prop) =
   127 fun add_def (name, prop) =
   116   Theory.add_defs_i false false [(name, prop)] #>
   128   Theory.add_defs_i false false [(name, prop)] #>
   117   (fn thy => (Drule.unvarify (Thm.get_axiom_i thy (Sign.full_name thy name)), thy));
   129   (fn thy => (Drule.unvarify (Thm.get_axiom_i thy (Sign.full_name thy name)), thy));
   118 
   130 
   119 fun expand_defs lthy =
       
   120   Drule.term_rule (ProofContext.theory_of lthy)
       
   121     (Assumption.export false lthy (LocalTheory.target_of lthy));
       
   122 
       
   123 infix also;
       
   124 fun eq1 also eq2 = Thm.transitive eq1 eq2;
       
   125 
       
   126 in
   131 in
   127 
   132 
   128 fun defs kind args lthy =
   133 fun defs kind args lthy0 =
   129   let
   134   let
   130     fun def ((c, mx), ((name, atts), rhs)) lthy1 =
   135     fun def ((c, mx), ((name, atts), rhs)) lthy1 =
   131       let
   136       let
       
   137         val (rhs', rhs_conv) = expand_defs lthy0 rhs;
       
   138         val xs = Variable.add_fixed (LocalTheory.target_of lthy0) rhs' [];
       
   139 
       
   140         val ([(lhs, lhs_def)], lthy2) = lthy1
       
   141           |> LocalTheory.consts (member (op =) xs) [((c, Term.fastype_of rhs), mx)];
       
   142         val lhs' = #2 (Logic.dest_equals (Thm.prop_of lhs_def));
       
   143 
   132         val name' = Thm.def_name_optional c name;
   144         val name' = Thm.def_name_optional c name;
   133         val T = Term.fastype_of rhs;
   145         val (def, lthy3) = lthy2
   134 
       
   135         val rhs' = expand_defs lthy1 rhs;
       
   136         val depends = member (op =) (Term.add_frees rhs' []);
       
   137         val defined = filter_out depends (Term.add_frees rhs []);
       
   138 
       
   139         val ([(lhs, local_def)], lthy2) = lthy1
       
   140           |> LocalTheory.consts depends [((c, T), mx)];
       
   141         val lhs' = #2 (Logic.dest_equals (Thm.prop_of local_def));
       
   142 
       
   143         val rhs_conv = rhs
       
   144           |> Thm.cterm_of (ProofContext.theory_of lthy1)
       
   145           |> Tactic.rewrite true (map_filter (LocalDefs.find_def lthy1 o #1) defined);
       
   146 
       
   147         val (global_def, lthy3) = lthy2
       
   148           |> LocalTheory.theory_result (add_def (name', Logic.mk_equals (lhs', rhs')));
   146           |> LocalTheory.theory_result (add_def (name', Logic.mk_equals (lhs', rhs')));
   149 
   147 
   150         val eq =
   148         val eq =
   151           local_def                      (*c == loc.c xs*)
   149           (*c == loc.c xs*) lhs_def
   152           also global_def                (*... == rhs'*)
   150           (*lhs' == rhs'*)  also def
   153           also Thm.symmetric rhs_conv;   (*... == rhs*)
   151           (*rhs' == rhs*)   also Thm.symmetric rhs_conv;
   154       in ((lhs, ((name', atts), [([eq], [])])), lthy3) end;
   152       in ((lhs, ((name', atts), [([eq], [])])), lthy3) end;
   155 
   153 
   156     val ((lhss, facts), lthy') = lthy |> fold_map def args |>> split_list;
   154     val ((lhss, facts), lthy') = lthy0 |> fold_map def args |>> split_list;
   157     val (res, lthy'') = lthy' |> LocalTheory.notes kind facts;
   155     val (res, lthy'') = lthy' |> LocalTheory.notes kind facts;
   158   in (lhss ~~ map (apsnd the_single) res, lthy'') end;
   156   in (lhss ~~ map (apsnd the_single) res, lthy'') end;
   159 
   157 
   160 end;
   158 end;
   161 
   159