src/HOLCF/Tools/fixrec_package.ML
changeset 28083 103d9282a946
parent 27691 ce171cbd4b93
child 28084 a05ca48ef263
equal deleted inserted replaced
28082:37350f301128 28083:103d9282a946
     7 
     7 
     8 signature FIXREC_PACKAGE =
     8 signature FIXREC_PACKAGE =
     9 sig
     9 sig
    10   val legacy_infer_term: theory -> term -> term
    10   val legacy_infer_term: theory -> term -> term
    11   val legacy_infer_prop: theory -> term -> term
    11   val legacy_infer_prop: theory -> term -> term
    12   val add_fixrec: bool -> ((string * Attrib.src list) * string) list list -> theory -> theory
    12   val add_fixrec: bool -> ((Name.binding * Attrib.src list) * string) list list -> theory -> theory
    13   val add_fixrec_i: bool -> ((string * attribute list) * term) list list -> theory -> theory
    13   val add_fixrec_i: bool -> ((Name.binding * attribute list) * term) list list -> theory -> theory
    14   val add_fixpat: (string * Attrib.src list) * string list -> theory -> theory
    14   val add_fixpat: (Name.binding * Attrib.src list) * string list -> theory -> theory
    15   val add_fixpat_i: (string * attribute list) * term list -> theory -> theory
    15   val add_fixpat_i: (Name.binding * attribute list) * term list -> theory -> theory
    16 end;
    16 end;
    17 
    17 
    18 structure FixrecPackage: FIXREC_PACKAGE =
    18 structure FixrecPackage: FIXREC_PACKAGE =
    19 struct
    19 struct
    20 
    20 
   224 fun gen_add_fixrec prep_prop prep_attrib strict blocks thy =
   224 fun gen_add_fixrec prep_prop prep_attrib strict blocks thy =
   225   let
   225   let
   226     val eqns = List.concat blocks;
   226     val eqns = List.concat blocks;
   227     val lengths = map length blocks;
   227     val lengths = map length blocks;
   228     
   228     
   229     val ((names, srcss), strings) = apfst split_list (split_list eqns);
   229     val ((bindings, srcss), strings) = apfst split_list (split_list eqns);
       
   230     val names = map Name.name_of bindings;
   230     val atts = map (map (prep_attrib thy)) srcss;
   231     val atts = map (map (prep_attrib thy)) srcss;
   231     val eqn_ts = map (prep_prop thy) strings;
   232     val eqn_ts = map (prep_prop thy) strings;
   232     val rec_ts = map (fn eq => chead_of (fst (dest_eqs (Logic.strip_imp_concl eq)))
   233     val rec_ts = map (fn eq => chead_of (fst (dest_eqs (Logic.strip_imp_concl eq)))
   233       handle TERM _ => fixrec_eq_err thy "not a proper equation" eq) eqn_ts;
   234       handle TERM _ => fixrec_eq_err thy "not a proper equation" eq) eqn_ts;
   234     val (_, eqn_ts') = OldPrimrecPackage.unify_consts thy rec_ts eqn_ts;
   235     val (_, eqn_ts') = OldPrimrecPackage.unify_consts thy rec_ts eqn_ts;
   276   let
   277   let
   277     val atts = map (prep_attrib thy) srcs;
   278     val atts = map (prep_attrib thy) srcs;
   278     val ts = map (prep_term thy) strings;
   279     val ts = map (prep_term thy) strings;
   279     val simps = map (fix_pat thy) ts;
   280     val simps = map (fix_pat thy) ts;
   280   in
   281   in
   281     (snd o PureThy.add_thmss [((name, simps), atts)]) thy
   282     (snd o PureThy.add_thmss [((Name.name_of name, simps), atts)]) thy
   282   end;
   283   end;
   283 
   284 
   284 val add_fixpat = gen_add_fixpat Syntax.read_term_global Attrib.attribute;
   285 val add_fixpat = gen_add_fixpat Syntax.read_term_global Attrib.attribute;
   285 val add_fixpat_i = gen_add_fixpat Sign.cert_term (K I);
   286 val add_fixpat_i = gen_add_fixpat Sign.cert_term (K I);
   286 
   287