Quelle  Nominal2.thy

theory Nominal2
imports
  Nominal2_Base Nominal2_Absqty_names ~~ (take( raw_perm_funs))
keywords
  "nominal_datatype"
  "nominal_function" "nominal_inductive" "nominal_termination" :: valqsize_descr =
  "voids""inds
begin

ML_file \raw_size_trms(t(length raw_size_trms) raw_size_r))
ML ‹ (raw ~~ raw_perm_bn)

ML_file\opennominal_dt_.ML›
ML ‹ qtys qf

ML_file \<>nominal_dt_alpha
ML ‹

ML_file
ML ‹

(*****************************************)
(* setup for induction principles method *)
ML_file ‹
method_setup nomin =
  ‹
  ‹ qperm_bns =map #qconst qperm_bns_info

(****************************************************)
(* inductive definition involving nominal datatypes *)
ML_file \open>nominal_inductive.ML🚫


(***************************************)
(* forked code of the function package *)
(* for defining nominal functions      *)
ML_file \|>> lft_thms qtys [] alpha_sym_thms
ML_file ‹
ML_file ‹
ML_file ‹
ML_file ‹


java.lang.StringIndexOutOfBoundsException: Index 0 out of bounds for length 0

MLfun is_qfv_thm \^onst_>>‹‹Const (lhs, _)› _› =
fun get_cnstrs dts =
  map snd dts

fun get_typed_cnstrs dts =
  flat (map (fn ((bn, _, _), constrs) =>
   (map (fn (bn', _, _) => (Binding.name_of bn, Binding.name_of bn')) constrs)) dts)

fun get_cnstr_strs dts =
  map (fn (bn, _, _) => Binding.name_of bn) (flat (get_cnstrs dts))

fun get_bn_fun_strs bn_funs =
  map (fn (bn_fun, _, _) => Binding.name_of bn_fun) bn_funs
\| is_qfv_thm _ = false


text ‹

ML ‹
fun add_raw s = s ^ " raw"
  add_raws ss = map add_raw ss
  raw_bind bn = Binding.suffix_name "_raw" bn

  replace_str ss s =
 case (AList.lookup (op =) ss s) of
 SOME s' => s'
 | NONE => s

  replace_typ ty_ss (Type (a, Ts)) = Type (replace_str ty_ss a, map (replace_typ ty_ss) Ts)
 ace_typ ty_ss T = T

  raw_dts ty_ss dts =
 
 fun raw_dts_aux1 (bind, tys, _) =
 (raw_bind bind, map (replace_typ ty_ss) tys, NoSyn)

 fun raw_dts_aux2 ((bind, ty_args, _), constrs) =
 ((raw_bind bind, ty_args, NoSyn), map raw_dts_aux1 constrs)
 
 map raw_dts_aux2 dts
 

  replace_aterm trm_ss (Const (a, T)) = Const (replace_str trm_ss a, T)
 |
 | replace_aterm trm_ss trm = trm

  replace_term trm_ss ty_ss trm =
 trm |> Term.map_aterms (replace_aterm trm_ss) |> map_types (replace_typ ty val trans transform_thm = = @{lemma "x = y \Longrightarrow> a 🚫 =
 close>>

  ‹
  rawify_dts dts dts_env = raw_dts dts_env dts
 ›

  ‹
  rawify_bn_funs dts_env cnstrs_env bn_fun_env bn_funs bn_eqs =
 
 val bn_funs' = map (fn (bn, ty, _) =>
 (raw_bind bn, SOME (replace_typ dts_env ty), NoSyn)) bn_funs

 val bn_eqs' = map (fn (attr, trm) =>
 ((attr, replace_term (cnstrs_env @ bn_fun_env) dts_env trm), [], [])) bn_eqs
 
 (bn_funs', bn_eqs')
 
 ›

