13 val lookup_by_constr: Proof.context -> string * typ -> (term * term list) option |
13 val lookup_by_constr: Proof.context -> string * typ -> (term * term list) option |
14 val lookup_by_constr_permissive: Proof.context -> string * typ -> (term * term list) option |
14 val lookup_by_constr_permissive: Proof.context -> string * typ -> (term * term list) option |
15 val lookup_by_case: Proof.context -> string -> (term * term list) option |
15 val lookup_by_case: Proof.context -> string -> (term * term list) option |
16 val make_case: Proof.context -> config -> Name.context -> term -> (term * term) list -> term |
16 val make_case: Proof.context -> config -> Name.context -> term -> (term * term) list -> term |
17 val print_case_translations: Proof.context -> unit |
17 val print_case_translations: Proof.context -> unit |
18 val strip_case: Proof.context -> bool -> term -> term |
18 val strip_case: Proof.context -> bool -> term -> (term * (term * term) list) option |
|
19 val strip_case_full: Proof.context -> bool -> term -> term |
19 val show_cases: bool Config.T |
20 val show_cases: bool Config.T |
20 val setup: theory -> theory |
21 val setup: theory -> theory |
21 val register: term -> term list -> Context.generic -> Context.generic |
22 val register: term -> term list -> Context.generic -> Context.generic |
22 end; |
23 end; |
23 |
24 |
499 | _ => NONE); |
500 | _ => NONE); |
500 |
501 |
501 |
502 |
502 (* destruct nested patterns *) |
503 (* destruct nested patterns *) |
503 |
504 |
504 fun encode_clause S T (pat, rhs) = |
505 fun encode_clause recur S T (pat, rhs) = |
505 fold (fn x as (_, U) => fn t => |
506 fold (fn x as (_, U) => fn t => |
506 Const (@{const_name case_abs}, (U --> T) --> T) $ Term.absfree x t) |
507 Const (@{const_name case_abs}, (U --> T) --> T) $ Term.absfree x t) |
507 (Term.add_frees pat []) |
508 (Term.add_frees pat []) |
508 (Const (@{const_name case_elem}, S --> T --> S --> T) $ pat $ rhs); |
509 (Const (@{const_name case_elem}, S --> T --> S --> T) $ pat $ recur rhs); |
509 |
510 |
510 fun encode_cases S T [] = Const (@{const_name case_nil}, S --> T) |
511 fun encode_cases _ S T [] = Const (@{const_name case_nil}, S --> T) |
511 | encode_cases S T (p :: ps) = |
512 | encode_cases recur S T (p :: ps) = |
512 Const (@{const_name case_cons}, (S --> T) --> (S --> T) --> S --> T) $ |
513 Const (@{const_name case_cons}, (S --> T) --> (S --> T) --> S --> T) $ |
513 encode_clause S T p $ encode_cases S T ps; |
514 encode_clause recur S T p $ encode_cases recur S T ps; |
514 |
515 |
515 fun encode_case (t, ps as (pat, rhs) :: _) = |
516 fun encode_case recur (t, ps as (pat, rhs) :: _) = |
516 let |
517 let |
517 val T = fastype_of rhs; |
518 val T = fastype_of rhs; |
518 in |
519 in |
519 Const (@{const_name case_guard}, T --> T) $ |
520 Const (@{const_name case_guard}, T --> T) $ |
520 (encode_cases (fastype_of pat) (fastype_of rhs) ps $ t) |
521 (encode_cases recur (fastype_of pat) (fastype_of rhs) ps $ t) |
521 end |
522 end |
522 | encode_case _ = case_error "encode_case"; |
523 | encode_case _ _ = case_error "encode_case"; |
523 |
524 |
524 fun strip_case' ctxt d (pat, rhs) = |
525 fun strip_case' ctxt d (pat, rhs) = |
525 (case dest_case ctxt d (Term.declare_term_frees pat Name.context) rhs of |
526 (case dest_case ctxt d (Term.declare_term_frees pat Name.context) rhs of |
526 SOME (exp as Free _, clauses) => |
527 SOME (exp as Free _, clauses) => |
527 if Term.exists_subterm (curry (op aconv) exp) pat andalso |
528 if Term.exists_subterm (curry (op aconv) exp) pat andalso |
533 else [(pat, rhs)] |
534 else [(pat, rhs)] |
534 | _ => [(pat, rhs)]); |
535 | _ => [(pat, rhs)]); |
535 |
536 |
536 fun strip_case ctxt d t = |
537 fun strip_case ctxt d t = |
537 (case dest_case ctxt d Name.context t of |
538 (case dest_case ctxt d Name.context t of |
538 SOME (x, clauses) => encode_case (x, maps (strip_case' ctxt d) clauses) |
539 SOME (x, clauses) => SOME (x, maps (strip_case' ctxt d) clauses) |
|
540 | NONE => NONE); |
|
541 |
|
542 fun strip_case_full ctxt d t = |
|
543 (case dest_case ctxt d Name.context t of |
|
544 SOME (x, clauses) => |
|
545 encode_case (strip_case_full ctxt d) |
|
546 (strip_case_full ctxt d x, maps (strip_case' ctxt d) clauses) |
539 | NONE => |
547 | NONE => |
540 (case t of |
548 (case t of |
541 (t $ u) => strip_case ctxt d t $ strip_case ctxt d u |
549 (t $ u) => strip_case_full ctxt d t $ strip_case_full ctxt d u |
542 | (Abs (x, T, u)) => |
550 | (Abs (x, T, u)) => |
543 let val (x', u') = Term.dest_abs (x, T, u); |
551 let val (x', u') = Term.dest_abs (x, T, u); |
544 in Term.absfree (x', T) (strip_case ctxt d u') end |
552 in Term.absfree (x', T) (strip_case_full ctxt d u') end |
545 | _ => t)); |
553 | _ => t)); |
546 |
554 |
547 |
555 |
548 (* term uncheck *) |
556 (* term uncheck *) |
549 |
557 |
550 val show_cases = Attrib.setup_config_bool @{binding show_cases} (K true); |
558 val show_cases = Attrib.setup_config_bool @{binding show_cases} (K true); |
551 |
559 |
552 fun uncheck_case ctxt ts = |
560 fun uncheck_case ctxt ts = |
553 if Config.get ctxt show_cases then map (strip_case ctxt true) ts else ts; |
561 if Config.get ctxt show_cases then map (strip_case_full ctxt true) ts else ts; |
554 |
562 |
555 val term_uncheck_setup = |
563 val term_uncheck_setup = |
556 Context.theory_map (Syntax_Phases.term_uncheck 1 "case" uncheck_case); |
564 Context.theory_map (Syntax_Phases.term_uncheck 1 "case" uncheck_case); |
557 |
565 |
558 |
566 |