src/HOL/Tools/inductive.ML
changeset 59859 f9d1442c70f3
parent 59845 fafb4d12c307
child 59880 30687c3f2b10
equal deleted inserted replaced
59858:890b68e1e8b6 59859:f9d1442c70f3
   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;