src/HOL/Tools/Nitpick/nitpick_hol.ML

thread along context instead of theory for typedef lookup

(*  Title:      HOL/Tools/Nitpick/nitpick_hol.ML
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2008, 2009, 2010

Auxiliary HOL-related functions used by Nitpick.
*)

signature NITPICK_HOL =
sig
  type styp = Nitpick_Util.styp
  type const_table = term list Symtab.table
  type special_fun = (styp * int list * term list) * styp
  type unrolled = styp * styp
  type wf_cache = (styp * (bool * bool)) list

  type hol_context =
    {thy: theory,
     ctxt: Proof.context,
     max_bisim_depth: int,
     boxes: (typ option * bool option) list,
     stds: (typ option * bool) list,
     wfs: (styp option * bool option) list,
     user_axioms: bool option,
     debug: bool,
     binary_ints: bool option,
     destroy_constrs: bool,
     specialize: bool,
     star_linear_preds: bool,
     fast_descrs: bool,
     tac_timeout: Time.time option,
     evals: term list,
     case_names: (string * int) list,
     def_table: const_table,
     nondef_table: const_table,
     user_nondefs: term list,
     simp_table: const_table Unsynchronized.ref,
     psimp_table: const_table,
     choice_spec_table: const_table,
     intro_table: const_table,
     ground_thm_table: term list Inttab.table,
     ersatz_table: (string * string) list,
     skolems: (string * string list) list Unsynchronized.ref,
     special_funs: special_fun list Unsynchronized.ref,
     unrolled_preds: unrolled list Unsynchronized.ref,
     wf_cache: wf_cache Unsynchronized.ref,
     constr_cache: (typ * styp list) list Unsynchronized.ref}

  datatype fixpoint_kind = Lfp | Gfp | NoFp
  datatype boxability =
    InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2

  val name_sep : string
  val numeral_prefix : string
  val base_prefix : string
  val step_prefix : string
  val unrolled_prefix : string
  val ubfp_prefix : string
  val lbfp_prefix : string
  val quot_normal_prefix : string
  val skolem_prefix : string
  val special_prefix : string
  val uncurry_prefix : string
  val eval_prefix : string
  val iter_var_prefix : string
  val strip_first_name_sep : string -> string * string
  val original_name : string -> string
  val s_conj : term * term -> term
  val s_disj : term * term -> term
  val strip_any_connective : term -> term list * term
  val conjuncts_of : term -> term list
  val disjuncts_of : term -> term list
  val unarize_unbox_etc_type : typ -> typ
  val uniterize_unarize_unbox_etc_type : typ -> typ
  val string_for_type : Proof.context -> typ -> string
  val prefix_name : string -> string -> string
  val shortest_name : string -> string
  val short_name : string -> string
  val shorten_names_in_term : term -> term
  val strict_type_match : theory -> typ * typ -> bool
  val type_match : theory -> typ * typ -> bool
  val const_match : theory -> styp * styp -> bool
  val term_match : theory -> term * term -> bool
  val frac_from_term_pair : typ -> term -> term -> term
  val is_TFree : typ -> bool
  val is_higher_order_type : typ -> bool
  val is_fun_type : typ -> bool
  val is_set_type : typ -> bool
  val is_pair_type : typ -> bool
  val is_lfp_iterator_type : typ -> bool
  val is_gfp_iterator_type : typ -> bool
  val is_fp_iterator_type : typ -> bool
  val is_iterator_type : typ -> bool
  val is_boolean_type : typ -> bool
  val is_integer_type : typ -> bool
  val is_bit_type : typ -> bool
  val is_word_type : typ -> bool
  val is_integer_like_type : typ -> bool
  val is_record_type : typ -> bool
  val is_number_type : theory -> typ -> bool
  val const_for_iterator_type : typ -> styp
  val strip_n_binders : int -> typ -> typ list * typ
  val nth_range_type : int -> typ -> typ
  val num_factors_in_type : typ -> int
  val num_binder_types : typ -> int
  val curried_binder_types : typ -> typ list
  val mk_flat_tuple : typ -> term list -> term
  val dest_n_tuple : int -> term -> term list
  val is_real_datatype : theory -> string -> bool
  val is_standard_datatype : theory -> (typ option * bool) list -> typ -> bool
  val is_quot_type : theory -> typ -> bool
  val is_codatatype : theory -> typ -> bool
  val is_pure_typedef : Proof.context -> typ -> bool
  val is_univ_typedef : Proof.context -> typ -> bool
  val is_datatype : Proof.context -> (typ option * bool) list -> typ -> bool
  val is_record_constr : styp -> bool
  val is_record_get : theory -> styp -> bool
  val is_record_update : theory -> styp -> bool
  val is_abs_fun : Proof.context -> styp -> bool
  val is_rep_fun : Proof.context -> styp -> bool
  val is_quot_abs_fun : Proof.context -> styp -> bool
  val is_quot_rep_fun : Proof.context -> styp -> bool
  val mate_of_rep_fun : Proof.context -> styp -> styp
  val is_constr_like : Proof.context -> styp -> bool
  val is_constr : Proof.context -> (typ option * bool) list -> styp -> bool
  val is_sel : string -> bool
  val is_sel_like_and_no_discr : string -> bool
  val box_type : hol_context -> boxability -> typ -> typ
  val binarize_nat_and_int_in_type : typ -> typ
  val binarize_nat_and_int_in_term : term -> term
  val discr_for_constr : styp -> styp
  val num_sels_for_constr_type : typ -> int
  val nth_sel_name_for_constr_name : string -> int -> string
  val nth_sel_for_constr : styp -> int -> styp
  val binarized_and_boxed_nth_sel_for_constr :
    hol_context -> bool -> styp -> int -> styp
  val sel_no_from_name : string -> int
  val close_form : term -> term
  val eta_expand : typ list -> term -> int -> term
  val extensionalize : term -> term
  val distinctness_formula : typ -> term list -> term
  val register_frac_type : string -> (string * string) list -> theory -> theory
  val unregister_frac_type : string -> theory -> theory
  val register_codatatype : typ -> string -> styp list -> theory -> theory
  val unregister_codatatype : typ -> theory -> theory
  val datatype_constrs : hol_context -> typ -> styp list
  val binarized_and_boxed_datatype_constrs :
    hol_context -> bool -> typ -> styp list
  val num_datatype_constrs : hol_context -> typ -> int
  val constr_name_for_sel_like : string -> string
  val binarized_and_boxed_constr_for_sel : hol_context -> bool -> styp -> styp
  val discriminate_value : hol_context -> styp -> term -> term
  val select_nth_constr_arg :
    Proof.context -> (typ option * bool) list -> styp -> term -> int -> typ
    -> term
  val construct_value :
    Proof.context -> (typ option * bool) list -> styp -> term list -> term
  val coerce_term : hol_context -> typ list -> typ -> typ -> term -> term
  val card_of_type : (typ * int) list -> typ -> int
  val bounded_card_of_type : int -> int -> (typ * int) list -> typ -> int
  val bounded_exact_card_of_type :
    hol_context -> typ list -> int -> int -> (typ * int) list -> typ -> int
  val is_finite_type : hol_context -> typ -> bool
  val is_small_finite_type : hol_context -> typ -> bool
  val special_bounds : term list -> (indexname * typ) list
  val abs_var : indexname * typ -> term -> term
  val is_funky_typedef : theory -> typ -> bool
  val all_axioms_of :
    Proof.context -> (term * term) list -> term list * term list * term list
  val arity_of_built_in_const :
    theory -> (typ option * bool) list -> bool -> styp -> int option
  val is_built_in_const :
    theory -> (typ option * bool) list -> bool -> styp -> bool
  val term_under_def : term -> term
  val case_const_names :
    theory -> (typ option * bool) list -> (string * int) list
  val unfold_defs_in_term : hol_context -> term -> term
  val const_def_table :
    Proof.context -> (term * term) list -> term list -> const_table
  val const_nondef_table : term list -> const_table
  val const_simp_table : Proof.context -> (term * term) list -> const_table
  val const_psimp_table : Proof.context -> (term * term) list -> const_table
  val const_choice_spec_table :
    Proof.context -> (term * term) list -> const_table
  val inductive_intro_table :
    Proof.context -> (term * term) list -> const_table -> const_table
  val ground_theorem_table : theory -> term list Inttab.table
  val ersatz_table : theory -> (string * string) list
  val add_simps : const_table Unsynchronized.ref -> string -> term list -> unit
  val inverse_axioms_for_rep_fun : Proof.context -> styp -> term list
  val optimized_typedef_axioms : Proof.context -> string * typ list -> term list
  val optimized_quot_type_axioms :
    Proof.context -> (typ option * bool) list -> string * typ list -> term list
  val def_of_const : theory -> const_table -> styp -> term option
  val fixpoint_kind_of_rhs : term -> fixpoint_kind
  val fixpoint_kind_of_const :
    theory -> const_table -> string * typ -> fixpoint_kind
  val is_inductive_pred : hol_context -> styp -> bool
  val is_equational_fun : hol_context -> styp -> bool
  val is_constr_pattern_lhs : Proof.context -> term -> bool
  val is_constr_pattern_formula : Proof.context -> term -> bool
  val nondef_props_for_const :
    theory -> bool -> const_table -> styp -> term list
  val is_choice_spec_fun : hol_context -> styp -> bool
  val is_choice_spec_axiom : theory -> const_table -> term -> bool
  val codatatype_bisim_axioms : hol_context -> typ -> term list
  val is_well_founded_inductive_pred : hol_context -> styp -> bool
  val unrolled_inductive_pred_const : hol_context -> bool -> styp -> term
  val equational_fun_axioms : hol_context -> styp -> term list
  val is_equational_fun_surely_complete : hol_context -> styp -> bool
  val merge_type_vars_in_terms : term list -> term list
  val ground_types_in_type : hol_context -> bool -> typ -> typ list
  val ground_types_in_terms : hol_context -> bool -> term list -> typ list