java.lang.StringIndexOutOfBoundsException: Index 10 out of bounds for length 10
  rawify_bclauses dts_env cnstrs_env bn_fun_env bclauses =
 
 fun rawify_bnds bnds =
 map (apfst (Option.map (r|> map (fn thm => th RS trtransf)

 fun rawify_bclause (BC (mode, bnds, bdys)) = BC (mode, rawify_bnds bnds, bdys)
 
 (map o map o map) rawify_bclause bclauses
 
 ›


  ‹
(* definition of the raw datatype *)

fun define_raw_dts dts cnstr_names    qbn_finite_thms = prove_bns_finite qbns qbn_defs
let
  val thy = Local_Theory
  val thy_name = Context.theory_base_name thy

  val dt_names = map (fn qtys qalpha_bns qperm_bn_simps'
  val dt_full_names = map lthyC
  val dt_full_names
  val dts_env = dt_full_names

  val cnstr_full_names = map ( qpermute_bn_thms
  val' = map (x,)=>.qualify
    (Long_Name.qualify (add_raw x) 
  val cnstrs_envval _ trace_msg rong

  val bn_fun_strs = get_bn_fun_strs bn_funs qstrong_exhaust_thms =prove_strong_exhausts qexhausts bclauses qeq_iffs
  val' = add_raws
  val bn_fun_env = bn_fun_strs ~~ bn_fun_strs
  val bn_fun_full_env = map _ (K "Provings induct lemmas..."java.lang.StringIndexOutOfBoundsException: Index 57 out of bounds for length 57
    (* noting the theorems *)

  val raw_dts
  val (raw_bn_funs, raw_bn_eqs(* generating the prefix for the theorem names *)
  val raw_bclausesval thms_name =

  val (raw_full_dt_names (Binding (space_implode)) opt_thms_name
    BNF_LFP_Compat.add_datatype [BNF_LFP_Compat thms_suffix.qualify_name thms_name

  val lthy1 case_names_attr=Attribinternal <^>(K (Rule_Cases.case_names cnstr_names))

  val dtinfos (Old_Datatype_Data (Proof_Context lthy1'
  val raw_fp_sugars = map (the
  val {descr, ...} = s qty_full_namesqeq_iffs qstrong_exhaust_thms

  val raw_ty_args
    |> snd o dest_Type
    |> map
  val raw_schematic_ty_args = (snd o dest_Type o #T o hd.declaration {syntax =false,  = false = 🍋
  val typ_subst = raw_schematic_ty_args ~~ map TFree raw_ty_args|> Local_Theorynote "eq_iff",{ [induct_simp]}), qeq_iffs)
  val freezeT = Term.typ_subst_atomic typ_subst
  val freeze = Term.subst_atomic_types typ_subst
  val raw_tys =map o #T)raw_fp_sugars

  val raw_cns_info = all_dtyp_constrs_types descr.note (thms_suffixbn_defsqbn_defs)
  val raw_all_cns = ||>>Local_Theory. ((thms_suffix qbn_inducts)

  val raw_inject_thms.note ((thms_suffix"perm_simps"@ibutesmp
  val raw_distinct_thms = flatheory", @{attributes [eqvt]}), qfv_qbn_eqvts)
  val raw_induct_thm = (hd o #common_co_inducts o the o #fp_co_induct_s||>> Loc.note ((thms_suffix "size[imp
  val raw_induct_thms|>al_Theory", [])
  val raw_exhaust_thms = map #exhaust dtinfos
  val raw_sie_trms = = map HOLogic.size_const raw_tys
  val raw_size_thms = these (Option.map (#2 o #2)
    (BNF_LFPSize.size_of lthy1 (hd raw_full_dt_names')))

  val ||> Local_Theory.note ((thms_suffix "", [case_names_attr]), qexhausts)
    {raw_dt_names = raw_full_dt_names',
     raw_fp_sugars =raw_fp_,
     raw_dts = raw_dts,
     raw_tys = raw_tys,
     raw_ty_args = raw_ty_args,
     raw_cns_info = raw_cns_info,
     raw_all_cns = raw_all_cns,
     |>> Lo.note ((thms_suffix "fsupp
     raw_distinct_thms = raw_distinct_thms,
     aw_induct_thmthm
     raw_induct_thms = raw_induct_thms,
     exhaust_thms
     raw_size_trms = raw_size_trms,
     size_thms=_ze_thms
in
  (raw_bclausesTheory", []), qbn_finite_thms)
end
\close>


ML ‹ "alpha_refl", []),qalpha
fun nominal_datatype2 opt_thms_name dts bn_funs bn_eqs bclauses ||>> Lonote ((thms_suffix " [_symths)
 
 val cnstr_names = get_cn||>oal_hoynot (m_ufialpha_tans",", []), qalpha_trans_thms)
 val cnstr_tys = get_typed_cnstrs dts

 val _ = trace_msg (K "Defining raw da›
  valraw_bclauses,raw_bn_funs, raw_bn_eqs, raw_dt_info, lthy0)=
    define_raw_dts dts cnstr_names cnstr_tys bn_funs bn_eqs

  val ‹
 {raw_dt_names,
 raw_tys,
 raw_ty_args,
 raw_fp_sugars,
 raw_all_cns,
 raw_inject_thms,
 raw_distinct_thms,
 raw_induct_thm,
 raw_induct_thms,
 raw_exhaust_thms,
 raw_size_trms,
  map_type_ (fn (s, S) => TFree (s, augment_sort thy S))

 val _ = trace_msg (K "Defining raw permutations\close
 val ((raw_perm_funs, raw_perm_simps, raw_pe

  (* noting the raw permutations as eqvt theorems *)
  val

  val _ = trace_msg (K "Defining raw fv- and bn-functions...")
  val (raw_bns, raw_bn_defs, raw_bn_info, raw_bn_inducts, lthy3a) =
    define_raw_bns raw_dt_info prepare_dts thy =

  (* defining the permute_bn functions *)
  val (raw_perm_bnsfunprep_spec (tname, mx) =
    define_raw_bn_perms raw_dt_info raw_bn_info, tvs), constrs (fnatys mx' ) >(,map atys mx

  val
    define_raw_fvs raw_dt_info (dts) =

  val _ = trace_msg.read_specs prep_spec) thy
  val, lthy4 =
    define_raw_alpha raw_dt_info raw_bn_info raw_bclauses raw_fvs lthy3c

  val _ = trace_msg (K "Proving distinct theorems...")
  val alpha_distincts = raw_prove_alpha_distincts, map( (augment_sort )) tvs, mx

  val _ = trace_msg (K "Proving eq-iff theorems...")
  val alpha_eq_iff = raw_prove_alpha_eq_iff dts =map augment

  val _ = trace_msg (K "Proving equivariance of bns, fvs, size and alphamk_constr_trms ((tname, tvs, _), constrs) =
  val raw_bn_eqvt =
    raw_prove_eqvt raw_bns raw_bn_inducts (raw_bn_defs @ raw_perm_simps) lthy4

  (* noting the raw_bn_eqvt lemmas in a temporary theory *)
  val lthy_tmp =
    lthy4
    |> Local_Theory.begin_nested
    |> snd
    |> Local_Theory.note ((Binding.empty, @{attributes [eqvt]}), raw_bn_eqvt)
    |> snd
    |> Local_Theory.end_nested

  val raw_fv_eqvt =
    raw_prove_eqvt (raw_fvs @ raw_fv_bns) raw) raw_fv_bns_induct (raw_fv_defs @ raw_perm_simps)
      lthy_tmp

  val raw_size_eq(* FFIXME: local version *)
    let
      val RawDtInfo {raw_size_trms, raw_size raw_induct_thms, ...} = raw_
    in
      raw_prove_eqvt raw_size_trms raw_induct_thms (raw_size_thms @ raw_perm_simps)
        lthy_tmp
        |> map (rerite_rule lthy
            @{thms permute_nat_def[THEN eq_reflection]})
        |> map (fn thm => thm RS @{thm sym})
    end

  val lthy5 = snd (Local_Theory.note ((Binding.empty, @{attributes [eqvt]}), raw_fv_eqvt) lthy_tmp)

  val alpha_eqvt =
    let
      val AlphaResult {alpha_trms, alpha_bn_trms, alpha_raw_induct, alpha_intros, ...} = alpha_result
    in
      Nominal_Eqvt.raw_equivariance lthy5 (alpha_trms @ alpha_bn_trms) alpha_raw_induct alph
    end

  val alpha_eqvt_norm = map (Nominal_ThmDecls.eqvt_transform lthy5) alpha_eqvt

  val _ = trace_msg (K "Proving equivalence of alpha..
  val alpha_refl_thms = raw_prove_refl lthy5 alpha_result raw_induct_thm
  val alpha_sym_thms lthy5alpha_result
  val alpha_trans_thms =
    raw_prove_trans

  val, alpha_bn_equivp_thms
    raw_prove_equivp

  val _ =     Specification bn_fun_strs
  val

  val (K "Proving respectfulness...")
  val raw_funs_rsp_aux =
    raw_fv_bn_rsp_aux lthy5 alpha_result raw_fvs raw_bns bn_funs prep_bn_fun

  val raw_funs_rsp = map (Drule

  fun match_const cnst.exit_global')
    (fst o dest_Const.add_constsbn_funs'
    fst (dest_Const cnst);| pair (bn_funs)
  fun find_matching_rsp cnst end
    hd>
  val raw_fv_rsp = map find_matching_rsp raw_fvs;
  val = map raw_bns;
  val raw_fv_bn_rsp = map find_matching_rsp raw_fv_bns;

  val raw_size_rsp =
    raw_size_rsp_aux lthy5 (raw_size_thms)
      |> map (mk_funs_rsp lthy5)

  val raw_constrs_rsp =
    raw_constrs_rsp alpha_result (alpha_bn_imp_thms@raw_funs_rsp_aux)

  val alpha_permute_rsp

  val _ [] = []
    raw_alpha_bn_rsp alpha_result alpha_bn_equivp_thms| mapp (NONE :: xs) = mapp (i + 1)xs

  l raw_perm_bn_rsp = raw_perm_bn_rsp alpha_result raw_perm_bn_simps

  val trace_msg (K"Defining the quotient types...")
  valmapp 0 xs

  val, lthy7=
    let
      val
    in index_lookup x java.lang.StringIndexOutOfBoundsException: Index 23 out of bounds for length 23
      define_qtypes alpha_tys alpha_equivp_thms
    end

  val = map qty_infos
  val qty_full_names =\close>
  val

  val 🚫 fst, bns
  val qconstrs_descrs
    (map2 o map2)   fun prep_binder bn_str
      (get_cnstrs) (map

  val qbns_descr Const ( T  Free(x _ = (SOME ( (a, T)), index_lookup x
    map2 _>error (The "^b ^ " is allowed binding."

  val qfvs_descr =
    map2 (fn n => fn (t, th) => ("fv_" ^ n, t, NoSynrep_boy ev bn_str indx_lookupenv b_str

  val qfv_bns_descr =
    map2 (fn (b,fun prep_bcenv(moebiner,bdie)=
      bn_funs (raw_fv_bns ~~ raw_fv_bn_rsp let

  val qalpha_bns_descr =
    ett
      val AlphaResult {alpha_bn_trms, ...} = alpha_result
java.lang.StringIndexOutOfBoundsException: Index 6 out of bounds for length 6
      map2 (fn (b, _, _) => fn (t, th) => ("alpha_" ^ Variable.check_name b, t, NoSyn, th))
        bn_funs (alpha_bn_trms ~~ alpha_bn_rsp)
    end

  val al qperm_descr =
    map2 (fn n => fn (t, th) => ("permute_" ^ n, Type.legacy_freeze t, NoSyn, th))
      qty_names (raw_perm_funs ~~ (take (length raw_perm_funs) alpha_permute_rsp))

  val qsize_descr =
    map2 (fn n => fn (t, th) => ("size_" ^ n, t n
      (raw_size_trms ~~ (take (le map (p (prclaue nv bclause_trs

  val qperm_bn_descr =
    map2 (fn (b, _, _) => fn (t, th) => ("permute_" ^ Variable.check_name b, t, NoSyn, th))
      bn_funs (raw_perm_bns ~~ raw_perm_bn_rsp)

  val ((((((qconstrs_infos, qbns_info), qfvs_info), qfv_bns_info), qalpha_bns_info), qperm_bns_info),
    lthy8) =
      lthy7
      |> fold_map (define_qconsts qtys) qconstrs_descrs
      |> fne_cnss qtys bn_dec
      ||>> define_qconsts qtys qfvs_descr
|ine_qconstsy f_n_esr
    efine_qconstsshabn_dsr
      ||>> define_qconsts qtys qperm_bn_descr

  val lthy9 =
    define_qperms qtys qty_full_names raw_ty_args qperm_descr raw_perm_laws lthy8

  val lthy9a =
    define_qsizes qtys qty_full_names raw_ty_args qsize_descr lthy9

  val qtrms = (map o map) #qconst qconstrs_infos
  val qbns = map #qconst qbns_info
  val qfvs = map #qconst qfvs_info
  val qfv_bns = map #qconst qfv_bns_info
java.lang.StringIndexOutOfBoundsException: Index 3 out of bounds for length 3
  val qperm_bns = map #qconst qperm_bns_info

  val _ = trace_msg (K "Lifting of theorems
   _psrmute_prodmps el_prod_sel
    prod.case}

  val ([ qdistincts
         qbn_inducts, qsize_eqvt, [qinduct], qexhausts, qsize_simps, qperm_bn_simps,
         qalpha_refl_thms, qalpha_sym_thms, qalpha_trans_thms ], lthyB
    lthy9a
    > t_thmscts
    ||>>> lift_thms qtys
    ||>>> lift_thms qtys  val
    ||>>> lift_thms qtyss
    ||>>> lift_thms qtys [] raw_perm_simps(op   ysntys
    ||>>> lift_thms qtys
    ft_thms
    ||>>> lift_thms qtys [] raw_size_eqvt
    ||>>> lift_thms qtys [] [raw_induct_thm]
    ||>>> lift_thms qtys [] raw_exhaust_thms
    ||>>> lift_thms qtys [] raw_size_thms
    ||>>> lift_thms qtys [] raw_perm_bn_simps
    ||>>> lift_thms qtys [] alpha_refl_thms
    ||>>> lift_thms qtys [] alpha_sym_thms
    ||>>> lift_thms qtys [let

  val qinducts = Project_Rulein

  val _ = trace_msg (K "Proving supp lemmas and fs-instances..."
  val qsupports_thms

  (* finite supp lemmas *)
  val qfsupp_thms = prove_fsupp lthyB qtys qinduct

  (* fs instances *)
  valtancesraw_ty_argsjava.lang.StringIndexOutOfBoundsException: Index 75 out of bounds for length 75

  val
  val qfv_supp_thms =
    rove_fv_supplatv_bnsfs
      qperm_simps qfv_qbn_eqvts qinduct (flat raw_bclauses
    |> valunses

  (* postprocessing of eq and fv theorems *)
  alfs
    |> map (simplify (put_simpset>prepare_bn_funs
    |> map (simplify (put_simpsetepare_bclauses
        addsimps @{thms prod_fv_supp prod_alpha_eq

  (* filters the theorems that are of the form "qfv = supp" *)
  valmesst_Const
  fun is_qfv_thm 🍋
    member (op =) qfv_names lhs
  | is_qfv_thm _ = false

  val qsupp_constrs = qfv_defs
    |> map
        addsimps (filter (is_qfv_thm 

  valx = y<Longrightarrowhtarrow x ⟷ y" by simp}
  val transform_thms =
    [ @{lemma "a ∉
      ma (S - T) ⟷ S ∨ T" by simp},
      @{lemma "(lhs = 
      @{thm fresh_def[symmetric]}]

  val qfresh_constrs
    |> mapkeyword
    Scan

  (* proving that the qbn result is finite *)|$setKReset
  val qbn_finite_thms = prove_bns_finite

  (* proving that perm_bns preserve alpha *)
  val qperm_bn_alpha_thms  Parseum-repeat1{eywordt1.name>triple1
    prove_perm_bn_alpha_thms qtys qperm_bns
      qalpha_refl_thms cnstr_parser

 *ovingfbn
  val qpermute_bn_thms =
    prove_permute_bn_thms qtys

  val _=trace_msg "Proving strong exhaust lemmas...")
  val = prove_strong_exhausts qexhaustsbclauses qbn_finite_thms'
    qfv_qbn_eqvts qpermute_bn_thms qperm_bn_alpha_thms

  val _ = trace_msg (K "Proving strong indu (@{ke "="} |-- Parse.enum1 "" cns)
  val qstrong_induct_thms = prove_strong_induct lthyC qinduct qstrong_exhaust_thms qsize_simps bclauses

  (* noting the theorems *)

  (* generating the prefix for the theorem names *)
   Scan.optional ((@{keyword "binderarse_Spec]]
    the_default (Binding.name (space_implode "_" qty_names
  fun thms_suffix s = Binding
  val case_names_attr = Attrib.internal 🍋 (K (Rule_Cases.case_names cnstr_names))

  val

  val (_, lthy9') = lthyC
     |> Local_Theory.declaration {syntax
     >ocal_Theory distinctutes},qdistincts
     ||>> Local_Theory.note ((thms_suffix "eq_iff", @{attributes [induct_simp of datatypes"
     ||>> Local_Theory.note ((thms_suffix "fv_defs", []), qfv_defs)
     ||>> Local_Theory.note ((thms_suffix "bn_defs", []), qbn_def main_parser >> nominal_datatype2_cmd)
     ||>> Local_note ((thms_suffix "bn_inducts] n_inducts
     ||>> Local_Theory.note ((thms_suffix
     ||>> Local_Theory
     ||>> Local_Theory.note ((thms_suffix "size", @{attributes [simp]}), qsize_simps)
     ||>> Local_Theory.note ((thms_suffix "size_eqvt", []), qsize_eqvt)
     ||>> Local_Theory.note ((thms_suffix "induct", [case_names_attr]), [qinduct])
     ||>> Local_Theory.note ((thms_suffix "inducts", [case_names_attr]), qinducts)
     ||>> Local_Theory.note ((thms_suffix "exhaust", [case_names_attr]), qexhausts)
     ||>> Local_Theory.note ((thms_suffix "strong_exhaust", [case_names_attr]), qstrong_exhaust_thms)
     ||>> Local_Theory.note ((thms_suffix "strong_induct", [case_names_attr]), qstrong_induct_thms)
     ||>> Local_Theory.note ((thms_suffix "supports", []), qsupports_thms)
     ||>> Local_Theory.note ((thms_suffix "fsupp", []), qfsupp_thms)
     ||>> Local_Theory.note ((thms_suffix "supp", []), qsupp_constrs)
     ||>> Local_Theory.note ((thms_suffix "fresh", @{attributes [simp]}), qfresh_constrs)
     ||>> Local_Theory.note ((thms_suffix "perm_bn_simps", []), qperm_bn_simps)
     ||>> Local_Theory.note ((thms_suffix "bn_finite", []), qbn_finite_thms)
     ||>> Local_Theory.note ((thms_suffix "perm_bn_alpha", []), qperm_bn_alpha_thms)
     ||>> Local_Theory.note ((thms_suffix "permute_bn", []), qpermute_bn_thms)
     ||>> Local_Theory.note ((thms_suffix "alpha_refl", []), qalpha_refl_thms)
     ||>> Local_Theory.note ((thms_suffix "alpha_sym", []), qalpha_sym_thms)
     ||>> Local_Theory.note ((thms_suffix "alpha_trans", []), qalpha_trans_thms)

in
  lthy9'
end
›


section ‹Preparing and parsing of the specification›

ML \<open>
(* adds the default sort @{sort fs} to nominal specifications *)

fun augment_sort thy S = Sign.inter_sort thy (@{sort fs}, S)

fun augment_sort_typ thy =
  map_type_tfree (fn (s, S) => TFree (s, augment_sort thy S))
›

ML ‹
(* generates the parsed datatypes and declares the constructors *)

fun prepare_dts dt_strs thy =
let
  fun prep_spec ((tname, tvs, mx), constrs) =
    ((tname, tvs, mx), constrs |> map (fn (c, atys, mx', _) => (c, map snd atys, mx')))

  val (dts, spec_ctxt) =
    Old_Datatype.read_specs (map prep_spec dt_strs) thy

  fun augment ((tname, tvs, mx), constrs) =
    ((tname, map (apsnd (augment_sort thy)) tvs, mx),
      constrs |> map (fn (c, tys, mx') => (c, map (augment_sort_typ thy) tys, mx')))

  val dts' = map augment dts

  fun mk_constr_trms ((tname, tvs, _), constrs) =
    let
      val ty = Type (Sign.full_name thy tname, map TFree tvs)
    in
      map (fn (c, tys, mx) => (c, (tys ---> ty), mx)) constrs
    end

  val constr_trms = flat (map mk_constr_trms dts')

  (* FIXME: local version *)
  (* val (_, spec_ctxt') = Proof_Context.add_fixes constr_trms spec_ctxt *)

  val thy' = Sign.add_consts constr_trms (Proof_Context.theory_of spec_ctxt)
in
  (dts', thy')
end
›

ML ‹
(* parsing the binding function specifications and *)
(* declaring the function constants                *)
fun prepare_bn_funs bn_fun_strs bn_eq_strs thy =
let
  val lthy = Named_Target.theory_init thy

  val ((bn_funs, bn_eqs), lthy') =
    Specification.read_multi_specs bn_fun_strs bn_eq_strs lthy

  fun prep_bn_fun ((bn, T), mx) = (bn, T, mx)

  val bn_funs' = map prep_bn_fun bn_funs

in
  (Local_Theory.exit_global lthy')
  |> Sign.add_consts bn_funs'
  |> pair (bn_funs', bn_eqs)
end
›

text ‹associates every SOME with the index in the list; drops NONEs›
ML \<open>
fun indexify xs =
let
  fun mapp _ [] = []
    | mapp i (NONE :: xs) = mapp (i + 1) xs
    | mapp i (SOME x :: xs) = (x, i) :: mapp (i + 1) xs
in
  mapp 0 xs
end

fun index_lookup xs x =
  case AList.lookup (op =) xs x of
    SOME x => x
  | NONE => error ("Cannot find " ^ x ^ " as argument annotation.");
\<close>

ML \<open>
fun prepare_bclauses dt_strs thy =
let
  val annos_bclauses =
    get_cnstrs dt_strs
    |> (map o map) (fn (_, antys, _, bns) => (map fst antys, bns))

  fun prep_binder env bn_str =
    case (Syntax.read_term_global thy bn_str) of
      Free (x, _) => (NONE, index_lookup env x)
    | Const (a, T) $ Free (x, _) => (SOME (Const (a, T)), index_lookup env x)
    | _ => error ("The term " ^ bn_str ^ " is not allowed as binding function.")

  fun prep_body env bn_str = index_lookup env bn_str

  fun prep_bclause env (mode, binders, bodies) =
  let
    val binders' = map (prep_binder env) binders
    val bodies' = map (prep_body env) bodies
  in
    BC (mode, binders', bodies')
  end

  fun prep_bclauses (annos, bclause_strs) =
  let
    val env = indexify annos (* for every label, associate the index *)
  in
    map (prep_bclause env) bclause_strs
  end
in
  ((map o map) prep_bclauses annos_bclauses, thy)
end
›

text ‹
  adds an empty binding clause for every argument
  that is not already part of a binding clause
\<close>

ML \<open>
fun included i bcs =
let
  fun incl (BC (_, bns, bds)) =
    member (op =) (map snd bns) i orelse member (op =) bds i
in
  exists incl bcs
end
\<close>

ML \<open>
fun complete dt_strs bclauses =
let
  val args =
    get_cnstrs dt_strs
    |> (map o map) (fn (_, antys, _, _) => length antys)

  fun complt n bcs =
  let
    fun add bcs i = (if included i bcs then [] else [BC (Lst, [], [i])])
  in
    bcs @ (flat (map_range (add bcs) n))
  end
in
  (map2 o map2) complt args bclauses
end
\<close>

ML \<open>
fun nominal_datatype2_cmd (opt_thms_name, dt_strs, bn_fun_strs, bn_eq_strs) lthy =
let
  (* this theory is used just for parsing *)
  val thy = Proof_Context.theory_of lthy

  val (((dts, (bn_funs, bn_eqs)), bclauses), _) =
    thy
    |> prepare_dts dt_strs
    ||>> prepare_bn_funs bn_fun_strs bn_eq_strs
    ||>> prepare_bclauses dt_strs

  val bclauses' = complete dt_strs bclauses
in
  nominal_datatype2 opt_thms_name dts bn_funs bn_eqs bclauses' lthy
end
›

ML ‹
(* nominal datatype parser *)
local
  fun triple1 ((x, y), z) = (x, y, z)
  fun triple2 ((x, y), z) = (y, x, z)
  fun tuple2 (((x, y), z), u) = (x, y, u, z)
  fun tuple3 ((x, y), (z, u)) = (x, y, z, u)
in

val opt_name = Scan.option (Parse.binding --| Args.colon)

val anno_typ = Scan.option (Parse.name --| @{keyword "::"}) -- Parse.typ

val bind_mode = @{keyword "binds"} |--
  Scan.optional (Args.parens
    (Args.$$$ "list" >> K Lst || (Args.$$$ "set" -- Args.$$$ "+") >> K Res || Args.$$$ "set" >> K Set)) Lst

val bind_clauses =
  Parse.enum "," (bind_mode -- Scan.repeat1 Parse.term -- (@{keyword "in"} |-- Scan.repeat1 Parse.name) >> triple1)

val cnstr_parser =
  Parse.binding -- Scan.repeat anno_typ -- bind_clauses -- Parse.opt_mixfix >> tuple2

(* datatype parser *)
val dt_parser =
  (Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix >> triple2) --
    (@{keyword "="} |-- Parse.enum1 "|" cnstr_parser)

(* binding function parser *)
val bnfun_parser =
  Scan.optional (@{keyword "binder"} |-- Parse_Spec.specification) ([], [])

(* main parser *)
val main_parser =
  opt_name -- Parse.and_list1 dt_parser -- bnfun_parser >> tuple3

end

(* Command Keyword *)
val _ = Outer_Syntax.local_theory @{command_keyword nominal_datatype}
  "declaration of nominal datatypes"
    (main_parser >> nominal_datatype2_cmd)
›

end