src/HOL/Tools/datatype_package.ML
changeset 14174 f3cafd2929d5
parent 13641 63d1790a43ed
child 14412 109cc0dc706b
equal deleted inserted replaced
14173:a3690aeb79d4 14174:f3cafd2929d5
   187   let val vs = InductAttrib.vars_of concl
   187   let val vs = InductAttrib.vars_of concl
   188   in mapfilter prep_var (Library.drop (length vs - length xs, vs) ~~ xs) end;
   188   in mapfilter prep_var (Library.drop (length vs - length xs, vs) ~~ xs) end;
   189 
   189 
   190 in
   190 in
   191 
   191 
   192 fun gen_induct_tac (varss, opt_rule) i state =
   192 fun gen_induct_tac inst_tac (varss, opt_rule) i state =
   193   let
   193   let
   194     val (_, _, Bi, _) = Thm.dest_state (state, i);
   194     val (_, _, Bi, _) = Thm.dest_state (state, i);
   195     val {sign, ...} = Thm.rep_thm state;
   195     val {sign, ...} = Thm.rep_thm state;
   196     val (rule, rule_name) =
   196     val (rule, rule_name) =
   197       (case opt_rule of
   197       (case opt_rule of
   201           in (#induction (datatype_info_sg_err sign tn), "Induction rule for type " ^ tn) end);
   201           in (#induction (datatype_info_sg_err sign tn), "Induction rule for type " ^ tn) end);
   202 
   202 
   203     val concls = HOLogic.dest_concls (Thm.concl_of rule);
   203     val concls = HOLogic.dest_concls (Thm.concl_of rule);
   204     val insts = flat (map prep_inst (concls ~~ varss)) handle LIST _ =>
   204     val insts = flat (map prep_inst (concls ~~ varss)) handle LIST _ =>
   205       error (rule_name ^ " has different numbers of variables");
   205       error (rule_name ^ " has different numbers of variables");
   206   in occs_in_prems (Tactic.res_inst_tac insts rule) (map #2 insts) i state end;
   206   in occs_in_prems (inst_tac insts rule) (map #2 insts) i state end;
   207 
   207 
   208 fun induct_tac s = gen_induct_tac (map (Library.single o Some) (Syntax.read_idents s), None);
   208 fun induct_tac s =
       
   209   gen_induct_tac Tactic.res_inst_tac
       
   210     (map (Library.single o Some) (Syntax.read_idents s), None);
   209 
   211 
   210 fun induct_thm_tac th s =
   212 fun induct_thm_tac th s =
   211   gen_induct_tac ([map Some (Syntax.read_idents s)], Some th);
   213   gen_induct_tac Tactic.res_inst_tac
       
   214     ([map Some (Syntax.read_idents s)], Some th);
   212 
   215 
   213 end;
   216 end;
   214 
   217 
   215 
   218 
   216 (* generic case tactic for datatypes *)
   219 (* generic case tactic for datatypes *)
   217 
   220 
   218 fun case_inst_tac t rule i state =
   221 fun case_inst_tac inst_tac t rule i state =
   219   let
   222   let
   220     val _ $ Var (ixn, _) $ _ = HOLogic.dest_Trueprop
   223     val _ $ Var (ixn, _) $ _ = HOLogic.dest_Trueprop
   221       (hd (Logic.strip_assums_hyp (hd (Thm.prems_of rule))));
   224       (hd (Logic.strip_assums_hyp (hd (Thm.prems_of rule))));
   222     val exh_vname = implode (tl (explode (Syntax.string_of_vname ixn)));
   225     val exh_vname = implode (tl (explode (Syntax.string_of_vname ixn)));
   223   in Tactic.res_inst_tac [(exh_vname, t)] rule i state end;
   226   in inst_tac [(exh_vname, t)] rule i state end;
   224 
   227 
   225 fun gen_case_tac (t, Some rule) i state = case_inst_tac t rule i state
   228 fun gen_case_tac inst_tac (t, Some rule) i state =
   226   | gen_case_tac (t, None) i state =
   229       case_inst_tac inst_tac t rule i state
       
   230   | gen_case_tac inst_tac (t, None) i state =
   227       let val tn = infer_tname state i t in
   231       let val tn = infer_tname state i t in
   228         if tn = HOLogic.boolN then Tactic.res_inst_tac [("P", t)] case_split_thm i state
   232         if tn = HOLogic.boolN then inst_tac [("P", t)] case_split_thm i state
   229         else case_inst_tac t (#exhaustion (datatype_info_sg_err (Thm.sign_of_thm state) tn)) i state
   233         else case_inst_tac inst_tac t
       
   234                (#exhaustion (datatype_info_sg_err (Thm.sign_of_thm state) tn))
       
   235                i state
   230       end;
   236       end;
   231 
   237 
   232 fun case_tac t = gen_case_tac (t, None);
   238 fun case_tac t = gen_case_tac Tactic.res_inst_tac (t, None);
   233 
   239 
   234 
   240 
   235 
   241 
   236 (** Isar tactic emulations **)
   242 (** Isar tactic emulations **)
   237 
   243 
   240 val rule_spec = Scan.lift (Args.$$$ "rule" -- Args.$$$ ":");
   246 val rule_spec = Scan.lift (Args.$$$ "rule" -- Args.$$$ ":");
   241 val opt_rule = Scan.option (rule_spec |-- Attrib.local_thm);
   247 val opt_rule = Scan.option (rule_spec |-- Attrib.local_thm);
   242 
   248 
   243 val varss = Args.and_list (Scan.repeat (Scan.unless rule_spec (Scan.lift Args.name_dummy)));
   249 val varss = Args.and_list (Scan.repeat (Scan.unless rule_spec (Scan.lift Args.name_dummy)));
   244 
   250 
       
   251 fun mk_ixn (vars, s) = (fst (Term.dest_Var (Syntax.read_var ("?" ^ vars))), s)
       
   252   handle _ => error (vars ^ " not a variable name");
       
   253 fun inst_tac ctxt sinsts =
       
   254   Method.bires_inst_tac false ctxt (map mk_ixn sinsts);
       
   255 
       
   256 fun induct_meth ctxt (varss, opt_rule) =
       
   257   gen_induct_tac (inst_tac ctxt) (varss, opt_rule);
       
   258 fun case_meth ctxt (varss, opt_rule) =
       
   259   gen_case_tac (inst_tac ctxt) (varss, opt_rule);
       
   260 
   245 in
   261 in
   246 
   262 
   247 val tactic_emulations =
   263 val tactic_emulations =
   248  [("induct_tac", Method.goal_args' (varss -- opt_rule) gen_induct_tac,
   264  [("induct_tac", Method.goal_args_ctxt' (varss -- opt_rule) induct_meth,
   249     "induct_tac emulation (dynamic instantiation!)"),
   265     "induct_tac emulation (dynamic instantiation)"),
   250   ("case_tac", Method.goal_args' (Scan.lift Args.name -- opt_rule) gen_case_tac,
   266   ("case_tac", Method.goal_args_ctxt' (Scan.lift Args.name -- opt_rule) case_meth,
   251     "case_tac emulation (dynamic instantiation!)")];
   267     "case_tac emulation (dynamic instantiation)")];
   252 
   268 
   253 end;
   269 end;
   254 
   270 
   255 
   271 
   256 
   272