end;

structure Nitpick_HOL : NITPICK_HOL =
struct

open Nitpick_Util

type const_table = term list Symtab.table
type special_fun = (styp * int list * term list) * styp
type unrolled = styp * styp
type wf_cache = (styp * (bool * bool)) list

type hol_context =
  {thy: theory,
   ctxt: Proof.context,
   max_bisim_depth: int,
   boxes: (typ option * bool option) list,
   stds: (typ option * bool) list,
   wfs: (styp option * bool option) list,
   user_axioms: bool option,
   debug: bool,
   binary_ints: bool option,
   destroy_constrs: bool,
   specialize: bool,
   star_linear_preds: bool,
   fast_descrs: bool,
   tac_timeout: Time.time option,
   evals: term list,
   case_names: (string * int) list,
   def_table: const_table,
   nondef_table: const_table,
   user_nondefs: term list,
   simp_table: const_table Unsynchronized.ref,
   psimp_table: const_table,
   choice_spec_table: const_table,
   intro_table: const_table,
   ground_thm_table: term list Inttab.table,
   ersatz_table: (string * string) list,
   skolems: (string * string list) list Unsynchronized.ref,
   special_funs: special_fun list Unsynchronized.ref,
   unrolled_preds: unrolled list Unsynchronized.ref,
   wf_cache: wf_cache Unsynchronized.ref,
   constr_cache: (typ * styp list) list Unsynchronized.ref}

datatype fixpoint_kind = Lfp | Gfp | NoFp
datatype boxability =
  InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2

structure Data = Theory_Data(
  type T = {frac_types: (string * (string * string) list) list,
            codatatypes: (string * (string * styp list)) list}
  val empty = {frac_types = [], codatatypes = []}
  val extend = I
  fun merge ({frac_types = fs1, codatatypes = cs1},
             {frac_types = fs2, codatatypes = cs2}) : T =
    {frac_types = AList.merge (op =) (K true) (fs1, fs2),
     codatatypes = AList.merge (op =) (K true) (cs1, cs2)})

val name_sep = "$"
val numeral_prefix = nitpick_prefix ^ "num" ^ name_sep
val sel_prefix = nitpick_prefix ^ "sel"
val discr_prefix = nitpick_prefix ^ "is" ^ name_sep
val set_prefix = nitpick_prefix ^ "set" ^ name_sep
val lfp_iterator_prefix = nitpick_prefix ^ "lfpit" ^ name_sep
val gfp_iterator_prefix = nitpick_prefix ^ "gfpit" ^ name_sep
val unrolled_prefix = nitpick_prefix ^ "unroll" ^ name_sep
val base_prefix = nitpick_prefix ^ "base" ^ name_sep
val step_prefix = nitpick_prefix ^ "step" ^ name_sep
val ubfp_prefix = nitpick_prefix ^ "ubfp" ^ name_sep
val lbfp_prefix = nitpick_prefix ^ "lbfp" ^ name_sep
val quot_normal_prefix = nitpick_prefix ^ "qn" ^ name_sep
val skolem_prefix = nitpick_prefix ^ "sk"
val special_prefix = nitpick_prefix ^ "sp"
val uncurry_prefix = nitpick_prefix ^ "unc"
val eval_prefix = nitpick_prefix ^ "eval"
val iter_var_prefix = "i"

(** Constant/type information and term/type manipulation **)

fun sel_prefix_for j = sel_prefix ^ string_of_int j ^ name_sep
fun quot_normal_name_for_type ctxt T =
  quot_normal_prefix ^ unyxml (Syntax.string_of_typ ctxt T)

val strip_first_name_sep =
  Substring.full #> Substring.position name_sep ##> Substring.triml 1
  #> pairself Substring.string
fun original_name s =
  if String.isPrefix nitpick_prefix s then
    case strip_first_name_sep s of (s1, "") => s1 | (_, s2) => original_name s2
  else
    s

fun s_betapply (Const (@{const_name If}, _) $ @{const True} $ t, _) = t
  | s_betapply (Const (@{const_name If}, _) $ @{const False} $ _, t) = t
  | s_betapply p = betapply p
val s_betapplys = Library.foldl s_betapply

fun s_conj (t1, @{const True}) = t1
  | s_conj (@{const True}, t2) = t2
  | s_conj (t1, t2) =
    if t1 = @{const False} orelse t2 = @{const False} then @{const False}
    else HOLogic.mk_conj (t1, t2)
fun s_disj (t1, @{const False}) = t1
  | s_disj (@{const False}, t2) = t2
  | s_disj (t1, t2) =
    if t1 = @{const True} orelse t2 = @{const True} then @{const True}
    else HOLogic.mk_disj (t1, t2)

