diff -r a746d49b0240 -r 331873ebc5cd Nominal/nominal_dt_quot.ML --- a/Nominal/nominal_dt_quot.ML Sun Aug 22 14:02:49 2010 +0800 +++ b/Nominal/nominal_dt_quot.ML Wed Aug 25 09:02:06 2010 +0800 @@ -13,11 +13,11 @@ val define_qconsts: typ list -> (string * term * mixfix) list -> local_theory -> Quotient_Info.qconsts_info list * local_theory - val define_qperms: typ list -> string list -> (string * term * mixfix) list -> - thm list -> local_theory -> local_theory + val define_qperms: typ list -> string list -> (string * sort) list -> + (string * term * mixfix) list -> thm list -> local_theory -> local_theory - val define_qsizes: typ list -> string list -> (string * term * mixfix) list -> - local_theory -> local_theory + val define_qsizes: typ list -> string list -> (string * sort) list -> + (string * term * mixfix) list -> local_theory -> local_theory val lift_thm: Proof.context -> typ list -> thm list -> thm -> thm end @@ -47,46 +47,62 @@ (* defines the quotient permutations and proves pt-class *) -fun define_qperms qtys qfull_ty_names perm_specs raw_perm_laws lthy = +fun define_qperms qtys qfull_ty_names tvs perm_specs raw_perm_laws lthy = let - val lthy' = + val _ = tracing ("qtys:\n" ^ cat_lines (map @{make_string} qtys)) + + val lthy1 = lthy |> Local_Theory.exit_global - |> Class.instantiation (qfull_ty_names, [], @{sort pt}) + |> Class.instantiation (qfull_ty_names, tvs, @{sort pt}) - val (_, lthy'') = define_qconsts qtys perm_specs lthy' + val (qs, lthy2) = define_qconsts qtys perm_specs lthy1 + + val ((_, raw_perm_laws'), lthy3) = Variable.importT raw_perm_laws lthy2 - val lifted_perm_laws = map (Quotient_Tacs.lifted lthy'' qtys []) raw_perm_laws + val lifted_perm_laws = + map (Quotient_Tacs.lifted lthy3 qtys []) raw_perm_laws' + |> Variable.exportT lthy3 lthy2 fun tac _ = Class.intro_classes_tac [] THEN (ALLGOALS (resolve_tac lifted_perm_laws)) in - lthy'' + lthy2 |> Class.prove_instantiation_exit tac |> Named_Target.theory_init end (* defines the size functions and proves size-class *) -fun define_qsizes qtys qfull_ty_names size_specs lthy = +fun define_qsizes qtys qfull_ty_names tvs size_specs lthy = let fun tac _ = Class.intro_classes_tac [] in lthy |> Local_Theory.exit_global - |> Class.instantiation (qfull_ty_names, [], @{sort size}) + |> Class.instantiation (qfull_ty_names, tvs, @{sort size}) |> snd o (define_qconsts qtys size_specs) |> Class.prove_instantiation_exit tac |> Named_Target.theory_init end -(* lifts a theorem and deletes all "_raw" suffixes *) +(* lifts a theorem and cleans all "_raw" instances + from variable names *) -fun unraw_str s = - unsuffix "_raw" s - handle Fail _ => s +local + val any = Scan.one (Symbol.not_eof) + val raw = Scan.this_string "_raw" + val exclude = + Scan.repeat (Scan.unless raw any) --| raw >> implode + val parser = Scan.repeat (exclude || any) +in + fun unraw_str s = + s |> explode + |> Scan.finite Symbol.stopper parser >> implode + |> fst +end fun unraw_vars_thm thm = let @@ -111,6 +127,7 @@ |> Quotient_Tacs.lifted ctxt qtys simps |> unraw_bounds_thm |> unraw_vars_thm + |> Drule.zero_var_indexes end (* structure *)