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 |