fun strip_connective conn_t (t as (t0 $ t1 $ t2)) =
    if t0 = conn_t then strip_connective t0 t2 @ strip_connective t0 t1 else [t]
  | strip_connective _ t = [t]
fun strip_any_connective (t as (t0 $ _ $ _)) =
    if t0 = @{const "op &"} orelse t0 = @{const "op |"} then
      (strip_connective t0 t, t0)
    else
      ([t], @{const Not})
  | strip_any_connective t = ([t], @{const Not})
val conjuncts_of = strip_connective @{const "op &"}
val disjuncts_of = strip_connective @{const "op |"}

(* When you add constants to these lists, make sure to handle them in
   "Nitpick_Nut.nut_from_term", and perhaps in "Nitpick_Mono.consider_term" as
   well. *)
val built_in_consts =
  [(@{const_name all}, 1),
   (@{const_name "=="}, 2),
   (@{const_name "==>"}, 2),
   (@{const_name Pure.conjunction}, 2),
   (@{const_name Trueprop}, 1),
   (@{const_name Not}, 1),
   (@{const_name False}, 0),
   (@{const_name True}, 0),
   (@{const_name All}, 1),
   (@{const_name Ex}, 1),
   (@{const_name "op ="}, 2),
   (@{const_name "op &"}, 2),
   (@{const_name "op |"}, 2),
   (@{const_name "op -->"}, 2),
   (@{const_name If}, 3),
   (@{const_name Let}, 2),
   (@{const_name Unity}, 0),
   (@{const_name Pair}, 2),
   (@{const_name fst}, 1),
   (@{const_name snd}, 1),
   (@{const_name Id}, 0),
   (@{const_name insert}, 2),
   (@{const_name converse}, 1),
   (@{const_name trancl}, 1),
   (@{const_name rel_comp}, 2),
   (@{const_name image}, 2),
   (@{const_name finite}, 1),
   (@{const_name unknown}, 0),
   (@{const_name is_unknown}, 1),
   (@{const_name safe_The}, 1),
   (@{const_name safe_Eps}, 1),
   (@{const_name Frac}, 0),
   (@{const_name norm_frac}, 0)]
val built_in_nat_consts =
  [(@{const_name Suc}, 0),
   (@{const_name nat}, 0),
   (@{const_name nat_gcd}, 0),
   (@{const_name nat_lcm}, 0)]
val built_in_descr_consts =
  [(@{const_name The}, 1),
   (@{const_name Eps}, 1)]
val built_in_typed_consts =
  [((@{const_name zero_class.zero}, int_T), 0),
   ((@{const_name one_class.one}, int_T), 0),
   ((@{const_name plus_class.plus}, int_T --> int_T --> int_T), 0),
   ((@{const_name minus_class.minus}, int_T --> int_T --> int_T), 0),
   ((@{const_name times_class.times}, int_T --> int_T --> int_T), 0),
   ((@{const_name div_class.div}, int_T --> int_T --> int_T), 0),
   ((@{const_name uminus_class.uminus}, int_T --> int_T), 0),
   ((@{const_name ord_class.less}, int_T --> int_T --> bool_T), 2),
   ((@{const_name ord_class.less_eq}, int_T --> int_T --> bool_T), 2)]
val built_in_typed_nat_consts =
  [((@{const_name zero_class.zero}, nat_T), 0),
   ((@{const_name one_class.one}, nat_T), 0),
   ((@{const_name plus_class.plus}, nat_T --> nat_T --> nat_T), 0),
   ((@{const_name minus_class.minus}, nat_T --> nat_T --> nat_T), 0),
   ((@{const_name times_class.times}, nat_T --> nat_T --> nat_T), 0),
   ((@{const_name div_class.div}, nat_T --> nat_T --> nat_T), 0),
   ((@{const_name ord_class.less}, nat_T --> nat_T --> bool_T), 2),
   ((@{const_name ord_class.less_eq}, nat_T --> nat_T --> bool_T), 2),
   ((@{const_name of_nat}, nat_T --> int_T), 0)]
val built_in_set_consts =
  [(@{const_name semilattice_inf_class.inf}, 2),
   (@{const_name semilattice_sup_class.sup}, 2),
   (@{const_name minus_class.minus}, 2),
   (@{const_name ord_class.less_eq}, 2)]

fun unarize_type @{typ "unsigned_bit word"} = nat_T
  | unarize_type @{typ "signed_bit word"} = int_T
  | unarize_type (Type (s, Ts as _ :: _)) = Type (s, map unarize_type Ts)
  | unarize_type T = T
fun unarize_unbox_etc_type (Type (@{type_name fin_fun}, Ts)) =
    unarize_unbox_etc_type (Type (@{type_name fun}, Ts))
  | unarize_unbox_etc_type (Type (@{type_name fun_box}, Ts)) =
    unarize_unbox_etc_type (Type (@{type_name fun}, Ts))
  | unarize_unbox_etc_type (Type (@{type_name pair_box}, Ts)) =
    Type (@{type_name "*"}, map unarize_unbox_etc_type Ts)
  | unarize_unbox_etc_type @{typ "unsigned_bit word"} = nat_T
  | unarize_unbox_etc_type @{typ "signed_bit word"} = int_T
  | unarize_unbox_etc_type (Type (s, Ts as _ :: _)) =
    Type (s, map unarize_unbox_etc_type Ts)
  | unarize_unbox_etc_type T = T
fun uniterize_type (Type (s, Ts as _ :: _)) = Type (s, map uniterize_type Ts)
  | uniterize_type @{typ bisim_iterator} = nat_T
  | uniterize_type T = T
val uniterize_unarize_unbox_etc_type = uniterize_type o unarize_unbox_etc_type

fun string_for_type ctxt = Syntax.string_of_typ ctxt o unarize_unbox_etc_type

val prefix_name = Long_Name.qualify o Long_Name.base_name
fun shortest_name s = List.last (space_explode "." s) handle List.Empty => ""
val prefix_abs_vars = Term.map_abs_vars o prefix_name
fun short_name s =
  case space_explode name_sep s of
    [_] => s |> String.isPrefix nitpick_prefix s ? unprefix nitpick_prefix
  | ss => map shortest_name ss |> space_implode "_"
fun shorten_names_in_type (Type (s, Ts)) =
    Type (short_name s, map shorten_names_in_type Ts)
  | shorten_names_in_type T = T
val shorten_names_in_term =
  map_aterms (fn Const (s, T) => Const (short_name s, T) | t => t)
  #> map_types shorten_names_in_type

fun strict_type_match thy (T1, T2) =
  (Sign.typ_match thy (T2, T1) Vartab.empty; true)
  handle Type.TYPE_MATCH => false
fun type_match thy = strict_type_match thy o pairself unarize_unbox_etc_type
fun const_match thy ((s1, T1), (s2, T2)) =
  s1 = s2 andalso type_match thy (T1, T2)
fun term_match thy (Const x1, Const x2) = const_match thy (x1, x2)
  | term_match thy (Free (s1, T1), Free (s2, T2)) =
    const_match thy ((shortest_name s1, T1), (shortest_name s2, T2))
  | term_match _ (t1, t2) = t1 aconv t2

fun frac_from_term_pair T t1 t2 =
  case snd (HOLogic.dest_number t1) of
    0 => HOLogic.mk_number T 0
  | n1 => case snd (HOLogic.dest_number t2) of
            1 => HOLogic.mk_number T n1
          | n2 => Const (@{const_name divide}, T --> T --> T)
                  $ HOLogic.mk_number T n1 $ HOLogic.mk_number T n2

