src/Pure/Isar/code.ML
changeset 28525 42297ae4df47
parent 28423 9fc3befd8191
child 28562 4e74209f113e
equal deleted inserted replaced
28524:644b62cf678f 28525:42297ae4df47
    34   val purge_data: theory -> theory
    34   val purge_data: theory -> theory
    35 
    35 
    36   val coregular_algebra: theory -> Sorts.algebra
    36   val coregular_algebra: theory -> Sorts.algebra
    37   val operational_algebra: theory -> (sort -> sort) * Sorts.algebra
    37   val operational_algebra: theory -> (sort -> sort) * Sorts.algebra
    38   val these_eqns: theory -> string -> (thm * bool) list
    38   val these_eqns: theory -> string -> (thm * bool) list
       
    39   val these_raw_eqns: theory -> string -> (thm * bool) list
    39   val get_datatype: theory -> string -> ((string * sort) list * (string * typ list) list)
    40   val get_datatype: theory -> string -> ((string * sort) list * (string * typ list) list)
    40   val get_datatype_of_constr: theory -> string -> string option
    41   val get_datatype_of_constr: theory -> string -> string option
    41   val get_case_data: theory -> string -> (int * string list) option
    42   val get_case_data: theory -> string -> (int * string list) option
    42   val is_undefined: theory -> string -> bool
    43   val is_undefined: theory -> string -> bool
    43   val default_typscheme: theory -> string -> (string * sort) list * typ
    44   val default_typscheme: theory -> string -> (string * sort) list * typ
   611   (map_exec_purge (SOME [c]) o map_cases o apsnd) (Symtab.update (c, ())) thy;
   612   (map_exec_purge (SOME [c]) o map_cases o apsnd) (Symtab.update (c, ())) thy;
   612 
   613 
   613 val map_pre = map_exec_purge NONE o map_thmproc o apfst o apfst;
   614 val map_pre = map_exec_purge NONE o map_thmproc o apfst o apfst;
   614 val map_post = map_exec_purge NONE o map_thmproc o apfst o apsnd;
   615 val map_post = map_exec_purge NONE o map_thmproc o apfst o apsnd;
   615 
   616 
   616 fun gen_add_del_pre_post f thm thy = f thm thy;
   617 val add_inline = map_pre o MetaSimplifier.add_simp;
   617 
   618 val del_inline = map_pre o MetaSimplifier.del_simp;
   618 val add_inline = gen_add_del_pre_post (map_pre o MetaSimplifier.add_simp);
   619 val add_post = map_post o MetaSimplifier.add_simp;
   619 val del_inline = gen_add_del_pre_post (map_pre o MetaSimplifier.del_simp);
   620 val del_post = map_post o MetaSimplifier.del_simp;
   620 val add_post = gen_add_del_pre_post (map_post o MetaSimplifier.add_simp);
       
   621 val del_post = gen_add_del_pre_post (map_post o MetaSimplifier.del_simp);
       
   622   
   621   
   623 fun add_functrans (name, f) =
   622 fun add_functrans (name, f) =
   624   (map_exec_purge NONE o map_thmproc o apsnd)
   623   (map_exec_purge NONE o map_thmproc o apsnd)
   625     (AList.update (op =) (name, (serial (), f)));
   624     (AList.update (op =) (name, (serial (), f)));
   626 
   625 
   647 
   646 
   648 (** post- and preprocessing **)
   647 (** post- and preprocessing **)
   649 
   648 
   650 local
   649 local
   651 
   650 
       
   651 fun get_eqns thy c =
       
   652   Symtab.lookup ((the_eqns o the_exec) thy) c
       
   653   |> Option.map (Susp.force o snd)
       
   654   |> these
       
   655   |> (map o apfst) (Thm.transfer thy);
       
   656 
   652 fun apply_functrans thy c _ [] = []
   657 fun apply_functrans thy c _ [] = []
   653   | apply_functrans thy c [] eqns = eqns
   658   | apply_functrans thy c [] eqns = eqns
   654   | apply_functrans thy c functrans eqns = eqns
   659   | apply_functrans thy c functrans eqns = eqns
   655       |> perhaps (perhaps_loop (perhaps_apply functrans))
   660       |> perhaps (perhaps_loop (perhaps_apply functrans))
   656       |> map (Code_Unit.assert_linear o apfst (Code_Unit.assert_eqn thy))
   661       |> (map o apfst) (AxClass.unoverload thy)
   657       |> certify_const thy c;
   662       |> (map o Code_Unit.error_thm) (Code_Unit.assert_linear o apfst (Code_Unit.assert_eqn thy))
       
   663       |> certify_const thy c
       
   664       |> (map o apfst) (AxClass.overload thy);
   658 
   665 
   659 fun rhs_conv conv thm = Thm.transitive thm ((conv o Thm.rhs_of) thm);
   666 fun rhs_conv conv thm = Thm.transitive thm ((conv o Thm.rhs_of) thm);
   660 
   667 
   661 fun term_of_conv thy f =
   668 fun term_of_conv thy f =
   662   Thm.cterm_of thy
   669   Thm.cterm_of thy
   668 fun preprocess thy functrans c eqns =
   675 fun preprocess thy functrans c eqns =
   669   let
   676   let
   670     val pre = (Simplifier.theory_context thy o #pre o the_thmproc o the_exec) thy;
   677     val pre = (Simplifier.theory_context thy o #pre o the_thmproc o the_exec) thy;
   671   in
   678   in
   672     eqns
   679     eqns
       
   680     |> (map o apfst) (AxClass.overload thy)
   673     |> apply_functrans thy c functrans
   681     |> apply_functrans thy c functrans
   674     |> (map o apfst) (Code_Unit.rewrite_eqn pre)
   682     |> (map o apfst) (Code_Unit.rewrite_eqn pre)
       
   683     |> (map o apfst) (AxClass.unoverload thy)
   675     |> map (Code_Unit.assert_linear o apfst (Code_Unit.assert_eqn thy))
   684     |> map (Code_Unit.assert_linear o apfst (Code_Unit.assert_eqn thy))
   676     |> burrow_fst (common_typ_eqns thy)
   685     |> burrow_fst (common_typ_eqns thy)
   677   end;
   686   end;
   678 
       
   679 fun get_eqns thy c =
       
   680   Symtab.lookup ((the_eqns o the_exec) thy) c
       
   681   |> Option.map (Susp.force o snd)
       
   682   |> these
       
   683   |> (map o apfst) (Thm.transfer thy);
       
   684 
   687 
   685 in
   688 in
   686 
   689 
   687 fun preprocess_conv thy ct =
   690 fun preprocess_conv thy ct =
   688   let
   691   let
   704     |> rhs_conv (Simplifier.rewrite post)
   707     |> rhs_conv (Simplifier.rewrite post)
   705   end;
   708   end;
   706 
   709 
   707 fun postprocess_term thy = term_of_conv thy (postprocess_conv thy);
   710 fun postprocess_term thy = term_of_conv thy (postprocess_conv thy);
   708 
   711 
       
   712 fun these_raw_eqns thy c =
       
   713   get_eqns thy c
       
   714   |> burrow_fst (common_typ_eqns thy);
       
   715 
   709 fun these_eqns thy c =
   716 fun these_eqns thy c =
   710   let
   717   let
   711     val functrans = (map (fn (_, (_, f)) => f thy) o #functrans
   718     val functrans = (map (fn (_, (_, f)) => f thy) o #functrans
   712       o the_thmproc o the_exec) thy;
   719       o the_thmproc o the_exec) thy;
   713     val drop_refl = filter_out
       
   714       (is_equal o Term.fast_term_ord o Logic.dest_equals o Thm.plain_prop_of o fst);
       
   715   in
   720   in
   716     get_eqns thy c
   721     get_eqns thy c
   717     |> preprocess thy functrans c
   722     |> preprocess thy functrans c
   718     |> drop_refl
   723   end;
   719   end;
   724 
   720 
   725 fun default_typscheme thy c =
   721 fun default_typscheme thy c = let
   726   let
   722     val typscheme = curry (Code_Unit.typscheme thy) c
   727     val typscheme = curry (Code_Unit.typscheme thy) c
   723     val the_const_type = snd o dest_Const o TermSubst.zero_var_indexes
   728     val the_const_type = snd o dest_Const o TermSubst.zero_var_indexes
   724       o curry Const "" o Sign.the_const_type thy;
   729       o curry Const "" o Sign.the_const_type thy;
   725   in case AxClass.class_of_param thy c
   730   in case AxClass.class_of_param thy c
   726    of SOME class => the_const_type c
   731    of SOME class => the_const_type c