841 Binding.name (space_implode "_" (map (Binding.name_of o fst) cnames_syn)) |
841 Binding.name (space_implode "_" (map (Binding.name_of o fst) cnames_syn)) |
842 else alt_name; |
842 else alt_name; |
843 |
843 |
844 val is_auxiliary = length cs >= 2; |
844 val is_auxiliary = length cs >= 2; |
845 val ((rec_const, (_, fp_def)), lthy') = lthy |
845 val ((rec_const, (_, fp_def)), lthy') = lthy |
846 |> is_auxiliary ? Local_Theory.conceal |
846 |> is_auxiliary ? Local_Theory.concealed |
847 |> Local_Theory.define |
847 |> Local_Theory.define |
848 ((rec_name, case cnames_syn of [(_, syn)] => syn | _ => NoSyn), |
848 ((rec_name, case cnames_syn of [(_, syn)] => syn | _ => NoSyn), |
849 ((Binding.conceal (Thm.def_binding rec_name), @{attributes [nitpick_unfold]}), |
849 ((Binding.concealed (Thm.def_binding rec_name), @{attributes [nitpick_unfold]}), |
850 fold_rev lambda params |
850 fold_rev lambda params |
851 (Const (fp_name, (predT --> predT) --> predT) $ fp_fun))) |
851 (Const (fp_name, (predT --> predT) --> predT) $ fp_fun))) |
852 ||> is_auxiliary ? Local_Theory.restore_naming lthy; |
852 ||> is_auxiliary ? Local_Theory.restore_naming lthy; |
853 val fp_def' = |
853 val fp_def' = |
854 Simplifier.rewrite (put_simpset HOL_basic_ss lthy' addsimps [fp_def]) |
854 Simplifier.rewrite (put_simpset HOL_basic_ss lthy' addsimps [fp_def]) |
860 let |
860 let |
861 val Ts = arg_types_of (length params) c; |
861 val Ts = arg_types_of (length params) c; |
862 val xs = |
862 val xs = |
863 map Free (Variable.variant_frees lthy intr_ts (mk_names "x" (length Ts) ~~ Ts)); |
863 map Free (Variable.variant_frees lthy intr_ts (mk_names "x" (length Ts) ~~ Ts)); |
864 in |
864 in |
865 (name_mx, (apfst Binding.conceal Attrib.empty_binding, fold_rev lambda (params @ xs) |
865 (name_mx, (apfst Binding.concealed Attrib.empty_binding, fold_rev lambda (params @ xs) |
866 (list_comb (rec_const, params @ make_bool_args' bs i @ |
866 (list_comb (rec_const, params @ make_bool_args' bs i @ |
867 make_args argTs (xs ~~ Ts))))) |
867 make_args argTs (xs ~~ Ts))))) |
868 end) (cnames_syn ~~ cs); |
868 end) (cnames_syn ~~ cs); |
869 val (consts_defs, lthy'') = lthy' |
869 val (consts_defs, lthy'') = lthy' |
870 |> fold_map Local_Theory.define specs; |
870 |> fold_map Local_Theory.define specs; |
871 val preds = (case cs of [_] => [rec_const] | _ => map #1 consts_defs); |
871 val preds = (case cs of [_] => [rec_const] | _ => map #1 consts_defs); |
872 |
872 |
873 val (_, lthy''') = Variable.add_fixes (map (fst o dest_Free) params) lthy''; |
873 val (_, lthy''') = Variable.add_fixes (map (fst o dest_Free) params) lthy''; |
874 val mono = prove_mono quiet_mode skip_mono predT fp_fun monos lthy'''; |
874 val mono = prove_mono quiet_mode skip_mono predT fp_fun monos lthy'''; |
875 val (_, lthy'''') = |
875 val (_, lthy'''') = |
876 Local_Theory.note (apfst Binding.conceal Attrib.empty_binding, |
876 Local_Theory.note (apfst Binding.concealed Attrib.empty_binding, |
877 Proof_Context.export lthy''' lthy'' [mono]) lthy''; |
877 Proof_Context.export lthy''' lthy'' [mono]) lthy''; |
878 |
878 |
879 in (lthy'''', lthy''', rec_name, mono, fp_def', map (#2 o #2) consts_defs, |
879 in (lthy'''', lthy''', rec_name, mono, fp_def', map (#2 o #2) consts_defs, |
880 list_comb (rec_const, params), preds, argTs, bs, xs) |
880 list_comb (rec_const, params), preds, argTs, bs, xs) |
881 end; |
881 end; |