fun is_TFree (TFree _) = true
  | is_TFree _ = false
fun is_higher_order_type (Type (@{type_name fun}, _)) = true
  | is_higher_order_type (Type (_, Ts)) = exists is_higher_order_type Ts
  | is_higher_order_type _ = false
fun is_fun_type (Type (@{type_name fun}, _)) = true
  | is_fun_type _ = false
fun is_set_type (Type (@{type_name fun}, [_, @{typ bool}])) = true
  | is_set_type _ = false
fun is_pair_type (Type (@{type_name "*"}, _)) = true
  | is_pair_type _ = false
fun is_lfp_iterator_type (Type (s, _)) = String.isPrefix lfp_iterator_prefix s
  | is_lfp_iterator_type _ = false
fun is_gfp_iterator_type (Type (s, _)) = String.isPrefix gfp_iterator_prefix s
  | is_gfp_iterator_type _ = false
val is_fp_iterator_type = is_lfp_iterator_type orf is_gfp_iterator_type
fun is_iterator_type T =
  (T = @{typ bisim_iterator} orelse is_fp_iterator_type T)
fun is_boolean_type T = (T = prop_T orelse T = bool_T)
fun is_integer_type T = (T = nat_T orelse T = int_T)
fun is_bit_type T = (T = @{typ unsigned_bit} orelse T = @{typ signed_bit})
fun is_word_type (Type (@{type_name word}, _)) = true
  | is_word_type _ = false
