1 (* Title: HOL/Tools/Lifting/lifting_util.ML
4 General-purpose functions used by the Lifting package.
7 signature LIFTING_UTIL =
9 val MRSL: thm list * thm -> thm
10 val option_fold: 'b -> ('a -> 'b) -> 'a option -> 'b
11 val map_snd: ('b -> 'c) -> ('a * 'b) list -> ('a * 'c) list
12 val dest_Quotient: term -> term * term * term * term
14 val quot_thm_rel: thm -> term
15 val quot_thm_abs: thm -> term
16 val quot_thm_rep: thm -> term
17 val quot_thm_crel: thm -> term
18 val quot_thm_rty_qty: thm -> typ * typ
20 val undisch: thm -> thm
21 val undisch_all: thm -> thm
22 val is_fun_type: typ -> bool
23 val get_args: int -> term -> term list
24 val strip_args: int -> term -> term
25 val all_args_conv: conv -> conv
26 val is_Type: typ -> bool
27 val is_fun_rel: term -> bool
28 val relation_types: typ -> typ * typ
29 val mk_HOL_eq: thm -> thm
30 val safe_HOL_meta_eq: thm -> thm
34 structure Lifting_Util: LIFTING_UTIL =
39 fun ants MRSL thm = fold (fn rl => fn thm => rl RS thm) ants thm
41 fun option_fold a _ NONE = a
42 | option_fold _ f (SOME x) = f x
44 fun map_snd f xs = map (fn (a, b) => (a, f b)) xs
46 fun dest_Quotient (Const (@{const_name Quotient}, _) $ rel $ abs $ rep $ cr)
48 | dest_Quotient t = raise TERM ("dest_Quotient", [t])
51 quot_thm_rel, quot_thm_abs, quot_thm_rep and quot_thm_rty_qty - simple functions
52 for destructing quotient theorems (Quotient R Abs Rep T).
55 fun quot_thm_rel quot_thm =
56 case (dest_Quotient o HOLogic.dest_Trueprop o prop_of) quot_thm of
59 fun quot_thm_abs quot_thm =
60 case (dest_Quotient o HOLogic.dest_Trueprop o prop_of) quot_thm of
63 fun quot_thm_rep quot_thm =
64 case (dest_Quotient o HOLogic.dest_Trueprop o prop_of) quot_thm of
67 fun quot_thm_crel quot_thm =
68 case (dest_Quotient o HOLogic.dest_Trueprop o prop_of) quot_thm of
69 (_, _, _, crel) => crel
71 fun quot_thm_rty_qty quot_thm =
73 val abs = quot_thm_abs quot_thm
74 val abs_type = fastype_of abs
76 (domain_type abs_type, range_type abs_type)
81 val assm = Thm.cprem_of thm 1
83 Thm.implies_elim thm (Thm.assume assm)
86 fun undisch_all thm = funpow (nprems_of thm) undisch thm
88 fun is_fun_type (Type (@{type_name fun}, _)) = true
89 | is_fun_type _ = false
91 fun get_args n = rev o fst o funpow_yield n (swap o dest_comb)
93 fun strip_args n = funpow n (fst o dest_comb)
95 fun all_args_conv conv ctm =
96 (Conv.combination_conv (Conv.try_conv (all_args_conv conv)) conv) ctm
98 fun is_Type (Type _) = true
101 fun is_fun_rel (Const (@{const_name "fun_rel"}, _) $ _ $ _) = true
102 | is_fun_rel _ = false
104 fun relation_types typ =
105 case strip_type typ of
106 ([typ1, typ2], @{typ bool}) => (typ1, typ2)
107 | _ => error "relation_types: not a relation"
109 fun mk_HOL_eq r = r RS @{thm meta_eq_to_obj_eq}
111 fun safe_HOL_meta_eq r = mk_HOL_eq r handle Thm.THM _ => r