src/HOL/Tools/function_package/fundef_package.ML
changeset 19611 da2a0014c461
parent 19585 70a1ce3b23ae
child 19617 7cb4b67d4b97
equal deleted inserted replaced
19610:93dc5e63d05e 19611:da2a0014c461
    24 open FundefCommon
    24 open FundefCommon
    25 
    25 
    26 val True_implies = thm "True_implies"
    26 val True_implies = thm "True_implies"
    27 
    27 
    28 
    28 
    29 fun fundef_afterqed congs curry_info name data natts thmss thy =
    29 fun fundef_afterqed congs curry_info name data names atts thmss thy =
    30     let
    30     let
    31 	val (complete_thm :: compat_thms) = map hd thmss
    31 	val (complete_thm :: compat_thms) = map hd thmss
    32 	val fundef_data = FundefProof.mk_partial_rules_curried thy congs curry_info data (freezeT complete_thm) (map freezeT compat_thms)
    32 	val fundef_data = FundefProof.mk_partial_rules_curried thy congs curry_info data (freezeT complete_thm) (map freezeT compat_thms)
    33 	val FundefResult {psimps, subset_pinduct, simple_pinduct, total_intro, dom_intros, ...} = fundef_data
    33 	val FundefResult {psimps, subset_pinduct, simple_pinduct, total_intro, dom_intros, ...} = fundef_data
    34 
    34 
    35 	val (names, attsrcs) = split_list natts
       
    36 	val atts = map (map (Attrib.attribute thy)) attsrcs
       
    37 
    35 
    38 	val Prep {names = Names {acc_R=accR, ...}, ...} = data
    36 	val Prep {names = Names {acc_R=accR, ...}, ...} = data
    39 	val dom_abbrev = Logic.mk_equals (Free (name ^ "_dom", fastype_of accR), accR)
    37 	val dom_abbrev = Logic.mk_equals (Free (name ^ "_dom", fastype_of accR), accR)
    40 	val (_, thy) = LocalTheory.mapping NONE (Specification.abbreviation_i ("", false) [(NONE, dom_abbrev)]) thy
    38 	val (_, thy) = LocalTheory.mapping NONE (Specification.abbreviation_i ("", false) [(NONE, dom_abbrev)]) thy
    41 
    39 
    53 	val thy = thy |> Theory.parent_path
    51 	val thy = thy |> Theory.parent_path
    54     in
    52     in
    55 	add_fundef_data name fundef_data thy
    53 	add_fundef_data name fundef_data thy
    56     end
    54     end
    57 
    55 
    58 fun add_fundef eqns_atts thy =
    56 fun gen_add_fundef prep_att eqns_atts thy =
    59     let
    57     let
    60 	val (natts, eqns) = split_list eqns_atts
    58 	val (natts, eqns) = split_list eqns_atts
       
    59 	val (names, raw_atts) = split_list natts
       
    60 
       
    61 	val atts = map (map (prep_att thy)) raw_atts
    61 
    62 
    62 	val congs = get_fundef_congs (Context.Theory thy)
    63 	val congs = get_fundef_congs (Context.Theory thy)
    63 
    64 
    64 	val (curry_info, name, (data, thy)) = FundefPrep.prepare_fundef_curried congs (map (Sign.read_prop thy) eqns) thy
    65 	val t_eqns = map (Sign.read_prop thy) eqns
       
    66 			 |> map (term_of o cterm_of thy) (* HACK to prevent strange things from happening with abbreviations *)
       
    67 
       
    68 	val (curry_info, name, (data, thy)) = FundefPrep.prepare_fundef_curried congs t_eqns thy
    65 	val Prep {complete, compat, ...} = data
    69 	val Prep {complete, compat, ...} = data
    66 
    70 
    67 	val props = (complete :: compat) (*(complete :: fst (chop 110 compat))*)
    71 	val props = (complete :: compat) (*(complete :: fst (chop 110 compat))*)
    68     in
    72     in
    69 	thy |> ProofContext.init
    73 	thy |> ProofContext.init
    70 	    |> Proof.theorem_i PureThy.internalK NONE (fundef_afterqed congs curry_info name data natts) NONE ("", [])
    74 	    |> Proof.theorem_i PureThy.internalK NONE (fundef_afterqed congs curry_info name data names atts) NONE ("", [])
    71 	    (map (fn t => (("", []), [(t, [])])) props)
    75 	    (map (fn t => (("", []), [(t, [])])) props)
    72     end
    76     end
    73 
    77 
    74 
    78 
    75 fun total_termination_afterqed name thmss thy =
    79 fun total_termination_afterqed name thmss thy =
   150 	    |> Proof.theorem_i PureThy.internalK NONE (K I) NONE ("", [])
   154 	    |> Proof.theorem_i PureThy.internalK NONE (K I) NONE ("", [])
   151 	    [(("", []), [(subs, []), (dcl, [])])]
   155 	    [(("", []), [(subs, []), (dcl, [])])]
   152     end	
   156     end	
   153 
   157 
   154 
   158 
       
   159 val add_fundef = gen_add_fundef Attrib.attribute
       
   160 
   155 
   161 
   156 
   162 
   157 (* congruence rules *)
   163 (* congruence rules *)
   158 
   164 
   159 val cong_add = Thm.declaration_attribute (map_fundef_congs o cons o safe_mk_meta_eq);
   165 val cong_add = Thm.declaration_attribute (map_fundef_congs o cons o safe_mk_meta_eq);