src/HOL/Tools/Datatype/datatype_data.ML
changeset 33968 f94fb13ecbb3
parent 33963 977b94b64905
equal deleted inserted replaced
33967:e191b400a8e0 33968:f94fb13ecbb3
     1 (*  Title:      HOL/Tools/datatype.ML
     1 (*  Title:      HOL/Tools/Datatype/datatype_data.ML
     2     Author:     Stefan Berghofer, TU Muenchen
     2     Author:     Stefan Berghofer, TU Muenchen
     3 
     3 
     4 Datatype package for Isabelle/HOL.
     4 Datatype package: bookkeeping; interpretation of existing types as datatypes.
     5 *)
     5 *)
     6 
     6 
     7 signature DATATYPE_DATA =
     7 signature DATATYPE_DATA =
     8 sig
     8 sig
     9   include DATATYPE_COMMON
     9   include DATATYPE_COMMON
    23   val get_constrs : theory -> string -> (string * typ) list option
    23   val get_constrs : theory -> string -> (string * typ) list option
    24   val get_all : theory -> info Symtab.table
    24   val get_all : theory -> info Symtab.table
    25   val info_of_constr : theory -> string * typ -> info option
    25   val info_of_constr : theory -> string * typ -> info option
    26   val info_of_case : theory -> string -> info option
    26   val info_of_case : theory -> string -> info option
    27   val interpretation : (config -> string list -> theory -> theory) -> theory -> theory
    27   val interpretation : (config -> string list -> theory -> theory) -> theory -> theory
    28   val make_case :  Proof.context -> DatatypeCase.config -> string list -> term ->
    28   val make_case :  Proof.context -> Datatype_Case.config -> string list -> term ->
    29     (term * term) list -> term * (term * (int * bool)) list
    29     (term * term) list -> term * (term * (int * bool)) list
    30   val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
    30   val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
    31   val read_typ: theory -> string -> (string * sort) list -> typ * (string * sort) list
    31   val read_typ: theory -> string -> (string * sort) list -> typ * (string * sort) list
    32   val cert_typ: theory -> typ -> (string * sort) list -> typ * (string * sort) list
    32   val cert_typ: theory -> typ -> (string * sort) list -> typ * (string * sort) list
    33   val mk_case_names_induct: descr -> attribute
    33   val mk_case_names_induct: descr -> attribute
    35 end;
    35 end;
    36 
    36 
    37 structure Datatype_Data: DATATYPE_DATA =
    37 structure Datatype_Data: DATATYPE_DATA =
    38 struct
    38 struct
    39 
    39 
    40 open DatatypeAux;
    40 open Datatype_Aux;
    41 
    41 
    42 (** theory data **)
    42 (** theory data **)
    43 
    43 
    44 (* data management *)
    44 (* data management *)
    45 
    45 
   102 fun the_spec thy dtco =
   102 fun the_spec thy dtco =
   103   let
   103   let
   104     val info as { descr, index, sorts = raw_sorts, ... } = the_info thy dtco;
   104     val info as { descr, index, sorts = raw_sorts, ... } = the_info thy dtco;
   105     val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index;
   105     val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index;
   106     val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v))
   106     val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v))
   107       o DatatypeAux.dest_DtTFree) dtys;
   107       o Datatype_Aux.dest_DtTFree) dtys;
   108     val cos = map
   108     val cos = map
   109       (fn (co, tys) => (co, map (DatatypeAux.typ_of_dtyp descr sorts) tys)) raw_cos;
   109       (fn (co, tys) => (co, map (Datatype_Aux.typ_of_dtyp descr sorts) tys)) raw_cos;
   110   in (sorts, cos) end;
   110   in (sorts, cos) end;
   111 
   111 
   112 fun the_descr thy (raw_tycos as raw_tyco :: _) =
   112 fun the_descr thy (raw_tycos as raw_tyco :: _) =
   113   let
   113   let
   114     val info = the_info thy raw_tyco;
   114     val info = the_info thy raw_tyco;
   195     fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
   195     fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
   196     val bnames = map the_bname (distinct (op =) (maps dt_recs args));
   196     val bnames = map the_bname (distinct (op =) (maps dt_recs args));
   197   in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
   197   in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
   198 
   198 
   199 fun induct_cases descr =
   199 fun induct_cases descr =
   200   DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
   200   Datatype_Prop.indexify_names (maps (dt_cases descr) (map #2 descr));
   201 
   201 
   202 fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
   202 fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
   203 
   203 
   204 in
   204 in
   205 
   205 
   212 end;
   212 end;
   213 
   213 
   214 
   214 
   215 (* translation rules for case *)
   215 (* translation rules for case *)
   216 
   216 
   217 fun make_case ctxt = DatatypeCase.make_case
   217 fun make_case ctxt = Datatype_Case.make_case
   218   (info_of_constr (ProofContext.theory_of ctxt)) ctxt;
   218   (info_of_constr (ProofContext.theory_of ctxt)) ctxt;
   219 
   219 
   220 fun strip_case ctxt = DatatypeCase.strip_case
   220 fun strip_case ctxt = Datatype_Case.strip_case
   221   (info_of_case (ProofContext.theory_of ctxt));
   221   (info_of_case (ProofContext.theory_of ctxt));
   222 
   222 
   223 fun add_case_tr' case_names thy =
   223 fun add_case_tr' case_names thy =
   224   Sign.add_advanced_trfuns ([], [],
   224   Sign.add_advanced_trfuns ([], [],
   225     map (fn case_name =>
   225     map (fn case_name =>
   226       let val case_name' = Sign.const_syntax_name thy case_name
   226       let val case_name' = Sign.const_syntax_name thy case_name
   227       in (case_name', DatatypeCase.case_tr' info_of_case case_name')
   227       in (case_name', Datatype_Case.case_tr' info_of_case case_name')
   228       end) case_names, []) thy;
   228       end) case_names, []) thy;
   229 
   229 
   230 val trfun_setup =
   230 val trfun_setup =
   231   Sign.add_advanced_trfuns ([],
   231   Sign.add_advanced_trfuns ([],
   232     [("_case_syntax", DatatypeCase.case_tr true info_of_constr)],
   232     [("_case_syntax", Datatype_Case.case_tr true info_of_constr)],
   233     [], []);
   233     [], []);
   234 
   234 
   235 
   235 
   236 
   236 
   237 (** document antiquotation **)
   237 (** document antiquotation **)
   297     val thy2 = thy1 |> Theory.checkpoint;
   297     val thy2 = thy1 |> Theory.checkpoint;
   298     val flat_descr = flat descr;
   298     val flat_descr = flat descr;
   299     val new_type_names = map Long_Name.base_name (the_default dt_names alt_names);
   299     val new_type_names = map Long_Name.base_name (the_default dt_names alt_names);
   300     val _ = message config ("Deriving properties for datatype(s) " ^ commas_quote new_type_names);
   300     val _ = message config ("Deriving properties for datatype(s) " ^ commas_quote new_type_names);
   301 
   301 
   302     val (exhaust, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names
   302     val (exhaust, thy3) = Datatype_Abs_Proofs.prove_casedist_thms config new_type_names
   303       descr sorts induct (mk_case_names_exhausts flat_descr dt_names) thy2;
   303       descr sorts induct (mk_case_names_exhausts flat_descr dt_names) thy2;
   304     val (nchotomys, thy4) = DatatypeAbsProofs.prove_nchotomys config new_type_names
   304     val (nchotomys, thy4) = Datatype_Abs_Proofs.prove_nchotomys config new_type_names
   305       descr sorts exhaust thy3;
   305       descr sorts exhaust thy3;
   306     val ((rec_names, rec_rewrites), thy5) = DatatypeAbsProofs.prove_primrec_thms
   306     val ((rec_names, rec_rewrites), thy5) = Datatype_Abs_Proofs.prove_primrec_thms
   307       config new_type_names descr sorts (#inject o the o Symtab.lookup (get_all thy4))
   307       config new_type_names descr sorts (#inject o the o Symtab.lookup (get_all thy4))
   308       inject (distinct, all_distincts thy2 (get_rec_types flat_descr sorts))
   308       inject (distinct, all_distincts thy2 (get_rec_types flat_descr sorts))
   309       induct thy4;
   309       induct thy4;
   310     val ((case_rewrites, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
   310     val ((case_rewrites, case_names), thy6) = Datatype_Abs_Proofs.prove_case_thms
   311       config new_type_names descr sorts rec_names rec_rewrites thy5;
   311       config new_type_names descr sorts rec_names rec_rewrites thy5;
   312     val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
   312     val (case_congs, thy7) = Datatype_Abs_Proofs.prove_case_congs new_type_names
   313       descr sorts nchotomys case_rewrites thy6;
   313       descr sorts nchotomys case_rewrites thy6;
   314     val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
   314     val (weak_case_congs, thy8) = Datatype_Abs_Proofs.prove_weak_case_congs new_type_names
   315       descr sorts thy7;
   315       descr sorts thy7;
   316     val (splits, thy9) = DatatypeAbsProofs.prove_split_thms
   316     val (splits, thy9) = Datatype_Abs_Proofs.prove_split_thms
   317       config new_type_names descr sorts inject distinct exhaust case_rewrites thy8;
   317       config new_type_names descr sorts inject distinct exhaust case_rewrites thy8;
   318 
   318 
   319     val inducts = Project_Rule.projections (ProofContext.init thy2) induct;
   319     val inducts = Project_Rule.projections (ProofContext.init thy2) induct;
   320     val dt_infos = map_index
   320     val dt_infos = map_index
   321       (make_dt_info alt_names flat_descr sorts induct inducts rec_names rec_rewrites)
   321       (make_dt_info alt_names flat_descr sorts induct inducts rec_names rec_rewrites)
   414 
   414 
   415     fun mk_spec (i, (tyco, constr)) = (i, (tyco,
   415     fun mk_spec (i, (tyco, constr)) = (i, (tyco,
   416       map (DtTFree o fst) vs,
   416       map (DtTFree o fst) vs,
   417       (map o apsnd) dtyps_of_typ constr))
   417       (map o apsnd) dtyps_of_typ constr))
   418     val descr = map_index mk_spec cs;
   418     val descr = map_index mk_spec cs;
   419     val injs = DatatypeProp.make_injs [descr] vs;
   419     val injs = Datatype_Prop.make_injs [descr] vs;
   420     val half_distincts = map snd (DatatypeProp.make_distincts [descr] vs);
   420     val half_distincts = map snd (Datatype_Prop.make_distincts [descr] vs);
   421     val ind = DatatypeProp.make_ind [descr] vs;
   421     val ind = Datatype_Prop.make_ind [descr] vs;
   422     val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
   422     val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
   423 
   423 
   424     fun after_qed' raw_thms =
   424     fun after_qed' raw_thms =
   425       let
   425       let
   426         val [[[raw_induct]], raw_inject, half_distinct] =
   426         val [[[raw_induct]], raw_inject, half_distinct] =