18 val get_datatype_constrs : theory -> string -> (string * typ) list option |
18 val get_datatype_constrs : theory -> string -> (string * typ) list option |
19 val construction_interpretation : theory |
19 val construction_interpretation : theory |
20 -> {atom : typ -> 'a, dtyp : string -> 'a, rtyp : string -> 'a list -> 'a} |
20 -> {atom : typ -> 'a, dtyp : string -> 'a, rtyp : string -> 'a list -> 'a} |
21 -> (string * sort) list -> string list |
21 -> (string * sort) list -> string list |
22 -> (string * (string * 'a list) list) list |
22 -> (string * (string * 'a list) list) list |
23 val induct_tac : string -> int -> tactic |
23 val induct_tac : Proof.context -> string -> int -> tactic |
24 val induct_thm_tac : thm -> string -> int -> tactic |
24 val induct_thm_tac : Proof.context -> thm -> string -> int -> tactic |
25 val case_tac : string -> int -> tactic |
25 val case_tac : string -> int -> tactic |
26 val distinct_simproc : simproc |
26 val distinct_simproc : simproc |
27 val make_case : Proof.context -> bool -> string list -> term -> |
27 val make_case : Proof.context -> bool -> string list -> term -> |
28 (term * term) list -> term * (term * (int * bool)) list |
28 (term * term) list -> term * (term * (int * bool)) list |
29 val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option |
29 val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option |
30 val interpretation : (string list -> theory -> theory) -> theory -> theory |
30 val interpretation : (string list -> theory -> theory) -> theory -> theory |
31 val rep_datatype_i : string list option -> (thm list * attribute list) list list -> |
31 val rep_datatype : ({distinct : thm list list, |
32 (thm list * attribute list) list list -> (thm list * attribute list) -> |
|
33 theory -> |
|
34 {distinct : thm list list, |
|
35 inject : thm list list, |
32 inject : thm list list, |
36 exhaustion : thm list, |
33 exhaustion : thm list, |
37 rec_thms : thm list, |
34 rec_thms : thm list, |
38 case_thms : thm list list, |
35 case_thms : thm list list, |
39 split_thms : (thm * thm) list, |
36 split_thms : (thm * thm) list, |
40 induction : thm, |
37 induction : thm, |
41 simps : thm list} * theory |
38 simps : thm list} -> Proof.context -> Proof.context) -> string list option -> term list |
42 val rep_datatype : string list option -> (Facts.ref * Attrib.src list) list list -> |
39 -> theory -> Proof.state; |
43 (Facts.ref * Attrib.src list) list list -> Facts.ref * Attrib.src list -> theory -> |
40 val rep_datatype_cmd : string list option -> string list -> theory -> Proof.state; |
44 {distinct : thm list list, |
41 val add_datatype : bool -> bool -> string list -> (string list * bstring * mixfix * |
45 inject : thm list list, |
|
46 exhaustion : thm list, |
|
47 rec_thms : thm list, |
|
48 case_thms : thm list list, |
|
49 split_thms : (thm * thm) list, |
|
50 induction : thm, |
|
51 simps : thm list} * theory |
|
52 val add_datatype_i : bool -> bool -> string list -> (string list * bstring * mixfix * |
|
53 (bstring * typ list * mixfix) list) list -> theory -> |
42 (bstring * typ list * mixfix) list) list -> theory -> |
54 {distinct : thm list list, |
43 {distinct : thm list list, |
55 inject : thm list list, |
44 inject : thm list list, |
56 exhaustion : thm list, |
45 exhaustion : thm list, |
57 rec_thms : thm list, |
46 rec_thms : thm list, |
58 case_thms : thm list list, |
47 case_thms : thm list list, |
59 split_thms : (thm * thm) list, |
48 split_thms : (thm * thm) list, |
60 induction : thm, |
49 induction : thm, |
61 simps : thm list} * theory |
50 simps : thm list} * theory |
62 val add_datatype : bool -> string list -> (string list * bstring * mixfix * |
51 val add_datatype_cmd : bool -> string list -> (string list * bstring * mixfix * |
63 (bstring * string list * mixfix) list) list -> theory -> |
52 (bstring * string list * mixfix) list) list -> theory -> |
64 {distinct : thm list list, |
53 {distinct : thm list list, |
65 inject : thm list list, |
54 inject : thm list list, |
66 exhaustion : thm list, |
55 exhaustion : thm list, |
67 rec_thms : thm list, |
56 rec_thms : thm list, |
219 let val vs = Induct.vars_of concl |
208 let val vs = Induct.vars_of concl |
220 in map_filter prep_var (Library.drop (length vs - length xs, vs) ~~ xs) end; |
209 in map_filter prep_var (Library.drop (length vs - length xs, vs) ~~ xs) end; |
221 |
210 |
222 in |
211 in |
223 |
212 |
224 fun gen_induct_tac inst_tac (varss, opt_rule) i state = |
213 fun gen_induct_tac inst_tac ctxt (varss, opt_rule) i state = |
225 SUBGOAL (fn (Bi,_) => |
214 SUBGOAL (fn (Bi,_) => |
226 let |
215 let |
227 val (rule, rule_name) = |
216 val (rule, rule_name) = |
228 case opt_rule of |
217 case opt_rule of |
229 SOME r => (r, "Induction rule") |
218 SOME r => (r, "Induction rule") |
230 | NONE => |
219 | NONE => |
231 let val tn = find_tname (hd (map_filter I (flat varss))) Bi |
220 let val tn = find_tname (hd (map_filter I (flat varss))) Bi |
232 val thy = Thm.theory_of_thm state |
221 val thy = Thm.theory_of_thm state |
233 in (#induction (the_datatype thy tn), "Induction rule for type " ^ tn) |
222 in case Induct.lookup_inductT ctxt tn of |
|
223 SOME thm => (thm, "Induction rule for type " ^ tn) |
|
224 | NONE => error ("No induction rule for type " ^ tn) |
234 end |
225 end |
235 val concls = HOLogic.dest_concls (Thm.concl_of rule); |
226 val concls = HOLogic.dest_concls (Thm.concl_of rule); |
236 val insts = maps prep_inst (concls ~~ varss) handle Library.UnequalLengths => |
227 val insts = maps prep_inst (concls ~~ varss) handle Library.UnequalLengths => |
237 error (rule_name ^ " has different numbers of variables"); |
228 error (rule_name ^ " has different numbers of variables"); |
238 in occs_in_prems (inst_tac insts rule) (map #2 insts) i end) |
229 in occs_in_prems (inst_tac insts rule) (map #2 insts) i end) |
239 i state; |
230 i state; |
240 |
231 |
241 fun induct_tac s = |
232 fun induct_tac ctxt s = |
242 gen_induct_tac Tactic.res_inst_tac' |
233 gen_induct_tac Tactic.res_inst_tac' ctxt |
243 (map (single o SOME) (Syntax.read_idents s), NONE); |
234 (map (single o SOME) (Syntax.read_idents s), NONE); |
244 |
235 |
245 fun induct_thm_tac th s = |
236 fun induct_thm_tac ctxt th s = |
246 gen_induct_tac Tactic.res_inst_tac' |
237 gen_induct_tac Tactic.res_inst_tac' ctxt |
247 ([map SOME (Syntax.read_idents s)], SOME th); |
238 ([map SOME (Syntax.read_idents s)], SOME th); |
248 |
239 |
249 end; |
240 end; |
250 |
241 |
251 |
242 |
543 end; |
534 end; |
544 |
535 |
545 |
536 |
546 (*********************** declare existing type as datatype *********************) |
537 (*********************** declare existing type as datatype *********************) |
547 |
538 |
548 fun gen_rep_datatype apply_theorems alt_names raw_distinct raw_inject raw_induction thy0 = |
539 fun prove_rep_datatype alt_names new_type_names descr sorts induct inject distinct thy = |
549 let |
540 let |
550 val (((distinct, inject), [induction]), thy1) = |
541 val ((_, [induct']), _) = |
551 thy0 |
542 Variable.importT_thms [induct] (Variable.thm_context induct); |
552 |> fold_map apply_theorems raw_distinct |
|
553 ||>> fold_map apply_theorems raw_inject |
|
554 ||>> apply_theorems [raw_induction]; |
|
555 |
|
556 val ((_, [induction']), _) = |
|
557 Variable.importT_thms [induction] (Variable.thm_context induction); |
|
558 |
543 |
559 fun err t = error ("Ill-formed predicate in induction rule: " ^ |
544 fun err t = error ("Ill-formed predicate in induction rule: " ^ |
560 Syntax.string_of_term_global thy1 t); |
545 Syntax.string_of_term_global thy t); |
561 |
546 |
562 fun get_typ (t as _ $ Var (_, Type (tname, Ts))) = |
547 fun get_typ (t as _ $ Var (_, Type (tname, Ts))) = |
563 ((tname, map (fst o dest_TFree) Ts) handle TERM _ => err t) |
548 ((tname, map (fst o dest_TFree) Ts) handle TERM _ => err t) |
564 | get_typ t = err t; |
549 | get_typ t = err t; |
565 |
550 val dtnames = map get_typ (HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induct'))); |
566 val dtnames = map get_typ (HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induction'))); |
551 |
567 val new_type_names = getOpt (alt_names, map fst dtnames); |
552 val dt_info = get_datatypes thy; |
568 |
|
569 fun get_constr t = (case Logic.strip_assums_concl t of |
|
570 _ $ (_ $ t') => (case head_of t' of |
|
571 Const (cname, cT) => (case strip_type cT of |
|
572 (Ts, Type (tname, _)) => (tname, (cname, map (dtyp_of_typ dtnames) Ts)) |
|
573 | _ => err t) |
|
574 | _ => err t) |
|
575 | _ => err t); |
|
576 |
|
577 fun make_dt_spec [] _ _ = [] |
|
578 | make_dt_spec ((tname, tvs)::dtnames') i constrs = |
|
579 let val (constrs', constrs'') = take_prefix (equal tname o fst) constrs |
|
580 in (i, (tname, map DtTFree tvs, map snd constrs')):: |
|
581 (make_dt_spec dtnames' (i + 1) constrs'') |
|
582 end; |
|
583 |
|
584 val descr = make_dt_spec dtnames 0 (map get_constr (prems_of induction')); |
|
585 val sorts = add_term_tfrees (concl_of induction', []); |
|
586 val dt_info = get_datatypes thy1; |
|
587 |
553 |
588 val (case_names_induct, case_names_exhausts) = |
554 val (case_names_induct, case_names_exhausts) = |
589 (mk_case_names_induct descr, mk_case_names_exhausts descr (map #1 dtnames)); |
555 (mk_case_names_induct descr, mk_case_names_exhausts descr (map #1 dtnames)); |
590 |
556 |
591 val _ = message ("Proofs for datatype(s) " ^ commas_quote new_type_names); |
557 val _ = message ("Proofs for datatype(s) " ^ commas_quote new_type_names); |
592 |
558 |
593 val (casedist_thms, thy2) = thy1 |> |
559 val (casedist_thms, thy2) = thy |> |
594 DatatypeAbsProofs.prove_casedist_thms new_type_names [descr] sorts induction |
560 DatatypeAbsProofs.prove_casedist_thms new_type_names [descr] sorts induct |
595 case_names_exhausts; |
561 case_names_exhausts; |
596 val ((reccomb_names, rec_thms), thy3) = DatatypeAbsProofs.prove_primrec_thms |
562 val ((reccomb_names, rec_thms), thy3) = DatatypeAbsProofs.prove_primrec_thms |
597 false new_type_names [descr] sorts dt_info inject distinct |
563 false new_type_names [descr] sorts dt_info inject distinct |
598 (Simplifier.theory_context thy2 dist_ss) induction thy2; |
564 (Simplifier.theory_context thy2 dist_ss) induct thy2; |
599 val ((case_thms, case_names), thy4) = DatatypeAbsProofs.prove_case_thms false |
565 val ((case_thms, case_names), thy4) = DatatypeAbsProofs.prove_case_thms false |
600 new_type_names [descr] sorts reccomb_names rec_thms thy3; |
566 new_type_names [descr] sorts reccomb_names rec_thms thy3; |
601 val (split_thms, thy5) = DatatypeAbsProofs.prove_split_thms |
567 val (split_thms, thy5) = DatatypeAbsProofs.prove_split_thms |
602 new_type_names [descr] sorts inject distinct casedist_thms case_thms thy4; |
568 new_type_names [descr] sorts inject distinct casedist_thms case_thms thy4; |
603 val (nchotomys, thy6) = DatatypeAbsProofs.prove_nchotomys new_type_names |
569 val (nchotomys, thy6) = DatatypeAbsProofs.prove_nchotomys new_type_names |
605 val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names |
571 val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names |
606 [descr] sorts nchotomys case_thms thy6; |
572 [descr] sorts nchotomys case_thms thy6; |
607 val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names |
573 val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names |
608 [descr] sorts thy7; |
574 [descr] sorts thy7; |
609 |
575 |
610 val ((_, [induction']), thy10) = |
576 val ((_, [induct']), thy10) = |
611 thy8 |
577 thy8 |
612 |> store_thmss "inject" new_type_names inject |
578 |> store_thmss "inject" new_type_names inject |
613 ||>> store_thmss "distinct" new_type_names distinct |
579 ||>> store_thmss "distinct" new_type_names distinct |
614 ||> Sign.add_path (space_implode "_" new_type_names) |
580 ||> Sign.add_path (space_implode "_" new_type_names) |
615 ||>> PureThy.add_thms [(("induct", induction), [case_names_induct])]; |
581 ||>> PureThy.add_thms [(("induct", induct), [case_names_induct])]; |
616 |
582 |
617 val dt_infos = map (make_dt_info alt_names descr sorts induction' reccomb_names rec_thms) |
583 val dt_infos = map (make_dt_info alt_names descr sorts induct' reccomb_names rec_thms) |
618 ((0 upto length descr - 1) ~~ descr ~~ case_names ~~ case_thms ~~ casedist_thms ~~ |
584 ((0 upto length descr - 1) ~~ descr ~~ case_names ~~ case_thms ~~ casedist_thms ~~ |
619 map FewConstrs distinct ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs); |
585 map FewConstrs distinct ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs); |
620 |
586 |
621 val simps = flat (distinct @ inject @ case_thms) @ rec_thms; |
587 val simps = flat (distinct @ inject @ case_thms) @ rec_thms; |
622 |
588 |
636 inject = inject, |
602 inject = inject, |
637 exhaustion = casedist_thms, |
603 exhaustion = casedist_thms, |
638 rec_thms = rec_thms, |
604 rec_thms = rec_thms, |
639 case_thms = case_thms, |
605 case_thms = case_thms, |
640 split_thms = split_thms, |
606 split_thms = split_thms, |
641 induction = induction', |
607 induction = induct', |
642 simps = simps}, thy11) |
608 simps = simps}, thy11) |
643 end; |
609 end; |
644 |
610 |
645 val rep_datatype = gen_rep_datatype IsarCmd.apply_theorems; |
611 fun gen_rep_datatype prep_term after_qed alt_names raw_ts thy = |
646 val rep_datatype_i = gen_rep_datatype IsarCmd.apply_theorems_i; |
612 let |
|
613 fun constr_of_term (Const (c, T)) = (c, T) |
|
614 | constr_of_term t = |
|
615 error ("Not a constant: " ^ Syntax.string_of_term_global thy t); |
|
616 fun no_constr (c, T) = error ("Bad constructor: " |
|
617 ^ Sign.extern_const thy c ^ "::" |
|
618 ^ Syntax.string_of_typ_global thy T); |
|
619 fun type_of_constr (cT as (_, T)) = |
|
620 let |
|
621 val frees = typ_tfrees T; |
|
622 val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) T |
|
623 handle TYPE _ => no_constr cT |
|
624 val _ = if has_duplicates (eq_fst (op =)) vs then no_constr cT else (); |
|
625 val _ = if length frees <> length vs then no_constr cT else (); |
|
626 in (tyco, (vs, cT)) end; |
|
627 |
|
628 val raw_cs = AList.group (op =) (map (type_of_constr o constr_of_term o prep_term thy) raw_ts); |
|
629 val _ = case map_filter (fn (tyco, _) => |
|
630 if Symtab.defined (get_datatypes thy) tyco then SOME tyco else NONE) raw_cs |
|
631 of [] => () |
|
632 | tycos => error ("Type(s) " ^ commas (map quote tycos) |
|
633 ^ " already represented inductivly"); |
|
634 val raw_vss = maps (map (map snd o fst) o snd) raw_cs; |
|
635 val ms = case distinct (op =) (map length raw_vss) |
|
636 of [n] => 0 upto n - 1 |
|
637 | _ => error ("Different types in given constructors"); |
|
638 fun inter_sort m = map (fn xs => nth xs m) raw_vss |
|
639 |> Library.foldr1 (Sorts.inter_sort (Sign.classes_of thy)) |
|
640 val sorts = map inter_sort ms; |
|
641 val vs = Name.names Name.context Name.aT sorts; |
|
642 |
|
643 fun norm_constr (raw_vs, (c, T)) = (c, map_atyps |
|
644 (TFree o (the o AList.lookup (op =) (map fst raw_vs ~~ vs)) o fst o dest_TFree) T); |
|
645 |
|
646 val cs = map (apsnd (map norm_constr)) raw_cs; |
|
647 val dtyps_of_typ = map (dtyp_of_typ (map (rpair (map fst vs) o fst) cs)) |
|
648 o fst o strip_type; |
|
649 val new_type_names = map NameSpace.base (the_default (map fst cs) alt_names); |
|
650 |
|
651 fun mk_spec (i, (tyco, constr)) = (i, (tyco, |
|
652 map (DtTFree o fst) vs, |
|
653 (map o apsnd) dtyps_of_typ constr)) |
|
654 val descr = map_index mk_spec cs; |
|
655 val injs = DatatypeProp.make_injs [descr] vs; |
|
656 val distincts = map snd (DatatypeProp.make_distincts [descr] vs); |
|
657 val ind = DatatypeProp.make_ind [descr] vs; |
|
658 val rules = (map o map o map) Logic.close_form [[[ind]], injs, distincts]; |
|
659 |
|
660 fun after_qed' raw_thms = |
|
661 let |
|
662 val [[[induct]], injs, distincts] = |
|
663 unflat rules (map Drule.zero_var_indexes_list raw_thms); |
|
664 (*FIXME somehow dubious*) |
|
665 in |
|
666 ProofContext.theory_result |
|
667 (prove_rep_datatype alt_names new_type_names descr vs induct injs distincts) |
|
668 #-> after_qed |
|
669 end; |
|
670 in |
|
671 thy |
|
672 |> ProofContext.init |
|
673 |> Proof.theorem_i NONE after_qed' ((map o map) (rpair []) (flat rules)) |
|
674 end; |
|
675 |
|
676 val rep_datatype = gen_rep_datatype Sign.cert_term; |
|
677 val rep_datatype_cmd = gen_rep_datatype Sign.read_term (K I); |
647 |
678 |
648 |
679 |
649 |
680 |
650 (******************************** add datatype ********************************) |
681 (******************************** add datatype ********************************) |
651 |
682 |
784 |
815 |
785 (* outer syntax *) |
816 (* outer syntax *) |
786 |
817 |
787 local structure P = OuterParse and K = OuterKeyword in |
818 local structure P = OuterParse and K = OuterKeyword in |
788 |
819 |
789 val _ = OuterSyntax.keywords ["distinct", "inject", "induction"]; |
|
790 |
|
791 val datatype_decl = |
820 val datatype_decl = |
792 Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.name -- P.opt_infix -- |
821 Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.name -- P.opt_infix -- |
793 (P.$$$ "=" |-- P.enum1 "|" (P.name -- Scan.repeat P.typ -- P.opt_mixfix)); |
822 (P.$$$ "=" |-- P.enum1 "|" (P.name -- Scan.repeat P.typ -- P.opt_mixfix)); |
794 |
823 |
795 fun mk_datatype args = |
824 fun mk_datatype args = |
796 let |
825 let |
797 val names = map (fn ((((NONE, _), t), _), _) => t | ((((SOME t, _), _), _), _) => t) args; |
826 val names = map (fn ((((NONE, _), t), _), _) => t | ((((SOME t, _), _), _), _) => t) args; |
798 val specs = map (fn ((((_, vs), t), mx), cons) => |
827 val specs = map (fn ((((_, vs), t), mx), cons) => |
799 (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args; |
828 (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args; |
800 in snd o add_datatype false names specs end; |
829 in snd o add_datatype_cmd false names specs end; |
801 |
830 |
802 val _ = |
831 val _ = |
803 OuterSyntax.command "datatype" "define inductive datatypes" K.thy_decl |
832 OuterSyntax.command "datatype" "define inductive datatypes" K.thy_decl |
804 (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype)); |
833 (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype)); |
805 |
834 |
806 |
|
807 val rep_datatype_decl = |
|
808 Scan.option (Scan.repeat1 P.name) -- |
|
809 Scan.optional (P.$$$ "distinct" |-- P.!!! (P.and_list1 SpecParse.xthms1)) [[]] -- |
|
810 Scan.optional (P.$$$ "inject" |-- P.!!! (P.and_list1 SpecParse.xthms1)) [[]] -- |
|
811 (P.$$$ "induction" |-- P.!!! SpecParse.xthm); |
|
812 |
|
813 fun mk_rep_datatype (((opt_ts, dss), iss), ind) = #2 o rep_datatype opt_ts dss iss ind; |
|
814 |
|
815 val _ = |
835 val _ = |
816 OuterSyntax.command "rep_datatype" "represent existing types inductively" K.thy_decl |
836 OuterSyntax.command "rep_datatype" "represent existing types inductively" K.thy_goal |
817 (rep_datatype_decl >> (Toplevel.theory o mk_rep_datatype)); |
837 (Scan.option (P.$$$ "(" |-- Scan.repeat1 P.name --| P.$$$ ")") -- Scan.repeat1 P.term |
|
838 >> (fn (alt_names, ts) => Toplevel.print |
|
839 o Toplevel.theory_to_proof (rep_datatype_cmd alt_names ts))); |
818 |
840 |
819 val _ = |
841 val _ = |
820 ThyOutput.add_commands [("datatype", |
842 ThyOutput.add_commands [("datatype", |
821 ThyOutput.args args_datatype (ThyOutput.output pretty_datatype))]; |
843 ThyOutput.args args_datatype (ThyOutput.output pretty_datatype))]; |
822 |
844 |
823 end; |
845 end; |
824 |
846 |
825 |
|
826 end; |
847 end; |
827 |
848 |