val is_integer_like_type = is_iterator_type orf is_integer_type orf is_word_type
val is_record_type = not o null o Record.dest_recTs
fun is_frac_type thy (Type (s, [])) =
    not (null (these (AList.lookup (op =) (#frac_types (Data.get thy)) s)))
  | is_frac_type _ _ = false
fun is_number_type thy = is_integer_like_type orf is_frac_type thy

fun iterator_type_for_const gfp (s, T) =
  Type ((if gfp then gfp_iterator_prefix else lfp_iterator_prefix) ^ s,
        binder_types T)
fun const_for_iterator_type (Type (s, Ts)) =
    (strip_first_name_sep s |> snd, Ts ---> bool_T)
  | const_for_iterator_type T =
    raise TYPE ("Nitpick_HOL.const_for_iterator_type", [T], [])

fun strip_n_binders 0 T = ([], T)
  | strip_n_binders n (Type (@{type_name fun}, [T1, T2])) =
    strip_n_binders (n - 1) T2 |>> cons T1
  | strip_n_binders n (Type (@{type_name fun_box}, Ts)) =
    strip_n_binders n (Type (@{type_name fun}, Ts))
  | strip_n_binders _ T = raise TYPE ("Nitpick_HOL.strip_n_binders", [T], [])
val nth_range_type = snd oo strip_n_binders

fun num_factors_in_type (Type (@{type_name "*"}, [T1, T2])) =
    fold (Integer.add o num_factors_in_type) [T1, T2] 0
  | num_factors_in_type _ = 1
fun num_binder_types (Type (@{type_name fun}, [_, T2])) =
    1 + num_binder_types T2
  | num_binder_types _ = 0
val curried_binder_types = maps HOLogic.flatten_tupleT o binder_types
fun maybe_curried_binder_types T =
  (if is_pair_type (body_type T) then binder_types else curried_binder_types) T

fun mk_flat_tuple _ [t] = t
  | mk_flat_tuple (Type (@{type_name "*"}, [T1, T2])) (t :: ts) =
    HOLogic.pair_const T1 T2 $ t $ (mk_flat_tuple T2 ts)
  | mk_flat_tuple T ts = raise TYPE ("Nitpick_HOL.mk_flat_tuple", [T], ts)
fun dest_n_tuple 1 t = [t]
  | dest_n_tuple n t = HOLogic.dest_prod t ||> dest_n_tuple (n - 1) |> op ::

type typedef_info =
  {rep_type: typ, abs_type: typ, Rep_name: string, Abs_name: string,
   set_def: thm option, prop_of_Rep: thm, set_name: string,
   Abs_inverse: thm option, Rep_inverse: thm option}

fun typedef_info ctxt s =
  let val thy = ProofContext.theory_of ctxt in
    if is_frac_type thy (Type (s, [])) then
      SOME {abs_type = Type (s, []), rep_type = @{typ "int * int"},
            Abs_name = @{const_name Abs_Frac}, Rep_name = @{const_name Rep_Frac},
            set_def = NONE, prop_of_Rep = @{prop "Rep_Frac x \<in> Frac"}
                            |> Logic.varify_global,
            set_name = @{const_name Frac}, Abs_inverse = NONE, Rep_inverse = NONE}
    else case Typedef.get_info ctxt s of
      (* ### multiple *)
      [({abs_type, rep_type, Abs_name, Rep_name, ...},
        {set_def, Rep, Abs_inverse, Rep_inverse, ...})] =>
      SOME {abs_type = abs_type, rep_type = rep_type, Abs_name = Abs_name,
            Rep_name = Rep_name, set_def = set_def, prop_of_Rep = prop_of Rep,
            set_name = set_prefix ^ s, Abs_inverse = SOME Abs_inverse,
            Rep_inverse = SOME Rep_inverse}
    | _ => NONE
  end

val is_typedef = is_some oo typedef_info
val is_real_datatype = is_some oo Datatype.get_info
fun is_standard_datatype thy = the oo triple_lookup (type_match thy)

(* FIXME: Use antiquotation for "code_numeral" below or detect "rep_datatype",
   e.g., by adding a field to "Datatype_Aux.info". *)
fun is_basic_datatype thy stds s =
  member (op =) [@{type_name "*"}, @{type_name bool}, @{type_name unit},
                 @{type_name int}, "Code_Numeral.code_numeral"] s orelse
  (s = @{type_name nat} andalso is_standard_datatype thy stds nat_T)

fun instantiate_type thy T1 T1' T2 =
  Same.commit (Envir.subst_type_same
                   (Sign.typ_match thy (T1, T1') Vartab.empty)) T2
  handle Type.TYPE_MATCH =>
         raise TYPE ("Nitpick_HOL.instantiate_type", [T1, T1'], [])
fun varify_and_instantiate_type thy T1 T1' T2 =
  instantiate_type thy (Logic.varifyT_global T1) T1' (Logic.varifyT_global T2)

fun repair_constr_type thy body_T' T =
  varify_and_instantiate_type thy (body_type T) body_T' T

fun register_frac_type frac_s ersaetze thy =
  let
    val {frac_types, codatatypes} = Data.get thy
    val frac_types = AList.update (op =) (frac_s, ersaetze) frac_types
  in Data.put {frac_types = frac_types, codatatypes = codatatypes} thy end
fun unregister_frac_type frac_s = register_frac_type frac_s []

fun register_codatatype co_T case_name constr_xs thy =
  let
    val {frac_types, codatatypes} = Data.get thy
    val constr_xs = map (apsnd (repair_constr_type thy co_T)) constr_xs
    val (co_s, co_Ts) = dest_Type co_T
    val _ =
      if forall is_TFree co_Ts andalso not (has_duplicates (op =) co_Ts) andalso
         co_s <> @{type_name fun} andalso
         not (is_basic_datatype thy [(NONE, true)] co_s) then
        ()
      else
        raise TYPE ("Nitpick_HOL.register_codatatype", [co_T], [])
    val codatatypes = AList.update (op =) (co_s, (case_name, constr_xs))
                                   codatatypes
  in Data.put {frac_types = frac_types, codatatypes = codatatypes} thy end
fun unregister_codatatype co_T = register_codatatype co_T "" []

fun is_quot_type thy (Type (s, _)) =
    is_some (Quotient_Info.quotdata_lookup_raw thy s)
  | is_quot_type _ _ = false
fun is_codatatype thy (Type (s, _)) =
    not (null (AList.lookup (op =) (#codatatypes (Data.get thy)) s
               |> Option.map snd |> these))
  | is_codatatype _ _ = false
fun is_pure_typedef ctxt (T as Type (s, _)) =
    let val thy = ProofContext.theory_of ctxt in
      is_typedef ctxt s andalso
      not (is_real_datatype thy s orelse is_quot_type thy T orelse
           is_codatatype thy T orelse is_record_type T orelse
           is_integer_like_type T)
    end
  | is_pure_typedef _ _ = false
fun is_univ_typedef ctxt (Type (s, _)) =
    (case typedef_info ctxt s of
       SOME {set_def, prop_of_Rep, ...} =>
       let
         val t_opt =
           case set_def of
             SOME thm => try (snd o Logic.dest_equals o prop_of) thm
           | NONE => try (snd o HOLogic.dest_mem o HOLogic.dest_Trueprop)
                         prop_of_Rep
       in
         case t_opt of
           SOME (Const (@{const_name top}, _)) => true
           (* "Multiset.multiset" *)
         | SOME (Const (@{const_name Collect}, _)
                 $ Abs (_, _, Const (@{const_name finite}, _) $ _)) => true
           (* "FinFun.finfun" *)
         | SOME (Const (@{const_name Collect}, _) $ Abs (_, _,
                     Const (@{const_name Ex}, _) $ Abs (_, _,
                         Const (@{const_name finite}, _) $ _))) => true
         | _ => false
       end
     | NONE => false)
  | is_univ_typedef _ _ = false
fun is_datatype ctxt stds (T as Type (s, _)) =
    let val thy = ProofContext.theory_of ctxt in
      (is_typedef ctxt s orelse is_codatatype thy T orelse T = @{typ ind} orelse
       is_quot_type thy T) andalso not (is_basic_datatype thy stds s)
    end
  | is_datatype _ _ _ = false

fun all_record_fields thy T =
  let val (recs, more) = Record.get_extT_fields thy T in
    recs @ more :: all_record_fields thy (snd more)
  end
  handle TYPE _ => []
fun is_record_constr (s, T) =
  String.isSuffix Record.extN s andalso
  let val dataT = body_type T in
    is_record_type dataT andalso
    s = unsuffix Record.ext_typeN (fst (dest_Type dataT)) ^ Record.extN
  end
val num_record_fields = Integer.add 1 o length o fst oo Record.get_extT_fields
fun no_of_record_field thy s T1 =
  find_index (curry (op =) s o fst)
             (Record.get_extT_fields thy T1 ||> single |> op @)
fun is_record_get thy (s, Type (@{type_name fun}, [T1, _])) =
    exists (curry (op =) s o fst) (all_record_fields thy T1)
  | is_record_get _ _ = false
fun is_record_update thy (s, T) =
  String.isSuffix Record.updateN s andalso
  exists (curry (op =) (unsuffix Record.updateN s) o fst)
         (all_record_fields thy (body_type T))
  handle TYPE _ => false
fun is_abs_fun ctxt (s, Type (@{type_name fun}, [_, Type (s', _)])) =
    (case typedef_info ctxt s' of
       SOME {Abs_name, ...} => s = Abs_name
     | NONE => false)
  | is_abs_fun _ _ = false
fun is_rep_fun ctxt (s, Type (@{type_name fun}, [Type (s', _), _])) =
    (case typedef_info ctxt s' of
       SOME {Rep_name, ...} => s = Rep_name
     | NONE => false)
  | is_rep_fun _ _ = false
fun is_quot_abs_fun ctxt
                    (x as (_, Type (@{type_name fun}, [_, Type (s', _)]))) =
    (try (Quotient_Term.absrep_const_chk Quotient_Term.AbsF ctxt) s'
     = SOME (Const x))
  | is_quot_abs_fun _ _ = false
fun is_quot_rep_fun ctxt
                    (x as (_, Type (@{type_name fun}, [Type (s', _), _]))) =
    (try (Quotient_Term.absrep_const_chk Quotient_Term.RepF ctxt) s'
     = SOME (Const x))
  | is_quot_rep_fun _ _ = false

fun mate_of_rep_fun ctxt (x as (_, Type (@{type_name fun},
                                         [T1 as Type (s', _), T2]))) =
    (case typedef_info ctxt s' of
       SOME {Abs_name, ...} => (Abs_name, Type (@{type_name fun}, [T2, T1]))
     | NONE => raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x]))
  | mate_of_rep_fun _ x = raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x])
fun rep_type_for_quot_type thy (T as Type (s, _)) =
  let val {qtyp, rtyp, ...} = Quotient_Info.quotdata_lookup thy s in
    instantiate_type thy qtyp T rtyp
  end
fun equiv_relation_for_quot_type thy (Type (s, Ts)) =
    let
      val {qtyp, equiv_rel, ...} = Quotient_Info.quotdata_lookup thy s
      val Ts' = qtyp |> dest_Type |> snd
    in subst_atomic_types (Ts' ~~ Ts) equiv_rel end
  | equiv_relation_for_quot_type _ T =
    raise TYPE ("Nitpick_HOL.equiv_relation_for_quot_type", [T], [])

fun is_coconstr thy (s, T) =
  let
    val {codatatypes, ...} = Data.get thy
    val co_T = body_type T
    val co_s = dest_Type co_T |> fst
  in
    exists (fn (s', T') => s = s' andalso repair_constr_type thy co_T T' = T)
           (AList.lookup (op =) codatatypes co_s |> Option.map snd |> these)
  end
  handle TYPE ("dest_Type", _, _) => false
fun is_constr_like ctxt (s, T) =
  member (op =) [@{const_name FinFun}, @{const_name FunBox},
                 @{const_name PairBox}, @{const_name Quot},
                 @{const_name Zero_Rep}, @{const_name Suc_Rep}] s orelse
  let
    val thy = ProofContext.theory_of ctxt
    val (x as (_, T)) = (s, unarize_unbox_etc_type T)
  in
    Refute.is_IDT_constructor thy x orelse is_record_constr x orelse
    (is_abs_fun ctxt x andalso is_pure_typedef ctxt (range_type T)) orelse
    is_coconstr thy x
  end
fun is_stale_constr ctxt (x as (_, T)) =
  let val thy = ProofContext.theory_of ctxt in
    is_codatatype thy (body_type T) andalso is_constr_like ctxt x andalso
    not (is_coconstr thy x)
  end
fun is_constr ctxt stds (x as (_, T)) =
  let val thy = ProofContext.theory_of ctxt in
    is_constr_like ctxt x andalso
    not (is_basic_datatype thy stds
                         (fst (dest_Type (unarize_type (body_type T))))) andalso
    not (is_stale_constr ctxt x)
  end
val is_sel = String.isPrefix discr_prefix orf String.isPrefix sel_prefix
val is_sel_like_and_no_discr =
  String.isPrefix sel_prefix orf
  (member (op =) [@{const_name fst}, @{const_name snd}])

fun in_fun_lhs_for InConstr = InSel
  | in_fun_lhs_for _ = InFunLHS
fun in_fun_rhs_for InConstr = InConstr
  | in_fun_rhs_for InSel = InSel
  | in_fun_rhs_for InFunRHS1 = InFunRHS2
  | in_fun_rhs_for _ = InFunRHS1

fun is_boxing_worth_it (hol_ctxt : hol_context) boxy T =
  case T of
    Type (@{type_name fun}, _) =>
    (boxy = InPair orelse boxy = InFunLHS) andalso
    not (is_boolean_type (body_type T))
  | Type (@{type_name "*"}, Ts) =>
    boxy = InPair orelse boxy = InFunRHS1 orelse boxy = InFunRHS2 orelse
    ((boxy = InExpr orelse boxy = InFunLHS) andalso
     exists (is_boxing_worth_it hol_ctxt InPair)
            (map (box_type hol_ctxt InPair) Ts))
  | _ => false
and should_box_type (hol_ctxt as {thy, boxes, ...}) boxy z =
  case triple_lookup (type_match thy) boxes (Type z) of
    SOME (SOME box_me) => box_me
  | _ => is_boxing_worth_it hol_ctxt boxy (Type z)
and box_type hol_ctxt boxy T =
  case T of
    Type (z as (@{type_name fun}, [T1, T2])) =>
    if boxy <> InConstr andalso boxy <> InSel andalso
       should_box_type hol_ctxt boxy z then
      Type (@{type_name fun_box},
            [box_type hol_ctxt InFunLHS T1, box_type hol_ctxt InFunRHS1 T2])
    else
      box_type hol_ctxt (in_fun_lhs_for boxy) T1
      --> box_type hol_ctxt (in_fun_rhs_for boxy) T2
  | Type (z as (@{type_name "*"}, Ts)) =>
    if boxy <> InConstr andalso boxy <> InSel
       andalso should_box_type hol_ctxt boxy z then
      Type (@{type_name pair_box}, map (box_type hol_ctxt InSel) Ts)
    else
      Type (@{type_name "*"},
            map (box_type hol_ctxt
                          (if boxy = InConstr orelse boxy = InSel then boxy
                           else InPair)) Ts)
  | _ => T

fun binarize_nat_and_int_in_type @{typ nat} = @{typ "unsigned_bit word"}
  | binarize_nat_and_int_in_type @{typ int} = @{typ "signed_bit word"}
  | binarize_nat_and_int_in_type (Type (s, Ts)) =
    Type (s, map binarize_nat_and_int_in_type Ts)
  | binarize_nat_and_int_in_type T = T
val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type

fun discr_for_constr (s, T) = (discr_prefix ^ s, body_type T --> bool_T)

fun num_sels_for_constr_type T = length (maybe_curried_binder_types T)
fun nth_sel_name_for_constr_name s n =
  if s = @{const_name Pair} then
    if n = 0 then @{const_name fst} else @{const_name snd}
  else
    sel_prefix_for n ^ s
fun nth_sel_for_constr x ~1 = discr_for_constr x
  | nth_sel_for_constr (s, T) n =
    (nth_sel_name_for_constr_name s n,
     body_type T --> nth (maybe_curried_binder_types T) n)
fun binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize =
  apsnd ((binarize ? binarize_nat_and_int_in_type) o box_type hol_ctxt InSel)
  oo nth_sel_for_constr

fun sel_no_from_name s =
  if String.isPrefix discr_prefix s then
    ~1
  else if String.isPrefix sel_prefix s then
    s |> unprefix sel_prefix |> Int.fromString |> the
  else if s = @{const_name snd} then
    1
  else
    0

val close_form =
  let
    fun close_up zs zs' =
      fold (fn (z as ((s, _), T)) => fn t' =>
               Term.all T $ Abs (s, T, abstract_over (Var z, t')))
           (take (length zs' - length zs) zs')
    fun aux zs (@{const "==>"} $ t1 $ t2) =
        let val zs' = Term.add_vars t1 zs in
          close_up zs zs' (Logic.mk_implies (t1, aux zs' t2))
        end
      | aux zs t = close_up zs (Term.add_vars t zs) t
  in aux [] end

fun eta_expand _ t 0 = t
  | eta_expand Ts (Abs (s, T, t')) n =
    Abs (s, T, eta_expand (T :: Ts) t' (n - 1))
  | eta_expand Ts t n =
    fold_rev (curry3 Abs ("x\<^isub>\<eta>" ^ nat_subscript n))
             (List.take (binder_types (fastype_of1 (Ts, t)), n))
             (list_comb (incr_boundvars n t, map Bound (n - 1 downto 0)))

fun extensionalize t =
  case t of
    (t0 as @{const Trueprop}) $ t1 => t0 $ extensionalize t1
  | Const (@{const_name "op ="}, _) $ t1 $ Abs (s, T, t2) =>
    let val v = Var ((s, maxidx_of_term t + 1), T) in
      extensionalize (HOLogic.mk_eq (t1 $ v, subst_bound (v, t2)))
    end
  | _ => t

fun distinctness_formula T =
  all_distinct_unordered_pairs_of
  #> map (fn (t1, t2) => @{const Not} $ (HOLogic.eq_const T $ t1 $ t2))
  #> List.foldr (s_conj o swap) @{const True}

fun zero_const T = Const (@{const_name zero_class.zero}, T)
fun suc_const T = Const (@{const_name Suc}, T --> T)

fun uncached_datatype_constrs ({thy, ctxt, stds, ...} : hol_context)
                              (T as Type (s, Ts)) =
    (case AList.lookup (op =) (#codatatypes (Data.get thy)) s of
       SOME (_, xs' as (_ :: _)) => map (apsnd (repair_constr_type thy T)) xs'
     | _ =>
       if is_datatype ctxt stds T then
         case Datatype.get_info thy s of
           SOME {index, descr, ...} =>
           let
             val (_, dtyps, constrs) = AList.lookup (op =) descr index |> the
           in
             map (fn (s', Us) =>
                     (s', map (Refute.typ_of_dtyp descr (dtyps ~~ Ts)) Us
                          ---> T)) constrs
           end
         | NONE =>
           if is_record_type T then
             let
               val s' = unsuffix Record.ext_typeN s ^ Record.extN
               val T' = (Record.get_extT_fields thy T
                        |> apsnd single |> uncurry append |> map snd) ---> T
             in [(s', T')] end
           else if is_quot_type thy T then
             [(@{const_name Quot}, rep_type_for_quot_type thy T --> T)]
           else case typedef_info ctxt s of
             SOME {abs_type, rep_type, Abs_name, ...} =>
             [(Abs_name,
               varify_and_instantiate_type thy abs_type T rep_type --> T)]
           | NONE =>
             if T = @{typ ind} then
               [dest_Const @{const Zero_Rep}, dest_Const @{const Suc_Rep}]
             else
               []
       else
         [])
  | uncached_datatype_constrs _ _ = []
fun datatype_constrs (hol_ctxt as {constr_cache, ...}) T =
  case AList.lookup (op =) (!constr_cache) T of
    SOME xs => xs
  | NONE =>
    let val xs = uncached_datatype_constrs hol_ctxt T in
      (Unsynchronized.change constr_cache (cons (T, xs)); xs)
    end
fun binarized_and_boxed_datatype_constrs hol_ctxt binarize =
  map (apsnd ((binarize ? binarize_nat_and_int_in_type)
              o box_type hol_ctxt InConstr)) o datatype_constrs hol_ctxt
val num_datatype_constrs = length oo datatype_constrs

fun constr_name_for_sel_like @{const_name fst} = @{const_name Pair}
  | constr_name_for_sel_like @{const_name snd} = @{const_name Pair}
  | constr_name_for_sel_like s' = original_name s'
fun binarized_and_boxed_constr_for_sel hol_ctxt binarize (s', T') =
  let val s = constr_name_for_sel_like s' in
    AList.lookup (op =)
        (binarized_and_boxed_datatype_constrs hol_ctxt binarize (domain_type T'))
        s
    |> the |> pair s
  end

fun discr_term_for_constr hol_ctxt (x as (s, T)) =
  let val dataT = body_type T in
    if s = @{const_name Suc} then
      Abs (Name.uu, dataT,
           @{const Not} $ HOLogic.mk_eq (zero_const dataT, Bound 0))
    else if num_datatype_constrs hol_ctxt dataT >= 2 then
      Const (discr_for_constr x)
    else
      Abs (Name.uu, dataT, @{const True})
  end
fun discriminate_value (hol_ctxt as {ctxt, ...}) x t =
  case head_of t of
    Const x' =>
    if x = x' then @{const True}
    else if is_constr_like ctxt x' then @{const False}
    else betapply (discr_term_for_constr hol_ctxt x, t)
  | _ => betapply (discr_term_for_constr hol_ctxt x, t)

fun nth_arg_sel_term_for_constr thy stds (x as (s, T)) n =
  let val (arg_Ts, dataT) = strip_type T in
    if dataT = nat_T andalso is_standard_datatype thy stds nat_T then
      @{term "%n::nat. n - 1"}
    else if is_pair_type dataT then
      Const (nth_sel_for_constr x n)
    else
      let
        fun aux m (Type (@{type_name "*"}, [T1, T2])) =
            let
              val (m, t1) = aux m T1
              val (m, t2) = aux m T2
            in (m, HOLogic.mk_prod (t1, t2)) end
          | aux m T =
            (m + 1, Const (nth_sel_name_for_constr_name s m, dataT --> T)
                    $ Bound 0)
        val m = fold (Integer.add o num_factors_in_type)
                     (List.take (arg_Ts, n)) 0
      in Abs ("x", dataT, aux m (nth arg_Ts n) |> snd) end
  end
fun select_nth_constr_arg ctxt stds x t n res_T =
  let val thy = ProofContext.theory_of ctxt in
    (case strip_comb t of
       (Const x', args) =>
       if x = x' then nth args n
       else if is_constr_like ctxt x' then Const (@{const_name unknown}, res_T)
       else raise SAME ()
     | _ => raise SAME())
    handle SAME () => betapply (nth_arg_sel_term_for_constr thy stds x n, t)
  end

fun construct_value _ _ x [] = Const x
  | construct_value ctxt stds (x as (s, _)) args =
    let val args = map Envir.eta_contract args in
      case hd args of
        Const (s', _) $ t =>
        if is_sel_like_and_no_discr s' andalso
           constr_name_for_sel_like s' = s andalso
           forall (fn (n, t') =>
                      select_nth_constr_arg ctxt stds x t n dummyT = t')
                  (index_seq 0 (length args) ~~ args) then
          t
        else
          list_comb (Const x, args)
      | _ => list_comb (Const x, args)
    end

fun constr_expand (hol_ctxt as {ctxt, stds, ...}) T t =
  (case head_of t of
     Const x => if is_constr_like ctxt x then t else raise SAME ()
   | _ => raise SAME ())
  handle SAME () =>
         let
           val x' as (_, T') =
             if is_pair_type T then
               let val (T1, T2) = HOLogic.dest_prodT T in
                 (@{const_name Pair}, T1 --> T2 --> T)
               end
             else
               datatype_constrs hol_ctxt T |> hd
           val arg_Ts = binder_types T'
         in
           list_comb (Const x', map2 (select_nth_constr_arg ctxt stds x' t)
                                     (index_seq 0 (length arg_Ts)) arg_Ts)
         end

fun coerce_bound_no f j t =
  case t of
    t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2
  | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t')
  | Bound j' => if j' = j then f t else t
  | _ => t
fun coerce_bound_0_in_term hol_ctxt new_T old_T =
  old_T <> new_T ? coerce_bound_no (coerce_term hol_ctxt [new_T] old_T new_T) 0
and coerce_term (hol_ctxt as {ctxt, stds, fast_descrs, ...}) Ts new_T old_T t =
  if old_T = new_T then
    t
  else
    case (new_T, old_T) of
      (Type (new_s, new_Ts as [new_T1, new_T2]),
       Type (@{type_name fun}, [old_T1, old_T2])) =>
      (case eta_expand Ts t 1 of
         Abs (s, _, t') =>
         Abs (s, new_T1,
              t' |> coerce_bound_0_in_term hol_ctxt new_T1 old_T1
                 |> coerce_term hol_ctxt (new_T1 :: Ts) new_T2 old_T2)
         |> Envir.eta_contract
         |> new_s <> @{type_name fun}
            ? construct_value ctxt stds
                  (if new_s = @{type_name fin_fun} then @{const_name FinFun}
                   else @{const_name FunBox},
                   Type (@{type_name fun}, new_Ts) --> new_T)
              o single
       | t' => raise TERM ("Nitpick_HOL.coerce_term", [t']))
    | (Type (new_s, new_Ts as [new_T1, new_T2]),
       Type (old_s, old_Ts as [old_T1, old_T2])) =>
      if old_s = @{type_name fin_fun} orelse old_s = @{type_name fun_box} orelse
         old_s = @{type_name pair_box} orelse old_s = @{type_name "*"} then
        case constr_expand hol_ctxt old_T t of
          Const (old_s, _) $ t1 =>
          if new_s = @{type_name fun} then
            coerce_term hol_ctxt Ts new_T (Type (@{type_name fun}, old_Ts)) t1
          else
            construct_value ctxt stds
                (old_s, Type (@{type_name fun}, new_Ts) --> new_T)
                [coerce_term hol_ctxt Ts (Type (@{type_name fun}, new_Ts))
                             (Type (@{type_name fun}, old_Ts)) t1]
        | Const _ $ t1 $ t2 =>
          construct_value ctxt stds
              (if new_s = @{type_name "*"} then @{const_name Pair}
               else @{const_name PairBox}, new_Ts ---> new_T)
              (map3 (coerce_term hol_ctxt Ts) [new_T1, new_T2] [old_T1, old_T2]
                    [t1, t2])
        | t' => raise TERM ("Nitpick_HOL.coerce_term", [t'])
      else
        raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t])
    | _ => raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t])

fun card_of_type assigns (Type (@{type_name fun}, [T1, T2])) =
    reasonable_power (card_of_type assigns T2) (card_of_type assigns T1)
  | card_of_type assigns (Type (@{type_name "*"}, [T1, T2])) =
    card_of_type assigns T1 * card_of_type assigns T2
  | card_of_type _ (Type (@{type_name itself}, _)) = 1
  | card_of_type _ @{typ prop} = 2
  | card_of_type _ @{typ bool} = 2
  | card_of_type _ @{typ unit} = 1
  | card_of_type assigns T =
    case AList.lookup (op =) assigns T of
      SOME k => k
    | NONE => if T = @{typ bisim_iterator} then 0
              else raise TYPE ("Nitpick_HOL.card_of_type", [T], [])
fun bounded_card_of_type max default_card assigns
                         (Type (@{type_name fun}, [T1, T2])) =
    let
      val k1 = bounded_card_of_type max default_card assigns T1
      val k2 = bounded_card_of_type max default_card assigns T2
    in
      if k1 = max orelse k2 = max then max
      else Int.min (max, reasonable_power k2 k1)
    end
  | bounded_card_of_type max default_card assigns
                         (Type (@{type_name "*"}, [T1, T2])) =
    let
      val k1 = bounded_card_of_type max default_card assigns T1
      val k2 = bounded_card_of_type max default_card assigns T2
    in if k1 = max orelse k2 = max then max else Int.min (max, k1 * k2) end
  | bounded_card_of_type max default_card assigns T =
    Int.min (max, if default_card = ~1 then
                    card_of_type assigns T
                  else
                    card_of_type assigns T
                    handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
                           default_card)
fun bounded_exact_card_of_type hol_ctxt finitizable_dataTs max default_card
                               assigns T =
  let
    fun aux avoid T =
      (if member (op =) avoid T then
         0
       else if member (op =) finitizable_dataTs T then
         raise SAME ()
       else case T of
         Type (@{type_name fun}, [T1, T2]) =>
         let
           val k1 = aux avoid T1
           val k2 = aux avoid T2
         in
           if k1 = 0 orelse k2 = 0 then 0
           else if k1 >= max orelse k2 >= max then max
           else Int.min (max, reasonable_power k2 k1)
         end
       | Type (@{type_name "*"}, [T1, T2]) =>
         let
           val k1 = aux avoid T1
           val k2 = aux avoid T2
         in
           if k1 = 0 orelse k2 = 0 then 0
           else if k1 >= max orelse k2 >= max then max
           else Int.min (max, k1 * k2)
         end
       | Type (@{type_name itself}, _) => 1
       | @{typ prop} => 2
       | @{typ bool} => 2
       | @{typ unit} => 1
       | Type _ =>
         (case datatype_constrs hol_ctxt T of
            [] => if is_integer_type T orelse is_bit_type T then 0
                  else raise SAME ()
          | constrs =>
            let
              val constr_cards =
                map (Integer.prod o map (aux (T :: avoid)) o binder_types o snd)
                    constrs
            in
              if exists (curry (op =) 0) constr_cards then 0
              else Integer.sum constr_cards
            end)
       | _ => raise SAME ())
      handle SAME () =>
             AList.lookup (op =) assigns T |> the_default default_card
  in Int.min (max, aux [] T) end

val small_type_max_card = 5

fun is_finite_type hol_ctxt T =
  bounded_exact_card_of_type hol_ctxt [] 1 2 [] T > 0
fun is_small_finite_type hol_ctxt T =
  let val n = bounded_exact_card_of_type hol_ctxt [] 1 2 [] T in
    n > 0 andalso n <= small_type_max_card
  end

fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2
  | is_ground_term (Const _) = true
  | is_ground_term _ = false

fun hashw_term (t1 $ t2) = hashw (hashw_term t1, hashw_term t2)
  | hashw_term (Const (s, _)) = hashw_string (s, 0w0)
  | hashw_term _ = 0w0
val hash_term = Word.toInt o hashw_term

fun special_bounds ts =
  fold Term.add_vars ts [] |> sort (Term_Ord.fast_indexname_ord o pairself fst)

fun abs_var ((s, j), T) body = Abs (s, T, abstract_over (Var ((s, j), T), body))

fun is_funky_typedef_name thy s =
  member (op =) [@{type_name unit}, @{type_name "*"}, @{type_name "+"},
                 @{type_name int}] s orelse
  is_frac_type thy (Type (s, []))
fun is_funky_typedef thy (Type (s, _)) = is_funky_typedef_name thy s
  | is_funky_typedef _ _ = false
fun is_arity_type_axiom (Const (@{const_name HOL.type_class}, _)
                         $ Const (@{const_name TYPE}, _)) = true
  | is_arity_type_axiom _ = false
fun is_typedef_axiom ctxt boring (@{const "==>"} $ _ $ t2) =
    is_typedef_axiom ctxt boring t2
  | is_typedef_axiom ctxt boring
        (@{const Trueprop} $ (Const (@{const_name Typedef.type_definition}, _)
         $ Const (_, Type (@{type_name fun}, [Type (s, _), _]))
         $ Const _ $ _)) =
    let val thy = ProofContext.theory_of ctxt in
      boring <> is_funky_typedef_name thy s andalso is_typedef ctxt s
    end
  | is_typedef_axiom _ _ _ = false
val is_class_axiom =
  Logic.strip_horn #> swap #> op :: #> forall (can Logic.dest_of_class)

(* Distinguishes between (1) constant definition axioms, (2) type arity and
   typedef axioms, and (3) other axioms, and returns the pair ((1), (3)).
   Typedef axioms are uninteresting to Nitpick, because it can retrieve them
   using "typedef_info". *)
fun partition_axioms_by_definitionality ctxt axioms def_names =
  let
    val axioms = sort (fast_string_ord o pairself fst) axioms
    val defs = OrdList.inter (fast_string_ord o apsnd fst) def_names axioms
    val nondefs =
      OrdList.subtract (fast_string_ord o apsnd fst) def_names axioms
      |> filter_out ((is_arity_type_axiom orf is_typedef_axiom ctxt true) o snd)
  in pairself (map snd) (defs, nondefs) end

(* Ideally we would check against "Complex_Main", not "Refute", but any theory
   will do as long as it contains all the "axioms" and "axiomatization"
   commands. *)
fun is_built_in_theory thy = Theory.subthy (thy, @{theory Refute})

val is_trivial_definition =
  the_default false o try (op aconv o Logic.dest_equals)
val is_plain_definition =
  let
    fun do_lhs t1 =
      case strip_comb t1 of
        (Const _, args) =>
        forall is_Var args andalso not (has_duplicates (op =) args)
      | _ => false
    fun do_eq (Const (@{const_name "=="}, _) $ t1 $ _) = do_lhs t1
      | do_eq (@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)) =
        do_lhs t1
      | do_eq _ = false
  in do_eq end

fun all_axioms_of ctxt subst =
  let
    val thy = ProofContext.theory_of ctxt
    val axioms_of_thys =
      maps Thm.axioms_of
      #> map (apsnd (subst_atomic subst o prop_of))
      #> filter_out (is_class_axiom o snd)
    val specs = Defs.all_specifications_of (Theory.defs_of thy)
    val def_names = specs |> maps snd |> map_filter #def
                    |> OrdList.make fast_string_ord
    val thys = thy :: Theory.ancestors_of thy
    val (built_in_thys, user_thys) = List.partition is_built_in_theory thys
    val built_in_axioms = axioms_of_thys built_in_thys
    val user_axioms = axioms_of_thys user_thys
    val (built_in_defs, built_in_nondefs) =
      partition_axioms_by_definitionality ctxt built_in_axioms def_names
      ||> filter (is_typedef_axiom ctxt false)
    val (u