454 fun thm_args f = thms_args (fn [thm] => f thm | _ => error "Single theorem expected"); |
454 fun thm_args f = thms_args (fn [thm] => f thm | _ => error "Single theorem expected"); |
455 |
455 |
456 end; |
456 end; |
457 |
457 |
458 |
458 |
|
459 (* extra rule methods *) |
|
460 |
|
461 fun xrule_meth m = |
|
462 Scan.lift (Scan.optional (Args.parens OuterParse.nat) 0) -- Attrib.thms >> |
|
463 (fn (n, ths) => K (m n ths)); |
|
464 |
|
465 |
459 (* tactic syntax *) |
466 (* tactic syntax *) |
460 |
467 |
461 fun nat_thms_args f = uncurry f oo |
468 fun goal_args' args tac src ctxt = fst (syntax (Args.goal_spec -- args >> |
462 (fst oo syntax (Scan.lift (Scan.optional (Args.parens P.nat) 0) -- Attrib.thms)); |
|
463 |
|
464 fun goal_args' args tac src ctxt = fst (syntax (Args.goal_spec HEADGOAL -- args >> |
|
465 (fn (quant, s) => SIMPLE_METHOD'' quant (tac s))) src ctxt); |
469 (fn (quant, s) => SIMPLE_METHOD'' quant (tac s))) src ctxt); |
466 |
470 |
467 fun goal_args args tac = goal_args' (Scan.lift args) tac; |
471 fun goal_args args tac = goal_args' (Scan.lift args) tac; |
468 |
472 |
469 fun goal_args_ctxt' args tac src ctxt = |
473 fun goal_args_ctxt' args tac src ctxt = |
470 fst (syntax (Args.goal_spec HEADGOAL -- args >> |
474 fst (syntax (Args.goal_spec -- args >> |
471 (fn (quant, s) => SIMPLE_METHOD'' quant (tac ctxt s))) src ctxt); |
475 (fn (quant, s) => SIMPLE_METHOD'' quant (tac ctxt s))) src ctxt); |
472 |
476 |
473 fun goal_args_ctxt args tac = goal_args_ctxt' (Scan.lift args) tac; |
477 fun goal_args_ctxt args tac = goal_args_ctxt' (Scan.lift args) tac; |
474 |
478 |
475 |
479 |
498 |
502 |
499 |
503 |
500 (* theory setup *) |
504 (* theory setup *) |
501 |
505 |
502 val _ = Context.>> (Context.map_theory |
506 val _ = Context.>> (Context.map_theory |
503 (add_methods |
507 (setup (Binding.name "fail") (Scan.succeed (K fail)) "force failure" #> |
504 [("fail", no_args fail, "force failure"), |
508 setup (Binding.name "succeed") (Scan.succeed (K succeed)) "succeed" #> |
505 ("succeed", no_args succeed, "succeed"), |
509 setup (Binding.name "-") (Scan.succeed (K insert_facts)) |
506 ("-", no_args insert_facts, "do nothing (insert current facts only)"), |
510 "do nothing (insert current facts only)" #> |
507 ("insert", thms_args insert, "insert theorems, ignoring facts (improper)"), |
511 setup (Binding.name "insert") (Attrib.thms >> (K o insert)) |
508 ("intro", thms_args intro, "repeatedly apply introduction rules"), |
512 "insert theorems, ignoring facts (improper)" #> |
509 ("elim", thms_args elim, "repeatedly apply elimination rules"), |
513 setup (Binding.name "intro") (Attrib.thms >> (K o intro)) |
510 ("unfold", thms_ctxt_args unfold_meth, "unfold definitions"), |
514 "repeatedly apply introduction rules" #> |
511 ("fold", thms_ctxt_args fold_meth, "fold definitions"), |
515 setup (Binding.name "elim") (Attrib.thms >> (K o elim)) |
512 ("atomize", (atomize o fst) oo syntax (Args.mode "full"), |
516 "repeatedly apply elimination rules" #> |
513 "present local premises as object-level statements"), |
517 setup (Binding.name "unfold") (Attrib.thms >> unfold_meth) "unfold definitions" #> |
514 ("rule", thms_ctxt_args some_rule, "apply some intro/elim rule"), |
518 setup (Binding.name "fold") (Attrib.thms >> fold_meth) "fold definitions" #> |
515 ("erule", nat_thms_args erule, "apply rule in elimination manner (improper)"), |
519 setup (Binding.name "atomize") (Args.mode "full" >> (K o atomize)) |
516 ("drule", nat_thms_args drule, "apply rule in destruct manner (improper)"), |
520 "present local premises as object-level statements" #> |
517 ("frule", nat_thms_args frule, "apply rule in forward manner (improper)"), |
521 setup (Binding.name "rule") (Attrib.thms >> some_rule) "apply some intro/elim rule" #> |
518 ("this", no_args this, "apply current facts as rules"), |
522 setup (Binding.name "erule") (xrule_meth erule) "apply rule in elimination manner (improper)" #> |
519 ("fact", thms_ctxt_args fact, "composition by facts from context"), |
523 setup (Binding.name "drule") (xrule_meth drule) "apply rule in destruct manner (improper)" #> |
520 ("assumption", ctxt_args assumption, "proof by assumption, preferring facts"), |
524 setup (Binding.name "frule") (xrule_meth frule) "apply rule in forward manner (improper)" #> |
521 ("rename_tac", goal_args (Scan.repeat1 Args.name) Tactic.rename_tac, |
525 setup (Binding.name "this") (Scan.succeed (K this)) "apply current facts as rules" #> |
522 "rename parameters of goal"), |
526 setup (Binding.name "fact") (Attrib.thms >> fact) "composition by facts from context" #> |
523 ("rotate_tac", goal_args (Scan.optional P.int 1) Tactic.rotate_tac, |
527 setup (Binding.name "assumption") (Scan.succeed assumption) |
524 "rotate assumptions of goal"), |
528 "proof by assumption, preferring facts" #> |
525 ("tactic", simple_args (P.position Args.name) tactic, "ML tactic as proof method"), |
529 setup (Binding.name "rename_tac") (Args.goal_spec -- Scan.lift (Scan.repeat1 Args.name) >> |
526 ("raw_tactic", simple_args (P.position Args.name) raw_tactic, |
530 (fn (quant, xs) => K (SIMPLE_METHOD'' quant (Tactic.rename_tac xs)))) |
527 "ML tactic as raw proof method")])); |
531 "rename parameters of goal" #> |
|
532 setup (Binding.name "rotate_tac") (Args.goal_spec -- Scan.lift (Scan.optional P.int 1) >> |
|
533 (fn (quant, i) => K (SIMPLE_METHOD'' quant (Tactic.rotate_tac i)))) |
|
534 "rotate assumptions of goal" #> |
|
535 setup (Binding.name "tactic") (Scan.lift (P.position Args.name) >> tactic) |
|
536 "ML tactic as proof method" #> |
|
537 setup (Binding.name "raw_tactic") (Scan.lift (P.position Args.name) >> raw_tactic) |
|
538 "ML tactic as raw proof method")); |
528 |
539 |
529 |
540 |
530 (*final declarations of this structure!*) |
541 (*final declarations of this structure!*) |
531 val unfold = unfold_meth; |
542 val unfold = unfold_meth; |
532 val fold = fold_meth; |
543 val fold = fold_meth; |