diff --git a/thys/Applicative_Lifting/applicative.ML b/thys/Applicative_Lifting/applicative.ML --- a/thys/Applicative_Lifting/applicative.ML +++ b/thys/Applicative_Lifting/applicative.ML @@ -1,1377 +1,1376 @@ (* Author: Joshua Schneider, ETH Zurich *) signature APPLICATIVE = sig type afun val intern: Context.generic -> xstring -> string val extern: Context.generic -> string -> xstring val afun_of_generic: Context.generic -> string -> afun val afun_of: Proof.context -> string -> afun val afuns_of_term_generic: Context.generic -> term -> afun list val afuns_of_term: Proof.context -> term -> afun list val afuns_of_typ_generic: Context.generic -> typ -> afun list val afuns_of_typ: Proof.context -> typ -> afun list val name_of_afun: afun -> binding val unfolds_of_afun: afun -> thm list type afun_inst val match_afun_inst: Proof.context -> afun -> term * int -> afun_inst val import_afun_inst: afun -> Proof.context -> afun_inst * Proof.context val inner_sort_of: afun_inst -> sort val mk_type: afun_inst -> typ -> typ val mk_pure: afun_inst -> typ -> term val lift_term: afun_inst -> term -> term val mk_ap: afun_inst -> typ * typ -> term val mk_comb: afun_inst -> typ -> term * term -> term val mk_set: afun_inst -> typ -> term val dest_type: Proof.context -> afun_inst -> typ -> typ option val dest_type': Proof.context -> afun_inst -> typ -> typ val dest_pure: Proof.context -> afun_inst -> term -> term val dest_comb: Proof.context -> afun_inst -> term -> term * term val infer_comb: Proof.context -> afun_inst -> term * term -> term val subst_lift_term: afun_inst -> (term * term) list -> term -> term val generalize_lift_terms: afun_inst -> term list -> Proof.context -> term list * Proof.context val afun_unfold_tac: Proof.context -> afun -> int -> tactic val afun_fold_tac: Proof.context -> afun -> int -> tactic val unfold_all_tac: Proof.context -> int -> tactic val normalform_conv: Proof.context -> afun -> conv val normalize_rel_tac: Proof.context -> afun -> int -> tactic val general_normalform_conv: Proof.context -> afun -> cterm * cterm -> thm * thm val general_normalize_rel_tac: Proof.context -> afun -> int -> tactic val forward_lift_rule: Proof.context -> afun -> thm -> thm val unfold_wrapper_tac: Proof.context -> afun option -> int -> tactic val fold_wrapper_tac: Proof.context -> afun option -> int -> tactic val normalize_wrapper_tac: Proof.context -> afun option -> int -> tactic val lifting_wrapper_tac: Proof.context -> afun option -> int -> tactic val setup_combinators: (string * thm) list -> local_theory -> local_theory val combinator_rule_attrib: string list option -> attribute val parse_opt_afun: afun option context_parser val applicative_cmd: (((((binding * string list) * string) * string) * string option) * string option) -> local_theory -> Proof.state val print_afuns: Proof.context -> unit val add_unfold_attrib: xstring option -> attribute val forward_lift_attrib: xstring -> attribute end; structure Applicative : APPLICATIVE = struct open Ctr_Sugar_Util (** General utilities **) fun fold_options xs = fold (fn x => (case x of SOME x' => cons x' | NONE => I)) xs []; fun the_pair [x, y] = (x, y) | the_pair _ = raise General.Size; fun strip_comb2 (f $ x $ y) = (f, (x, y)) | strip_comb2 t = raise TERM ("strip_comb2", [t]); fun mk_comb_pattern (t, n) = let val Ts = take n (binder_types (fastype_of t)); val maxidx = maxidx_of_term t; val vars = map (fn (T, i) => ((Name.uu, maxidx + i), T)) (Ts ~~ (1 upto n)); in (vars, Term.betapplys (t, map Var vars)) end; fun match_comb_pattern ctxt tn u = let val thy = Proof_Context.theory_of ctxt; val (vars, pat) = mk_comb_pattern tn; val envs = Pattern.match thy (pat, u) (Vartab.empty, Vartab.empty) handle Pattern.MATCH => raise TERM ("match_comb_pattern", [u, pat]); in (vars, envs) end; fun dest_comb_pattern ctxt tn u = let val (vars, (_, env)) = match_comb_pattern ctxt tn u; in map (the o Envir.lookup1 env) vars end; fun norm_term_types tyenv t = Term_Subst.map_types_same (Envir.norm_type_same tyenv) t handle Same.SAME => t; val mk_TFrees_of = mk_TFrees' oo replicate; fun mk_Free name typ ctxt = yield_singleton Variable.variant_fixes name ctxt |>> (fn name' => Free (name', typ)); (*tuples with explicit sentinel*) fun mk_tuple' ts = fold_rev (curry HOLogic.mk_prod) ts HOLogic.unit; fun strip_tuple' (Const (@{const_name Unity}, _)) = [] | strip_tuple' (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: strip_tuple' t2 | strip_tuple' t = raise TERM ("strip_tuple'", [t]); fun mk_eq_on S = let val (SA, ST) = `HOLogic.dest_setT (fastype_of S); in Const (@{const_name eq_on}, ST --> BNF_Util.mk_pred2T SA SA) $ S end; (* Polymorphic terms and term groups *) type poly_type = typ list * typ; type poly_term = typ list * term; fun instantiate_poly_type (tvars, T) insts = typ_subst_atomic (tvars ~~ insts) T; fun instantiate_poly_term (tvars, t) insts = subst_atomic_types (tvars ~~ insts) t; fun dest_poly_type ctxt (tvars, T) U = let val thy = Proof_Context.theory_of ctxt; val tyenv = Sign.typ_match thy (T, U) Vartab.empty handle Type.TYPE_MATCH => raise TYPE ("dest_poly_type", [U, T], []); in map (Type.lookup tyenv o dest_TVar) tvars end; fun poly_type_to_term (tvars, T) = (tvars, Logic.mk_type T); fun poly_type_of_term (tvars, t) = (tvars, Logic.dest_type t); (* Schematic variables are treated uniformly in packed terms, thus forming an ad hoc context of type variables. Otherwise, morphisms are allowed to rename schematic variables non-consistently in separate terms, and occasionally will do so. *) fun pack_poly_term (tvars, t) = HOLogic.mk_prod (mk_tuple' (map Logic.mk_type tvars), t); fun unpack_poly_term t = let val (tvars, t') = HOLogic.dest_prod t; in (map Logic.dest_type (strip_tuple' tvars), t') end; val pack_poly_terms = mk_tuple' o map pack_poly_term; val unpack_poly_terms = map unpack_poly_term o strip_tuple'; (*match and instantiate schematic type variables which are not "quantified" in the packed term*) fun match_poly_terms_type ctxt (pt, i) (U, maxidx) = let val thy = Proof_Context.theory_of ctxt; val pt' = Logic.incr_indexes ([], [], maxidx + 1) pt; val (tvars, T) = poly_type_of_term (nth (unpack_poly_terms pt') i); val tyenv = Sign.typ_match thy (T, U) Vartab.empty handle Type.TYPE_MATCH => raise TYPE ("match_poly_terms", [U, T], []); val tyenv' = fold Vartab.delete_safe (map (#1 o dest_TVar) tvars) tyenv; val pt'' = Envir.subst_term_types tyenv' pt'; in unpack_poly_terms pt'' end; fun match_poly_terms ctxt (pt, i) (t, maxidx) = match_poly_terms_type ctxt (pt, i) (fastype_of t, maxidx); (*fix schematic type variables which are not "quantified", as well as schematic term variables*) fun import_poly_terms pt ctxt = let fun insert_paramTs (tvars, t) = fold_types (fold_atyps (fn TVar v => if member (op =) tvars (TVar v) then I else insert (op =) v | _ => I)) t; val paramTs = rev (fold insert_paramTs (unpack_poly_terms pt) []); val (tfrees, ctxt') = Variable.invent_types (map #2 paramTs) ctxt; val instT = TVars.make (paramTs ~~ map TFree tfrees); val params = map (apsnd (Term_Subst.instantiateT instT)) (rev (Term.add_vars pt [])); val (frees, ctxt'') = Variable.variant_fixes (map (Name.clean o #1 o #1) params) ctxt'; val inst = Vars.make (params ~~ map Free (frees ~~ map #2 params)); val pt' = Term_Subst.instantiate (instT, inst) pt; in (unpack_poly_terms pt', ctxt'') end; (** Internal representation **) (* Applicative functors *) type rel_thms = { pure_transfer: thm, ap_rel_fun: thm }; fun map_rel_thms f {pure_transfer, ap_rel_fun} = {pure_transfer = f pure_transfer, ap_rel_fun = f ap_rel_fun}; type afun_thms = { hom: thm, ichng: thm, reds: thm Symtab.table, rel_thms: rel_thms option, rel_intros: thm list, pure_comp_conv: thm }; fun map_afun_thms f {hom, ichng, reds, rel_thms, rel_intros, pure_comp_conv} = {hom = f hom, ichng = f ichng, reds = Symtab.map (K f) reds, rel_thms = Option.map (map_rel_thms f) rel_thms, rel_intros = map f rel_intros, pure_comp_conv = f pure_comp_conv}; datatype afun = AFun of { name: binding, terms: term, rel: term option, thms: afun_thms, unfolds: thm Item_Net.T }; fun rep_afun (AFun af) = af; val name_of_afun = #name o rep_afun; val terms_of_afun = #terms o rep_afun; val rel_of_afun = #rel o rep_afun; val thms_of_afun = #thms o rep_afun; val unfolds_of_afun = Item_Net.content o #unfolds o rep_afun; val red_of_afun = Symtab.lookup o #reds o thms_of_afun; val has_red_afun = is_some oo red_of_afun; fun mk_afun name terms rel thms = AFun {name = name, terms = terms, rel = rel, thms = thms, unfolds = Thm.item_net}; fun map_afun f1 f2 f3 f4 f5 (AFun {name, terms, rel, thms, unfolds}) = AFun {name = f1 name, terms = f2 terms, rel = f3 rel, thms = f4 thms, unfolds = f5 unfolds}; fun map_unfolds f thms = fold Item_Net.update (map f (Item_Net.content thms)) Thm.item_net; fun morph_afun phi = let val binding = Morphism.binding phi; val term = Morphism.term phi; val thm = Morphism.thm phi; in map_afun binding term (Option.map term) (map_afun_thms thm) (map_unfolds thm) end; val transfer_afun = morph_afun o Morphism.transfer_morphism; fun add_unfolds_afun thms = map_afun I I I I (fold Item_Net.update thms); fun patterns_of_afun af = let val [Tt, (_, pure), (_, ap), _] = unpack_poly_terms (terms_of_afun af); val (_, T) = poly_type_of_term Tt; in [#2 (mk_comb_pattern (pure, 1)), #2 (mk_comb_pattern (ap, 2)), Net.encode_type T] end; (* Combinator rules *) datatype combinator_rule = Combinator_Rule of { strong_premises: string Ord_List.T, weak_premises: bool, conclusion: string, eq_thm: thm }; fun rep_combinator_rule (Combinator_Rule rule) = rule; val conclusion_of_rule = #conclusion o rep_combinator_rule; val thm_of_rule = #eq_thm o rep_combinator_rule; fun eq_combinator_rule (rule1, rule2) = pointer_eq (rule1, rule2) orelse Thm.eq_thm (thm_of_rule rule1, thm_of_rule rule2); fun is_applicable_rule rule have_weak have_premises = let val {strong_premises, weak_premises, ...} = rep_combinator_rule rule; in (have_weak orelse not weak_premises) andalso have_premises strong_premises end; fun map_combinator_rule f1 f2 f3 f4 (Combinator_Rule {strong_premises, weak_premises, conclusion, eq_thm}) = Combinator_Rule {strong_premises = f1 strong_premises, weak_premises = f2 weak_premises, conclusion = f3 conclusion, eq_thm = f4 eq_thm}; fun transfer_combinator_rule thy = map_combinator_rule I I I (Thm.transfer thy); fun mk_combinator_rule comb_names weak_premises thm = let val (lhs, rhs) = Logic.dest_equals (Thm.prop_of thm); val conclusion = the (Symtab.lookup comb_names (#1 (dest_Const lhs))); val premises = Ord_List.make fast_string_ord (fold_options (map (Symtab.lookup comb_names o #1) (Term.add_consts rhs []))); val weak_premises' = Ord_List.make fast_string_ord (these weak_premises); val strong_premises = Ord_List.subtract fast_string_ord weak_premises' premises; in Combinator_Rule {strong_premises = strong_premises, weak_premises = is_some weak_premises, conclusion = conclusion, eq_thm = thm} end; (* Generic data *) (*FIXME: needs tests, especially around theory merging*) fun merge_afuns _ (af1, af2) = if pointer_eq (af1, af2) then raise Change_Table.SAME else map_afun I I I I (fn thms1 => Item_Net.merge (thms1, #unfolds (rep_afun af2))) af1; structure Data = Generic_Data ( type T = { combinators: thm Symtab.table * combinator_rule list, afuns: afun Name_Space.table, patterns: (string * term list) Item_Net.T }; val empty = { combinators = (Symtab.empty, []), afuns = Name_Space.empty_table "applicative functor", patterns = Item_Net.init (op = o apply2 #1) #2 }; - val extend = I; fun merge ({combinators = (cd1, cr1), afuns = a1, patterns = p1}, {combinators = (cd2, cr2), afuns = a2, patterns = p2}) = {combinators = (Symtab.merge (K true) (cd1, cd2), Library.merge eq_combinator_rule (cr1, cr2)), afuns = Name_Space.join_tables merge_afuns (a1, a2), patterns = Item_Net.merge (p1, p2)}; ); fun get_combinators context = let val thy = Context.theory_of context; val {combinators = (defs, rules), ...} = Data.get context; in (Symtab.map (K (Thm.transfer thy)) defs, map (transfer_combinator_rule thy) rules) end; val get_afun_table = #afuns o Data.get; val get_afun_space = Name_Space.space_of_table o get_afun_table; val get_patterns = #patterns o Data.get; fun map_data f1 f2 f3 {combinators, afuns, patterns} = {combinators = f1 combinators, afuns = f2 afuns, patterns = f3 patterns}; val intern = Name_Space.intern o get_afun_space; fun extern context = Name_Space.extern (Context.proof_of context) (get_afun_space context); local fun undeclared name = error ("Undeclared applicative functor " ^ quote name); in fun afun_of_generic context name = case Name_Space.lookup (get_afun_table context) name of SOME af => transfer_afun (Context.theory_of context) af | NONE => undeclared name; val afun_of = afun_of_generic o Context.Proof; fun update_afun name f context = if Name_Space.defined (get_afun_table context) name then Data.map (map_data I (Name_Space.map_table_entry name f) I) context else undeclared name; end; fun match_term context = map #1 o Item_Net.retrieve_matching (get_patterns context); fun match_typ context = match_term context o Net.encode_type; (*works only with terms which are combinations of pure and ap*) fun afuns_of_term_generic context = map (afun_of_generic context) o match_term context; val afuns_of_term = afuns_of_term_generic o Context.Proof; fun afuns_of_typ_generic context = map (afun_of_generic context) o match_typ context; val afuns_of_typ = afuns_of_typ_generic o Context.Proof; fun all_unfolds_of_generic context = let val unfolds_of = map (Thm.transfer'' context) o unfolds_of_afun; in Name_Space.fold_table (fn (_, af) => append (unfolds_of af)) (get_afun_table context) [] end; val all_unfolds_of = all_unfolds_of_generic o Context.Proof; (** Term construction and destruction **) type afun_inst = { T: poly_type, pure: poly_term, ap: poly_term, set: poly_term }; fun mk_afun_inst [T, pure, ap, set] = {T = poly_type_of_term T, pure = pure, ap = ap, set = set}; fun pack_afun_inst {T, pure, ap, set} = pack_poly_terms [poly_type_to_term T, pure, ap, set]; fun match_afun_inst ctxt af = match_poly_terms ctxt (terms_of_afun af, 0) #> mk_afun_inst; fun import_afun_inst_raw terms = import_poly_terms terms #>> mk_afun_inst; val import_afun_inst = import_afun_inst_raw o terms_of_afun; fun inner_sort_of {T = (tvars, _), ...} = Type.sort_of_atyp (the_single tvars); fun mk_type {T, ...} = instantiate_poly_type T o single; fun mk_pure {pure, ...} = instantiate_poly_term pure o single; fun mk_ap {ap, ...} (T1, T2) = instantiate_poly_term ap [T1, T2]; fun mk_set {set, ...} = instantiate_poly_term set o single; fun lift_term af_inst t = Term.betapply (mk_pure af_inst (Term.fastype_of t), t); fun mk_comb af_inst funT (t1, t2) = Term.betapplys (mk_ap af_inst (dest_funT funT), [t1, t2]); fun dest_type ctxt {T, ...} = the_single o dest_poly_type ctxt T; val dest_type' = the_default HOLogic.unitT ooo dest_type; fun dest_pure ctxt {pure = (_, pure), ...} = the_single o dest_comb_pattern ctxt (pure, 1); fun dest_comb ctxt {ap = (_, ap), ...} = the_pair o dest_comb_pattern ctxt (ap, 2); fun infer_comb ctxt af_inst (t1, t2) = let val funT = the_default (dummyT --> dummyT) (dest_type ctxt af_inst (fastype_of t1)); in mk_comb af_inst funT (t1, t2) end; (*lift a term, except for non-combination subterms mapped by subst*) fun subst_lift_term af_inst subst tm = let fun subst_lift (s $ t) = (case (subst_lift s, subst_lift t) of (NONE, NONE) => NONE | (SOME s', NONE) => SOME (mk_comb af_inst (fastype_of s) (s', lift_term af_inst t)) | (NONE, SOME t') => SOME (mk_comb af_inst (fastype_of s) (lift_term af_inst s, t')) | (SOME s', SOME t') => SOME (mk_comb af_inst (fastype_of s) (s', t'))) | subst_lift t = AList.lookup (op aconv) subst t; in (case subst_lift tm of NONE => lift_term af_inst tm | SOME tm' => tm') end; fun add_lifted_vars (s $ t) = add_lifted_vars s #> add_lifted_vars t | add_lifted_vars (Abs (_, _, t)) = Term.add_vars t | add_lifted_vars _ = I; (*lift terms, where schematic variables are generalized to the functor and then fixed*) fun generalize_lift_terms af_inst ts ctxt = let val vars = subtract (op =) (fold add_lifted_vars ts []) (fold Term.add_vars ts []); val (var_names, Ts) = split_list vars; val (free_names, ctxt') = Variable.variant_fixes (map #1 var_names) ctxt; val Ts' = map (mk_type af_inst) Ts; val subst = map Var vars ~~ map Free (free_names ~~ Ts'); in (map (subst_lift_term af_inst subst) ts, ctxt') end; (** Reasoning with applicative functors **) (* Utilities *) val clean_name = perhaps (perhaps_apply [try Name.dest_skolem, try Name.dest_internal]); (*based on term_name from Pure/term.ML*) fun term_to_vname (Const (x, _)) = Long_Name.base_name x | term_to_vname (Free (x, _)) = clean_name x | term_to_vname (Var ((x, _), _)) = clean_name x | term_to_vname _ = "x"; fun afuns_of_rel precise ctxt t = let val (_, (lhs, rhs)) = Variable.focus NONE t ctxt |> #1 |> #2 |> Logic.strip_imp_concl |> Envir.beta_eta_contract |> HOLogic.dest_Trueprop |> strip_comb2; in if precise then (case afuns_of_term ctxt lhs of [] => afuns_of_term ctxt rhs | afs => afs) else afuns_of_typ ctxt (fastype_of lhs) end; fun AUTO_AFUNS precise tac ctxt opt_af = case opt_af of SOME af => tac [af] | NONE => SUBGOAL (fn (goal, i) => (case afuns_of_rel precise ctxt goal of [] => no_tac | afs => tac afs i) handle TERM _ => no_tac); fun AUTO_AFUN precise tac = AUTO_AFUNS precise (tac o hd); fun binop_par_conv cv ct = let val ((binop, arg1), arg2) = Thm.dest_comb ct |>> Thm.dest_comb; val (th1, th2) = cv (arg1, arg2); in Drule.binop_cong_rule binop th1 th2 end; fun binop_par_conv_tac cv = CONVERSION (HOLogic.Trueprop_conv (binop_par_conv cv)); val fold_goal_tac = SELECT_GOAL oo Raw_Simplifier.fold_goals_tac; (* Unfolding of lifted constants *) fun afun_unfold_tac ctxt af = Raw_Simplifier.rewrite_goal_tac ctxt (unfolds_of_afun af); fun afun_fold_tac ctxt af = fold_goal_tac ctxt (unfolds_of_afun af); fun unfold_all_tac ctxt = Raw_Simplifier.rewrite_goal_tac ctxt (all_unfolds_of ctxt); (* Basic conversions *) fun pure_conv ctxt {pure = (_, pure), ...} cv ct = let val ([var], (tyenv, env)) = match_comb_pattern ctxt (pure, 1) (Thm.term_of ct); val arg = the (Envir.lookup1 env var); val thm = cv (Thm.cterm_of ctxt arg); in if Thm.is_reflexive thm then Conv.all_conv ct else let val pure_inst = Envir.subst_term_types tyenv pure; in Drule.arg_cong_rule (Thm.cterm_of ctxt pure_inst) thm end end; fun ap_conv ctxt {ap = (_, ap), ...} cv1 cv2 ct = let val ([var1, var2], (tyenv, env)) = match_comb_pattern ctxt (ap, 2) (Thm.term_of ct); val (arg1, arg2) = apply2 (the o Envir.lookup1 env) (var1, var2); val thm1 = cv1 (Thm.cterm_of ctxt arg1); val thm2 = cv2 (Thm.cterm_of ctxt arg2); in if Thm.is_reflexive thm1 andalso Thm.is_reflexive thm2 then Conv.all_conv ct else let val ap_inst = Envir.subst_term_types tyenv ap; in Drule.binop_cong_rule (Thm.cterm_of ctxt ap_inst) thm1 thm2 end end; (* Normal form conversion *) (*convert a term into applicative normal form*) fun normalform_conv ctxt af ct = let val {hom, ichng, pure_comp_conv, ...} = thms_of_afun af; val the_red = the o red_of_afun af; val leaf_conv = Conv.rewr_conv (mk_meta_eq (the_red "I") |> Thm.symmetric); val merge_conv = Conv.rewr_conv (mk_meta_eq hom); val swap_conv = Conv.rewr_conv (mk_meta_eq ichng); val rotate_conv = Conv.rewr_conv (mk_meta_eq (the_red "B") |> Thm.symmetric); val pure_rotate_conv = Conv.rewr_conv (mk_meta_eq pure_comp_conv); val af_inst = match_afun_inst ctxt af (Thm.term_of ct, Thm.maxidx_of_cterm ct); fun left_conv cv = ap_conv ctxt af_inst cv Conv.all_conv; fun norm_pure_nf ct = ((pure_rotate_conv then_conv left_conv norm_pure_nf) else_conv merge_conv) ct; val norm_nf_pure = swap_conv then_conv norm_pure_nf; fun norm_nf_nf ct = ((rotate_conv then_conv left_conv (left_conv norm_pure_nf then_conv norm_nf_nf)) else_conv norm_nf_pure) ct; fun normalize ct = ((ap_conv ctxt af_inst normalize normalize then_conv norm_nf_nf) else_conv pure_conv ctxt af_inst Conv.all_conv else_conv leaf_conv) ct; in normalize ct end; val normalize_rel_tac = binop_par_conv_tac o apply2 oo normalform_conv; (* Bracket abstraction and generalized unlifting *) (*TODO: use proper conversions*) datatype apterm = Pure of term (*includes pure application*) | ApVar of int * term (*unique index, instantiated term*) | Ap of apterm * apterm; fun apterm_vars (Pure _) = I | apterm_vars (ApVar v) = cons v | apterm_vars (Ap (t1, t2)) = apterm_vars t1 #> apterm_vars t2; fun occurs_any _ (Pure _) = false | occurs_any vs (ApVar (i, _)) = exists (fn j => i = j) vs | occurs_any vs (Ap (t1, t2)) = occurs_any vs t1 orelse occurs_any vs t2; fun term_of_apterm ctxt af_inst t = let fun tm_of (Pure t) = t | tm_of (ApVar (_, t)) = t | tm_of (Ap (t1, t2)) = infer_comb ctxt af_inst (tm_of t1, tm_of t2); in tm_of t end; fun apterm_of_term ctxt af_inst t = let fun aptm_of t i = case try (dest_comb ctxt af_inst) t of SOME (t1, t2) => i |> aptm_of t1 ||>> aptm_of t2 |>> Ap | NONE => if can (dest_pure ctxt af_inst) t then (Pure t, i) else (ApVar (i, t), i + 1); in aptm_of t end; (*find a common variable sequence for two applicative terms, depending on available combinators*) fun consolidate ctxt af (t1, t2) = let fun common_inst (i, t) (j, insts) = case Termtab.lookup insts t of SOME k => (((i, t), k), (j, insts)) | NONE => (((i, t), j), (j + 1, Termtab.update (t, j) insts)); val (vars, _) = (0, Termtab.empty) |> fold_map common_inst (apterm_vars t1 []) ||>> fold_map common_inst (apterm_vars t2 []); fun merge_adjacent (([], _), _) [] = [] | merge_adjacent ((is, t), d) [] = [((is, t), d)] | merge_adjacent (([], _), _) (((i, t), d)::xs) = merge_adjacent (([i], t), d) xs | merge_adjacent ((is, t), d) (((i', t'), d')::xs) = if d = d' then merge_adjacent ((i'::is, t), d) xs else ((is, t), d) :: merge_adjacent (([i'], t'), d') xs; fun align _ [] = NONE | align ((i, t), d) (((i', t'), d')::xs) = if d = d' then SOME ([((i @ i', t), d)], xs) else Option.map (apfst (cons ((i', t'), d'))) (align ((i, t), d) xs); fun merge ([], ys) = ys | merge (xs, []) = xs | merge ((xs as ((is1, t1), d1)::xs'), ys as (((is2, t2), d2)::ys')) = if d1 = d2 then ((is1 @ is2, t1), d1) :: merge (xs', ys') else case (align ((is2, t2), d2) xs, align ((is1, t1), d1) ys) of (SOME (zs, xs''), NONE) => zs @ merge (xs'', ys') | (NONE, SOME (zs, ys'')) => zs @ merge (xs', ys'') | _ => ((is1, t1), d1) :: ((is2, t2), d2) :: merge (xs', ys'); fun unbalanced vs = error ("Unbalanced opaque terms " ^ commas_quote (map (Syntax.string_of_term ctxt o #2 o #1) vs)); fun mismatch (t1, t2) = error ("Mismatched opaque terms " ^ quote (Syntax.string_of_term ctxt t1) ^ " and " ^ quote (Syntax.string_of_term ctxt t2)); fun same ([], []) = [] | same ([], ys) = unbalanced ys | same (xs, []) = unbalanced xs | same ((((i1, t1), d1)::xs), (((i2, t2), d2)::ys)) = if d1 = d2 then ((i1 @ i2, t1), d1) :: same (xs, ys) else mismatch (t1, t2); in vars |> has_red_afun af "C" ? apply2 (sort (int_ord o apply2 #2)) |> apply2 (if has_red_afun af "W" then merge_adjacent (([], Term.dummy), 0) else map (apfst (apfst single))) |> (if has_red_afun af "K" then merge else same) |> map #1 end; fun ap_cong ctxt af_inst thm1 thm2 = let val funT = the_default (dummyT --> dummyT) (dest_type ctxt af_inst (Thm.typ_of_cterm (Thm.lhs_of thm1))); val ap_inst = Thm.cterm_of ctxt (mk_ap af_inst (dest_funT funT)); in Drule.binop_cong_rule ap_inst thm1 thm2 end; fun rewr_subst_ap ctxt af_inst rewr thm1 thm2 = let val rule1 = ap_cong ctxt af_inst thm1 thm2; val rule2 = Conv.rewr_conv rewr (Thm.rhs_of rule1); in Thm.transitive rule1 rule2 end; fun merge_pures ctxt af_inst merge_thm tt = let fun merge (Pure t) = SOME (Thm.reflexive (Thm.cterm_of ctxt t)) | merge (ApVar _) = NONE | merge (Ap (tt1, tt2)) = case merge tt1 of NONE => NONE | SOME thm1 => case merge tt2 of NONE => NONE | SOME thm2 => SOME (rewr_subst_ap ctxt af_inst merge_thm thm1 thm2); in merge tt end; exception ASSERT of string; (*abstract over a variable (opaque subterm)*) fun eliminate ctxt (af, af_inst) tt (v, v_tm) = let val {hom, ichng, ...} = thms_of_afun af; val the_red = the o red_of_afun af; val hom_conv = mk_meta_eq hom; val ichng_conv = mk_meta_eq ichng; val mk_combI = Thm.symmetric o mk_meta_eq; val id_conv = mk_combI (the_red "I"); val comp_conv = mk_combI (the_red "B"); val flip_conv = Option.map mk_combI (red_of_afun af "C"); val const_conv = Option.map mk_combI (red_of_afun af "K"); val dup_conv = Option.map mk_combI (red_of_afun af "W"); val rewr_subst_ap = rewr_subst_ap ctxt af_inst; fun extract_comb n thm = Pure (thm |> Thm.rhs_of |> funpow n Thm.dest_arg1 |> Thm.term_of); fun refl_step tt = (tt, Thm.reflexive (Thm.cterm_of ctxt (term_of_apterm ctxt af_inst tt))); fun comb2_step def (tt1, thm1) (tt2, thm2) = let val thm = rewr_subst_ap def thm1 thm2; in (Ap (Ap (extract_comb 3 thm, tt1), tt2), thm) end; val B_step = comb2_step comp_conv; fun swap_B_step (tt1, thm1) thm2 = let val thm3 = rewr_subst_ap ichng_conv thm1 thm2; val thm4 = Thm.transitive thm3 (Conv.rewr_conv comp_conv (Thm.rhs_of thm3)); in (Ap (Ap (extract_comb 3 thm4, extract_comb 1 thm3), tt1), thm4) end; fun I_step tm = let val thm = Conv.rewr_conv id_conv (Thm.cterm_of ctxt tm) in (extract_comb 1 thm, thm) end; fun W_step s1 s2 = let val (Ap (Ap (tt1, tt2), tt3), thm1) = B_step s1 s2; val thm2 = Conv.rewr_conv comp_conv (Thm.rhs_of thm1 |> funpow 2 Thm.dest_arg1); val thm3 = merge_pures ctxt af_inst hom_conv tt3 |> the; val (tt4, thm4) = swap_B_step (Ap (Ap (extract_comb 3 thm2, tt1), tt2), thm2) thm3; val var = Thm.rhs_of thm1 |> Thm.dest_arg; val thm5 = rewr_subst_ap (the dup_conv) thm4 (Thm.reflexive var); val thm6 = Thm.transitive thm1 thm5; in (Ap (extract_comb 2 thm6, tt4), thm6) end; fun S_step s1 s2 = let val (Ap (Ap (tt1, tt2), tt3), thm1) = comb2_step (the flip_conv) s1 s2; val thm2 = Conv.rewr_conv comp_conv (Thm.rhs_of thm1 |> Thm.dest_arg1); val var = Thm.rhs_of thm1 |> Thm.dest_arg; val thm3 = rewr_subst_ap (the dup_conv) thm2 (Thm.reflexive var); val thm4 = Thm.transitive thm1 thm3; val tt = Ap (extract_comb 2 thm4, Ap (Ap (extract_comb 3 thm2, Ap (tt1, tt2)), tt3)); in (tt, thm4) end; fun K_step tt tm = let val ct = Thm.cterm_of ctxt tm; val T_opt = Term.fastype_of tm |> dest_type ctxt af_inst |> Option.map (Thm.ctyp_of ctxt); val thm = Thm.instantiate' [T_opt] [SOME ct] (Conv.rewr_conv (the const_conv) (term_of_apterm ctxt af_inst tt |> Thm.cterm_of ctxt)) in (Ap (extract_comb 2 thm, tt), thm) end; fun unreachable _ = raise ASSERT "eliminate: assertion failed"; fun elim (Pure _) = unreachable () | elim (ApVar (i, t)) = if exists (fn x => x = i) v then I_step t else unreachable () | elim (Ap (t1, t2)) = (case (occurs_any v t1, occurs_any v t2) of (false, false) => unreachable () | (false, true) => B_step (refl_step t1) (elim t2) | (true, false) => (case merge_pures ctxt af_inst hom_conv t2 of SOME thm => swap_B_step (elim t1) thm | NONE => comb2_step (the flip_conv) (elim t1) (refl_step t2)) | (true, true) => if is_some flip_conv then S_step (elim t1) (elim t2) else W_step (elim t1) (elim t2)); in if occurs_any v tt then elim tt else K_step tt v_tm end; (*convert a pair of terms into equal canonical forms, modulo pure terms*) fun general_normalform_conv ctxt af cts = let val (t1, t2) = apply2 (Thm.term_of) cts; val maxidx = Int.max (apply2 Thm.maxidx_of_cterm cts); (* TODO: is there a better strategy for finding the instantiated functor? *) val af_inst = match_afun_inst ctxt af (t1, maxidx); val ((apt1, apt2), _) = 0 |> apterm_of_term ctxt af_inst t1 ||>> apterm_of_term ctxt af_inst t2; val vs = consolidate ctxt af (apt1, apt2); val merge_thm = mk_meta_eq (#hom (thms_of_afun af)); fun elim_all tt [] = the (merge_pures ctxt af_inst merge_thm tt) | elim_all tt (v::vs) = let val (tt', rule1) = eliminate ctxt (af, af_inst) tt v; val rule2 = elim_all tt' vs; val (_, vartm) = dest_comb ctxt af_inst (Thm.term_of (Thm.rhs_of rule1)); val rule3 = ap_cong ctxt af_inst rule2 (Thm.reflexive (Thm.cterm_of ctxt vartm)); in Thm.transitive rule1 rule3 end; in (elim_all apt1 vs, elim_all apt2 vs) end; val general_normalize_rel_tac = binop_par_conv_tac oo general_normalform_conv; (* Reduce canonical forms to base relation *) fun rename_params names i st = let val (_, Bs, Bi, C) = Thm.dest_state (st, i); val Bi' = Logic.list_rename_params names Bi; in Thm.renamed_prop (Logic.list_implies (Bs @ [Bi'], C)) st end; (* R' (pure f <> x1 <> ... <> xn) (pure g <> x1 <> ... <> xn) ===> !!y1 ... yn. [| yi : setF xi ... |] ==> R (f y1 ... yn) (g y1 ... yn), where either both R and R' are equality, or R' = relF R for relator relF of the functor. The premises yi : setF xi are added only in the latter case and if the set operator is available. Succeeds if partial progress can be made. The names of the new parameters yi are derived from the arguments xi. *) fun head_cong_tac ctxt af renames = let val {rel_intros, ...} = thms_of_afun af; fun term_name tm = case AList.lookup (op aconv) renames tm of SOME n => n | NONE => term_to_vname tm; fun gather_vars' af_inst tm = case try (dest_comb ctxt af_inst) tm of SOME (t1, t2) => term_name t2 :: gather_vars' af_inst t1 | NONE => []; fun gather_vars prop = case prop of Const (@{const_name Trueprop}, _) $ (_ $ rhs) => rev (gather_vars' (match_afun_inst ctxt af (rhs, maxidx_of_term prop)) rhs) | _ => []; in SUBGOAL (fn (subgoal, i) => (REPEAT_DETERM (resolve_tac ctxt rel_intros i) THEN REPEAT_DETERM (resolve_tac ctxt [ext, @{thm rel_fun_eq_onI}] i ORELSE eresolve_tac ctxt [@{thm UNIV_E}] i) THEN PRIMITIVE (rename_params (gather_vars subgoal) i))) end; (* Forward lifting *) (* TODO: add limited support for premises, where used variables are not generalized in the conclusion *) fun forward_lift_rule ctxt af thm = let val thm = Object_Logic.rulify ctxt thm; val (af_inst, ctxt_inst) = import_afun_inst af ctxt; val (prop, ctxt_Ts) = yield_singleton Variable.importT_terms (Thm.prop_of thm) ctxt_inst; val (lhs, rhs) = prop |> HOLogic.dest_Trueprop |> HOLogic.dest_eq; val ([lhs', rhs'], ctxt_lifted) = generalize_lift_terms af_inst [lhs, rhs] ctxt_Ts; val lifted = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs', rhs')); val (lifted', ctxt') = yield_singleton (Variable.import_terms true) lifted ctxt_lifted; fun tac {prems, context} = HEADGOAL (general_normalize_rel_tac context af THEN' head_cong_tac context af [] THEN' resolve_tac context [prems MRS thm]); val thm' = singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] lifted' tac); val thm'' = Raw_Simplifier.fold_rule ctxt (unfolds_of_afun af) thm'; in thm'' end; fun forward_lift_attrib name = Thm.rule_attribute [] (fn context => fn thm => let val af = afun_of_generic context (intern context name) (* FIXME !?!? *) in forward_lift_rule (Context.proof_of context) af thm end); (* High-level tactics *) fun unfold_wrapper_tac ctxt = AUTO_AFUNS false (fn afs => Simplifier.safe_asm_full_simp_tac (ctxt addsimps flat (map unfolds_of_afun afs))) ctxt; fun fold_wrapper_tac ctxt = AUTO_AFUN true (fold_goal_tac ctxt o unfolds_of_afun) ctxt; fun WRAPPER tac ctxt opt_af = REPEAT_DETERM o resolve_tac ctxt [@{thm allI}] THEN' Subgoal.FOCUS (fn {context = ctxt, params, ...} => let val renames = map (swap o apsnd Thm.term_of) params in AUTO_AFUNS false (EVERY' o map (afun_unfold_tac ctxt)) ctxt opt_af 1 THEN AUTO_AFUN true (fn af => afun_unfold_tac ctxt af THEN' CONVERSION Drule.beta_eta_conversion THEN' tac ctxt af THEN' head_cong_tac ctxt af renames) ctxt opt_af 1 end) ctxt THEN' Raw_Simplifier.rewrite_goal_tac ctxt [Drule.triv_forall_equality]; val normalize_wrapper_tac = WRAPPER normalize_rel_tac; val lifting_wrapper_tac = WRAPPER general_normalize_rel_tac; val parse_opt_afun = Scan.peek (fn context => Scan.option Parse.name >> Option.map (intern context #> afun_of_generic context)); (** Declaration **) (* Combinator setup *) fun declare_combinators combs phi = let val (names, thms) = split_list combs; val thms' = map (Morphism.thm phi) thms; fun add_combs (defs, rules) = (fold (Symtab.insert (K false)) (names ~~ thms') defs, rules); in Data.map (map_data add_combs I I) end; val setup_combinators = Local_Theory.declaration {syntax = false, pervasive = false} o declare_combinators; fun combinator_of_red thm = let val (lhs, _) = Logic.dest_equals (Thm.prop_of thm); val (head, _) = strip_comb lhs; in #1 (dest_Const head) end; fun register_combinator_rule weak_premises thm context = let val (lhs, rhs) = Logic.dest_equals (Thm.prop_of thm); val ltvars = Term.add_tvars lhs []; val rtvars = Term.add_tvars rhs []; val _ = if exists (not o member op = ltvars) rtvars then Pretty.breaks [Pretty.str "Combinator equation", Pretty.quote (Syntax.pretty_term (Context.proof_of context) (Thm.prop_of thm)), Pretty.str "has additional type variables on right-hand side."] |> Pretty.block |> Pretty.string_of |> error else (); val (defs, _) = #combinators (Data.get context); val comb_names = Symtab.make (map (fn (name, thm) => (combinator_of_red thm, name)) (Symtab.dest defs)); val rule = mk_combinator_rule comb_names weak_premises thm; fun add_rule (defs, rules) = (defs, insert eq_combinator_rule rule rules); in Data.map (map_data add_rule I I) context end; val combinator_rule_attrib = Thm.declaration_attribute o register_combinator_rule; (* Derivation of combinator reductions *) fun combinator_closure rules have_weak combs = let fun apply rule (cs, changed) = if not (Ord_List.member fast_string_ord cs (conclusion_of_rule rule)) andalso is_applicable_rule rule have_weak (fn prems => Ord_List.subset fast_string_ord (prems, cs)) then (Ord_List.insert fast_string_ord (conclusion_of_rule rule) cs, true) else (cs, changed); fun loop cs = (case fold apply rules (cs, false) of (cs', true) => loop cs' | (_, false) => cs); in loop combs end; fun derive_combinator_red ctxt af_inst red_thms (base_thm, eq_thm) = let val base_prop = Thm.prop_of base_thm; val tvars = Term.add_tvars base_prop []; val (Ts, ctxt_Ts) = mk_TFrees_of (length tvars) (inner_sort_of af_inst) ctxt; val base_prop' = base_prop |> Term_Subst.instantiate (TVars.make (tvars ~~ Ts), Vars.empty); val (lhs, rhs) = Logic.dest_equals base_prop'; val ([lhs', rhs'], ctxt') = generalize_lift_terms af_inst [lhs, rhs] ctxt_Ts; val lifted_prop = (lhs', rhs') |> HOLogic.mk_eq |> HOLogic.mk_Trueprop; val unfold_comb_conv = HOLogic.Trueprop_conv (HOLogic.eq_conv (Conv.top_sweep_rewrs_conv [eq_thm] ctxt') Conv.all_conv); fun tac goal_ctxt = HEADGOAL (CONVERSION unfold_comb_conv THEN' Raw_Simplifier.rewrite_goal_tac goal_ctxt red_thms THEN' resolve_tac goal_ctxt [@{thm refl}]); in singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] lifted_prop (tac o #context)) end; (*derive all instantiations with pure terms which can be simplified by homomorphism*) (*FIXME: more of a workaround than a sensible solution*) fun weak_red_closure ctxt (af_inst, merge_thm) strong_red = let val (lhs, _) = Thm.prop_of strong_red |> Logic.dest_equals; val vars = rev (Term.add_vars lhs []); fun closure [] prev thms = (prev::thms) | closure ((v, af_T)::vs) prev thms = (case try (dest_type ctxt af_inst) af_T of NONE => closure vs prev thms | SOME T_opt => let val (T, ctxt') = (case T_opt of NONE => yield_singleton Variable.invent_types (inner_sort_of af_inst) ctxt |>> TFree | SOME T => (T, ctxt)); val (v', ctxt'') = mk_Free (#1 v) T ctxt'; val pure_v = Thm.cterm_of ctxt'' (lift_term af_inst v'); val next = Drule.instantiate_normalize (TVars.empty, Vars.make [((v, af_T), pure_v)]) prev; val next' = Raw_Simplifier.rewrite_rule ctxt'' [merge_thm] next; val next'' = singleton (Variable.export ctxt'' ctxt) next'; in closure vs next'' (prev::thms) end); in closure vars strong_red [] end; fun combinator_red_closure ctxt (comb_defs, rules) (af_inst, merge_thm) weak_reds combs = let val have_weak = not (null weak_reds); val red_thms0 = Symtab.fold (fn (_, thm) => cons (mk_meta_eq thm)) combs weak_reds; val red_thms = flat (map (weak_red_closure ctxt (af_inst, merge_thm)) red_thms0); fun apply rule ((cs, rs), changed) = if not (Symtab.defined cs (conclusion_of_rule rule)) andalso is_applicable_rule rule have_weak (forall (Symtab.defined cs)) then let val conclusion = conclusion_of_rule rule; val def = the (Symtab.lookup comb_defs conclusion); val new_red_thm = derive_combinator_red ctxt af_inst rs (def, thm_of_rule rule); val new_red_thms = weak_red_closure ctxt (af_inst, merge_thm) (mk_meta_eq new_red_thm); in ((Symtab.update (conclusion, new_red_thm) cs, new_red_thms @ rs), true) end else ((cs, rs), changed); fun loop xs = (case fold apply rules (xs, false) of (xs', true) => loop xs' | (_, false) => xs); in #1 (loop (combs, red_thms)) end; (* Preparation of AFun data *) fun mk_terms ctxt (raw_pure, raw_ap, raw_rel, raw_set) = let val thy = Proof_Context.theory_of ctxt; val show_typ = quote o Syntax.string_of_typ ctxt; val show_term = quote o Syntax.string_of_term ctxt; fun closed_poly_term t = let val poly_t = singleton (Variable.polymorphic ctxt) t; in case Term.add_vars (singleton (Variable.export_terms (Proof_Context.augment t ctxt) ctxt) t) [] of [] => (case (Term.hidden_polymorphism poly_t) of [] => poly_t | _ => error ("Hidden type variables in term " ^ show_term t)) | _ => error ("Locally free variables in term " ^ show_term t) end; val pure = closed_poly_term raw_pure; val (tvar, T1) = fastype_of pure |> dest_funT |>> dest_TVar handle TYPE _ => error ("Bad type for pure: " ^ show_typ (fastype_of pure)); val maxidx_pure = maxidx_of_term pure; val ap = Logic.incr_indexes ([], [], maxidx_pure + 1) (closed_poly_term raw_ap); fun bad_ap _ = error ("Bad type for ap: " ^ show_typ (fastype_of ap)); val (T23, (T2, T3)) = fastype_of ap |> dest_funT ||> dest_funT handle TYPE _ => bad_ap (); val maxidx_common = Term.maxidx_term ap maxidx_pure; (*unify type variables, while keeping the live variables separate*) fun no_unifier (T, U) = error ("Unable to infer common functor type from " ^ commas (map show_typ [T, U])); fun unify_ap_type T (tyenv, maxidx) = let val argT = TVar ((Name.aT, maxidx + 1), []); val T1' = Term_Subst.instantiateT (TVars.make [(tvar, argT)]) T1; val (tyenv', maxidx') = Sign.typ_unify thy (T1', T) (tyenv, maxidx + 1) handle Type.TUNIFY => no_unifier (T1', T); in (argT, (tyenv', maxidx')) end; val (ap_args, (ap_env, maxidx_env)) = fold_map unify_ap_type [T2, T3, T23] (Vartab.empty, maxidx_common); val [T2_arg, T3_arg, T23_arg] = map (Envir.norm_type ap_env) ap_args; val (tvar2, tvar3) = (dest_TVar T2_arg, dest_TVar T3_arg) handle TYPE _ => bad_ap (); val _ = if T23_arg = T2_arg --> T3_arg then () else bad_ap (); val sort = foldl1 (Sign.inter_sort thy) (map #2 [tvar, tvar2, tvar3]); val _ = Sign.of_sort thy (Term.aT sort --> Term.aT sort, sort) orelse error ("Sort constraint " ^ quote (Syntax.string_of_sort ctxt sort) ^ " not closed under function types"); fun update_sort (v, S) (tyenv, maxidx) = (Vartab.update_new (v, (S, TVar ((Name.aT, maxidx + 1), sort))) tyenv, maxidx + 1); val (common_env, _) = fold update_sort [tvar, tvar2, tvar3] (ap_env, maxidx_env); val tvar' = Envir.norm_type common_env (TVar tvar); val pure' = norm_term_types common_env pure; val (tvar2', tvar3') = apply2 (Envir.norm_type common_env) (T2_arg, T3_arg); val ap' = norm_term_types common_env ap; fun bad_set set = error ("Bad type for set: " ^ show_typ (fastype_of set)); fun mk_set set = let val tyenv = Sign.typ_match thy (domain_type (fastype_of set), range_type (fastype_of pure')) Vartab.empty handle Type.TYPE_MATCH => bad_set set; val set' = Envir.subst_term_types tyenv set; val set_tvar = fastype_of set' |> range_type |> HOLogic.dest_setT |> dest_TVar handle TYPE _ => bad_set set; val _ = if Term.eq_tvar (dest_TVar tvar', set_tvar) then () else bad_set set; in ([tvar'], set') end val set = (case raw_set of NONE => ([tvar'], Abs ("x", tvar', HOLogic.mk_UNIV tvar')) | SOME t => mk_set (closed_poly_term t)); val terms = Term_Subst.zero_var_indexes (pack_poly_terms [poly_type_to_term ([tvar'], range_type (fastype_of pure')), ([tvar'], pure'), ([tvar2', tvar3'], ap'), set]); (*TODO: also infer the relator type?*) fun bad_rel rel = error ("Bad type for rel: " ^ show_typ (fastype_of rel)); fun mk_rel rel = let val ((T1, T2), (T1_af, T2_af)) = fastype_of rel |> dest_funT |>> BNF_Util.dest_pred2T ||> BNF_Util.dest_pred2T; val _ = (dest_TVar T1; dest_TVar T2); val _ = if T1 = T2 then bad_rel rel else (); val af_inst = mk_afun_inst (match_poly_terms_type ctxt (terms, 0) (T1_af, maxidx_of_term rel)); val (T1', T2') = apply2 (dest_type ctxt af_inst) (T1_af, T2_af); val _ = if (is_none T1' andalso is_none T2') orelse (T1' = SOME T1 andalso T2' = SOME T2) then () else bad_rel rel; in Term_Subst.zero_var_indexes (pack_poly_terms [([T1, T2], rel)]) end handle TYPE _ => bad_rel rel; val rel = Option.map (mk_rel o closed_poly_term) raw_rel; in (terms, rel) end; fun mk_rel_intros {pure_transfer, ap_rel_fun} = let val pure_rel_intro = pure_transfer RS @{thm rel_funD}; in [pure_rel_intro, ap_rel_fun] end; fun mk_afun_thms ctxt af_inst (hom_thm, ichng_thm, reds, rel_axioms) = let val pure_comp_conv = let val ([T1, T2, T3], ctxt_Ts) = mk_TFrees_of 3 (inner_sort_of af_inst) ctxt; val (((g, f), x), ctxt') = ctxt_Ts |> mk_Free "g" (T2 --> T3) ||>> mk_Free "f" (mk_type af_inst (T1 --> T2)) ||>> mk_Free "x" (mk_type af_inst T1); val comb = mk_comb af_inst; val lhs = comb (T2 --> T3) (lift_term af_inst g, comb (T1 --> T2) (f, x)); val B_g = Abs ("f", T1 --> T2, Abs ("x", T1, Term.betapply (g, Bound 1 $ Bound 0))); val rhs = comb (T1 --> T3) (comb ((T1 --> T2) --> T1 --> T3) (lift_term af_inst B_g, f), x); val prop = HOLogic.mk_eq (lhs, rhs) |> HOLogic.mk_Trueprop; val merge_rule = mk_meta_eq hom_thm; val B_intro = the (Symtab.lookup reds "B") |> mk_meta_eq |> Thm.symmetric; fun tac goal_ctxt = HEADGOAL (Raw_Simplifier.rewrite_goal_tac goal_ctxt [B_intro, merge_rule] THEN' resolve_tac goal_ctxt [@{thm refl}]); in singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] prop (tac o #context)) end; val eq_intros = let val ([T1, T2], ctxt_Ts) = mk_TFrees_of 2 (inner_sort_of af_inst) ctxt; val T12 = mk_type af_inst (T1 --> T2); val (((((x, y), x'), f), g), ctxt') = ctxt_Ts |> mk_Free "x" T1 ||>> mk_Free "y" T1 ||>> mk_Free "x" (mk_type af_inst T1) ||>> mk_Free "f" T12 ||>> mk_Free "g" T12; val pure_fun = mk_pure af_inst T1; val pure_cong = Drule.infer_instantiate' ctxt' (map (SOME o Thm.cterm_of ctxt') [x, y, pure_fun]) @{thm arg_cong}; val ap_fun = mk_ap af_inst (T1, T2); val ap_cong1 = Drule.infer_instantiate' ctxt' (map (SOME o Thm.cterm_of ctxt') [f, g, ap_fun, x']) @{thm arg1_cong}; in Variable.export ctxt' ctxt [pure_cong, ap_cong1] end; val rel_intros = case rel_axioms of NONE => [] | SOME axioms => mk_rel_intros axioms; in {hom = hom_thm, ichng = ichng_thm, reds = reds, rel_thms = rel_axioms, rel_intros = eq_intros @ rel_intros, pure_comp_conv = pure_comp_conv} end; fun reuse_TFrees n S (ctxt, Ts) = let val have_n = Int.min (n, length Ts); val (more_Ts, ctxt') = mk_TFrees_of (n - have_n) S ctxt; in (take have_n Ts @ more_Ts, (ctxt', Ts @ more_Ts)) end; fun mk_comb_prop lift_pos thm af_inst ctxt_Ts = let val base = Thm.prop_of thm; val tvars = Term.add_tvars base []; val (Ts, (ctxt', Ts')) = reuse_TFrees (length tvars) (inner_sort_of af_inst) ctxt_Ts; val base' = base |> Term_Subst.instantiate (TVars.make (tvars ~~ Ts), Vars.empty); val (lhs, rhs) = Logic.dest_equals base'; val (_, lhs_args) = strip_comb lhs; val lift_var = Var o apsnd (mk_type af_inst) o dest_Var; val (lhs_args', subst) = fold_index (fn (i, v) => if member (op =) lift_pos i then apfst (cons v) else map_prod (cons (lift_var v)) (cons (v, lift_var v))) lhs_args ([], []); val (lhs', rhs') = apply2 (subst_lift_term af_inst subst) (lhs, rhs); val lifted = (lhs', rhs') |> HOLogic.mk_eq |> HOLogic.mk_Trueprop; in (fold Logic.all lhs_args' lifted, (ctxt', Ts')) end; fun mk_homomorphism_prop af_inst ctxt_Ts = let val ([T1, T2], (ctxt', Ts')) = reuse_TFrees 2 (inner_sort_of af_inst) ctxt_Ts; val ((f, x), _) = ctxt' |> mk_Free "f" (T1 --> T2) ||>> mk_Free "x" T1; val lhs = mk_comb af_inst (T1 --> T2) (lift_term af_inst f, lift_term af_inst x); val rhs = lift_term af_inst (f $ x); val prop = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)); in (Logic.all f (Logic.all x prop), (ctxt', Ts')) end; fun mk_interchange_prop af_inst ctxt_Ts = let val ([T1, T2], (ctxt', Ts')) = reuse_TFrees 2 (inner_sort_of af_inst) ctxt_Ts; val ((f, x), _) = ctxt' |> mk_Free "f" (mk_type af_inst (T1 --> T2)) ||>> mk_Free "x" T1; val lhs = mk_comb af_inst (T1 --> T2) (f, lift_term af_inst x); val T_x = Abs ("f", T1 --> T2, Bound 0 $ x); val rhs = mk_comb af_inst ((T1 --> T2) --> T2) (lift_term af_inst T_x, f); val prop = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)); in (Logic.all f (Logic.all x prop), (ctxt', Ts')) end; fun mk_rel_props (af_inst, rel_inst) ctxt_Ts = let fun mk_af_rel tm = let val (T1, T2) = BNF_Util.dest_pred2T (fastype_of tm); in betapply (instantiate_poly_term rel_inst [T1, T2], tm) end; val ([T1, T2, T3], (ctxt', Ts')) = reuse_TFrees 3 (inner_sort_of af_inst) ctxt_Ts; val (pure_R, _) = mk_Free "R" (T1 --> T2 --> @{typ bool}) ctxt'; val rel_pure = BNF_Util.mk_rel_fun pure_R (mk_af_rel pure_R) $ mk_pure af_inst T1 $ mk_pure af_inst T2; val pure_prop = Logic.all pure_R (HOLogic.mk_Trueprop rel_pure); val ((((f, g), x), ap_R), _) = ctxt' |> mk_Free "f" (mk_type af_inst (T1 --> T2)) ||>> mk_Free "g" (mk_type af_inst (T1 --> T3)) ||>> mk_Free "x" (mk_type af_inst T1) ||>> mk_Free "R" (T2 --> T3 --> @{typ bool}); val fun_rel = BNF_Util.mk_rel_fun (mk_eq_on (mk_set af_inst T1 $ x)) ap_R; val rel_ap = Logic.mk_implies (HOLogic.mk_Trueprop (mk_af_rel fun_rel $ f $ g), HOLogic.mk_Trueprop (mk_af_rel ap_R $ mk_comb af_inst (T1 --> T2) (f, x) $ mk_comb af_inst (T1 --> T3) (g, x))); val ap_prop = fold_rev Logic.all [ap_R, f, g, x] rel_ap; in ([pure_prop, ap_prop], (ctxt', Ts')) end; fun mk_interchange ctxt ((comb_defs, _), comb_unfolds) (af_inst, merge_thm) reds = let val T_def = the (Symtab.lookup comb_defs "T"); val T_red = the (Symtab.lookup reds "T"); val (weak_prop, (ctxt', _)) = mk_comb_prop [0] T_def af_inst (ctxt, []); fun tac goal_ctxt = HEADGOAL (Raw_Simplifier.rewrite_goal_tac goal_ctxt [Thm.symmetric merge_thm] THEN' resolve_tac goal_ctxt [T_red]); val weak_red = singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] weak_prop (tac o #context)); in Raw_Simplifier.rewrite_rule ctxt (comb_unfolds) weak_red RS sym end; fun mk_weak_reds ctxt ((comb_defs, _), comb_unfolds) af_inst (hom_thm, ichng_thm, reds) = let val unfolded_reds = Symtab.map (K (Raw_Simplifier.rewrite_rule ctxt comb_unfolds)) reds; val af_thms = mk_afun_thms ctxt af_inst (hom_thm, ichng_thm, unfolded_reds, NONE); val af = mk_afun Binding.empty (pack_afun_inst af_inst) NONE af_thms; fun tac goal_ctxt = HEADGOAL (normalize_wrapper_tac goal_ctxt (SOME af) THEN' Raw_Simplifier.rewrite_goal_tac goal_ctxt comb_unfolds THEN' resolve_tac goal_ctxt [refl]); fun mk comb lift_pos = let val def = the (Symtab.lookup comb_defs comb); val (prop, (ctxt', _)) = mk_comb_prop lift_pos def af_inst (ctxt, []); val hol_thm = singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] prop (tac o #context)); in mk_meta_eq hol_thm end; val uncurry_thm = mk_meta_eq (forward_lift_rule ctxt af @{thm uncurry_pair}); in [mk "C" [1], mk "C" [2], uncurry_thm] end; fun mk_comb_reds ctxt combss af_inst user_combs (hom_thm, user_thms, ichng_thms) = let val ((comb_defs, comb_rules), comb_unfolds) = combss; val merge_thm = mk_meta_eq hom_thm; val user_reds = Symtab.make (user_combs ~~ user_thms); val reds0 = combinator_red_closure ctxt (comb_defs, comb_rules) (af_inst, merge_thm) [] user_reds; val ichng_thm = case ichng_thms of [] => singleton (Variable.export ctxt ctxt) (mk_interchange ctxt combss (af_inst, merge_thm) reds0) | [thm] => thm; val weak_reds = mk_weak_reds ctxt combss af_inst (hom_thm, ichng_thm, reds0); val reds1 = combinator_red_closure ctxt (comb_defs, comb_rules) (af_inst, merge_thm) weak_reds reds0; val unfold = Raw_Simplifier.rewrite_rule ctxt comb_unfolds; in (Symtab.map (K unfold) reds1, ichng_thm) end; fun note_afun_thms af = let val thms = thms_of_afun af; val named_thms = [("homomorphism", [#hom thms]), ("interchange", [#ichng thms]), ("afun_rel_intros", #rel_intros thms)] @ map (fn (name, thm) => ("pure_" ^ name ^ "_conv", [thm])) (Symtab.dest (#reds thms)) @ (case #rel_thms thms of NONE => [] | SOME rel_thms' => [("pure_transfer", [#pure_transfer rel_thms']), ("ap_rel_fun_cong", [#ap_rel_fun rel_thms'])]); val base_name = Binding.name_of (name_of_afun af); fun mk_note (name, thms) = ((Binding.qualify true base_name (Binding.name name), []), [(thms, [])]); in Local_Theory.notes (map mk_note named_thms) #> #2 end; fun register_afun af = let fun decl phi context = Data.map (fn {combinators, afuns, patterns} => let val af' = morph_afun phi af; val (name, afuns') = Name_Space.define context true (name_of_afun af', af') afuns; val patterns' = Item_Net.update (name, patterns_of_afun af') patterns; in {combinators = combinators, afuns = afuns', patterns = patterns'} end) context; in Local_Theory.declaration {syntax = false, pervasive = false} decl end; fun applicative_cmd (((((name, flags), raw_pure), raw_ap), raw_rel), raw_set) lthy = let val comb_unfolds = Named_Theorems.get lthy @{named_theorems combinator_unfold}; val comb_reprs = Named_Theorems.get lthy @{named_theorems combinator_repr}; val (comb_defs, comb_rules) = get_combinators (Context.Proof lthy); val _ = fold (fn name => if Symtab.defined comb_defs name then I else error ("Unknown combinator " ^ quote name)) flags (); val _ = if has_duplicates op = flags then warning "Ignoring duplicate combinators" else (); val user_combs0 = Ord_List.make fast_string_ord flags; val raw_pure' = Syntax.read_term lthy raw_pure; val raw_ap' = Syntax.read_term lthy raw_ap; val raw_rel' = Option.map (Syntax.read_term lthy) raw_rel; val raw_set' = Option.map (Syntax.read_term lthy) raw_set; val (terms, rel) = mk_terms lthy (raw_pure', raw_ap', raw_rel', raw_set'); val derived_combs0 = combinator_closure comb_rules false user_combs0; val required_combs = Ord_List.make fast_string_ord ["B", "I"]; val user_combs = Ord_List.union fast_string_ord user_combs0 (Ord_List.subtract fast_string_ord derived_combs0 required_combs); val derived_combs1 = combinator_closure comb_rules false user_combs; val derived_combs2 = combinator_closure comb_rules true derived_combs1; fun is_redundant comb = eq_list (op =) (derived_combs2, (combinator_closure comb_rules true (Ord_List.remove fast_string_ord comb user_combs))); val redundant_combs = filter is_redundant user_combs; val _ = if null redundant_combs then () else warning ("Redundant combinators: " ^ commas redundant_combs); val prove_interchange = not (Ord_List.member fast_string_ord derived_combs1 "T"); val (af_inst, ctxt_af) = import_afun_inst_raw terms lthy; (* TODO: reuse TFrees from above *) val (rel_insts, ctxt_inst) = (case rel of NONE => (NONE, ctxt_af) | SOME r => let val (rel_inst, ctxt') = import_poly_terms r ctxt_af |>> the_single; val T = fastype_of (#2 rel_inst) |> range_type |> domain_type; val af_inst = match_poly_terms_type ctxt' (terms, 0) (T, ~1) |> mk_afun_inst; in (SOME (af_inst, rel_inst), ctxt') end); val mk_propss = [apfst single o mk_homomorphism_prop af_inst, fold_map (fn comb => mk_comb_prop [] (the (Symtab.lookup comb_defs comb)) af_inst) user_combs, if prove_interchange then apfst single o mk_interchange_prop af_inst else pair [], if is_some rel then mk_rel_props (the rel_insts) else pair []]; val (propss, (ctxt_Ts, _)) = fold_map I mk_propss (ctxt_inst, []); fun repr_tac ctxt = Raw_Simplifier.rewrite_goals_tac ctxt comb_reprs; fun after_qed thmss lthy' = let val [[hom_thm], user_thms, ichng_thms, rel_thms] = map (Variable.export lthy' ctxt_inst) thmss; val (reds, ichng_thm) = mk_comb_reds ctxt_inst ((comb_defs, comb_rules), comb_unfolds) af_inst user_combs (hom_thm, user_thms, ichng_thms); val rel_axioms = case rel_thms of [] => NONE | [thm1, thm2] => SOME {pure_transfer = thm1, ap_rel_fun = thm2}; val af_thms = mk_afun_thms ctxt_inst af_inst (hom_thm, ichng_thm, reds, rel_axioms); val af_thms = map_afun_thms (singleton (Variable.export ctxt_inst lthy)) af_thms; val af = mk_afun name terms rel af_thms; in lthy |> register_afun af |> note_afun_thms af end; in Proof.theorem NONE after_qed ((map o map) (rpair []) propss) ctxt_Ts |> Proof.refine (Method.Basic (SIMPLE_METHOD o repr_tac)) |> Seq.the_result "" end; fun print_afuns ctxt = let fun pretty_afun (name, af) = let val [pT, (_, pure), (_, ap), (_, set)] = unpack_poly_terms (terms_of_afun af); val ([tvar], T) = poly_type_of_term pT; val rel = Option.map (#2 o the_single o unpack_poly_terms) (rel_of_afun af); val combinators = Symtab.keys (#reds (thms_of_afun af)); in Pretty.block (Pretty.fbreaks ([Pretty.block [Pretty.str name, Pretty.str ":", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt T), Pretty.brk 1, Pretty.str "of", Pretty.brk 1, Syntax.pretty_typ ctxt tvar], Pretty.block [Pretty.str "pure:", Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt pure)], Pretty.block [Pretty.str "ap:", Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt ap)], Pretty.block [Pretty.str "set:", Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt set)]] @ (case rel of NONE => [] | SOME rel' => [Pretty.block [Pretty.str "rel:", Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt rel')]]) @ [Pretty.block ([Pretty.str "combinators:", Pretty.brk 1] @ Pretty.commas (map Pretty.str combinators))])) end; val afuns = sort_by #1 (Name_Space.fold_table cons (get_afun_table (Context.Proof ctxt)) []); in Pretty.writeln (Pretty.big_list "Registered applicative functors:" (map pretty_afun afuns)) end; (* Unfolding *) fun add_unfold_thm name thm context = let val (lhs, _) = Thm.prop_of thm |> HOLogic.dest_Trueprop |> HOLogic.dest_eq handle TERM _ => error "Not an equation"; val names = case name of SOME n => [intern context n] | NONE => case match_typ context (Term.fastype_of lhs) of ns as (_::_) => ns | [] => error "Unable to determine applicative functor instance"; val _ = map (afun_of_generic context) names; (*TODO: check equation*) val thm' = mk_meta_eq thm; in fold (fn n => update_afun n (add_unfolds_afun [thm'])) names context end; fun add_unfold_attrib name = Thm.declaration_attribute (add_unfold_thm name); (*TODO: attribute to delete unfolds*) end; diff --git a/thys/Auto2_HOL/HOL/acdata.ML b/thys/Auto2_HOL/HOL/acdata.ML --- a/thys/Auto2_HOL/HOL/acdata.ML +++ b/thys/Auto2_HOL/HOL/acdata.ML @@ -1,334 +1,333 @@ (* File: acdata.ML Author: Bohua Zhan Dealing with associative-commutative operations. *) (* Data for an AC function. *) type ac_info = { cfhead: cterm, unit: cterm option, assoc_th: thm, (* (a . b) . c = a . (b . c) *) comm_th: thm, (* a . b = b . a *) unitl_th: thm, (* e . a = a *) unitr_th: thm (* a . e = a *) } signature ACUTIL = sig val inst_ac_info: theory -> typ -> ac_info -> ac_info option val head_agrees: ac_info -> term -> bool val eq_unit: ac_info -> term -> bool val add_ac_data: ac_info -> theory -> theory val get_head_ac_info: theory -> term -> ac_info option val has_assoc_th: ac_info -> bool val has_comm_th: ac_info -> bool val has_unit_th: ac_info -> bool val comm_cv: ac_info -> conv val assoc_cv: ac_info -> conv val assoc_sym_cv: ac_info -> conv val swap_cv: ac_info -> conv val swap_r_cv: ac_info -> conv val dest_ac: ac_info -> term -> term list val cdest_ac: ac_info -> cterm -> cterm list val comb_ac_equiv: ac_info -> thm list -> thm val normalize_assoc: ac_info -> conv val move_outmost: ac_info -> term -> conv val normalize_unit: ac_info -> conv val normalize_comm_gen: ac_info -> (term * term -> bool) -> conv val normalize_comm: ac_info -> conv val normalize_au: ac_info -> conv val normalize_all_ac: ac_info -> conv val ac_last_conv: ac_info -> conv -> conv val norm_combine: ac_info -> (term -> bool) -> conv -> conv end; structure ACUtil : ACUTIL = struct (* Register of generators of ac_inst_info. *) structure Data = Theory_Data ( type T = ac_info Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge (fn (info1, info2) => #cfhead info1 aconvc #cfhead info2) ) (* Instantiate an ac_info for a specific type T. *) fun inst_ac_info thy T {assoc_th, comm_th, unitl_th, unitr_th, ...} = let (* Instantiate th to having argument of type T. If not possible, change th to true_th. *) fun inst_th th = if is_true_th th then true_th else let (* Extract the first argument of th, then the body type of that argument. *) val arg_type = th |> prop_of' |> Util.dest_args |> hd |> Term.type_of |> Term.body_type in if arg_type = T then th else let val tenv = Sign.typ_match thy (arg_type, T) Vartab.empty in Util.subst_thm_thy thy (tenv, Vartab.empty) th end handle Type.TYPE_MATCH => true_th end val assoc_th' = inst_th assoc_th val unitl_th' = inst_th unitl_th in if is_true_th assoc_th' then NONE else SOME {cfhead = assoc_th' |> cprop_of' |> Thm.dest_arg1 |> Thm.dest_fun2, unit = if is_true_th unitl_th' then NONE else SOME (unitl_th' |> cprop_of' |> Thm.dest_arg1 |> Thm.dest_arg1), assoc_th = assoc_th', comm_th = inst_th comm_th, unitl_th = unitl_th', unitr_th = inst_th unitr_th} end fun head_agrees {cfhead, ...} t = Util.is_head (Thm.term_of cfhead) t fun eq_unit {unit, ...} t = case unit of NONE => false | SOME ct' => t aconv (Thm.term_of ct') (* Add the given ac_info under the given name. *) fun add_ac_data info thy = let val {assoc_th, ...} = info val f = assoc_th |> prop_of' |> dest_eq |> snd |> Term.head_of in case f of Const (c, _) => let val _ = tracing ("Add ac data for function " ^ c) in Data.map (Symtab.update_new (c, info)) thy end | _ => error "Add AC data: invalid assoc_th" end handle Symtab.DUP _ => error "Add AC data: info already exists." fun get_head_ac_info thy t = case t of Const (c, _) $ _ $ _ => (case Symtab.lookup (Data.get thy) c of NONE => NONE | SOME ac_info => inst_ac_info thy (fastype_of t) ac_info) | _ => NONE fun has_assoc_th {assoc_th, ...} = not (is_true_th assoc_th) fun has_comm_th {comm_th, ...} = not (is_true_th comm_th) fun has_unit_th {unitl_th, ...} = not (is_true_th unitl_th) fun comm_cv {comm_th, ...} = rewr_obj_eq comm_th fun assoc_cv {assoc_th, ...} = rewr_obj_eq assoc_th fun assoc_sym_cv {assoc_th, ...} = rewr_obj_eq (obj_sym assoc_th) (* (a . b) . c = (a . c) . b *) fun swap_cv (ac_info as {assoc_th, comm_th, ...}) ct = if head_agrees ac_info (dest_arg1 (Thm.term_of ct)) then Conv.every_conv [rewr_obj_eq assoc_th, Conv.arg_conv (rewr_obj_eq comm_th), rewr_obj_eq (obj_sym assoc_th)] ct else rewr_obj_eq comm_th ct (* a . (b . c) = b . (a . c) *) fun swap_r_cv (ac_info as {assoc_th, comm_th, ...}) ct = if head_agrees ac_info (dest_arg (Thm.term_of ct)) then Conv.every_conv [rewr_obj_eq (obj_sym assoc_th), Conv.arg1_conv (rewr_obj_eq comm_th), rewr_obj_eq assoc_th] ct else rewr_obj_eq comm_th ct (* Destruct t, assuming it is associated to the left. *) fun dest_ac ac_info t = let fun dest t = if head_agrees ac_info t then let val (a1, a2) = Util.dest_binop_args t in a2 :: dest a1 end else [t] in rev (dest t) end fun cdest_ac ac_info ct = let fun dest ct = if head_agrees ac_info (Thm.term_of ct) then let val (a1, a2) = Util.dest_binop_cargs ct in a2 :: dest a1 end else [ct] in rev (dest ct) end (* Given ths: [A1 == B1, ..., An == Bn], get theorem A1...An == B1...Bn. Associate to the left only. *) fun comb_ac_equiv {cfhead, ...} ths = let fun binop_comb th1 th2 = Thm.combination (Thm.combination (Thm.reflexive cfhead) th1) th2 (* Combine in the reverse order. *) fun comb ths = case ths of [] => raise Fail "comb_ac_equiv: empty list" | [th] => th | [th1, th2] => binop_comb th2 th1 | th :: ths' => binop_comb (comb ths') th in comb (rev ths) end (* Normalize association with the given direction. *) fun normalize_assoc ac_info ct = if not (has_assoc_th ac_info) then Conv.all_conv ct else let val {assoc_th, ...} = ac_info (* First rewrite into form (...) * a, then rewrite the remaining parts. *) fun normalize ct = if head_agrees ac_info (Thm.term_of ct) then Conv.every_conv [Conv.repeat_conv (rewr_obj_eq (obj_sym assoc_th)), Conv.arg1_conv normalize] ct else Conv.all_conv ct in normalize ct end (* Move the given u within ct to the rightmost position. Assume associate to the left. *) fun move_outmost (ac_info as {comm_th, ...}) u ct = if not (has_assoc_th ac_info andalso has_comm_th ac_info) then raise Fail "move_outmost: commutativity is not available." else if u aconv (Thm.term_of ct) then Conv.all_conv ct else if not (head_agrees ac_info (Thm.term_of ct)) then raise Fail "move_outmost: u not found in ct." else let val (a, b) = Util.dest_binop_args (Thm.term_of ct) in if u aconv b then Conv.all_conv ct else if head_agrees ac_info a then ((Conv.arg1_conv (move_outmost ac_info u)) then_conv (swap_cv ac_info)) ct else if u aconv a then rewr_obj_eq comm_th ct else raise Fail "move_outmost: u not found in ct." end (* In a product of a_1, a_2, ..., remove any a_i that is a unit. *) fun normalize_unit (ac_info as {unitl_th, unitr_th, ...}) ct = if not (has_unit_th ac_info) then Conv.all_conv ct else let fun normalize ct = if head_agrees ac_info (Thm.term_of ct) then Conv.every_conv [Conv.binop_conv normalize, Conv.try_conv (rewr_obj_eq unitl_th), Conv.try_conv (rewr_obj_eq unitr_th)] ct else Conv.all_conv ct in normalize ct end (* Rearrange subterms of ct according to the given term ordering. Returns theorem ct == ct'. *) fun normalize_comm_gen (ac_info as {comm_th, ...}) termless ct = if not (has_comm_th ac_info) then Conv.all_conv ct else let (* If there are two terms a.b, swap if a > b. If there are at least three terms, in the left associate case this is (a.b).c, swap b and c if b > c. If there is a swap, recursively call swap_last until the original outside term is swapped into position. *) fun swap_last ct = if head_agrees ac_info (Thm.term_of ct) then let val (a1, a2) = Util.dest_binop_args (Thm.term_of ct) in if head_agrees ac_info a1 then (* Structure of t is a1 . a2 = (_ . b2) . a2. *) if termless (a2, dest_arg a1) then ((swap_cv ac_info) then_conv (Conv.arg1_conv swap_last)) ct else Conv.all_conv ct else (* Structure of t is a1 . a2. *) if termless (a2, a1) then rewr_obj_eq comm_th ct else Conv.all_conv ct end else Conv.all_conv ct (* Full ordering. Recursively perform full ordering on all but the outermost, then swap outermost into position. *) fun normalize ct = if head_agrees ac_info (Thm.term_of ct) then ((Conv.arg1_conv normalize) then_conv swap_last) ct else Conv.all_conv ct in normalize ct end fun normalize_comm ac_info = normalize_comm_gen ac_info (fn (s, t) => Term_Ord.term_ord (s, t) = LESS) (* Normalize all except comm. *) fun normalize_au ac_info = Conv.every_conv [normalize_unit ac_info, normalize_assoc ac_info] (* Normalize everything. *) fun normalize_all_ac ac_info = Conv.every_conv [normalize_au ac_info, normalize_comm ac_info] (* Rewrite the last term in ct using cv. Assume associative to left. *) fun ac_last_conv ac_info cv ct = if head_agrees ac_info (Thm.term_of ct) then Conv.arg_conv cv ct else cv ct (* Given ct in the form x_1 * ... * x_n, where some sequence of x_i satisfies predicate pred. Combine these x_i into a single term using the binary combinator cv. *) fun norm_combine ac_info pred cv ct = let val t = Thm.term_of ct in if head_agrees ac_info t then let val (a, b) = Util.dest_binop_args t in if pred b then if pred a then cv ct else if head_agrees ac_info a andalso pred (dest_arg a) then Conv.every_conv [assoc_cv ac_info, Conv.arg_conv cv, norm_combine ac_info pred cv] ct else Conv.all_conv ct else Conv.arg1_conv (norm_combine ac_info pred cv) ct end else Conv.all_conv ct end end (* structure ACUtil. *) diff --git a/thys/Auto2_HOL/HOL/induct_outer.ML b/thys/Auto2_HOL/HOL/induct_outer.ML --- a/thys/Auto2_HOL/HOL/induct_outer.ML +++ b/thys/Auto2_HOL/HOL/induct_outer.ML @@ -1,539 +1,538 @@ (* File: induct_outer.ML Author: Bohua Zhan Proof language for induction. *) signature INDUCT_PROOFSTEPS = sig val add_induct_data: string -> term * thm -> theory -> theory val add_typed_induct_data: string -> typ * thm -> theory -> theory val get_typed_ind_th: theory -> string -> typ -> thm val get_term_ind_th: theory -> string -> term -> thm val check_strong_ind_prop: term -> term list * term val add_strong_induct_rule: thm -> theory -> theory val add_case_induct_rule: thm -> theory -> theory val add_prop_induct_rule: thm -> theory -> theory val add_var_induct_rule: thm -> theory -> theory val add_cases_rule: thm -> theory -> theory val add_fun_induct_rule: term * thm -> theory -> theory val strong_induct_cmd: string * string list -> Proof.state -> Proof.state val apply_induct_hyp_cmd: string list -> Proof.state -> Proof.state val case_induct_cmd: string -> Proof.state -> Proof.state val prop_induct_cmd: string * string option -> Proof.state -> Proof.state val induct_cmd: string -> string * string option * string list * string option -> Proof.state -> Proof.state val is_simple_fun_induct: thm -> bool val fun_induct_cmd: string * string list * string option -> Proof.state -> Proof.state end; structure Induct_ProofSteps : INDUCT_PROOFSTEPS = struct structure Data = Theory_Data ( type T = ((term * thm) list) Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge_list (eq_fst (op =)) ) fun add_induct_data str (t, ind_th) = Data.map (Symtab.map_default (str, []) (cons (t, ind_th))) fun add_typed_induct_data str (ty, ind_th) = add_induct_data str (Term.dummy_pattern ty, ind_th) fun get_typed_ind_th thy ind_type ty = let val typ_can_match = can (fn t' => Sign.typ_match thy (type_of t', ty) Vartab.empty) in case Symtab.lookup (Data.get thy) ind_type of NONE => raise Fail (ind_type ^ ": cannot find theorem.") | SOME lst => case find_first (fn (t', _) => typ_can_match t') lst of NONE => raise Fail (ind_type ^ ": cannot find theorem.") | SOME (_, ind_th) => ind_th end fun get_term_ind_th thy ind_type t = let val data = Symtab.lookup_list (Data.get thy) ind_type fun match_data (pat, th) = let val inst = Pattern.first_order_match thy (pat, t) fo_init in SOME (Util.subst_thm_thy thy inst th) end handle Pattern.MATCH => NONE in case get_first match_data data of NONE => raise Fail (ind_type ^ ": cannot find theorem.") | SOME ind_th => ind_th end (* Check a strong induction theorem ind_th is of the right form, and extract the induction variables and substitution. *) fun check_strong_ind_prop ind_prop = let fun err str = "Strong induction: " ^ str val (cond_ind, concl) = ind_prop |> Logic.dest_implies |> apply2 dest_Trueprop (* concl must be of form ?P [?vars]. *) val err_concl = err "concl of ind_th must be ?P [?vars]." val (P, pat_vars) = Term.strip_comb concl handle TERM _ => error err_concl val _ = assert (is_Var P andalso forall is_Var pat_vars andalso (dest_Var P |> fst |> fst) = "P") err_concl (* cond_ind must be of form !n. P' n --> ?P n. Return the substitution pattern P'. *) val err_ind_hyp = err "cond_ind of ind_th must be !n. P' --> ?P vars." fun dest_one_all var body = case body of Const (c, _) $ Abs (_, _, t) => if c = UtilBase.All_name then subst_bound (var, t) else error err_ind_hyp | _ => error err_ind_hyp val (pat_subst, P_vars) = cond_ind |> fold dest_one_all pat_vars |> dest_imp val _ = assert (P_vars aconv concl) err_ind_hyp in (pat_vars, pat_subst) end fun add_strong_induct_rule ind_th thy = let val name = Util.name_of_thm ind_th val ctxt = Proof_Context.init_global thy val ind_th' = apply_to_thm (UtilLogic.to_obj_conv_on_horn ctxt) ind_th val (pat_var, pat_subst) = check_strong_ind_prop (Thm.prop_of ind_th') |> apfst the_single handle List.Empty => error "Strong induction: more than one var." val ty_var = type_of pat_var val _ = writeln (name ^ "\nSubstitution: " ^ (Util.string_of_terms_global thy [pat_var, pat_subst])) in thy |> add_typed_induct_data "strong_induct" (ty_var, ind_th') end fun add_case_induct_rule ind_th thy = let val init_assum = ind_th |> Thm.prems_of |> hd |> dest_Trueprop in thy |> add_induct_data "case_induct" (init_assum, ind_th) end fun add_prop_induct_rule ind_th thy = let val init_assum = ind_th |> Thm.prems_of |> hd |> dest_Trueprop in thy |> add_induct_data "prop_induct" (init_assum, ind_th) end fun add_var_induct_rule ind_th thy = let val (P, n) = ind_th |> concl_of' |> Term.dest_comb val _ = assert (Term.is_Var P andalso Term.is_Var n) "add_var_induct_rule: concl of ind_th must be ?P ?var" in thy |> add_typed_induct_data "var_induct" (type_of n, ind_th) end fun add_cases_rule ind_th thy = let val (P, n) = ind_th |> concl_of' |> Term.dest_comb val _ = assert (Term.is_Var P andalso Term.is_Var n) "add_cases_rule: concl of ind_th must be ?P ?var" in thy |> add_typed_induct_data "cases" (type_of n, ind_th) end fun add_fun_induct_rule (t, ind_th) thy = thy |> add_induct_data "fun_induct" (t, ind_th) (* Obtain the induction statement. *) fun get_induct_stmt ctxt (filt_A, ind_vars, stmt, arbitrary) = case stmt of NONE => let val (_, (As, C)) = ctxt |> Auto2_State.get_subgoal |> Util.strip_meta_horn val obj_As = As |> map dest_Trueprop |> filter filt_A val obj_C = dest_Trueprop C in (UtilLogic.list_obj_horn (arbitrary, (obj_As, obj_C))) |> fold Util.lambda_abstract (rev ind_vars) end | SOME s => (UtilLogic.list_obj_horn (arbitrary, ([], Syntax.read_term ctxt s))) |> fold Util.lambda_abstract (rev ind_vars) fun apply_simple_induct_th ind_th vars arbitraries prem_only state = let val {context = ctxt, ...} = Proof.goal state val prop = Auto2_State.get_selected ctxt val (vars', _) = prop |> Thm.prems_of |> the_single |> Util.strip_meta_horn val ind_th = ind_th |> apply_to_thm (Conv.binop_conv (UtilLogic.to_meta_conv ctxt)) val assum = hd (Drule.cprems_of ind_th) val ind_th = ind_th |> Util.send_first_to_hyps |> fold Thm.forall_elim (map (Thm.cterm_of ctxt) arbitraries) |> fold Thm.forall_intr (map (Thm.cterm_of ctxt) vars') |> Thm.implies_intr assum val t' = case Thm.prop_of ind_th of imp $ A $ B => imp $ Util.rename_abs_term vars A $ B | _ => raise Fail "strong_induct_cmd" val ind_th = ind_th |> Thm.renamed_prop t' val prop = prop |> Auto2_Outer.refine_subgoal_th ind_th in if prem_only then let val (_, (As, _)) = prop |> Thm.prems_of |> the_single |> Util.strip_meta_horn val stmt = dest_Trueprop (hd As) in state |> Proof.map_contexts (Auto2_State.map_head_th (K prop)) |> Proof.map_contexts (Auto2_State.set_induct_stmt stmt) |> Proof.map_contexts (Auto2_State.add_prem_only stmt) end else state |> Proof.map_contexts (Auto2_State.map_head_th (K prop)) end fun strong_induct_cmd (s, t) state = let val {context = ctxt, ...} = Proof.goal state val thy = Proof_Context.theory_of ctxt val var = Syntax.read_term ctxt s val arbitraries = map (Syntax.read_term ctxt) t val P = get_induct_stmt ctxt (K true, [var], NONE, arbitraries) val ind_th = get_typed_ind_th thy "strong_induct" (type_of var) val (var_P, var_n) = ind_th |> concl_of' |> Term.dest_comb val inst = fold (Pattern.match thy) [(var_P, P), (var_n, var)] fo_init val ind_th = Util.subst_thm ctxt inst ind_th in state |> apply_simple_induct_th ind_th [var] arbitraries true end val arbitrary = Scan.option (@{keyword "arbitrary"} |-- Scan.repeat Parse.term) val _ = Outer_Syntax.command @{command_keyword "@strong_induct"} "apply strong induction" ((Parse.term -- arbitrary) >> (fn (s, t) => Toplevel.proof (fn state => strong_induct_cmd (s, these t) state))) fun apply_induct_hyp_cmd s state = let val {context = ctxt, ...} = Proof.goal state val ts = Syntax.read_terms ctxt s val induct_stmt = Auto2_State.get_last_induct_stmt ctxt val stmt = induct_stmt |> the |> mk_Trueprop |> Thm.cterm_of ctxt handle Option.Option => raise Fail "apply_induct_hyp: no induct_stmt" val prop = Auto2_State.get_selected ctxt val (_, (As, _)) = prop |> Thm.prems_of |> the_single |> Util.strip_meta_horn val _ = assert (member (op aconv) As (Thm.term_of stmt)) "apply_induct_hyp: induct_stmt not found among As." val cAs = map (Thm.cterm_of ctxt) As val th = stmt |> Thm.assume |> apply_to_thm (UtilLogic.to_meta_conv ctxt) |> fold Thm.forall_elim (map (Thm.cterm_of ctxt) ts) |> apply_to_thm (Util.normalize_meta_all_imp ctxt) val prems = th |> Thm.prems_of |> map (fn t => Logic.list_implies (As, t)) |> map (Thm.cterm_of ctxt) val prems_th = (map (Auto2_Outer.auto2_solve ctxt) prems) |> map Util.send_all_to_hyps val concl = th |> fold Thm.elim_implies prems_th |> fold Thm.implies_intr (rev cAs) val _ = writeln ("Obtained " ^ Syntax.string_of_term ctxt (Thm.concl_of concl)) in state |> Proof.map_contexts ( Auto2_State.map_head_th (Auto2_Outer.have_after_qed ctxt concl)) end val _ = Outer_Syntax.command @{command_keyword "@apply_induct_hyp"} "apply induction hypothesis" ((Scan.repeat Parse.term) >> (fn s => Toplevel.proof (fn state => apply_induct_hyp_cmd s state))) fun solve_goals ind_th pats_opt filt_As state = let val {context = ctxt, ...} = Proof.goal state val (_, (As, _)) = ctxt |> Auto2_State.get_subgoal |> Util.strip_meta_horn val use_As = filter filt_As As val cAs = map (Thm.cterm_of ctxt) As val ind_goals = ind_th |> Thm.prems_of |> map (fn t => Logic.list_implies (use_As, t)) |> map (Thm.cterm_of ctxt) |> map (UtilLogic.to_meta_conv ctxt) in case pats_opt of NONE => let (* Solve the right side, obtain the left side. *) fun solve_eq eq = Thm.equal_elim (meta_sym eq) (Auto2_Outer.auto2_solve ctxt (Thm.rhs_of eq)) val ths = ind_goals |> map solve_eq |> map Util.send_all_to_hyps val ind_concl = ind_th |> fold Thm.elim_implies ths |> fold Thm.implies_intr (rev cAs) val after_qed = Auto2_Outer.have_after_qed ctxt ind_concl in state |> Proof.map_contexts (Auto2_State.map_head_th after_qed) end | SOME pats => let (* Create new block with the subgoals *) fun after_qed ths prop = let val ths' = (ind_goals ~~ ths) |> map (fn (eq, th) => Thm.equal_elim (meta_sym eq) th) |> map Util.send_all_to_hyps val ind_concl = ind_th |> fold Thm.elim_implies ths' |> fold Thm.implies_intr (rev cAs) in Auto2_Outer.have_after_qed ctxt ind_concl prop end val _ = writeln ("Patterns: " ^ Util.string_of_terms ctxt pats) val new_frame = Auto2_State.multiple_frame ( pats ~~ map Thm.rhs_of ind_goals, SOME ([], after_qed)) in state |> Proof.map_contexts (Auto2_State.push_head new_frame) end end fun case_induct_cmd s state = let val {context = ctxt, ...} = Proof.goal state val thy = Proof_Context.theory_of ctxt val start = Syntax.read_term ctxt s val ind_th = get_term_ind_th thy "case_induct" start (* Obtain list of assumptions *) val (_, (_, C)) = ctxt |> Auto2_State.get_subgoal |> Util.strip_meta_horn (* Instantiate the induction theorem *) val var_P = concl_of' ind_th val inst = Pattern.match thy (var_P, dest_Trueprop C) fo_init val ind_th = Util.subst_thm_thy thy inst ind_th in state |> solve_goals ind_th NONE (K true) end val _ = Outer_Syntax.command @{command_keyword "@case_induct"} "apply induction" (Parse.term >> (fn s => Toplevel.proof (fn state => case_induct_cmd s state))) val for_stmt = Scan.option (@{keyword "for"} |-- Parse.term) fun prop_induct_cmd (s, t) state = let val {context = ctxt, ...} = Proof.goal state val thy = Proof_Context.theory_of ctxt val start = Syntax.read_term ctxt s val ind_th = get_term_ind_th thy "prop_induct" start val (var_P, args) = ind_th |> concl_of' |> Term.strip_comb val start_As = strip_conj start val filt_A = (fn t => not (member (op aconv) start_As t)) val P = get_induct_stmt ctxt (filt_A, args, t, []) val _ = writeln ("Induct statement: " ^ Syntax.string_of_term ctxt P) val inst = Pattern.match thy (var_P, P) fo_init (* Instantiate the induction theorem *) val ind_th = Util.subst_thm_thy thy inst ind_th in state |> solve_goals ind_th NONE (K true) end val _ = Outer_Syntax.command @{command_keyword "@prop_induct"} "apply induction" ((Parse.term -- for_stmt) >> (fn (s, t) => Toplevel.proof (fn state => prop_induct_cmd (s, t) state))) (* Given an induction subgoal of the form !!x_i. A_i ==> C, retrieve the list of induction patterns. *) fun retrieve_pat ind_vars t = let val (vars, (_, C)) = Util.strip_meta_horn t fun free_to_var t = let val (x, T) = Term.dest_Free t in Var ((x,0), T) end val pat_vars = map free_to_var vars val args = C |> dest_Trueprop |> Util.dest_args |> map (Term.subst_atomic (vars ~~ pat_vars)) in HOLogic.mk_tuple (map mk_eq (ind_vars ~~ args)) end fun induct_cmd ind_ty_str (s, t, u, v) state = let val {context = ctxt, ...} = Proof.goal state val thy = Proof_Context.theory_of ctxt val var = Syntax.read_term ctxt s val arbitraries = map (Syntax.read_term ctxt) u val filt_A = Util.occurs_frees (var :: arbitraries) val P = get_induct_stmt ctxt (filt_A, [var], t, arbitraries) val ind_th = get_typed_ind_th thy ind_ty_str (type_of var) (* Instantiate the induction theorem *) val concl = concl_of' ind_th val (var_P, var_n) = Term.dest_comb concl val inst = fold (Pattern.match thy) [(var_P, P), (var_n, var)] fo_init val ind_th' = Util.subst_thm_thy thy inst ind_th val pats = case v of NONE => NONE | _ => SOME (map (retrieve_pat [var]) (Thm.prems_of ind_th)) in state |> solve_goals ind_th' pats (not o filt_A) end val _ = Outer_Syntax.command @{command_keyword "@induct"} "apply induction" (Parse.term -- for_stmt -- arbitrary -- Scan.option @{keyword "@with"} >> (fn (((s, t), u), v) => Toplevel.proof ( fn state => induct_cmd "var_induct" (s, t, these u, v) state))) val _ = Outer_Syntax.command @{command_keyword "@cases"} "apply induction" (Parse.term -- Scan.option @{keyword "@with"} >> (fn (s, v) => Toplevel.proof ( fn state => induct_cmd "cases" (s, NONE, [], v) state))) fun get_fun_induct_th thy t = let val ind_th = get_term_ind_th thy "fun_induct" (Term.head_of t) handle Fail _ => Global_Theory.get_thm thy (Util.get_head_name t ^ ".induct") handle ERROR _ => raise Fail "fun_induct: cannot find theorem." val (_, args) = Term.strip_comb t val (_, pat_args) = ind_th |> concl_of' |> Term.strip_comb val inst = Util.first_order_match_list thy (pat_args ~~ args) fo_init in Util.subst_thm_thy thy inst ind_th end fun is_simple_fun_induct ind_th = let val prems = Thm.prems_of ind_th in if length prems > 1 then false else let val (var, (_, C)) = Util.strip_meta_horn (the_single prems) val (_, args) = Term.strip_comb (dest_Trueprop C) in eq_list (op aconv) (var, args) end end fun fun_induct_cmd (s, t, u) state = let val {context = ctxt, ...} = Proof.goal state val thy = Proof_Context.theory_of ctxt val expr = Syntax.read_term ctxt s val arbitraries = map (Syntax.read_term ctxt) t val ind_th = get_fun_induct_th thy expr val (var_P, vars) = ind_th |> concl_of' |> Term.strip_comb in if is_simple_fun_induct ind_th then let val _ = assert (is_none u) "fun_induct: simple induction." (* Instantiate the induction theorem *) val P = get_induct_stmt ctxt (K true, vars, NONE, arbitraries) val inst = Pattern.match thy (var_P, P) fo_init val ind_th = Util.subst_thm_thy thy inst ind_th in state |> apply_simple_induct_th ind_th vars arbitraries false end else let (* Instantiate the induction theorem *) val filt_A = Util.occurs_frees (vars @ arbitraries) val P = get_induct_stmt ctxt (filt_A, vars, NONE, arbitraries) val inst = Pattern.match thy (var_P, P) fo_init val ind_th' = ind_th |> Util.subst_thm_thy thy inst val prems = Thm.prems_of ind_th val pats = case u of NONE => NONE | SOME _ => SOME (map (retrieve_pat vars) prems) in state |> solve_goals ind_th' pats (not o filt_A) end end val _ = Outer_Syntax.command @{command_keyword "@fun_induct"} "apply induction" (Parse.term -- arbitrary -- Scan.option @{keyword "@with"} >> (fn ((s, t), u) => Toplevel.proof (fn state => fun_induct_cmd (s, these t, u) state))) end (* structure Induct_ProofSteps. *) val add_strong_induct_rule = Induct_ProofSteps.add_strong_induct_rule val add_case_induct_rule = Induct_ProofSteps.add_case_induct_rule val add_prop_induct_rule = Induct_ProofSteps.add_prop_induct_rule val add_var_induct_rule = Induct_ProofSteps.add_var_induct_rule val add_fun_induct_rule = Induct_ProofSteps.add_fun_induct_rule val add_cases_rule = Induct_ProofSteps.add_cases_rule diff --git a/thys/Auto2_HOL/consts.ML b/thys/Auto2_HOL/consts.ML --- a/thys/Auto2_HOL/consts.ML +++ b/thys/Auto2_HOL/consts.ML @@ -1,66 +1,65 @@ (* File: consts.ML Author: Bohua Zhan Dealing with constants. *) signature CONSTS = sig val add_const_data: string * (term -> bool) -> theory -> theory val detect_const: theory -> term -> string option val detect_const_ctxt: Proof.context -> term -> string option val is_const: theory -> term -> bool val is_const_ctxt: Proof.context -> term -> bool val neq_const: theory -> term * term -> bool val neq_const_ctxt: Proof.context -> term * term -> bool end; structure Consts : CONSTS = struct (* Table of detectors for constants, each registered under a descriptive name. *) structure Data = Theory_Data ( type T = (term -> bool) Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge pointer_eq ) fun add_const_data (str, f) = Data.map (Symtab.update_new (str, f)) fun detect_const thy t = let val data = Symtab.dest (Data.get thy) in get_first (fn (str, f) => if f t then SOME str else NONE) data end fun detect_const_ctxt ctxt t = detect_const (Proof_Context.theory_of ctxt) t fun is_const thy t = is_some (detect_const thy t) fun is_const_ctxt ctxt t = is_const (Proof_Context.theory_of ctxt) t (* Whether two constants are of the same type and not equal. If either input is not a constant, return false. *) fun neq_const thy (t1, t2) = let val ty1 = the (detect_const thy t1) val ty2 = the (detect_const thy t2) in ty1 = ty2 andalso not (t1 aconv t2) end handle Option.Option => false fun neq_const_ctxt ctxt (t1, t2) = neq_const (Proof_Context.theory_of ctxt) (t1, t2) end (* structure Consts. *) diff --git a/thys/Auto2_HOL/items.ML b/thys/Auto2_HOL/items.ML --- a/thys/Auto2_HOL/items.ML +++ b/thys/Auto2_HOL/items.ML @@ -1,698 +1,697 @@ (* File: items.ML Author: Bohua Zhan Items and matching on items. *) val TY_NULL = "NULL" val TY_EQ = "EQ" val TY_VAR = "VAR" val TY_PROP = "PROP" val TY_TERM = "TERM" val TY_PROPERTY = "PROPERTY" datatype raw_item = Handler of term list * term * thm | Fact of string * term list * thm type box_item = {uid: int, id: box_id, sc: int, ty_str: string, tname: cterm list, prop: thm} signature BOXITEM = sig (* Facts. *) val var_to_fact: term -> raw_item val term_to_fact: term -> raw_item val is_fact_raw: raw_item -> bool val match_ty_str_raw: string -> raw_item -> bool val match_ty_strs_raw: string list -> raw_item -> bool val get_tname_raw: raw_item -> term list val get_thm_raw: raw_item -> thm (* Handlers. *) val is_handler_raw: raw_item -> bool val dest_handler_raw: raw_item -> term list * term * thm (* Misc. functions. *) val eq_ritem: raw_item * raw_item -> bool val instantiate: (cterm * cterm) list -> raw_item -> raw_item val obtain_variant_frees: Proof.context * raw_item list -> Proof.context * (cterm * cterm) list val null_item: box_item val item_with_id: box_id -> box_item -> box_item val item_with_incr: box_item -> box_item val item_replace_incr: box_item -> box_item val eq_item: box_item * box_item -> bool val match_ty_str: string -> box_item -> bool val match_ty_strs: string list -> box_item -> bool (* Misc. functions. *) val merged_id: Proof.context -> box_item list -> box_id val mk_box_item: Proof.context -> int * box_id * int * raw_item -> box_item end; structure BoxItem : BOXITEM = struct fun var_to_fact t = Fact (TY_VAR, [t], true_th) fun term_to_fact t = Fact (TY_TERM, [t], true_th) fun is_fact_raw ritem = case ritem of Fact _ => true | _ => false fun match_ty_str_raw s ritem = case ritem of Fact (ty_str, _, _) => s = "" orelse ty_str = s | _ => false fun match_ty_strs_raw slist ritem = case ritem of Fact (ty_str, _, _) => member (op =) slist ty_str | _ => false fun get_tname_raw ritem = case ritem of Fact (_, ts, _) => ts | _ => raise Fail "get_tname_raw" fun get_thm_raw ritem = case ritem of Fact (_, _, th) => th | _ => raise Fail "get_thm_raw" fun is_handler_raw ritem = case ritem of Handler _ => true | _ => false fun dest_handler_raw ritem = case ritem of Handler (vars, t, ex_th) => (vars, t, ex_th) | _ => raise Fail "dest_handler_raw: wrong type" fun eq_ritem (ritem1, ritem2) = case ritem1 of Fact (ty1, ts1, th1) => (case ritem2 of Fact (ty2, ts2, th2) => ty1 = ty2 andalso eq_list (op aconv) (ts1, ts2) andalso Thm.eq_thm_prop (th1, th2) | _ => false) | Handler (vars1, t1, ex_th1) => (case ritem2 of Fact _ => false | Handler (vars2, t2, ex_th2) => eq_list (op aconv) (vars1, vars2) andalso t1 aconv t2 andalso Thm.eq_thm_prop (ex_th1, ex_th2)) (* Given a context and list of raw items, obtain fresh names of free variables for each internal (schematic) variable declared in the raw items, and declare the new variables in context. Return the substitution from internal schematic variables to the new free variables. *) fun obtain_variant_frees (ctxt, ritems) = let (* Original internal variables. *) val all_vars = ritems |> filter (match_ty_str_raw TY_VAR) |> maps get_tname_raw |> filter is_Free |> map dest_Free |> filter (Util.is_just_internal o fst) (* New names for these variables. *) val all_vars' = all_vars |> map (fn (x, T) => (Name.dest_internal x, T)) |> Variable.variant_frees ctxt [] val subst = map (apply2 (Thm.cterm_of ctxt o Free)) (all_vars ~~ all_vars') in (fold Util.declare_free_term (map Free all_vars') ctxt, subst) end (* Here inst is the return value of obtain_variant_frees. Perform the replacement on the ritems. *) fun instantiate subst ritem = let val subst_fun = Term.subst_atomic (map (apply2 Thm.term_of) subst) in case ritem of Handler (vars, t, ex_th) => Handler (map subst_fun vars, subst_fun t, Util.subst_thm_atomic subst ex_th) | Fact (ty_str, tname, th) => Fact (ty_str, map subst_fun tname, Util.subst_thm_atomic subst th) end val null_item = {uid = 0, id = [], sc = 0, ty_str = TY_NULL, tname = [], prop = true_th} fun item_with_id id {uid, sc, ty_str, tname, prop, ...} = {uid = uid, id = id, sc = sc, ty_str = ty_str, tname = tname, prop = prop} fun item_with_incr item = item_with_id (BoxID.add_incr_id (#id item)) item fun item_replace_incr item = item_with_id (BoxID.replace_incr_id (#id item)) item fun eq_item (item1, item2) = (#uid item1 = #uid item2) fun match_ty_str s {ty_str, ...} = (s = "" orelse s = ty_str) fun match_ty_strs slist {ty_str, ...} = member (op =) slist ty_str fun merged_id ctxt items = case items of [] => [] | {id, ...} :: items' => BoxID.merge_boxes ctxt (id, merged_id ctxt items') fun mk_box_item ctxt (uid, id, sc, ritem) = case ritem of Handler _ => raise Fail "mk_box_item: ritem must be Fact" | Fact (ty_str, ts, prop) => {uid = uid, id = id, sc = sc, ty_str = ty_str, tname = map (Thm.cterm_of ctxt) ts, prop = prop} end (* structure BoxItem. *) (* Specifies a method for matching patterns against items. - pre_match is a filter function checking whether it is possible for the pattern to match the item, after possibly instantiating some schematic variables in the pattern (for example, this function should always return true if input pattern is ?A). - match is the actual matching function, returning instantiation, as well as theorem justifying the instantiated pattern. If the matcher is for justifying a proposition, the input term to pre_match and match is of type bool. Othewise, the restrictions depend on type of item to match. *) type item_matcher = { pre_match: term -> box_item -> Proof.context -> bool, match: term -> box_item -> Proof.context -> id_inst -> id_inst_th list } (* Output function for items of a given type. *) type item_output = Proof.context -> term list * thm -> string (* Data structure containing methods involved in the input / output of items of a given type. - prop_matchers: methods for matching the item against a desired proposition. - typed_matchers: methods for matching the item against a pattern for items of the same type. - output_fn: printing function of theorems. Input is tname and the proposition. *) type item_io_info = { prop_matchers: item_matcher list, typed_matchers: item_matcher list, term_fn: (term list -> term list) option, output_fn: item_output option, shadow_fn: (Proof.context -> box_id -> term list * cterm list -> bool) option } datatype match_arg = PropMatch of term | TypedMatch of string * term | TypedUniv of string | PropertyMatch of term | WellFormMatch of term * term type prfstep_filter = Proof.context -> id_inst -> bool signature ITEM_IO = sig val pat_of_match_arg: match_arg -> term val subst_arg: Type.tyenv * Envir.tenv -> match_arg -> match_arg val assert_valid_arg: match_arg -> unit val check_ty_str: string -> match_arg -> bool val is_ordinary_match: match_arg -> bool val is_side_match: match_arg -> bool val add_item_type: string * (term list -> term list) option * item_output option * (Proof.context -> box_id -> term list * cterm list -> bool) option -> theory -> theory val add_prop_matcher: string * item_matcher -> theory -> theory val add_typed_matcher: string * item_matcher -> theory -> theory val get_io_info: theory -> string -> item_io_info val get_prop_matchers: theory -> string -> item_matcher list val get_typed_matchers: theory -> string -> item_matcher list val prop_matcher: item_matcher val term_prop_matcher: item_matcher val null_eq_matcher: item_matcher val term_typed_matcher: item_matcher val eq_tname_typed_matcher: item_matcher val null_property_matcher: item_matcher val term_property_matcher: item_matcher val pre_match_arg: Proof.context -> match_arg -> box_item -> bool val match_arg: Proof.context -> match_arg -> box_item -> id_inst -> id_inst_th list val no_rewr_terms: term list -> term list val rewr_terms_of_item: Proof.context -> string * term list -> term list val output_prop_fn: item_output val string_of_item_info: Proof.context -> string * term list * thm -> string val add_basic_item_io: theory -> theory val string_of_raw_item: Proof.context -> raw_item -> string val string_of_item: Proof.context -> box_item -> string val trace_ritem: Proof.context -> string -> raw_item -> unit val trace_item: Proof.context -> string -> box_item -> unit val trace_ritems: Proof.context -> string -> raw_item list -> unit val trace_items: Proof.context -> string -> box_item list -> unit end; structure ItemIO : ITEM_IO = struct fun add_prop_matcher_to_info mtch {prop_matchers, typed_matchers, term_fn, output_fn, shadow_fn} = {prop_matchers = mtch :: prop_matchers, typed_matchers = typed_matchers, term_fn = term_fn, output_fn = output_fn, shadow_fn = shadow_fn} fun add_typed_matcher_to_info mtch {prop_matchers, typed_matchers, term_fn, output_fn, shadow_fn} = {prop_matchers = prop_matchers, typed_matchers = mtch :: typed_matchers, term_fn = term_fn, output_fn = output_fn, shadow_fn = shadow_fn} fun join_infos ( {prop_matchers = pm1, typed_matchers = tm1, term_fn = tf1, output_fn = of1, shadow_fn = sf1}, {prop_matchers = pm2, typed_matchers = tm2, term_fn = tf2, output_fn = of2, shadow_fn = sf2}) = {prop_matchers = merge pointer_eq (pm1, pm2), typed_matchers = merge pointer_eq (tm1, tm2), term_fn = (if pointer_eq (tf1, tf2) then tf1 else raise Fail "join_infos: term_fn non-equal"), output_fn = (if pointer_eq (of1, of2) then of1 else raise Fail "join_infos: output_fn non-equal"), shadow_fn = (if pointer_eq (sf1, sf2) then sf1 else raise Fail "join_infos: shadow_fn non-equal")} structure Data = Theory_Data ( type T = item_io_info Symtab.table val empty = Symtab.empty - val extend = I; val merge = Symtab.join (fn _ => join_infos) ) fun pat_of_match_arg arg = case arg of PropMatch pat => pat | TypedMatch (_, pat) => pat | TypedUniv _ => Term.dummy | PropertyMatch pat => pat | WellFormMatch (_, req) => req fun subst_arg inst arg = case arg of PropMatch pat => PropMatch (Util.subst_term_norm inst pat) | TypedMatch (ty_str, pat) => TypedMatch (ty_str, Util.subst_term_norm inst pat) | TypedUniv ty_str => TypedUniv ty_str | PropertyMatch pat => PropertyMatch (Util.subst_term_norm inst pat) | WellFormMatch (t, req) => WellFormMatch (Util.subst_term_norm inst t, Util.subst_term_norm inst req) fun assert_valid_arg arg = case arg of PropMatch pat => assert (fastype_of pat = boolT) "assert_valid_arg: arg for PropMatch should be bool." | TypedMatch _ => () | TypedUniv _ => () | PropertyMatch pat => assert (fastype_of pat = boolT) "assert_valid_arg: arg for PropertyMatch should be bool." | WellFormMatch (_, req) => assert (fastype_of req = boolT) "assert_valid_arg: arg for WellFormMatch should be bool." fun check_ty_str ty_str arg = case arg of TypedMatch (ty_str', _) => ty_str = ty_str' | TypedUniv ty_str' => ty_str = ty_str' | _ => true fun is_ordinary_match arg = case arg of PropMatch _ => true | TypedMatch _ => true | _ => false fun is_side_match arg = case arg of PropertyMatch _ => true | WellFormMatch _ => true | _ => false fun add_item_type (ty_str, term_fn, output_fn, shadow_fn) = let val item_info = {prop_matchers = [], typed_matchers = [], term_fn = term_fn, output_fn = output_fn, shadow_fn = shadow_fn} in Data.map (Symtab.update_new (ty_str, item_info)) end fun add_prop_matcher (ty_str, it_match) = Data.map ( Symtab.map_entry ty_str (add_prop_matcher_to_info it_match)) fun add_typed_matcher (ty_str, it_match) = Data.map ( Symtab.map_entry ty_str (add_typed_matcher_to_info it_match)) fun get_io_info thy ty_str = the (Symtab.lookup (Data.get thy) ty_str) handle Option.Option => raise Fail ("get_io_info: not found " ^ ty_str) fun get_prop_matchers thy ty_str = #prop_matchers (get_io_info thy ty_str) fun get_typed_matchers thy ty_str = #typed_matchers (get_io_info thy ty_str) (* Prop-matching with a PROP item. *) val prop_matcher = let fun pre_match pat {tname, ...} ctxt = let val ct = the_single tname val t = Thm.term_of ct in if is_neg pat then is_neg t andalso Matcher.pre_match_head ctxt (get_neg pat, UtilLogic.get_cneg ct) else Term.is_Var pat orelse (not (is_neg t) andalso Matcher.pre_match_head ctxt (pat, ct)) end fun match pat {tname, prop, ...} ctxt (id, inst) = let val ct = the_single tname val t = Thm.term_of ct in if is_neg pat andalso is_neg t then let val insts' = Matcher.rewrite_match_head ctxt (get_neg pat, UtilLogic.get_cneg ct) (id, inst) fun process_inst (inst, eq_th) = let (* This version certainly will not cancel ~~ on two sides. *) val make_neg_eq' = Thm.combination (Thm.reflexive UtilBase.cNot) in (inst, Thm.equal_elim ( make_trueprop_eq (make_neg_eq' (meta_sym eq_th))) prop) end in map process_inst insts' end else if not (is_neg pat) andalso (Term.is_Var pat orelse not (is_neg t)) then let val insts' = Matcher.rewrite_match_head ctxt (pat, ct) (id, inst) fun process_inst (inst, eq_th) = (inst, Thm.equal_elim ( make_trueprop_eq (meta_sym eq_th)) prop) in map process_inst insts' end else [] end in {pre_match = pre_match, match = match} end (* Prop-matching with a TERM item (used to justify equalities). *) val term_prop_matcher = let fun pre_match pat {tname, ...} ctxt = if not (Util.has_vars pat) then false else if is_eq_term pat then Matcher.pre_match ctxt (fst (dest_eq pat), the_single tname) else false fun match pat {tname, ...} ctxt (id, inst) = if not (is_eq_term pat) then [] else if not (Util.has_vars pat) then [] else let val (lhs, rhs) = dest_eq pat val cu = the_single tname val pairs = if Term.is_Var lhs then [(false, (lhs, cu)), (true, (rhs, cu))] else [(true, (lhs, cu)), (false, (rhs, cu))] val insts' = Matcher.rewrite_match_list ctxt pairs (id, inst) fun process_inst (inst, ths) = let (* th1: lhs(env) == u, th2: rhs(env) == u. *) val (th1, th2) = the_pair ths in (inst, to_obj_eq (Util.transitive_list [th1, meta_sym th2])) end in map process_inst insts' end in {pre_match = pre_match, match = match} end val null_eq_matcher = let fun pre_match pat _ _ = is_eq_term pat fun match pat _ ctxt (id, inst) = if not (is_eq_term pat) then [] else if Util.has_vars pat then [] else let val (lhs, rhs) = dest_eq pat val infos = RewriteTable.equiv_info_t ctxt id (lhs, rhs) fun process_info (id', th) = ((id', inst), to_obj_eq th) in map process_info infos end in {pre_match = pre_match, match = match} end (* Typed matching with a TERM item. *) val term_typed_matcher = let fun pre_match pat {tname, ...} ctxt = Matcher.pre_match_head ctxt (pat, the_single tname) (* Return value is (inst, eq), where eq is pat(inst) == tname. *) fun match pat {tname, ...} ctxt (id, inst) = Matcher.rewrite_match_head ctxt (pat, the_single tname) (id, inst) in {pre_match = pre_match, match = match} end (* Typed matching for items representing an equality ?A = ?B, where the tname is the pair (?A, ?B). Pattern is expected to be of the form ?A = ?B. *) val eq_tname_typed_matcher = let fun pre_match pat {tname, ...} ctxt = let val thy = Proof_Context.theory_of ctxt val (lhs, rhs) = the_pair (map Thm.term_of tname) val _ = Pattern.first_order_match thy (pat, mk_eq (lhs, rhs)) fo_init in true end handle Pattern.MATCH => false fun match pat {tname, ...} ctxt (id, inst) = let val thy = Proof_Context.theory_of ctxt val (lhs, rhs) = the_pair (map Thm.term_of tname) val inst' = Pattern.first_order_match thy (pat, mk_eq (lhs, rhs)) inst in [((id, inst'), true_th)] end handle Pattern.MATCH => [] in {pre_match = pre_match, match = match} end (* Obtain a proposition from the property table. *) val null_property_matcher = let fun pre_match pat _ _ = Property.is_property pat fun match pat _ ctxt (id, inst) = if Util.has_vars pat then [] else if not (Property.is_property pat) then [] else map (fn (id', th) => ((id', inst), th)) (PropertyData.get_property_t ctxt (id, pat)) in {pre_match = pre_match, match = match} end (* Obtain a proposition from the property table, matching the argument of the property with the given term. *) val term_property_matcher = let fun pre_match pat {tname, ...} ctxt = Property.is_property pat andalso Matcher.pre_match_head ctxt ( Property.get_property_arg pat, the_single tname) fun match pat {tname, ...} ctxt (id, inst) = if not (Util.has_vars pat) then [] else if not (Property.is_property pat) then [] else let val arg = Property.get_property_arg pat in let val insts' = Matcher.rewrite_match_head ctxt (arg, the_single tname) (id, inst) fun process_inst ((id', inst'), _) = let val t = Util.subst_term_norm inst' pat in map (fn (id'', th) => ((id'', inst'), th)) (PropertyData.get_property_t ctxt (id', t)) end in maps process_inst insts' end end in {pre_match = pre_match, match = match} end (* Generic pre-matching function. Returns whether there is a possible match among any of the registered matchers. *) fun pre_match_arg ctxt arg (item as {ty_str, ...}) = if not (check_ty_str ty_str arg) then false else let val _ = assert_valid_arg arg val thy = Proof_Context.theory_of ctxt val {prop_matchers, typed_matchers, ...} = get_io_info thy ty_str in case arg of PropMatch pat => Term.is_Var pat orelse (is_neg pat andalso Term.is_Var (get_neg pat)) orelse not (Util.is_pattern pat) orelse exists (fn f => f pat item ctxt) (map #pre_match prop_matchers) | TypedMatch (_, pat) => not (Util.is_pattern pat) orelse exists (fn f => f pat item ctxt) (map #pre_match typed_matchers) | TypedUniv _ => true | PropertyMatch _ => raise Fail "pre_match_arg: should not be called on PropertyMatch." | WellFormMatch _ => raise Fail "pre_match_arg: should not be called on WellFormMatch." end (* Generic matching function. Returns list of all matches (iterating over all registered matchers for the given item type. Note box_id for item is taken into account here. *) fun match_arg ctxt arg (item as {id, ty_str, ...}) (id', inst) = if not (check_ty_str ty_str arg) then [] else let val _ = assert_valid_arg arg val thy = Proof_Context.theory_of ctxt val {prop_matchers, typed_matchers, ...} = get_io_info thy ty_str val pat = pat_of_match_arg arg val id'' = BoxID.merge_boxes ctxt (id, id') in case arg of PropMatch _ => maps (fn f => f pat item ctxt (id'', inst)) (map #match prop_matchers) | TypedUniv _ => [((id'', inst), true_th)] | TypedMatch _ => maps (fn f => f pat item ctxt (id'', inst)) (map #match typed_matchers) | PropertyMatch _ => raise Fail "match_arg: should not be called on PropertyMatch." | WellFormMatch _ => raise Fail "match_arg: should not be called on WellFormMatch." end val no_rewr_terms = K [] fun arg_rewr_terms ts = maps Util.dest_args ts fun prop_rewr_terms ts = let val t = the_single ts in if is_neg t then t |> dest_arg |> Util.dest_args else t |> Util.dest_args end fun rewr_terms_of_item ctxt (ty_str, tname) = let val thy = Proof_Context.theory_of ctxt val {term_fn, ...} = get_io_info thy ty_str in case term_fn of NONE => tname | SOME f => f tname end fun output_prop_fn ctxt (_, th) = Thm.prop_of th |> Syntax.string_of_term ctxt fun string_of_item_info ctxt (ty_str, ts, th) = let val thy = Proof_Context.theory_of ctxt val {output_fn, ...} = get_io_info thy ty_str in case output_fn of NONE => ty_str ^ " " ^ (Util.string_of_terms ctxt ts) | SOME f => f ctxt (ts, th) end fun string_of_raw_item ctxt ritem = case ritem of Handler (_, t, _) => "Handler " ^ (Syntax.string_of_term ctxt t) | Fact info => string_of_item_info ctxt info fun string_of_item ctxt {ty_str, tname, prop, ...} = string_of_item_info ctxt (ty_str, map Thm.term_of tname, prop) fun trace_ritem ctxt s ritem = tracing (s ^ " " ^ (string_of_raw_item ctxt ritem)) fun trace_ritems ctxt s ritems = tracing (s ^ "\n" ^ (cat_lines (map (string_of_raw_item ctxt) ritems))) fun trace_item ctxt s item = tracing (s ^ " " ^ (string_of_item ctxt item)) fun trace_items ctxt s items = tracing (s ^ "\n" ^ (cat_lines (map (string_of_item ctxt) items))) (* We assume ts1 is the new item at the given id, while cts2 is for an existing item, at some previous id. *) fun shadow_prop_fn ctxt id (ts1, cts2) = let val (t1, ct2) = (the_single ts1, the_single cts2) val (lhs, crhs) = if is_neg t1 andalso is_neg (Thm.term_of ct2) then (get_neg t1, UtilLogic.get_cneg ct2) else (t1, ct2) in (Matcher.rewrite_match_head ctxt (lhs, crhs) (id, fo_init)) |> filter (fn ((id', _), _) => id' = id) |> not o null end fun shadow_term_fn ctxt id (ts1, cts2) = let val (lhs, crhs) = (the_single ts1, the_single cts2) in (Matcher.rewrite_match_head ctxt (lhs, crhs) (id, fo_init)) |> filter (fn ((id', _), _) => id' = id) |> not o null end val add_basic_item_io = fold add_item_type [ (TY_NULL, NONE, NONE, NONE), (TY_PROP, SOME prop_rewr_terms, SOME output_prop_fn, SOME shadow_prop_fn), (TY_TERM, SOME no_rewr_terms, NONE, SOME shadow_term_fn), (TY_EQ, NONE, SOME output_prop_fn, NONE), (TY_VAR, NONE, NONE, NONE), (TY_PROPERTY, SOME arg_rewr_terms, NONE, NONE) ] #> fold add_prop_matcher [ (TY_PROP, prop_matcher), (TY_TERM, term_prop_matcher), (TY_NULL, null_eq_matcher), (TY_NULL, null_property_matcher), (TY_TERM, term_property_matcher) ] #> fold add_typed_matcher [ (TY_PROP, prop_matcher), (TY_TERM, term_typed_matcher), (TY_VAR, term_typed_matcher), (TY_EQ, eq_tname_typed_matcher) ] end (* structure ItemIO. *) diff --git a/thys/Auto2_HOL/normalize.ML b/thys/Auto2_HOL/normalize.ML --- a/thys/Auto2_HOL/normalize.ML +++ b/thys/Auto2_HOL/normalize.ML @@ -1,291 +1,289 @@ (* File: normalize.ML Author: Bohua Zhan Normalization procedure for facts obtained during a proof. *) type normalizer = Proof.context -> raw_item -> raw_item list signature NORMALIZER = sig val add_normalizer: string * normalizer -> theory -> theory val add_th_normalizer: string * (Proof.context -> thm -> thm list) -> theory -> theory val add_rewr_normalizer: string * thm -> theory -> theory val get_normalizers: theory -> (string * normalizer) list val normalize: Proof.context -> raw_item -> raw_item list val normalize_keep: Proof.context -> raw_item -> raw_item list (* Normalization of definition of variable *) val add_inj_struct_data: thm -> theory -> theory val is_def_eq: theory -> term -> bool val swap_eq_to_front: conv val meta_use_vardef: thm -> (term * term) list * thm val meta_use_vardefs: thm -> (term * term) list * thm val def_subst: (term * term) list -> term -> term end; structure Normalizer : NORMALIZER = struct (* Keeps list of normalizers. *) structure Data = Theory_Data ( type T = normalizer Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge pointer_eq ) fun add_normalizer (norm_name, norm_fun) = Data.map (Symtab.update_new (norm_name, norm_fun)) (* Apply norm_fun: thm -> thm list to any PROP item. *) fun th_normalizer norm_fun ctxt ritem = case ritem of Handler _ => [ritem] | Fact (ty_str, _, th) => if ty_str = TY_PROP then map Update.thm_to_ritem (norm_fun ctxt th) else [ritem] fun add_th_normalizer (norm_name, norm_fun) = add_normalizer (norm_name, th_normalizer norm_fun) (* eq_th is a meta equality. *) fun rewr_normalizer eq_th ctxt ritem = let val cv = (Conv.top_conv (K (Conv.try_conv (Conv.rewr_conv eq_th))) ctxt) then_conv (Thm.beta_conversion true) in case ritem of Handler _ => [ritem] | Fact (ty_str, _, th) => if ty_str = TY_PROP then [Update.thm_to_ritem (apply_to_thm cv th)] else if ty_str = TY_EQ then if Util.is_meta_eq (Thm.prop_of th) then (* Equality between lambda terms *) [ritem] else let (* Apply to right side *) val th' = apply_to_thm' (Conv.arg_conv cv) th val (lhs, rhs) = dest_eq (prop_of' th') in [Fact (TY_EQ, [lhs, rhs], th')] end else [ritem] end fun add_rewr_normalizer (norm_name, eq_th) = add_normalizer (norm_name, rewr_normalizer eq_th) fun get_normalizers thy = Symtab.dest (Data.get thy) fun normalize ctxt ritem = let val norms = get_normalizers (Proof_Context.theory_of ctxt) fun apply_norm (_, norm_fun) ritems = maps (norm_fun ctxt) ritems val norm_once = fold apply_norm norms [ritem] in case norm_once of [ritem'] => if BoxItem.eq_ritem (ritem, ritem') then [ritem'] else normalize ctxt ritem' | _ => maps (normalize ctxt) norm_once end (* Perform normalization, but keep the original ritem. *) fun normalize_keep ctxt ritem = let val norm_ritems = normalize ctxt ritem in if length norm_ritems = 1 then norm_ritems else ritem :: norm_ritems end (* Normalization of variable definition *) structure InjStructData = Theory_Data ( type T = thm Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge pointer_eq ) fun add_inj_struct_data th thy = let val (lhs, _) = th |> prop_of' |> dest_eq |> fst |> dest_eq val (f, _) = Term.strip_comb lhs in case f of Const (nm, _) => InjStructData.map (Symtab.update_new (nm, th)) thy | _ => raise Fail "add_inj_struct_data" end (* Check whether t is of the form ?A = t, where t does not contain ?A. *) fun inj_args thy t = if Term.is_Var t then [t] else let val (f, args) = Term.strip_comb t in if Term.is_Const f andalso Symtab.defined (InjStructData.get thy) (Util.get_head_name f) then maps (inj_args thy) args else [t] end fun is_def_eq thy t = if not (is_eq_term t) then false else let val (lhs, rhs) = dest_eq t val (l_args, r_args) = apply2 (inj_args thy) (lhs, rhs) in forall Term.is_Var l_args andalso not (forall Term.is_Var r_args) andalso forall (fn t => not (Util.is_subterm t rhs)) l_args end fun is_def_eq' thy t = is_Trueprop t andalso is_def_eq thy (dest_Trueprop t) fun is_neg_def_eq thy t = is_neg t andalso is_def_eq thy (dest_not t) (* Given t of the form A_1 ==> ... ==> A_n ==> C, swap all A_i of the form ?A = t to the front. *) fun swap_eq_to_front ct = let val t = Thm.term_of ct val thy = Thm.theory_of_cterm ct in if Util.is_implies t then if is_def_eq' thy (dest_arg1 t) then Conv.all_conv ct else Conv.every_conv [Conv.arg_conv swap_eq_to_front, Conv.rewr_conv Drule.swap_prems_eq] ct else Conv.no_conv ct end (* Given th where the first premise is in the form ?A = t, or f ?A_1 ... ?A_n = t, where f is injective, replace ?A or each ?A_i in the rest of th, and remove the first premise. *) fun meta_use_vardef th = if not (Util.is_implies (Thm.prop_of th)) then ([], th) else let val cprem = th |> Thm.cprop_of |> Thm.dest_arg1 |> Thm.dest_arg val prem = Thm.term_of cprem val thy = Thm.theory_of_thm th in if is_conj prem then th |> apply_to_thm (Conv.rewr_conv (meta_sym @{thm atomize_conjL})) |> meta_use_vardef else if is_def_eq thy prem then let val (c_lhs, c_rhs) = cdest_eq cprem val (lhs, rhs) = dest_eq prem in if Term.is_Var lhs then let val (pairs, th') = th |> Util.subst_thm_atomic [(c_lhs, c_rhs)] |> apply_to_thm (Conv.arg1_conv UtilBase.to_meta_eq_cv) |> Thm.elim_implies (Thm.reflexive c_rhs) |> meta_use_vardef in ((lhs, rhs) :: pairs, th') end else let val nm = Util.get_head_name lhs val data = InjStructData.get thy val inj_th = the (Symtab.lookup data nm) handle Option.Option => raise Fail "meta_use_vardef" in th |> apply_to_thm ( Conv.arg1_conv (Conv.arg_conv (rewr_obj_eq inj_th))) |> meta_use_vardef end end else ([], th) end fun disj_ts t = if is_disj t then dest_arg1 t :: disj_ts (dest_arg t) else [t] fun swap_disj ct = Conv.every_conv [rewr_obj_eq (obj_sym UtilBase.disj_assoc_th), Conv.arg1_conv (rewr_obj_eq UtilBase.disj_commute_th), rewr_obj_eq UtilBase.disj_assoc_th] ct fun disj_swap_eq_to_front' ct = let val t = Thm.term_of ct val thy = Thm.theory_of_cterm ct in if is_disj t then if is_neg_def_eq thy (dest_arg1 t) then Conv.all_conv ct else if is_disj (dest_arg t) then Conv.every_conv [Conv.arg_conv disj_swap_eq_to_front', swap_disj] ct else if is_neg_def_eq thy (dest_arg t) then rewr_obj_eq UtilBase.disj_commute_th ct else Conv.no_conv ct else Conv.no_conv ct end fun disj_swap_eq_to_front ct = Conv.every_conv [ Trueprop_conv disj_swap_eq_to_front', Trueprop_conv (rewr_obj_eq (obj_sym UtilBase.imp_conv_disj_th)), Conv.rewr_conv (meta_sym UtilBase.atomize_imp_th) ] ct fun meta_use_vardefs th = let val thy = Thm.theory_of_thm th in if exists (is_def_eq' thy) (Thm.prems_of th) then let val (pairs, th') = th |> apply_to_thm swap_eq_to_front |> meta_use_vardef val (pairs', th'') = meta_use_vardefs th' in (pairs @ pairs', th'') end else if is_Trueprop (Thm.prop_of th) then let val ts = disj_ts (prop_of' th) in if length ts > 1 andalso exists (is_neg_def_eq thy) ts then let val (pairs, th') = th |> apply_to_thm disj_swap_eq_to_front |> meta_use_vardef val (pairs', th'') = meta_use_vardefs th' in (pairs @ pairs', th'') end else ([], th) end else ([], th) end fun def_subst pairs t = fold (fn p => Term.subst_atomic [p]) pairs t end (* structure Normalizer. *) diff --git a/thys/Auto2_HOL/proofsteps.ML b/thys/Auto2_HOL/proofsteps.ML --- a/thys/Auto2_HOL/proofsteps.ML +++ b/thys/Auto2_HOL/proofsteps.ML @@ -1,968 +1,967 @@ (* File: proofsteps.ML Author: Bohua Zhan Definition of type proofstep, and facility for adding basic proof steps. *) datatype proofstep_fn = OneStep of Proof.context -> box_item -> raw_update list | TwoStep of Proof.context -> box_item -> box_item -> raw_update list type proofstep = { name: string, args: match_arg list, func: proofstep_fn } datatype prfstep_descriptor = WithFact of term | WithItem of string * term | WithProperty of term | WithWellForm of term * term | WithScore of int | GetFact of term * thm | ShadowFirst | ShadowSecond | CreateCase of term | CreateConcl of term | Filter of prfstep_filter signature PROOFSTEP = sig val eq_prfstep: proofstep * proofstep -> bool val apply_prfstep: Proof.context -> box_item list -> proofstep -> raw_update list val WithGoal: term -> prfstep_descriptor val WithTerm: term -> prfstep_descriptor val WithProp: term -> prfstep_descriptor val string_of_desc: theory -> prfstep_descriptor -> string val string_of_descs: theory -> prfstep_descriptor list -> string (* prfstep_filter *) val all_insts: prfstep_filter val neq_filter: term -> prfstep_filter val order_filter: string -> string -> prfstep_filter val size1_filter: string -> prfstep_filter val not_type_filter: string -> typ -> prfstep_filter (* First level proofstep writing functions. *) val apply_pat_r: Proof.context -> id_inst_ths -> term * thm -> thm val retrieve_args: prfstep_descriptor list -> match_arg list val retrieve_pats_r: prfstep_descriptor list -> (term * thm) list val retrieve_filts: prfstep_descriptor list -> prfstep_filter val retrieve_cases: prfstep_descriptor list -> term list val retrieve_shadows: prfstep_descriptor list -> int list val get_side_ths: Proof.context -> id_inst -> match_arg list -> (box_id * thm list) list val prfstep_custom: string -> prfstep_descriptor list -> (id_inst_ths -> box_item list -> Proof.context -> raw_update list) -> proofstep val gen_prfstep: string -> prfstep_descriptor list -> proofstep val prfstep_pre_conv: string -> prfstep_descriptor list -> (Proof.context -> conv) -> proofstep val prfstep_conv: string -> prfstep_descriptor list -> conv -> proofstep end; structure ProofStep : PROOFSTEP = struct fun eq_prfstep (prfstep1, prfstep2) = (#name prfstep1 = #name prfstep2) fun apply_prfstep ctxt items {func, ...} = case func of OneStep f => f ctxt (the_single items) | TwoStep f => f ctxt (hd items) (nth items 1) fun WithGoal t = let val _ = assert (type_of t = boolT) "WithGoal: pat should have type bool." in WithFact (get_neg t) end fun WithTerm t = WithItem (TY_TERM, t) fun WithProp t = let val _ = assert (type_of t = boolT) "WithProp: pat should have type bool." in WithItem (TY_PROP, t) end fun string_of_desc thy desc = let val print = Syntax.string_of_term_global thy in case desc of WithFact t => if is_neg t then "WithGoal " ^ (print (get_neg t)) else "WithFact " ^ (print t) | WithItem (ty_str, t) => if ty_str = TY_TERM then "WithTerm " ^ (print t) else "WithItem " ^ ty_str ^ " " ^ (print t) | WithProperty t => "WithProperty " ^ (print t) | WithWellForm (_, req) => "WithWellForm " ^ (print req) | WithScore n => "WithScore " ^ (string_of_int n) | GetFact (t, th) => if t aconv @{term False} then "GetResolve " ^ (Util.name_of_thm th) else if is_neg t then "GetGoal (" ^ (print (get_neg t)) ^ ", " ^ (Util.name_of_thm th) ^ ")" else "GetFact (" ^ (print t) ^ ", " ^ (Util.name_of_thm th) ^ ")" | ShadowFirst => "Shadow first" | ShadowSecond => "Shadow second" | CreateCase assum => "CreateCase " ^ (print assum) | CreateConcl concl => "CreateConcl " ^ (print concl) | Filter _ => "Filter (...)" end fun string_of_descs thy descs = let fun is_filter desc = case desc of Filter _ => true | _ => false val (filts, non_filts) = filter_split is_filter descs in (cat_lines (map (string_of_desc thy) non_filts)) ^ (if length filts > 0 then (" + " ^ (string_of_int (length filts)) ^ " filters") else "") end (* prfstep_filter *) val all_insts = fn _ => fn _ => true fun neq_filter cond ctxt (id, inst) = let val (lhs, rhs) = cond |> dest_not |> dest_eq handle Fail "dest_not" => raise Fail "neq_filter: not an inequality." | Fail "dest_eq" => raise Fail "neq_filter: not an inequality." val _ = assert (null (Term.add_frees cond [])) "neq_filter: should not contain free variable." val t1 = Util.subst_term_norm inst lhs val t2 = Util.subst_term_norm inst rhs in if Util.has_vars t1 andalso Util.has_vars t2 then true else if Util.has_vars t1 then (Matcher.rewrite_match ctxt (t1, Thm.cterm_of ctxt t2) (id, fo_init)) |> filter (fn ((id', _), _) => id = id') |> null else if Util.has_vars t2 then (Matcher.rewrite_match ctxt (t2, Thm.cterm_of ctxt t1) (id, fo_init)) |> filter (fn ((id', _), _) => id = id') |> null else not (RewriteTable.is_equiv_t id ctxt (t1, t2)) end fun order_filter s1 s2 _ (_, inst) = not (Term_Ord.term_ord (lookup_inst inst s2, lookup_inst inst s1) = LESS) fun size1_filter s1 ctxt (id, inst) = size_of_term (RewriteTable.simp_val_t id ctxt (lookup_inst inst s1)) = 1 fun not_type_filter s ty _ (_, inst) = not (Term.fastype_of (lookup_inst inst s) = ty) (* First level proofstep writing functions. *) fun apply_pat_r ctxt ((_, inst), ths) (pat_r, th) = let val _ = assert (fastype_of pat_r = boolT) "apply_pat_r: pat_r should be of type bool" (* Split into meta equalities (usually produced by term matching, not applied to th, and others (assumptions for th). *) val (eqs, ths') = ths |> filter_split (Util.is_meta_eq o Thm.prop_of) val _ = assert (length ths' = Thm.nprems_of th) "apply_pat_r: wrong number of assumptions." val inst_new = Util.subst_term_norm inst (mk_Trueprop pat_r) val th' = th |> Util.subst_thm ctxt inst |> fold Thm.elim_implies ths' val _ = if inst_new aconv (Thm.prop_of th') then () else raise Fail "apply_pat_r: conclusion mismatch" (* Rewrite on subterms, top sweep order. *) fun rewr_top eq_th = Conv.top_sweep_rewrs_conv [eq_th] ctxt in th' |> apply_to_thm (Conv.every_conv (map rewr_top eqs)) end fun retrieve_args descs = maps (fn desc => case desc of WithFact t => [PropMatch t] | WithItem (ty_str, t) => [TypedMatch (ty_str, t)] | WithProperty t => [PropertyMatch t] | WithWellForm t => [WellFormMatch t] | _ => []) descs fun retrieve_pats_r descs = maps (fn desc => case desc of GetFact (pat_r, th) => [(pat_r, th)] | _ => []) descs fun retrieve_filts descs = let val filts = maps (fn Filter filt => [filt] | _ => []) descs in fn ctxt => fn inst => forall (fn f => f ctxt inst) filts end fun retrieve_cases descs = let fun retrieve_case desc = case desc of CreateCase assum => [mk_Trueprop assum] | CreateConcl concl => [mk_Trueprop (get_neg concl)] | _ => [] in maps retrieve_case descs end fun retrieve_shadows descs = let fun retrieve_shadow desc = case desc of ShadowFirst => [0] | ShadowSecond => [1] | _ => [] in maps retrieve_shadow descs end fun retrieve_score descs = let fun retrieve_score desc = case desc of WithScore n => SOME n | _ => NONE in get_first retrieve_score descs end (* Given list of PropertyMatch and WellFormMatch arguments, attempt to find the corresponding theorems in the rewrite table. Return the list of theorems for each possible (mutually non-comparable) box IDs. *) fun get_side_ths ctxt (id, inst) side_args = if null side_args then [(id, [])] else let val side_args' = map (ItemIO.subst_arg inst) side_args fun process_side_arg side_arg = case side_arg of PropertyMatch prop => PropertyData.get_property_t ctxt (id, prop) | WellFormMatch (t, req) => (WellformData.get_wellform_t ctxt (id, t)) |> filter (fn (_, th) => prop_of' th aconv req) | _ => raise Fail "get_side_ths: wrong kind of arg." val side_ths = map process_side_arg side_args' in if exists null side_ths then [] else side_ths |> BoxID.get_all_merges_info ctxt |> Util.max_partial (BoxID.id_is_eq_ancestor ctxt) end (* Creates a proofstep with specified patterns and filters (in descs), and a custom function converting any instantiations into updates. *) fun prfstep_custom name descs updt_fn = let val args = retrieve_args descs val (item_args, side_args) = filter_split ItemIO.is_ordinary_match args val filt = retrieve_filts descs val shadows = retrieve_shadows descs (* Processing an instantiation after matching the one or two main matchers: apply filters, remove trivial True from matchings, find properties, and replace incremental ids. *) fun process_inst ctxt ((id, inst), ths) = (get_side_ths ctxt (id, inst) side_args) |> filter (BoxID.has_incr_id o fst) |> map (fn (id', p_ths) => ((id', inst), p_ths @ ths)) |> filter (filt ctxt o fst) fun shadow_to_update items ((id, _), _) n = ShadowItem {id = id, item = nth items n} in if length item_args = 1 then let val arg = the_single item_args fun prfstep ctxt item = let val inst_ths = (ItemIO.match_arg ctxt arg item ([], fo_init)) |> map (fn (inst, th) => (inst, [th])) |> maps (process_inst ctxt) fun process_inst inst_th = updt_fn inst_th [item] ctxt @ map (shadow_to_update [item] inst_th) shadows in maps process_inst inst_ths end in {name = name, args = args, func = OneStep prfstep} end else if length item_args = 2 then let val (arg1, arg2) = the_pair item_args fun prfstep1 ctxt item1 = let val inst_ths = ItemIO.match_arg ctxt arg1 item1 ([], fo_init) fun process_inst1 item2 ((id, inst), th) = let val arg2' = ItemIO.subst_arg inst arg2 val inst_ths' = (ItemIO.match_arg ctxt arg2' item2 (id, inst)) |> map (fn (inst', th') => (inst', [th, th'])) |> maps (process_inst ctxt) fun process_inst inst_th' = updt_fn inst_th' [item1, item2] ctxt @ map (shadow_to_update [item1, item2] inst_th') shadows in maps process_inst inst_ths' end in fn item2 => maps (process_inst1 item2) inst_ths end in {name = name, args = args, func = TwoStep prfstep1} end else raise Fail "prfstep_custom: must have 1 or 2 patterns." end (* Create a proofstep from a list of proofstep descriptors. See datatype prfstep_descriptor for allowed types of descriptors. *) fun gen_prfstep name descs = let val args = retrieve_args descs val pats_r = retrieve_pats_r descs val cases = retrieve_cases descs val sc = retrieve_score descs val input_descs = filter (fn desc => case desc of GetFact _ => false | CreateCase _ => false | CreateConcl _ => false | _ => true) descs (* Verify that all schematic variables appearing in pats_r / cases appear in pats. *) val pats = map ItemIO.pat_of_match_arg args val vars = map Var (fold Term.add_vars pats []) fun check_pat_r (pat_r, _) = subset (op aconv) (map Var (Term.add_vars pat_r []), vars) fun check_case assum = subset (op aconv) (map Var (Term.add_vars assum []), vars) val _ = assert (forall check_pat_r pats_r andalso forall check_case cases) "gen_prfstep: new schematic variable in pats_r / cases." fun pats_r_to_update ctxt (inst_ths as ((id, _), _)) = if null pats_r then [] else let val ths = map (apply_pat_r ctxt inst_ths) pats_r in if length ths = 1 andalso Thm.prop_of (the_single ths) aconv pFalse then [ResolveBox {id = id, th = the_single ths}] else [AddItems {id = id, sc = sc, raw_items = map Update.thm_to_ritem ths}] end fun case_to_update ((id, inst), _) assum = AddBoxes {id = id, sc = sc, init_assum = Util.subst_term_norm inst assum} fun cases_to_update inst_ths = map (case_to_update inst_ths) cases fun updt_fn inst_th _ ctxt = pats_r_to_update ctxt inst_th @ cases_to_update inst_th in prfstep_custom name input_descs updt_fn end fun prfstep_pre_conv name descs pre_cv = let val args = retrieve_args descs val _ = case args of [TypedMatch ("TERM", _)] => () | _ => raise Fail ("prfstep_conv: should have exactly one " ^ "term pattern.") val filt = retrieve_filts descs fun prfstep ctxt item = let val inst_ths = (ItemIO.match_arg ctxt (the_single args) item ([], fo_init)) |> filter (BoxID.has_incr_id o fst o fst) |> filter (filt ctxt o fst) fun inst_to_updt ((id, _), eq1) = (* Here eq1 is meta_eq from pat(inst) to item. *) let val ct = Thm.lhs_of eq1 val err = name ^ ": cv failed." val eq_th = pre_cv ctxt ct handle CTERM _ => raise Fail err in if Thm.is_reflexive eq_th then [] else if RewriteTable.is_equiv id ctxt (Thm.rhs_of eq1, Thm.rhs_of eq_th) then [] else let val th = to_obj_eq (Util.transitive_list [meta_sym eq1, eq_th]) in [Update.thm_update (id, th)] end end in maps inst_to_updt inst_ths end in {name = name, args = args, func = OneStep prfstep} end fun prfstep_conv name descs cv = prfstep_pre_conv name descs (K cv) end (* structure ProofStep *) val WithTerm = ProofStep.WithTerm val WithGoal = ProofStep.WithGoal val WithProp = ProofStep.WithProp val neq_filter = ProofStep.neq_filter val order_filter = ProofStep.order_filter val size1_filter = ProofStep.size1_filter val not_type_filter = ProofStep.not_type_filter signature PROOFSTEP_DATA = sig val add_prfstep: proofstep -> theory -> theory val del_prfstep_pred: (string -> bool) -> theory -> theory val del_prfstep: string -> theory -> theory val del_prfstep_thm: thm -> theory -> theory val del_prfstep_thm_str: string -> thm -> theory -> theory val del_prfstep_thm_eqforward: thm -> theory -> theory val get_prfsteps: theory -> proofstep list val add_prfstep_custom: (string * prfstep_descriptor list * (id_inst_ths -> box_item list -> Proof.context -> raw_update list)) -> theory -> theory val add_gen_prfstep: string * prfstep_descriptor list -> theory -> theory val add_prfstep_pre_conv: string * prfstep_descriptor list * (Proof.context -> conv) -> theory -> theory val add_prfstep_conv: string * prfstep_descriptor list * conv -> theory -> theory (* Constructing conditional prfstep_descriptors. *) type pre_prfstep_descriptor = Proof.context -> prfstep_descriptor val with_term: string -> pre_prfstep_descriptor val with_cond: string -> pre_prfstep_descriptor val with_conds: string list -> pre_prfstep_descriptor list val with_filt: prfstep_filter -> pre_prfstep_descriptor val with_filts: prfstep_filter list -> pre_prfstep_descriptor list val with_score: int -> pre_prfstep_descriptor (* Second level proofstep writing functions. *) datatype prfstep_mode = MODE_FORWARD | MODE_FORWARD' | MODE_BACKWARD | MODE_BACKWARD1 | MODE_BACKWARD2 | MODE_RESOLVE val add_prfstep_check_req: string * string -> theory -> theory val add_forward_prfstep_cond: thm -> pre_prfstep_descriptor list -> theory -> theory val add_forward'_prfstep_cond: thm -> pre_prfstep_descriptor list -> theory -> theory val add_backward_prfstep_cond: thm -> pre_prfstep_descriptor list -> theory -> theory val add_backward1_prfstep_cond: thm -> pre_prfstep_descriptor list -> theory -> theory val add_backward2_prfstep_cond: thm -> pre_prfstep_descriptor list -> theory -> theory val add_resolve_prfstep_cond: thm -> pre_prfstep_descriptor list -> theory -> theory val add_forward_prfstep: thm -> theory -> theory val add_forward'_prfstep: thm -> theory -> theory val add_backward_prfstep: thm -> theory -> theory val add_backward1_prfstep: thm -> theory -> theory val add_backward2_prfstep: thm -> theory -> theory val add_resolve_prfstep: thm -> theory -> theory val add_rewrite_rule_cond: thm -> pre_prfstep_descriptor list -> theory -> theory val add_rewrite_rule_back_cond: thm -> pre_prfstep_descriptor list -> theory -> theory val add_rewrite_rule_bidir_cond: thm -> pre_prfstep_descriptor list -> theory -> theory val add_rewrite_rule: thm -> theory -> theory val add_rewrite_rule_back: thm -> theory -> theory val add_rewrite_rule_bidir: thm -> theory -> theory val setup_attrib: (thm -> theory -> theory) -> attribute context_parser end; structure ProofStepData : PROOFSTEP_DATA = struct structure Data = Theory_Data ( type T = proofstep list; val empty = []; - val extend = I; fun merge (ps1, ps2) = Library.merge ProofStep.eq_prfstep (ps1, ps2) ) (* Add the given proof step. *) fun add_prfstep (prfstep as {args, ...}) = Data.map (fn prfsteps => if Util.is_prefix_str "$" (#name prfstep) then error "Add prfstep: names beginning with $ is reserved." else let val num_args = length (filter_out ItemIO.is_side_match args) in if num_args >= 1 andalso num_args <= 2 then prfsteps @ [prfstep] else error "add_proofstep: need 1 or 2 patterns." end) (* Deleting a proofstep. For string inputs, try adding theory name. For theorem inputs, try all @-suffixes. *) fun del_prfstep_pred pred = Data.map (fn prfsteps => let val names = map #name prfsteps val to_delete = filter pred names fun eq_name (key, {name, ...}) = (key = name) in if null to_delete then error "Delete prfstep: not found" else let val _ = writeln (cat_lines (map (fn name => "Delete " ^ name) to_delete)) in subtract eq_name to_delete prfsteps end end) fun del_prfstep prfstep_name thy = del_prfstep_pred (equal prfstep_name) thy (* Delete all proofsteps for a given theorem. *) fun del_prfstep_thm th = let val th_name = Util.name_of_thm th in del_prfstep_pred (equal th_name orf Util.is_prefix_str (th_name ^ "@")) end (* Delete proofsteps for a given theorem, with the given postfix. *) fun del_prfstep_thm_str str th = del_prfstep_pred (equal (Util.name_of_thm th ^ str)) val del_prfstep_thm_eqforward = del_prfstep_thm_str "@eqforward" fun get_prfsteps thy = Data.get thy fun add_prfstep_custom (name, descs, updt_fn) = add_prfstep (ProofStep.prfstep_custom name descs updt_fn) fun add_gen_prfstep (name, descs) = add_prfstep (ProofStep.gen_prfstep name descs) fun add_prfstep_pre_conv (name, descs, pre_cv) = add_prfstep (ProofStep.prfstep_pre_conv name descs pre_cv) fun add_prfstep_conv (name, descs, cv) = add_prfstep (ProofStep.prfstep_conv name descs cv) (* Constructing conditional prfstep_descriptors. *) type pre_prfstep_descriptor = Proof.context -> prfstep_descriptor fun with_term str ctxt = let val t = Proof_Context.read_term_pattern ctxt str val _ = assert (null (Term.add_frees t [])) "with_term: should not contain free variable." in WithTerm t end fun with_cond str ctxt = Filter (neq_filter (Proof_Context.read_term_pattern ctxt str)) fun with_conds strs = map with_cond strs fun with_filt filt = K (Filter filt) fun with_filts filts = map with_filt filts fun with_score n = K (WithScore n) (* Second level proofstep writing functions. *) fun add_and_print_prfstep prfstep_name descs thy = let val _ = writeln (prfstep_name ^ "\n" ^ (ProofStep.string_of_descs thy descs)) in add_gen_prfstep (prfstep_name, descs) thy end (* Add a proofstep checking a requirement. *) fun add_prfstep_check_req (t_str, req_str) thy = let val ctxt = Proof_Context.init_global thy val t = Proof_Context.read_term_pattern ctxt t_str val vars = map Free (Term.add_frees t []) val c = Util.get_head_name t val ctxt' = fold Util.declare_free_term vars ctxt val req = Proof_Context.read_term_pattern ctxt' req_str fun get_subst var = case var of Free (x, T) => (var, Var ((x, 0), T)) | _ => raise Fail "add_prfstep_check_req" val subst = map get_subst vars val t' = Term.subst_atomic subst t val req' = Term.subst_atomic subst req in add_and_print_prfstep (c ^ "_case") [WithTerm t', CreateConcl req'] thy end datatype prfstep_mode = MODE_FORWARD | MODE_FORWARD' | MODE_BACKWARD | MODE_BACKWARD1 | MODE_BACKWARD2 | MODE_RESOLVE (* Maximum number of term matches for the given mode. *) fun max_term_matches mode = case mode of MODE_FORWARD => 2 | MODE_FORWARD' => 1 | MODE_BACKWARD => 1 | MODE_RESOLVE => 1 | _ => 0 (* Obtain the first several premises of th that are either properties or wellformed-ness data. ts is the list of term matches. *) fun get_side_prems thy mode ts th = let val (prems, concl) = UtilLogic.strip_horn' th val _ = assert (length ts <= max_term_matches mode) "get_side_prems: too many term matches." (* Helper function. Consider the case where the first n premises are side conditions. Find the additional terms to match against for each mode. *) fun additional_matches n = let val prems' = drop n prems in case mode of MODE_FORWARD => take (2 - length ts) prems' | MODE_FORWARD' => if null ts andalso length prems' >= 2 then [hd prems', List.last prems'] else [List.last prems'] | MODE_BACKWARD => [get_neg concl] | MODE_BACKWARD1 => [get_neg concl, List.last prems'] | MODE_BACKWARD2 => [get_neg concl, hd prems'] | MODE_RESOLVE => if null ts andalso length prems' > 0 then [get_neg concl, List.last prems'] else [get_neg concl] end (* Determine whether t is a valid side premises, relative to the matches ts'. If yes, return the corresponding side matching. Otherwise return NONE. *) fun to_side_prems ts' t = case WellForm.is_subterm_wellform_data thy t ts' of SOME (t, req) => SOME (WithWellForm (t, req)) | NONE => if Property.is_property_prem thy t then SOME (WithProperty t) else NONE (* Attempt to convert the first n premises to side matchings. *) fun to_side_prems_n n = let val ts' = additional_matches n @ ts val side_prems' = prems |> take n |> map (to_side_prems ts') in if forall is_some side_prems' then SOME (map the side_prems') else NONE end (* Minimum number of premises for the given mode. *) val min_prems = case mode of MODE_FORWARD => 1 - length ts | MODE_FORWARD' => 1 | MODE_BACKWARD => 1 | MODE_BACKWARD1 => 2 | MODE_BACKWARD2 => 2 | MODE_RESOLVE => 0 val _ = assert (length prems >= min_prems) "get_side_prems: too few premises." val to_test = rev (0 upto (length prems - min_prems)) in (* Always succeeds at 0. *) the (get_first to_side_prems_n to_test) end (* Convert theorems of the form A1 ==> ... ==> An ==> C to A1 & ... & An ==> C. If keep_last = true, the last assumption is kept in implication form. *) fun atomize_conj_cv keep_last ct = if length (Logic.strip_imp_prems (Thm.term_of ct)) <= (if keep_last then 2 else 1) then Conv.all_conv ct else Conv.every_conv [Conv.arg_conv (atomize_conj_cv keep_last), Conv.rewr_conv UtilBase.atomize_conjL_th] ct (* Swap the last premise to become the first. *) fun swap_prem_to_front ct = let val n = length (Logic.strip_imp_prems (Thm.term_of ct)) in if n < 2 then Conv.all_conv ct else if n = 2 then Conv.rewr_conv Drule.swap_prems_eq ct else ((Conv.arg_conv swap_prem_to_front) then_conv (Conv.rewr_conv Drule.swap_prems_eq)) ct end (* Using cv, rewrite all assumptions and conclusion in ct. *) fun horn_conv cv ct = (case Thm.term_of ct of @{const Pure.imp} $ _ $ _ => (Conv.arg1_conv (Trueprop_conv cv)) then_conv (Conv.arg_conv (horn_conv cv)) | _ => Trueprop_conv cv) ct (* Try to cancel terms of the form ~~A. *) val try_nn_cancel_cv = Conv.try_conv (rewr_obj_eq UtilBase.nn_cancel_th) (* Post-processing of the given theorem according to mode. *) fun post_process_th ctxt mode side_count ts th = case mode of MODE_FORWARD => let val to_skip = side_count + (2 - length ts) in th |> apply_to_thm (Util.skip_n_conv to_skip (UtilLogic.to_obj_conv ctxt)) |> Util.update_name_of_thm th "" end | MODE_FORWARD' => let val cv = swap_prem_to_front then_conv (Util.skip_n_conv (2 - length ts) (UtilLogic.to_obj_conv ctxt)) in th |> apply_to_thm (Util.skip_n_conv side_count cv) |> Util.update_name_of_thm th "" end | MODE_BACKWARD => let val cv = (atomize_conj_cv false) then_conv (Conv.rewr_conv UtilBase.backward_conv_th) then_conv (horn_conv try_nn_cancel_cv) in th |> apply_to_thm (Util.skip_n_conv side_count cv) |> Util.update_name_of_thm th "@back" end | MODE_BACKWARD1 => let val cv = (atomize_conj_cv true) then_conv (Conv.rewr_conv UtilBase.backward1_conv_th) then_conv (horn_conv try_nn_cancel_cv) in th |> apply_to_thm (Util.skip_n_conv side_count cv) |> Util.update_name_of_thm th "@back1" end | MODE_BACKWARD2 => let val cv = (Conv.arg_conv (atomize_conj_cv false)) then_conv (Conv.rewr_conv UtilBase.backward2_conv_th) then_conv (horn_conv try_nn_cancel_cv) in th |> apply_to_thm (Util.skip_n_conv side_count cv) |> Util.update_name_of_thm th "@back2" end | MODE_RESOLVE => let val rewr_th = case Thm.nprems_of th - side_count of 0 => if is_neg (concl_of' th) then UtilBase.to_contra_form_th' else UtilBase.to_contra_form_th | 1 => UtilBase.resolve_conv_th | _ => raise Fail "resolve: too many hypothesis in th." val cv = (Conv.rewr_conv rewr_th) then_conv (horn_conv try_nn_cancel_cv) in th |> apply_to_thm (Util.skip_n_conv side_count cv) |> Util.update_name_of_thm th "@res" end (* Add basic proofstep for the given theorem and mode. *) fun add_basic_prfstep_cond th mode conds thy = let val ctxt = Proof_Context.init_global thy val ctxt' = ctxt |> Variable.declare_term (Thm.prop_of th) (* Replace variable definitions, obtaining list of replacements and the new theorem. *) val (pairs, th) = th |> apply_to_thm (UtilLogic.to_obj_conv_on_horn ctxt') |> Normalizer.meta_use_vardefs |> apsnd (Util.update_name_of_thm th "") (* List of definitions used. *) fun print_def_subst (lhs, rhs) = writeln ("Apply def " ^ (Syntax.string_of_term ctxt' lhs) ^ " = " ^ (Syntax.string_of_term ctxt' rhs)) val _ = map print_def_subst pairs fun def_subst_fun cond = case cond of WithItem ("TERM", t) => WithItem ("TERM", Normalizer.def_subst pairs t) | _ => cond in if null conds andalso (mode = MODE_FORWARD orelse mode = MODE_FORWARD') andalso Property.can_add_property_update th thy then Property.add_property_update th thy else let fun is_term_cond cond = case cond of WithItem ("TERM", _) => true | _ => false fun extract_term_cond cond = case cond of WithItem ("TERM", t) => t | _ => raise Fail "extract_term_cond" (* Instantiate each element of conds with ctxt', then separate into term and other (filter and shadow) conds. *) val (term_conds, filt_conds) = conds |> map (fn cond => cond ctxt') |> filter_split is_term_cond |> apfst (map def_subst_fun) (* Get list of assumptions to be obtained from either the property table or the wellform table. *) val ts = map extract_term_cond term_conds val side_prems = get_side_prems thy mode ts th val side_count = length side_prems val th' = th |> post_process_th ctxt' mode side_count ts val (assums, concl) = th' |> UtilLogic.strip_horn' |> apfst (drop side_count) val pats = map extract_term_cond term_conds @ assums val match_descs = term_conds @ map WithFact assums val _ = assert (Util.is_pattern_list pats) "add_basic_prfstep: invalid patterns." val _ = assert (length pats > 0 andalso length pats <= 2) "add_basic_prfstep: invalid number of patterns." in (* Switch two assumptions if necessary. *) if length pats = 2 andalso not (Util.is_pattern (hd pats)) then let val _ = writeln "Switching two patterns." val swap_prems_cv = Conv.rewr_conv Drule.swap_prems_eq val th'' = if length assums = 1 then th' else th' |> apply_to_thm (Util.skip_n_conv side_count swap_prems_cv) |> Util.update_name_of_thm th' "" val swap_match_descs = [nth match_descs 1, hd match_descs] val descs = side_prems @ swap_match_descs @ filt_conds @ [GetFact (concl, th'')] in add_and_print_prfstep (Util.name_of_thm th') descs thy end else let val descs = side_prems @ match_descs @ filt_conds @ [GetFact (concl, th')] in add_and_print_prfstep (Util.name_of_thm th') descs thy end end end fun add_forward_prfstep_cond th = add_basic_prfstep_cond th MODE_FORWARD fun add_forward'_prfstep_cond th = add_basic_prfstep_cond th MODE_FORWARD' fun add_backward_prfstep_cond th = add_basic_prfstep_cond th MODE_BACKWARD fun add_backward1_prfstep_cond th = add_basic_prfstep_cond th MODE_BACKWARD1 fun add_backward2_prfstep_cond th = add_basic_prfstep_cond th MODE_BACKWARD2 fun add_resolve_prfstep_cond th = add_basic_prfstep_cond th MODE_RESOLVE fun add_forward_prfstep th = add_forward_prfstep_cond th [] fun add_forward'_prfstep th = add_forward'_prfstep_cond th [] fun add_backward_prfstep th = add_backward_prfstep_cond th [] fun add_backward1_prfstep th = add_backward1_prfstep_cond th [] fun add_backward2_prfstep th = add_backward2_prfstep_cond th [] fun add_resolve_prfstep th = add_resolve_prfstep_cond th [] fun add_rewrite_eq_rule_cond th conds thy = let val th = if Util.is_meta_eq (Thm.concl_of th) then UtilLogic.to_obj_eq_th th else th val (lhs, _) = th |> concl_of' |> strip_conj |> hd |> dest_eq in thy |> add_forward_prfstep_cond th (K (WithTerm lhs) :: conds) end fun add_rewrite_iff_rule_cond th conds thy = let val th = if Util.is_meta_eq (Thm.concl_of th) then UtilLogic.to_obj_eq_iff_th th else th val (lhs, _) = th |> concl_of' |> dest_eq val _ = assert (fastype_of lhs = boolT) "add_rewrite_iff: argument not of type bool." val forward_th = th |> equiv_forward_th val nforward_th = th |> inv_backward_th |> apply_to_thm (horn_conv try_nn_cancel_cv) |> Util.update_name_of_thm th "@invbackward" in thy |> add_basic_prfstep_cond forward_th MODE_FORWARD' conds |> add_basic_prfstep_cond nforward_th MODE_FORWARD' conds end fun add_rewrite_rule_cond th conds thy = let val th = if Util.is_meta_eq (Thm.concl_of th) then to_obj_eq_th th else th val (lhs, _) = th |> concl_of' |> strip_conj |> hd |> dest_eq in if fastype_of lhs = boolT then add_rewrite_iff_rule_cond th conds thy else add_rewrite_eq_rule_cond th conds thy end fun add_rewrite_rule_back_cond th conds = add_rewrite_rule_cond (obj_sym_th th) conds fun add_rewrite_rule_bidir_cond th conds = (add_rewrite_rule_cond th conds) #> add_rewrite_rule_back_cond th conds fun add_rewrite_rule th = add_rewrite_rule_cond th [] fun add_rewrite_rule_back th = add_rewrite_rule_back_cond th [] fun add_rewrite_rule_bidir th = add_rewrite_rule th #> add_rewrite_rule_back th fun setup_attrib f = Attrib.add_del (Thm.declaration_attribute ( fn th => Context.mapping (f th) I)) (Thm.declaration_attribute ( fn _ => fn _ => raise Fail "del_step: not implemented.")) end (* structure ProofStepData. *) open ProofStepData diff --git a/thys/Auto2_HOL/property.ML b/thys/Auto2_HOL/property.ML --- a/thys/Auto2_HOL/property.ML +++ b/thys/Auto2_HOL/property.ML @@ -1,258 +1,255 @@ (* File: property.ML Author: Bohua Zhan Theory data for properties. This data consists of the following parts: - Two tables containing property update rules. - A table containing list of fields that can have properties. *) signature PROPERTY = sig val is_property: term -> bool val add_property_field_const: term -> theory -> theory val is_property_field: theory -> term -> bool val strip_property_field: theory -> term -> term list val is_property_prem: theory -> term -> bool val get_property_name: term -> string val get_property_names: term list -> string list val get_property_arg: term -> term val get_property_arg_th: thm -> cterm (* About the PropertyUpdateData table.*) val can_add_property_update: thm -> theory -> bool val add_property_update: thm -> theory -> theory val lookup_property_update: theory -> string -> thm list val lookup_property_update_fun: theory -> string -> thm list val instantiate_property_update: Proof.context -> term -> thm -> thm option end; structure Property : PROPERTY = struct (* Rules deriving new properties of t from other properties of t. They are indexed under the names of the properties in the premises. *) structure UpdateData = Theory_Data ( type T = (thm list) Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge_list Thm.eq_thm_prop ) (* Rules for deriving properties of f x_1 ... x_n from properties of x_1, ... x_n. They are indexed under the name of the head function f. *) structure UpdateFunData = Theory_Data ( type T = (thm list) Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge_list Thm.eq_thm_prop ) (* Set of fields of a structure whose property can be considered as properties of the structure itself. Relevant when checking is_property_prem. *) structure FieldData = Theory_Data ( type T = unit Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge (K true) ) (* Whether the term is a property predicate applied to a term. *) fun is_property t = let val _ = assert (fastype_of t = boolT) "is_property: wrong type" val (f, ts) = Term.strip_comb t in if length ts <> 1 orelse not (Term.is_Const f) then false else let val T = fastype_of (the_single ts) val (dT, _) = Term.strip_type T in length dT = 0 andalso T <> boolT end end (* Insert the following constant as a property field. *) fun add_property_field_const t thy = case Term.head_of t of Const (c, T) => let val (pTs, _) = Term.strip_type T val _ = if length pTs = 1 then () else error "Add property field: input should be a field." val _ = writeln ("Add field " ^ c ^ " as property field.") in thy |> FieldData.map (Symtab.update_new (c, ())) end | _ => error "Add property field: input should be a constant." (* Whether the term is zero or more property field constants applied to a Var term. *) fun is_property_field thy t = case t of Var _ => true | Const (c, _) $ t' => Symtab.defined (FieldData.get thy) c andalso is_property_field thy t' | _ => false (* Given a term t, return all possible ways to strip property field constants from t. For example, if t is of the form f1(f2(x)), where f1 and f2 are property constants, then the result is [f1(f2(x)), f2(x), x]. *) fun strip_property_field thy t = case t of Const (c, _) $ t' => if Symtab.defined (FieldData.get thy) c then t :: strip_property_field thy t' else [t] | _ => [t] (* Stricter condition than is_property: the argument must be a schematic variable (up to property fields). *) fun is_property_prem thy t = is_property t andalso is_property_field thy (dest_arg t) val get_property_name = Util.get_head_name fun get_property_names ts = ts |> map get_property_name |> distinct (op =) (* Return the argument of the property. *) fun get_property_arg t = dest_arg t handle Fail "dest_arg" => raise Fail "get_property_arg: t in wrong form." (* Return the argument of the property theorem as a cterm. *) fun get_property_arg_th th = Thm.dest_arg (cprop_of' th) handle CTERM _ => raise Fail "get_property_carg" | Fail "dest_Trueprop" => raise Fail "get_property_carg" (* Add the given rule as a property update. The requirements on th is as follows: - The conclusion must be a property constant, with argument in the form of either ?x or f ?x1 ... ?xn. - Each premise must be a property constant on ?x (in the first case) or one of ?x1 ... ?xn (in the second case). The argument of the property in the conclusion must contain all schematic variables of the theorem. *) fun can_add_property_update th thy = let val (prems, concl) = UtilLogic.strip_horn' th in if is_property concl andalso forall (is_property_prem thy) prems then let val concl_arg = get_property_arg concl val all_vars = map Var (Term.add_vars (Thm.prop_of th) []) in if is_Var concl_arg then (* First case: check that concl_arg is the only schematic Var. *) length all_vars = 1 else (* Second case: concl_arg is of the form f ?x1 ... ?xn. *) let val args = Util.dest_args concl_arg in forall is_Var args andalso subset (op aconv) (all_vars, args) end end else false end (* Add the given theorem as a property update rule. Choose which table to add the rule to. *) fun add_property_update th thy = let val (prems, concl) = UtilLogic.strip_horn' th val _ = assert (is_property concl) "add_property_update: concl must be a property constant." val _ = assert (forall (is_property_prem thy) prems) "add_property_update: prem must be a property premise." val concl_arg = get_property_arg concl val all_vars = map Var (Term.add_vars (Thm.prop_of th) []) in if is_Var concl_arg then (* First case. Each premise must also be about ?x. Add to UpdateData table under the names of the predicates. *) let val _ = assert (length all_vars = 1) "add_property_update: extraneous Vars in th." val names = get_property_names prems val _ = writeln ("Add property rule for " ^ (Util.string_of_list I names)) in thy |> UpdateData.map ( fold (Symtab.update_list Thm.eq_thm_prop) (map (rpair th) names)) end else (* Second case. concl_arg in the form f ?x1 ... ?xn. Add to UpdateFunData table under f. *) let val (f, args) = Term.strip_comb concl_arg val c = case f of Const (c, _) => c | _ => raise Fail "add_property_update: f is not constant." val _ = assert (forall is_Var args) "add_property_update: all args of concl must be Vars." val _ = assert (subset (op aconv) (all_vars, args)) "add_property_update: extraneous Vars in th." val _ = writeln ("Add property rule for function " ^ c) in thy |> UpdateFunData.map (Symtab.update_list Thm.eq_thm_prop (c, th)) end end (* Find update rules of the form P1 x ==> ... ==> Pn x ==> P x, where c is one of P1, ... Pn. *) fun lookup_property_update thy c = Symtab.lookup_list (UpdateData.get thy) c (* Find update rules of the form A1 ==> ... ==> An ==> P(f(x1,...,xn)), where each A_i is a property on one of x_j. Here c is the name of f. *) fun lookup_property_update_fun thy c = Symtab.lookup_list (UpdateFunData.get thy) c (* Instantiate th by matching t with the argument of the conclusion of th. Return NONE if instantiation is unsuccessful (because type does not match). *) fun instantiate_property_update ctxt t th = let val (_, concl) = UtilLogic.strip_horn' th val concl_arg = get_property_arg concl val thy = Proof_Context.theory_of ctxt in if Sign.typ_instance thy (fastype_of t, fastype_of concl_arg) then let val err_str = "instantiate_property_update: cannot match with t." val inst = Pattern.first_order_match thy (concl_arg, t) fo_init handle Pattern.MATCH => raise Fail err_str in SOME (Util.subst_thm ctxt inst th) end else NONE end end (* structure Property. *) val add_property_field_const = Property.add_property_field_const diff --git a/thys/Auto2_HOL/wellform.ML b/thys/Auto2_HOL/wellform.ML --- a/thys/Auto2_HOL/wellform.ML +++ b/thys/Auto2_HOL/wellform.ML @@ -1,138 +1,137 @@ (* File: wellform.ML Author: Bohua Zhan Wellformed-ness of terms. *) signature WELLFORM = sig val register_wellform_data: string * string list -> theory -> theory val lookup_wellform_data: theory -> term -> term list val is_subterm_wellform_data': theory -> term -> term -> (term * term) option val is_subterm_wellform_data: theory -> term -> term list -> (term * term) option val lookup_wellform_pattern: theory -> term * term -> (term * term) option end; structure WellForm : WELLFORM = struct (* Each entry in the table consists of a term of the form f ?a_1 ... ?a_n, where f is a constant, and each ?a_i is a pure schematic variable, paired with a list of requirements for the term to be valid. It is indexed under the string of the constant f. *) structure Data = Theory_Data ( type T = (term * term list) Symtab.table val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge (op =) ) (* Add a term with its requirements to the table. *) fun register_wellform_data (t_str, req_strs) thy = let val ctxt = Proof_Context.init_global thy val t = Proof_Context.read_term_pattern ctxt t_str val ctxt' = Variable.declare_term t ctxt val reqs = map (Proof_Context.read_term_pattern ctxt') req_strs val (f, args) = Term.strip_comb t val _ = assert (Term.is_Const f) "add_wellform_data: head must be Const." val _ = assert (forall Term.is_Free args) "add_wellform_data: arguments must be Free." val (c, _) = Term.dest_Const f in thy |> Data.map (Symtab.update_new (c, (t, reqs))) end (* Lookup table for the given term t. If nothing is found, return the empty list by default. *) fun lookup_wellform_data thy t = let val (f, args) = Term.strip_comb t val data = Data.get thy in case f of Const (c, _) => (case Symtab.lookup data c of NONE => [] | SOME (t', reqs) => let val (_, vars) = Term.strip_comb t' in if length vars <> length args then [] else let val tys = map fastype_of vars ~~ map fastype_of args val tyinst = fold (Sign.typ_match thy) tys Vartab.empty val vars' = map (Envir.subst_term_types tyinst) vars fun subst_fun req = req |> Envir.subst_term_types tyinst |> Term.subst_atomic (vars' ~~ args) in distinct (op aconv) (map subst_fun reqs) end handle Type.TYPE_MATCH => [] end) | _ => [] end (* Check whether req is part of the wellformed-ness data of a subterm of t. If so, return the pair SOME (t', req), where t' is a subterm of t and req is a wellformed-ness data of t'. Otherwise return NONE. *) fun is_subterm_wellform_data' thy req t = if member (op aconv) (lookup_wellform_data thy t) req then SOME (t, req) else let val (_, args) = Term.strip_comb t in get_first (is_subterm_wellform_data' thy req) args end fun is_subterm_wellform_data thy req ts = get_first (is_subterm_wellform_data' thy req) ts (* Given a term t and wellform data for t, return the relevant wellform pattern. *) fun lookup_wellform_pattern thy (t, wf_t) = let val (f, args) = Term.strip_comb t val data = Data.get thy in case f of Const (c, _) => (case Symtab.lookup data c of NONE => NONE | SOME (t', reqs) => let val (_, vars) = Term.strip_comb t' in if length vars <> length args then NONE else let val tys = map fastype_of vars ~~ map fastype_of args val tyinst = fold (Sign.typ_match thy) tys Vartab.empty val vars' = map (Envir.subst_term_types tyinst) vars fun subst_fun t = t |> Envir.subst_term_types tyinst |> Term.subst_atomic (vars' ~~ args) val reqs' = filter (fn req => wf_t aconv subst_fun req) reqs in case reqs' of [] => NONE | req' :: _ => SOME (apply2 (Envir.subst_term_types tyinst) (t', req')) end end) | _ => NONE end end (* structure WellForm. *) val register_wellform_data = WellForm.register_wellform_data diff --git a/thys/Auto2_Imperative_HOL/Imperative/assn_matcher.ML b/thys/Auto2_Imperative_HOL/Imperative/assn_matcher.ML --- a/thys/Auto2_Imperative_HOL/Imperative/assn_matcher.ML +++ b/thys/Auto2_Imperative_HOL/Imperative/assn_matcher.ML @@ -1,324 +1,323 @@ (* File: assn_matcher.ML Author: Bohua Zhan Matching of assertions. *) (* Given arguments ctxt (pat, t) (id, inst), match pat with t. Assume pat is not a product. Produce t ==> pat(s) or t ==> pat(s) * t' for those in AssnMatchData. Produce pat(s) or pat(s) * t' ==> t for those in AssnInvMatchData. *) type assn_matcher = Proof.context -> term * cterm -> id_inst -> id_inst_th list signature ASSN_MATCHER = sig val add_assn_matcher: assn_matcher -> theory -> theory val assn_match_term: Proof.context -> term * cterm -> id_inst -> id_inst_th list val assn_match_all: Proof.context -> term * cterm -> id_inst -> id_inst_th list val assn_match_strict: Proof.context -> term * cterm -> id_inst -> id_inst_th list val triv_assn_matcher: assn_matcher val emp_assn_matcher: assn_matcher val true_assn_matcher: assn_matcher val add_entail_matcher: thm -> theory -> theory val assn_match_single: Proof.context -> term * cterm -> id_inst -> id_inst_th list val add_assn_matcher_proofsteps: theory -> theory end (* Due to strange interaction between functors and Theory_Data, this must be put outside. *) structure MatchData = Theory_Data ( type T = assn_matcher list val empty = [] - val extend = I; - val merge = merge (op pointer_eq) + val merge = merge (op pointer_eq) (* FIXME !? *) ) functor AssnMatcher(SepUtil: SEP_UTIL): ASSN_MATCHER = struct open SepUtil (* Matching in the forward direction *) fun add_assn_matcher matcher = MatchData.map (cons matcher) (* Assume pat is not in the form A * B. Match pat with one or more terms of t. Return theorem of form t ==> pat(s) * t'. *) fun assn_match_term ctxt (pat, ct) (id, inst) = let val _ = assert (not (Term.is_Var pat)) "assn_match_term: pat should not be Var." val thy = Proof_Context.theory_of ctxt fun apply_matcher matcher = matcher ctxt (pat, ct) (id, inst) (* th must be an entailment, and the right side must be pat(s), pat(s) * t', or t' * pat(s). *) fun process_res ((id, inst'), th) = let val _ = assert (is_entail (prop_of' th)) "assn_match_term" val (_, rhs) = th |> prop_of' |> dest_entail val exp_rhs = Util.subst_term_norm inst' pat in if rhs aconv exp_rhs then ((id, inst'), th |> apply_to_entail_r mult_emp_right) else if UtilArith.is_times rhs andalso dest_arg1 rhs aconv exp_rhs then ((id, inst'), th) else if UtilArith.is_times rhs andalso dest_arg rhs aconv exp_rhs then ((id, inst'), th |> apply_to_entail_r (ACUtil.comm_cv assn_ac_info)) else raise Fail "assn_match_term" end in (maps apply_matcher (MatchData.get thy)) |> map process_res end (* Match each term of pat with some term in t. Returns t ==> pat(s) * t'. *) fun assn_match_all ctxt (pat, ct) (id, inst) = if UtilArith.is_times pat then let val (A, B) = Util.dest_binop_args pat val insts = assn_match_all ctxt (A, ct) (id, inst) (* th is t ==> A(s) * t'. Match B(s) with t', with result t' ==> B(s) * t''. Produce t ==> (A(s) * B(s)) * t'' *) fun process_inst ((id', inst'), th) = let val ct' = th |> cprop_of' |> cdest_entail |> snd |> Thm.dest_arg val B' = Util.subst_term_norm inst' B val insts' = assn_match_all ctxt (B', ct') (id', inst') (* th' is t' ==> B(s) * t''. *) fun process_inst' ((id'', inst''), th') = let val res = ([th, th'] MRS entails_trans2_th) |> apply_to_entail_r ( ACUtil.assoc_sym_cv assn_ac_info) in ((id'', inst''), res) end in map process_inst' insts' end in maps process_inst insts end else assn_match_term ctxt (pat, ct) (id, inst) (* Guarantees that every term in t is matched. Returns t ==> pat(s). *) fun assn_match_strict ctxt (pat, ct) (id, inst) = let val inst = assn_match_all ctxt (pat, ct) (id, inst) fun process_inst ((id', inst'), th) = let val rhs = th |> prop_of' |> dest_entail |> snd val _ = assert (UtilArith.is_times rhs andalso dest_arg1 rhs aconv Util.subst_term_norm inst' pat) "assn_match_strict" in if dest_arg rhs aconv emp then [((id', inst'), th |> apply_to_entail_r reduce_emp_right)] else [] end in maps process_inst inst end (* Specific assertion matchers *) (* Matcher using the theorem A ==> A. *) fun triv_assn_matcher ctxt (pat, ct) (id, inst) = if pat aconv emp then [] (* leave to emp_assn_matcher *) else let val cts = ACUtil.cdest_ac assn_ac_info ct fun match_i i = let val ct' = nth cts i val insts = Matcher.rewrite_match ctxt (pat, ct') (id, inst) (* eq_th is of form pat(inst') == t'. *) fun process_inst ((id', inst'), eq_th) = let val th = entail_triv_th ctxt (Thm.term_of ct) val cv = Conv.every_conv [ ACUtil.move_outmost assn_ac_info (Thm.term_of ct'), ACUtil.ac_last_conv assn_ac_info (Conv.rewr_conv (meta_sym eq_th))] in ((id', inst'), th |> apply_to_entail_r cv) end in map process_inst insts end in maps match_i (0 upto (length cts - 1)) end (* Consider the case where pat = emp. Return t ==> emp * t. *) fun emp_assn_matcher ctxt (pat, ct) (id, inst) = if not (pat aconv emp) then [] else [((id, inst), ct |> Thm.term_of |> entail_triv_th ctxt |> apply_to_entail_r mult_emp_left)] (* If pat = true, match all of t. Return t ==> emp * true. *) fun true_assn_matcher ctxt (pat, ct) (id, inst) = if not (pat aconv assn_true) then [] else [((id, inst), ct |> Thm.term_of |> entail_true_th ctxt |> apply_to_entail_r mult_emp_left)] (* We now consider the case of generating a matcher from an entailment theorem of a particular form. Given an entailment A ==> B, where B is of the form f ?xs pat_r, where f is a constant, and pat_r may contain additional schematic variables. Attempt to find a term of form f xs r within t, for the input term r, by matching the pattern A. For each match, return the implication t ==> f xs r or t ==> t' * f xs r. This function serves as the first step of entail_matcher. *) fun entail_matcher' entail_th ctxt r ct id = let (* Match pat_r with r. *) val pat_r = entail_th |> prop_of' |> dest_entail |> snd |> dest_arg val inst_r = Matcher.rewrite_match ctxt (pat_r, Thm.cterm_of ctxt r) (id, fo_init) (* For each match, recursively match the instantiated version of A (named pat here) with t. *) fun process_inst_r ((id', inst'), eq_th) = let val entail_th' = Util.subst_thm ctxt inst' entail_th val pat = entail_th' |> prop_of' |> dest_arg1 val matches = assn_match_all ctxt (pat, ct) (id', fo_init) (* th is of form t ==> pat(s) * t'. Convert to t ==> t' * pat(s). Then use entailment theorem to convert to t ==> t' * B. Finally, convert the argument in B to the given r. *) fun process_match ((id'', _), th) = let val cv = eq_th |> Conv.rewr_conv |> Util.argn_conv 1 |> ACUtil.ac_last_conv assn_ac_info val th' = th |> apply_to_entail_r (ACUtil.comm_cv assn_ac_info) in (id'', ([th', entail_th'] MRS entails_trans2_th) |> apply_to_entail_r cv) end in map process_match matches end in maps process_inst_r inst_r end (* Given entailment theorem A ==> B, with same condition as in entail_matcher', attempt to match pat with t, and return t ==> t' * pat(s). For any matching to be performed, pat must be in the form f pat_xs r, where pat_xs may contain schematic variables, but r cannot. First, find f xs r using entail_matcher', then match pat_xs with xs. *) fun entail_matcher entail_th ctxt (pat, ct) (id, inst) = let val (f, args) = Term.strip_comb pat val pat_f = entail_th |> prop_of' |> dest_entail |> snd |> Term.head_of in if not (Term.aconv_untyped (f, pat_f)) orelse Util.has_vars (nth args 1) then [] else let val (pat_xs, r) = the_pair args val matches = entail_matcher' entail_th ctxt r ct id fun process_res (id', th) = let val xs = th |> cprop_of' |> Thm.dest_arg |> ACUtil.cdest_ac assn_ac_info |> List.last |> Drule.strip_comb |> snd |> hd val insts = Matcher.rewrite_match ctxt (pat_xs, xs) (id', inst) fun process_inst ((id'', inst'), eq_th) = let val cv = eq_th |> meta_sym |> Conv.rewr_conv |> Conv.arg1_conv |> ACUtil.ac_last_conv assn_ac_info in ((id'', inst'), th |> apply_to_entail_r cv) end in map process_inst insts end in maps process_res matches end end fun add_entail_matcher th = let val (pat_f, pat_args) = th |> prop_of' |> dest_entail |> snd |> Term.strip_comb val _ = assert (length pat_args = 2 andalso Term.is_Const pat_f) "add_entail_matcher: th must be in form A ==> f ?xs pat_r." in add_assn_matcher (entail_matcher th) end (* Matching in the backward direction *) (* Given a pattern pat, write t in the form pat(inst) * t'. *) fun assn_match_single ctxt (pat, ct) (id, inst) = let val cts = ACUtil.cdest_ac assn_ac_info ct fun match_i i = let val ct' = nth cts i val t' = Thm.term_of ct' val insts = Matcher.rewrite_match ctxt (pat, ct') (id, inst) (* eq_th is of form pat(inst) == t'. *) fun process_inst ((id', inst'), eq_th) = let val eq_th' = if length cts = 1 then eq_th |> meta_sym |> apply_to_rhs mult_emp_right else Conv.every_conv [ ACUtil.move_outmost assn_ac_info t', Conv.arg_conv (Conv.rewr_conv (meta_sym eq_th)), ACUtil.comm_cv assn_ac_info] ct in ((id', inst'), eq_th') end in map process_inst insts end in maps match_i (0 upto (length cts - 1)) end val add_assn_matcher_proofsteps = fold add_assn_matcher [ triv_assn_matcher, emp_assn_matcher, true_assn_matcher ] end (* structure AssnMatcher. *) diff --git a/thys/Auto2_Imperative_HOL/Imperative/sep_steps.ML b/thys/Auto2_Imperative_HOL/Imperative/sep_steps.ML --- a/thys/Auto2_Imperative_HOL/Imperative/sep_steps.ML +++ b/thys/Auto2_Imperative_HOL/Imperative/sep_steps.ML @@ -1,825 +1,824 @@ (* File: sep_steps.ML Author: Bohua Zhan Proof steps for separation logic. *) signature SEP_LOGIC = sig val normalize_hoare_goal_cv: Proof.context -> conv val normalize_entail_goal_cv: Proof.context -> conv val get_proc_def: theory -> term -> thm list val update_hoare_triple: thm -> theory -> theory val get_hoare_triples: theory -> string -> thm list val is_bind_cmd: term -> bool val get_first_cmd: term -> term val TY_CODE_POS: string val TY_ENTAIL: string val is_neg_hoare_triple: term -> bool val is_neg_entail: term -> bool val norm_precond: Proof.context -> conv val norm_entail_conds: Proof.context -> conv val is_implies_item: box_item -> bool val hoare_goal_update: Proof.context -> box_id * thm -> raw_update val entail_goal_update: Proof.context -> box_id * thm -> raw_update val init_entail: proofstep val entails_resolve: proofstep val init_pos: proofstep val add_forward_ent_prfstep: thm -> theory -> theory val add_backward_ent_prfstep: thm -> theory -> theory val add_rewrite_ent_rule: thm -> theory -> theory val rewrite_pos: proofstep val extract_pure_hoare_cv: conv val match_hoare_th: box_id -> Proof.context -> thm -> thm -> box_item -> raw_update list val match_hoare_prop: proofstep val match_hoare_disj: proofstep val match_assn_pure: proofstep val hoare_create_case: proofstep val entail_pure: proofstep val entail_create_case: proofstep val hoare_triple: proofstep val contract_hoare_cv: Proof.context -> conv val add_hoare_triple_prfstep: thm -> theory -> theory val add_sep_logic_proofsteps: theory -> theory end; functor SepLogic(SepUtil: SEP_UTIL) : SEP_LOGIC = struct open SepUtil structure AssnMatcher = AssnMatcher(SepUtil) (* Normalize a Hoare triple goal. *) fun normalize_hoare_goal_cv' ctxt ct = let val t = Thm.term_of ct val (P, _, _) = t |> dest_not |> dest_hoare_triple in if is_pure_assn P then rewr_obj_eq pre_pure_rule_th' ct else if UtilArith.is_times P andalso is_pure_assn (dest_arg P) then Conv.every_conv [rewr_obj_eq pre_pure_rule_th, Conv.arg1_conv (normalize_hoare_goal_cv' ctxt)] ct else if is_ex_assn P then Conv.every_conv [ rewr_obj_eq pre_ex_rule_th, Conv.binder_conv (normalize_hoare_goal_cv' o snd) ctxt] ct else Conv.all_conv ct end fun normalize_hoare_goal_cv ctxt ct = if is_ex (Thm.term_of ct) then Conv.binder_conv (normalize_hoare_goal_cv o snd) ctxt ct else Conv.every_conv [ Conv.arg_conv (Util.argn_conv 0 (SepUtil.normalize_assn_cv ctxt)), normalize_hoare_goal_cv' ctxt] ct fun normalize_entail_goal_cv' ctxt ct = let val t = Thm.term_of ct val (P, _) = t |> dest_not |> dest_entail in if is_pure_assn P then rewr_obj_eq entails_pure_th' ct else if UtilArith.is_times P andalso is_pure_assn (dest_arg P) then Conv.every_conv [rewr_obj_eq entails_pure_th, Conv.arg1_conv (normalize_entail_goal_cv' ctxt)] ct else if is_ex_assn P then Conv.every_conv [ rewr_obj_eq entails_ex_th, Conv.binder_conv (normalize_entail_goal_cv' o snd) ctxt] ct else Conv.all_conv ct end fun normalize_entail_goal_cv ctxt ct = if is_ex (Thm.term_of ct) then Conv.binder_conv (normalize_entail_goal_cv o snd) ctxt ct else Conv.every_conv [ Conv.arg_conv (Conv.binop_conv (SepUtil.normalize_assn_cv ctxt)), normalize_entail_goal_cv' ctxt] ct (* Data maintained for each imperative command. *) structure Data = Theory_Data ( type T = thm Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge (op Thm.eq_thm_prop) ) (* Add the given theorem as a Hoare triple. Replace previous Hoare triples for this theorem if any exist. *) fun update_hoare_triple hoare_th thy = let val (_, c, _) = dest_hoare_triple (prop_of' hoare_th) val nm = Util.get_head_name c in thy |> Data.map (Symtab.update (nm, hoare_th)) end (* Obtain list of Hoare triples for the given command *) fun get_hoare_triples thy nm = the_list (Symtab.lookup (Data.get thy) nm) fun get_proc_def thy t = if is_bind_cmd t then [] else let val nm = Util.get_head_name t in if null (get_hoare_triples thy nm) then Unfolding.get_unfold_thms_by_name thy nm else [] end fun get_first_cmd c = if is_bind_cmd c then dest_arg1 c else c fun extract_return_var t = if is_bind_cmd t then case dest_arg t of Abs (x, T, _) => if x = "uu_" then Free ("u",T) (* no assigned name *) else Free (x,T) (* regular assigned name *) | c => Free ("r", Term.domain_type (fastype_of c)) else raise Fail "extract_return_var" (* CODE_POS item stores a Hoare triple goal, indicating the current position in the program. *) val TY_CODE_POS = "CODE_POS" (* ENTAIL item stores an entailment goal, usually indicating the end of the program. *) val TY_ENTAIL = "ENTAIL" fun is_neg_hoare_triple t = is_neg t andalso is_hoare_triple (dest_not t) fun is_neg_entail t = is_neg t andalso is_entail (dest_not t) fun norm_precond ctxt ct = Util.argn_conv 0 (SepUtil.normalize_assn_cv ctxt) ct fun norm_entail_conds ctxt ct = Conv.binop_conv (SepUtil.normalize_assn_cv ctxt) ct fun is_implies_item item = Util.is_implies (Thm.prop_of (#prop item)) fun normalize_let ctxt th = let val rewr_one = Conv.first_conv [Conv.rewr_conv @{thm Let_def}, rewr_obj_eq @{thm case_prod_beta'}] val cv = Conv.every_conv [ Conv.top_conv (K (Conv.try_conv rewr_one)) ctxt, Thm.beta_conversion true] in apply_to_thm' cv th end fun hoare_goal_update ctxt (id, th) = if Util.is_implies (Thm.prop_of th) then AddItems {id = id, sc = SOME 1, raw_items = [Fact (TY_CODE_POS, [Thm.prop_of th], th)]} else let val (ex_ritems, res_th) = th |> apply_to_thm' (normalize_hoare_goal_cv ctxt) |> Update.apply_exists_ritems ctxt val (res_th', rest) = res_th |> UtilLogic.split_conj_gen_th |> filter_split (is_neg_hoare_triple o prop_of') val _ = assert (length res_th' = 1) "hoare_goal_update" val res_th' = res_th' |> the_single |> apply_to_thm' (Conv.arg_conv (norm_precond ctxt)) |> normalize_let ctxt val ritems = ex_ritems @ map Update.thm_to_ritem rest @ [Fact (TY_CODE_POS, [prop_of' res_th'], res_th')] in AddItems {id = id, sc = SOME 1, raw_items = ritems} end fun entail_goal_update ctxt (id, th) = if Util.is_implies (Thm.prop_of th) then AddItems {id = id, sc = SOME 1, raw_items = [Fact (TY_ENTAIL, [Thm.prop_of th], th)]} else let val (ex_ritems, res_th) = th |> apply_to_thm' (normalize_entail_goal_cv ctxt) |> Update.apply_exists_ritems ctxt val (res_th', rest) = res_th |> UtilLogic.split_conj_gen_th |> filter_split (is_neg_entail o prop_of') val _ = assert (length res_th' = 1) "entail_goal_update" val res_th' = res_th' |> the_single |> apply_to_thm' (Conv.arg_conv (norm_entail_conds ctxt)) |> normalize_let ctxt val ritems = ex_ritems @ map Update.thm_to_ritem rest @ [Fact (TY_ENTAIL, [prop_of' res_th'], res_th')] in AddItems {id = id, sc = SOME 1, raw_items = ritems} end fun init_entail_fn ctxt item = if not (BoxID.has_incr_id (#id item)) then [] else let val {id, prop, ...} = item in [entail_goal_update ctxt (id, prop)] end val init_entail = {name = "sep.init_entail", args = [TypedMatch (TY_PROP, get_neg (entail_t $ Var (("A",0), assnT) $ Var (("B",0), assnT)))], func = OneStep init_entail_fn} (* Apply entailment to the pre-condition P of P ==>_A Q. *) fun forward_ent_prfstep_fn ent_th ctxt item = if is_implies_item item then [] else let val (A, _) = dest_entail (prop_of' ent_th) val {id, prop, ...} = item val (P, _) = prop |> prop_of' |> dest_not |> dest_entail val cP = Thm.cterm_of ctxt P val insts = (AssnMatcher.assn_match_single ctxt (A, cP) (id, fo_init)) |> filter (BoxID.has_incr_id o fst o fst) fun process_inst ((id', _), eq_th) = (* eq_th is P == pat(inst) * P' *) let val prop' = prop |> apply_to_thm' ( Conv.arg_conv (Conv.arg1_conv (Conv.rewr_conv eq_th))) val prop'' = [prop', ent_th] MRS entails_frame_th' in [entail_goal_update ctxt (id', prop''), ShadowItem {id = id', item = item}] end in if null insts then [] else process_inst (hd insts) end fun forward_ent_prfstep ent_th = {name = Util.name_of_thm ent_th ^ "@ent", args = [TypedUniv TY_ENTAIL], func = OneStep (forward_ent_prfstep_fn ent_th)} fun backward_ent_prfstep_fn ent_th ctxt item = if is_implies_item item then [] else let val (_, B) = dest_entail (prop_of' ent_th) val {id, prop, ...} = item val (_, Q) = prop |> prop_of' |> dest_not |> dest_entail val cQ = Thm.cterm_of ctxt Q val insts = (AssnMatcher.assn_match_single ctxt (B, cQ) (id, fo_init)) |> filter (BoxID.has_incr_id o fst o fst) fun process_inst ((id', _), eq_th) = (* eq_th is P == pat(inst) * P' *) let val prop' = prop |> apply_to_thm' ( Conv.arg_conv (Conv.arg_conv (Conv.rewr_conv eq_th))) val prop'' = [prop', ent_th] MRS entails_frame_th'' in [entail_goal_update ctxt (id', prop''), ShadowItem {id = id', item = item}] end in if null insts then [] else process_inst (hd insts) end fun backward_ent_prfstep ent_th = {name = Util.name_of_thm ent_th ^ "@entback", args = [TypedUniv TY_ENTAIL], func = OneStep (backward_ent_prfstep_fn ent_th)} fun group_pure_assn ct = let val t = Thm.term_of ct in if is_pure_assn t then mult_emp_left ct else if UtilArith.is_times t then if has_pure_assn (dest_arg1 t) then Conv.every_conv [ Conv.arg1_conv group_pure_assn, ACUtil.assoc_cv assn_ac_info, Conv.arg_conv (rewr_obj_eq (obj_sym pure_conj_th))] ct else Conv.all_conv ct else Conv.all_conv ct end fun make_sch_th ctxt th = case Thm.prop_of th of Const (@{const_name Pure.all}, _) $ Abs (nm, T, _) => let val var = Var ((nm,0),T) in Thm.forall_elim (Thm.cterm_of ctxt var) th end | _ => raise Fail "make_sch_th" fun entails_norm_ex ctxt th = let val t = prop_of' th val (_, Q) = t |> dest_not |> dest_entail in if is_ex_assn Q then (th RS entails_ex_post_th) |> apply_to_thm (UtilLogic.to_meta_conv ctxt) |> make_sch_th ctxt |> entails_norm_ex ctxt else th end (* Solve an entailment. *) fun entails_resolve_fn ctxt item = if is_implies_item item then [] else let val {id, prop, ...} = item val prop = entails_norm_ex ctxt prop val (P, Q) = dest_entail (get_neg (prop_of' prop)) val cP = Thm.cterm_of ctxt P val Q' = strip_pure_assn Q val insts = (AssnMatcher.assn_match_strict ctxt (Q', cP) (id, fo_init)) |> filter (BoxID.has_incr_id o fst o fst) fun process_inst ((id', _), mod_th) = if has_pure_assn Q then let val prop' = prop |> apply_to_thm' ( Conv.arg_conv (Conv.arg_conv group_pure_assn)) val res = [prop', mod_th] MRS entails_pure_post_th in Update.thm_update (id', res) end else Update.thm_update (id', [prop, mod_th] MRS @{thm contra_triv}) in map process_inst insts end val entails_resolve = {name = "sep.entails_resolve", args = [TypedUniv TY_ENTAIL], func = OneStep entails_resolve_fn} (* Initialize CODE_POS item from a Hoare triple goal. *) fun init_pos_fn ctxt item = let val {id, prop, ...} = item val thy = Proof_Context.theory_of ctxt val (_, c, _) = dest_hoare_triple (get_neg (prop_of' prop)) val proc_defs = get_proc_def thy c fun process_proc_def proc_def = let val (lhs, _) = proc_def |> prop_of' |> dest_eq val cc = Thm.cterm_of ctxt c val insts = (Matcher.rewrite_match ctxt (lhs, cc) (id, fo_init)) |> filter (BoxID.has_incr_id o fst o fst) fun process_inst ((id', _), eq_th) = let val cv = Conv.every_conv [ Conv.rewr_conv (meta_sym eq_th), rewr_obj_eq proc_def] val th = apply_to_thm' (Conv.arg_conv (Conv.arg1_conv cv)) prop in hoare_goal_update ctxt (id', th) end in map process_inst insts end in if null proc_defs then if BoxID.has_incr_id id then [hoare_goal_update ctxt (id, prop)] else [] else maps process_proc_def proc_defs end val init_pos = {name = "sep.init_pos", args = [TypedMatch (TY_PROP, get_neg hoare_triple_pat)], func = OneStep init_pos_fn} fun forward_hoare_prfstep_fn ent_th ctxt item = if is_implies_item item then [] else let val (A, _) = dest_entail (prop_of' ent_th) val {id, prop, ...} = item val (P, _, _) = prop |> prop_of' |> dest_not |> dest_hoare_triple val cP = Thm.cterm_of ctxt P val insts = (AssnMatcher.assn_match_single ctxt (A, cP) (id, fo_init)) |> filter (BoxID.has_incr_id o fst o fst) fun process_inst ((id', _), eq_th) = let val prop' = prop |> apply_to_thm' ( Conv.arg_conv (Util.argn_conv 0 (Conv.rewr_conv eq_th))) val prop'' = [prop', ent_th] MRS pre_rule_th' in [hoare_goal_update ctxt (id', prop''), ShadowItem {id = id', item = item}] end in if null insts then [] else process_inst (hd insts) end fun forward_hoare_prfstep ent_th = {name = Util.name_of_thm ent_th ^ "@hoare_ent", args = [TypedUniv TY_CODE_POS], func = OneStep (forward_hoare_prfstep_fn ent_th)} fun add_forward_ent_prfstep ent_th thy = let val name = Util.name_of_thm ent_th val ctxt = Proof_Context.init_global thy val _ = writeln ("Add forward entailment " ^ name ^ "\n" ^ Syntax.string_of_term ctxt (prop_of' ent_th)) in thy |> add_prfstep (forward_ent_prfstep ent_th) |> add_prfstep (forward_hoare_prfstep ent_th) end fun add_backward_ent_prfstep ent_th thy = let val name = Util.name_of_thm ent_th val ctxt = Proof_Context.init_global thy val _ = writeln ("Add backward entailment " ^ name ^ "\n" ^ Syntax.string_of_term ctxt (prop_of' ent_th)) in add_prfstep (backward_ent_prfstep ent_th) thy end fun add_rewrite_ent_rule th thy = let val forward_th = (th RS entails_equiv_forward_th) |> Drule.zero_var_indexes |> Util.update_name_of_thm th "@forward" val backward_th = (th RS entails_equiv_backward_th) |> Drule.zero_var_indexes |> Util.update_name_of_thm th "@backward" in thy |> add_forward_ent_prfstep forward_th |> add_backward_ent_prfstep backward_th end (* Rewrite the first command of a Hoare triple. *) fun rewr_first_cmd eq_th ct = let val (_, c, _) = ct |> Thm.term_of |> dest_hoare_triple in if is_bind_cmd c then Conv.arg1_conv (Conv.arg1_conv (rewr_obj_eq eq_th)) ct else Conv.arg1_conv (rewr_obj_eq eq_th) ct end (* Apply rewrite to the first command in CODE_POS. *) fun rewrite_pos_fn ctxt item1 item2 = if is_implies_item item1 then [] else let val {id = id1, prop = th, ...} = item1 val {id = id2, prop = eq_th, ...} = item2 val (_, c, _) = th |> prop_of' |> dest_not |> dest_hoare_triple val c' = get_first_cmd c val (c1, _) = eq_th |> prop_of' |> dest_eq val id = BoxID.merge_boxes ctxt (id1, id2) in if not (BoxID.has_incr_id id) then [] else if c1 aconv c' then let val th' = th |> apply_to_thm' (Conv.arg_conv (rewr_first_cmd eq_th)) in [hoare_goal_update ctxt (id, th'), ShadowItem {id = id, item = item1}] end else [] end val rewrite_pos = {name = "sep.rewrite_pos", args = [TypedUniv TY_CODE_POS, TypedMatch (TY_EQ, heap_eq_pat)], func = TwoStep rewrite_pos_fn} (* Extract the pure pre-conditions from a Hoare triple fact. *) fun extract_pure_hoare_cv ct = let val (P, _, _) = ct |> Thm.term_of |> dest_hoare_triple in if is_pure_assn P then rewr_obj_eq norm_pre_pure_iff2_th ct else if UtilArith.is_times P andalso is_pure_assn (dest_arg P) then Conv.every_conv [rewr_obj_eq norm_pre_pure_iff_th, Conv.arg_conv extract_pure_hoare_cv] ct else Conv.all_conv ct end (* Use a Hoare triple to advance a step in CODE_POS. *) fun match_hoare_th id ctxt hoare_th goal item = let val (P, c, _) = goal |> prop_of' |> dest_not |> dest_hoare_triple val c' = get_first_cmd c val (P', pat, _) = dest_hoare_triple (prop_of' hoare_th) val cc = Thm.cterm_of ctxt c' val insts = Matcher.rewrite_match ctxt (pat, cc) (id, fo_init) fun process_inst ((id', inst), eq_th) = let val P'' = P' |> strip_pure_assn |> Util.subst_term_norm inst val cP = Thm.cterm_of ctxt P val insts' = (AssnMatcher.assn_match_all ctxt (P'', cP) (id', inst)) |> filter (BoxID.has_incr_id o fst o fst) fun process_inst' ((id'', inst'), ent_th) = let val hoare_th = (Util.subst_thm ctxt inst' hoare_th) |> apply_to_thm' (Conv.arg1_conv (Conv.rewr_conv eq_th)) |> apply_to_thm' extract_pure_hoare_cv |> apply_to_thm (UtilLogic.to_meta_conv ctxt) val hoare_th' = [hoare_th, ent_th] MRS pre_rule_th'' in if is_bind_cmd c then let val return_var = extract_return_var c val th' = [hoare_th', goal] MRS bind_rule_th' val (_, (assms, concl)) = th' |> Thm.prop_of |> Util.strip_meta_horn val concl' = concl |> dest_Trueprop |> Util.rename_abs_term [return_var] |> mk_Trueprop val t' = Util.list_meta_horn ([], (assms, concl')) val th' = Thm.renamed_prop t' th' in [hoare_goal_update ctxt (id'', th'), ShadowItem {id = id'', item = item}] end else [entail_goal_update ctxt (id'', [hoare_th', goal] MRS post_rule_th'), ShadowItem {id = id'', item = item}] end in if null insts' then [] else process_inst' (hd insts') end in if null insts then [] else process_inst (hd insts) end (* Match with PROP or DISJ items that are Hoare triples. In this function, we assume item1 is a Hoare triple (and item2 is the CODE_POS item). *) fun match_hoare_prop_fn ctxt item1 item2 = if is_implies_item item2 then [] else let val {id = id1, prop = hoare_th, ...} = item1 val {id = id2, prop = goal, ...} = item2 val id = BoxID.merge_boxes ctxt (id1, id2) in match_hoare_th id ctxt hoare_th goal item2 end val match_hoare_prop = {name = "sep.match_hoare_prop", args = [TypedMatch (TY_PROP, hoare_triple_pat), TypedUniv TY_CODE_POS], func = TwoStep match_hoare_prop_fn} (* For DISJ items, check that it is a Hoare triple. *) fun match_hoare_disj_fn ctxt item1 item2 = if is_implies_item item2 then [] else let val {tname, ...} = item1 val (_, csubs) = Logic_ProofSteps.dest_tname_of_disj tname val subs = map Thm.term_of csubs in if length subs > 1 then [] else if not (is_hoare_triple (the_single subs)) then [] else match_hoare_prop_fn ctxt item1 item2 end val match_hoare_disj = {name = "sep.match_hoare_disj", args = [TypedUniv TY_DISJ, TypedUniv TY_CODE_POS], func = TwoStep match_hoare_disj_fn} (* Match a MATCH_POS item with hoare triple

(b)> c with proposition b, resulting in a new MATCH_POS item (shadowing the original one) with hoare triple

c . Only work in the case where there are no schematic variables in b. *) fun match_assn_pure_fn ctxt item1 item2 = let val {id, prop, ...} = item1 in if Util.is_implies (Thm.prop_of prop) then let val (A, _) = Logic.dest_implies (Thm.prop_of prop) val pat = PropMatch (dest_Trueprop A) val insts = (ItemIO.match_arg ctxt pat item2 (id, fo_init)) |> filter (BoxID.has_incr_id o fst o fst) fun process_inst ((id', _), th) = [hoare_goal_update ctxt (id', th RS prop), ShadowItem {id = id', item = item1}] in maps process_inst insts end else [] end val match_assn_pure = {name = "sep.match_assn_pure", args = [TypedUniv TY_CODE_POS, PropMatch (@{term_pat "?b::bool"})], func = TwoStep match_assn_pure_fn} fun hoare_create_case_fn _ item = let val {id, prop, ...} = item in if not (BoxID.has_incr_id id) then [] else if Util.is_implies (Thm.prop_of prop) then let val (A, _) = Logic.dest_implies (Thm.prop_of prop) in [AddBoxes {id = id, sc = SOME 1, init_assum = get_neg' A}] end else [] end val hoare_create_case = {name = "sep.hoare_create_case", args = [TypedUniv TY_CODE_POS], func = OneStep hoare_create_case_fn} fun entail_pure_fn ctxt item1 item2 = let val {id, prop, ...} = item1 in if Util.is_implies (Thm.prop_of prop) then let val (A, _) = Logic.dest_implies (Thm.prop_of prop) val pat = PropMatch (dest_Trueprop A) val insts = (ItemIO.match_arg ctxt pat item2 (id, fo_init)) |> filter (BoxID.has_incr_id o fst o fst) fun process_inst ((id', _), th) = [entail_goal_update ctxt (id', th RS prop), ShadowItem {id = id', item = item1}] in maps process_inst insts end else [] end val entail_pure = {name = "sep.entail_pure", args = [TypedUniv TY_ENTAIL, PropMatch (@{term_pat "?b::bool"})], func = TwoStep entail_pure_fn} fun entail_create_case_fn _ item = let val {id, prop, ...} = item in if not (BoxID.has_incr_id id) then [] else if Util.is_implies (Thm.prop_of prop) then let val (A, _) = Logic.dest_implies (Thm.prop_of prop) in [AddBoxes {id = id, sc = SOME 1, init_assum = get_neg' A}] end else [] end val entail_create_case = {name = "sep.entail_create_case", args = [TypedUniv TY_ENTAIL], func = OneStep entail_create_case_fn} (* Matching CODE_POS with an existing Hoare triple. *) fun hoare_triple_fn ctxt item = if is_implies_item item then [] else let val thy = Proof_Context.theory_of ctxt val {id, prop = goal, ...} = item val (_, c, _) = goal |> prop_of' |> dest_not |> dest_hoare_triple val hoare_ths = c |> get_first_cmd |> Util.get_head_name |> get_hoare_triples thy in maps (fn hoare_th => match_hoare_th id ctxt hoare_th goal item) hoare_ths end val hoare_triple = {name = "sep.hoare_triple", args = [TypedUniv TY_CODE_POS], func = OneStep hoare_triple_fn} (* Contract a Hoare triple to

c form. *) fun contract_hoare_cv' ct = if is_imp (Thm.term_of ct) then Conv.every_conv [Conv.arg_conv contract_hoare_cv', rewr_obj_eq (obj_sym norm_pre_pure_iff_th)] ct else Conv.all_conv ct fun contract_hoare_cv ctxt ct = Conv.every_conv [contract_hoare_cv', norm_precond ctxt] ct (* Given hoare_th of the form ?c , produce proofstep matching item1 with CODE_POS (?h, ?c) and item2 with proposition ?h |= ?P * ?Ru. *) fun add_hoare_triple_prfstep hoare_th thy = let val name = Util.name_of_thm hoare_th val ctxt = Proof_Context.init_global thy val hoare_th' = hoare_th |> apply_to_thm (UtilLogic.to_obj_conv ctxt) |> apply_to_thm' (contract_hoare_cv ctxt) |> Util.update_name_of_thm hoare_th "" val _ = writeln ("Add Hoare triple " ^ name ^ "\n" ^ Syntax.string_of_term ctxt (prop_of' hoare_th')) in thy |> update_hoare_triple hoare_th' end fun code_pos_terms ts = let val t = the_single ts in if fastype_of t = propT then [] else let val (P, c, _) = t |> dest_not |> dest_hoare_triple in SepUtil.assn_rewr_terms P @ [get_first_cmd c] end end fun entail_terms ts = let val t = the_single ts in if fastype_of t = propT then [] else let val (P, Q) = t |> dest_not |> dest_entail in maps SepUtil.assn_rewr_terms [P, Q] end end val add_sep_logic_proofsteps = fold ItemIO.add_item_type [ (TY_CODE_POS, SOME code_pos_terms, NONE, NONE), (TY_ENTAIL, SOME entail_terms, NONE, NONE) ] #> fold add_prfstep [ init_entail, entails_resolve, init_pos, rewrite_pos, match_assn_pure, hoare_triple, match_hoare_disj, match_hoare_prop, hoare_create_case, entail_pure, entail_create_case ] end (* structure SepLogic *) diff --git a/thys/Automated_Stateful_Protocol_Verification/trac/trac.thy b/thys/Automated_Stateful_Protocol_Verification/trac/trac.thy --- a/thys/Automated_Stateful_Protocol_Verification/trac/trac.thy +++ b/thys/Automated_Stateful_Protocol_Verification/trac/trac.thy @@ -1,1947 +1,1946 @@ (* (C) Copyright Andreas Viktor Hess, DTU, 2020 (C) Copyright Sebastian A. Mödersheim, DTU, 2020 (C) Copyright Achim D. Brucker, University of Exeter, 2020 (C) Copyright Anders Schlichtkrull, DTU, 2020 All Rights Reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (* Title: trac.thy Author: Andreas Viktor Hess, DTU Author: Sebastian A. Mödersheim, DTU Author: Achim D. Brucker, University of Exeter Author: Anders Schlichtkrull, DTU *) section\Support for the Trac Format\ theory "trac" imports trac_fp_parser trac_protocol_parser keywords "trac" :: thy_decl and "trac_import" :: thy_decl and "trac_trac" :: thy_decl and "trac_import_trac" :: thy_decl and "protocol_model_setup" :: thy_decl and "protocol_security_proof" :: thy_decl and "manual_protocol_model_setup" :: thy_decl and "manual_protocol_security_proof" :: thy_decl and "compute_fixpoint" :: thy_decl and "compute_SMP" :: thy_decl and "setup_protocol_model'" :: thy_decl and "protocol_security_proof'" :: thy_decl and "setup_protocol_checks" :: thy_decl begin ML \ (* Some of this is based on code from the following files distributed with Isabelle 2018: * HOL/Tools/value_command.ML * HOL/Code_Evaluation.thy * Pure.thy *) fun protocol_model_interpretation_defs name = let fun f s = (Binding.empty_atts:Attrib.binding, ((Binding.name s, NoSyn), name ^ "." ^ s)) in (map f [ "public", "arity", "Ana", "\", "\\<^sub>v", "timpls_transformable_to", "intruder_synth_mod_timpls", "analyzed_closed_mod_timpls", "timpls_transformable_to'", "intruder_synth_mod_timpls'", "analyzed_closed_mod_timpls'", "admissible_transaction_terms", "admissible_transaction", "abs_substs_set", "abs_substs_fun", "in_trancl", "transaction_poschecks_comp", "transaction_negchecks_comp", "transaction_check_comp", "transaction_check", "transaction_check_pre", "transaction_check_post", "compute_fixpoint_fun'", "compute_fixpoint_fun", "attack_notin_fixpoint", "protocol_covered_by_fixpoint", "analyzed_fixpoint", "wellformed_protocol'", "wellformed_protocol", "wellformed_fixpoint", "wellformed_composable_protocols", "composable_protocols" ]):string Interpretation.defines end fun protocol_model_interpretation_params name = let fun f s = name ^ "_" ^ s in map SOME [f "arity", "\_. 0", f "public", f "Ana", f "\", "0::nat", "1::nat"] end fun declare_thm_attr attribute name print lthy = let val arg = [(Facts.named name, [[Token.make_string (attribute, Position.none)]])] val (_, lthy') = Specification.theorems_cmd "" [(Binding.empty_atts, arg)] [] print lthy in lthy' end fun declare_def_attr attribute name = declare_thm_attr attribute (name ^ "_def") val declare_code_eqn = declare_def_attr "code" val declare_protocol_check = declare_def_attr "protocol_checks" fun declare_protocol_checks print = declare_protocol_check "attack_notin_fixpoint" print #> declare_protocol_check "protocol_covered_by_fixpoint" print #> declare_protocol_check "analyzed_fixpoint" print #> declare_protocol_check "wellformed_protocol'" print #> declare_protocol_check "wellformed_protocol" print #> declare_protocol_check "wellformed_fixpoint" print #> declare_protocol_check "compute_fixpoint_fun" print fun eval_define (name, raw_t) lthy = let val t = Code_Evaluation.dynamic_value_strict lthy (Syntax.read_term lthy raw_t) val arg = ((Binding.name name, NoSyn), ((Binding.name (name ^ "_def"),[]), t)) val (_, lthy') = Local_Theory.define arg lthy in (t, lthy') end fun eval_define_declare (name, raw_t) print = eval_define (name, raw_t) ##> declare_code_eqn name print val _ = Outer_Syntax.local_theory' @{command_keyword "compute_fixpoint"} "evaluate and define protocol fixpoint" (Parse.name -- Parse.name >> (fn (protocol, fixpoint) => fn print => snd o eval_define_declare (fixpoint, "compute_fixpoint_fun " ^ protocol) print)); val _ = Outer_Syntax.local_theory' @{command_keyword "compute_SMP"} "evaluate and define a finite representation of the sub-message patterns of a protocol" ((Scan.optional (\<^keyword>\[\ |-- Parse.name --| \<^keyword>\]\) "no_optimizations") -- Parse.name -- Parse.name >> (fn ((opt,protocol), smp) => fn print => let val rmd = "List.remdups" val f = "Stateful_Strands.trms_list\<^sub>s\<^sub>s\<^sub>t" val g = "(\T. " ^ f ^ " T@map (pair' prot_fun.Pair) (Stateful_Strands.setops_list\<^sub>s\<^sub>s\<^sub>t T))" fun s trms = "(" ^ rmd ^ " (List.concat (List.map (" ^ trms ^ " \ Labeled_Strands.unlabel \ transaction_strand) " ^ protocol ^ ")))" val opt1 = "remove_superfluous_terms \" val opt2 = "generalize_terms \ is_Var" val gsmp_opt = "generalize_terms \ (\t. is_Var t \ t \ TAtom AttackType \ " ^ "t \ TAtom SetType \ t \ TAtom OccursSecType \ \is_Atom (the_Var t))" val smp_fun = "SMP0 Ana \" fun smp_fun' opts = "(\T. let T' = (" ^ rmd ^ " \ " ^ opts ^ " \ " ^ smp_fun ^ ") T in List.map (\t. t \ Typed_Model.var_rename (Typed_Model.max_var_set " ^ "(Messages.fv\<^sub>s\<^sub>e\<^sub>t (set (T@T'))))) T')" val cmd = if opt = "no_optimizations" then smp_fun ^ " " ^ s f else if opt = "optimized" then smp_fun' (opt1 ^ " \ " ^ opt2) ^ " " ^ s f else if opt = "GSMP" then smp_fun' (opt1 ^ " \ " ^ gsmp_opt) ^ " " ^ s g else error ("Invalid option: " ^ opt) in snd o eval_define_declare (smp, cmd) print end)); val _ = Outer_Syntax.local_theory' @{command_keyword "setup_protocol_checks"} "setup protocol checks" (Parse.name -- Parse.name >> (fn (protocol_model, protocol_name) => fn print => let val a1 = "coverage_check_intro_lemmata" val a2 = "coverage_check_unfold_lemmata" val a3 = "coverage_check_unfold_protocol_lemma" in declare_protocol_checks print #> declare_thm_attr a1 (protocol_model ^ ".protocol_covered_by_fixpoint_intros") print #> declare_def_attr a2 (protocol_model ^ ".protocol_covered_by_fixpoint") print #> declare_def_attr a3 protocol_name print end )); val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\setup_protocol_model'\ "prove interpretation of protocol model locale into global theory" (Parse.!!! (Parse.name -- Parse_Spec.locale_expression) >> (fn (prefix,expr) => fn lthy => let fun f x y z = ([(x,(y,(Expression.Positional z,[])))],[]) val (a,(b,c)) = nth (fst expr) 0 val name = fst b val _ = case c of (Expression.Named [],[]) => () | _ => error "Invalid arguments" val pexpr = f a b (protocol_model_interpretation_params prefix) val pdefs = protocol_model_interpretation_defs name in if name = "" then error "No name given" else Interpretation.global_interpretation_cmd pexpr pdefs lthy end)); val _ = Outer_Syntax.local_theory_to_proof' \<^command_keyword>\protocol_security_proof'\ "prove interpretation of secure protocol locale into global theory" (Parse.!!! (Parse.name -- Parse_Spec.locale_expression) >> (fn (prefix,expr) => fn print => let fun f x y z = ([(x,(y,(Expression.Positional z,[])))],[]) val (a,(b,c)) = nth (fst expr) 0 val d = case c of (Expression.Positional ps,[]) => ps | _ => error "Invalid arguments" val pexpr = f a b (protocol_model_interpretation_params prefix@d) in declare_protocol_checks print #> Interpretation.global_interpretation_cmd pexpr [] end )); \ ML\ structure ml_isar_wrapper = struct fun define_constant_definition (constname, trm) lthy = let val arg = ((Binding.name constname, NoSyn), ((Binding.name (constname^"_def"),[]), trm)) val ((_, (_ , thm)), lthy') = Local_Theory.define arg lthy in (thm, lthy') end fun define_constant_definition' (constname, trm) print lthy = let val arg = ((Binding.name constname, NoSyn), ((Binding.name (constname^"_def"),[]), trm)) val ((_, (_ , thm)), lthy') = Local_Theory.define arg lthy val lthy'' = declare_code_eqn constname print lthy' in (thm, lthy'') end fun define_simple_abbrev (constname, trm) lthy = let val arg = ((Binding.name constname, NoSyn), trm) val ((_, _), lthy') = Local_Theory.abbrev Syntax.mode_default arg lthy in lthy' end fun define_simple_type_synonym (name, typedecl) lthy = let val (_, lthy') = Typedecl.abbrev_global (Binding.name name, [], NoSyn) typedecl lthy in lthy' end fun define_simple_datatype (dt_tyargs, dt_name) constructors = let val options = Plugin_Name.default_filter fun lift_c (tyargs, name) = (((Binding.empty, Binding.name name), map (fn t => (Binding.empty, t)) tyargs), NoSyn) val c_spec = map lift_c constructors val datatyp = ((map (fn ty => (NONE, ty)) dt_tyargs, Binding.name dt_name), NoSyn) val dtspec = ((options,false), [(((datatyp, c_spec), (Binding.empty, Binding.empty, Binding.empty)), [])]) in BNF_FP_Def_Sugar.co_datatypes BNF_Util.Least_FP BNF_LFP.construct_lfp dtspec end fun define_simple_primrec pname precs lthy = let val rec_eqs = map (fn (lhs,rhs) => (((Binding.empty,[]), HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs))),[],[])) precs in snd (BNF_LFP_Rec_Sugar.primrec false [] [(Binding.name pname, NONE, NoSyn)] rec_eqs lthy) end fun define_simple_fun pname precs lthy = let val rec_eqs = map (fn (lhs,rhs) => (((Binding.empty,[]), HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs))),[],[])) precs in Function_Fun.add_fun [(Binding.name pname, NONE, NoSyn)] rec_eqs Function_Common.default_config lthy end fun prove_simple name stmt tactic lthy = let val thm = Goal.prove lthy [] [] stmt (tactic o #context) |> Goal.norm_result lthy |> Goal.check_finished lthy in lthy |> snd o Local_Theory.note ((Binding.name name, []), [thm]) end fun prove_state_simple method proof_state = Seq.the_result "error in proof state" ( (Proof.refine method proof_state)) |> Proof.global_done_proof end \ ML\ structure trac_definitorial_package = struct (* constant names *) open Trac_Utils val enum_constsN="enum_consts" val setsN="sets" val funN="fun" val atomN="atom" val arityN="arity" val publicN = "public" val gammaN = "\" val anaN = "Ana" val valN = "val" val timpliesN = "timplies" val occursN = "occurs" val enumN = "enum" val priv_fun_secN = "PrivFunSec" val secret_typeN = "SecretType" val enum_typeN = "EnumType" val other_pubconsts_typeN = "PubConstType" val types = [enum_typeN, secret_typeN] val special_funs = ["occurs", "zero", valN, priv_fun_secN] fun mk_listT T = Type ("List.list", [T]) val mk_setT = HOLogic.mk_setT val boolT = HOLogic.boolT val natT = HOLogic.natT val mk_tupleT = HOLogic.mk_tupleT val mk_prodT = HOLogic.mk_prodT val mk_set = HOLogic.mk_set val mk_list = HOLogic.mk_list val mk_nat = HOLogic.mk_nat val mk_eq = HOLogic.mk_eq val mk_Trueprop = HOLogic.mk_Trueprop val mk_tuple = HOLogic.mk_tuple val mk_prod = HOLogic.mk_prod fun mkN (a,b) = a^"_"^b val info = Output.information fun rm_special_funs sel l = list_minus (list_rm_pair sel) l special_funs fun is_priv_fun (trac:TracProtocol.protocol) f = let val funs = #private (Option.valOf (#function_spec trac)) in (* not (List.find (fn g => fst g = f) funs = NONE) *) List.exists (fn (g,n) => f = g andalso n <> "0") funs end fun full_name name lthy = Local_Theory.full_name lthy (Binding.name name) fun full_name' n (trac:TracProtocol.protocol) lthy = full_name (mkN (#name trac, n)) lthy fun mk_prot_type name targs (trac:TracProtocol.protocol) lthy = Term.Type (full_name' name trac lthy, targs) val enum_constsT = mk_prot_type enum_constsN [] fun mk_enum_const a trac lthy = Term.Const (full_name' enum_constsN trac lthy ^ "." ^ a, enum_constsT trac lthy) val databaseT = mk_prot_type setsN [] val funT = mk_prot_type funN [] val atomT = mk_prot_type atomN [] fun messageT (trac:TracProtocol.protocol) lthy = Term.Type ("Transactions.prot_term", [funT trac lthy, atomT trac lthy, databaseT trac lthy]) fun message_funT (trac:TracProtocol.protocol) lthy = Term.Type ("Transactions.prot_fun", [funT trac lthy, atomT trac lthy, databaseT trac lthy]) fun message_varT (trac:TracProtocol.protocol) lthy = Term.Type ("Transactions.prot_var", [funT trac lthy, atomT trac lthy, databaseT trac lthy]) fun message_term_typeT (trc:TracProtocol.protocol) lthy = Term.Type ("Transactions.prot_term_type", [funT trc lthy, atomT trc lthy, databaseT trc lthy]) fun message_atomT (trac:TracProtocol.protocol) lthy = Term.Type ("Transactions.prot_atom", [atomT trac lthy]) fun messageT' varT (trac:TracProtocol.protocol) lthy = Term.Type ("Term.term", [message_funT trac lthy, varT]) fun message_listT (trac:TracProtocol.protocol) lthy = mk_listT (messageT trac lthy) fun message_listT' varT (trac:TracProtocol.protocol) lthy = mk_listT (messageT' varT trac lthy) fun absT (trac:TracProtocol.protocol) lthy = mk_setT (databaseT trac lthy) fun abssT (trac:TracProtocol.protocol) lthy = mk_setT (absT trac lthy) val poscheckvariantT = Term.Type ("Strands_and_Constraints.poscheckvariant", []) val strand_labelT = Term.Type ("Labeled_Strands.strand_label", [natT]) fun strand_stepT (trac:TracProtocol.protocol) lthy = Term.Type ("Stateful_Strands.stateful_strand_step", [message_funT trac lthy, message_varT trac lthy]) fun labeled_strand_stepT (trac:TracProtocol.protocol) lthy = mk_prodT (strand_labelT, strand_stepT trac lthy) fun prot_strandT (trac:TracProtocol.protocol) lthy = mk_listT (labeled_strand_stepT trac lthy) fun prot_transactionT (trac:TracProtocol.protocol) lthy = Term.Type ("Transactions.prot_transaction", [funT trac lthy, atomT trac lthy, databaseT trac lthy, natT]) val mk_star_label = Term.Const ("Labeled_Strands.strand_label.LabelS", strand_labelT) fun mk_prot_label (lbl:int) = Term.Const ("Labeled_Strands.strand_label.LabelN", natT --> strand_labelT) $ mk_nat lbl fun mk_labeled_step (label:term) (step:term) = mk_prod (label, step) fun mk_Send_step (trac:TracProtocol.protocol) lthy (label:term) (msg:term) = mk_labeled_step label (Term.Const ("Stateful_Strands.stateful_strand_step.Send", messageT trac lthy --> strand_stepT trac lthy) $ msg) fun mk_Receive_step (trac:TracProtocol.protocol) lthy (label:term) (msg:term) = mk_labeled_step label (Term.Const ("Stateful_Strands.stateful_strand_step.Receive", messageT trac lthy --> strand_stepT trac lthy) $ msg) fun mk_InSet_step (trac:TracProtocol.protocol) lthy (label:term) (elem:term) (set:term) = let val psT = [poscheckvariantT, messageT trac lthy, messageT trac lthy] in mk_labeled_step label (Term.Const ("Stateful_Strands.stateful_strand_step.InSet", psT ---> strand_stepT trac lthy) $ Term.Const ("Strands_and_Constraints.poscheckvariant.Check", poscheckvariantT) $ elem $ set) end fun mk_NotInSet_step (trac:TracProtocol.protocol) lthy (label:term) (elem:term) (set:term) = let val varT = message_varT trac lthy val trm_prodT = mk_prodT (messageT trac lthy, messageT trac lthy) val psT = [mk_listT varT, mk_listT trm_prodT, mk_listT trm_prodT] in mk_labeled_step label (Term.Const ("Stateful_Strands.stateful_strand_step.NegChecks", psT ---> strand_stepT trac lthy) $ mk_list varT [] $ mk_list trm_prodT [] $ mk_list trm_prodT [mk_prod (elem,set)]) end fun mk_Inequality_step (trac:TracProtocol.protocol) lthy (label:term) (t1:term) (t2:term) = let val varT = message_varT trac lthy val trm_prodT = mk_prodT (messageT trac lthy, messageT trac lthy) val psT = [mk_listT varT, mk_listT trm_prodT, mk_listT trm_prodT] in mk_labeled_step label (Term.Const ("Stateful_Strands.stateful_strand_step.NegChecks", psT ---> strand_stepT trac lthy) $ mk_list varT [] $ mk_list trm_prodT [mk_prod (t1,t2)] $ mk_list trm_prodT []) end fun mk_Insert_step (trac:TracProtocol.protocol) lthy (label:term) (elem:term) (set:term) = mk_labeled_step label (Term.Const ("Stateful_Strands.stateful_strand_step.Insert", [messageT trac lthy, messageT trac lthy] ---> strand_stepT trac lthy) $ elem $ set) fun mk_Delete_step (trac:TracProtocol.protocol) lthy (label:term) (elem:term) (set:term) = mk_labeled_step label (Term.Const ("Stateful_Strands.stateful_strand_step.Delete", [messageT trac lthy, messageT trac lthy] ---> strand_stepT trac lthy) $ elem $ set) fun mk_Transaction (trac:TracProtocol.protocol) lthy S1 S2 S3 S4 S5 S6 = let val varT = message_varT trac lthy val msgT = messageT trac lthy val var_listT = mk_listT varT val msg_listT = mk_listT msgT val trT = prot_transactionT trac lthy (* val decl_elemT = mk_prodT (varT, mk_listT msgT) val declT = mk_listT decl_elemT *) val stepT = labeled_strand_stepT trac lthy val strandT = prot_strandT trac lthy val strandsT = mk_listT strandT val paramsT = [(* declT, *)var_listT, strandT, strandT, strandT, strandT, strandT] in Term.Const ("Transactions.prot_transaction.Transaction", paramsT ---> trT) $ (* mk_list decl_elemT [] $ *) (if null S4 then mk_list varT [] else (Term.Const (@{const_name "map"}, [msgT --> varT, msg_listT] ---> var_listT) $ Term.Const (@{const_name "the_Var"}, msgT --> varT) $ mk_list msgT S4)) $ mk_list stepT S1 $ mk_list stepT [] $ (if null S3 then mk_list stepT S2 else (Term.Const (@{const_name "append"}, [strandT,strandT] ---> strandT) $ mk_list stepT S2 $ (Term.Const (@{const_name "concat"}, strandsT --> strandT) $ mk_list strandT S3))) $ mk_list stepT S5 $ mk_list stepT S6 end fun get_funs (trac:TracProtocol.protocol) = let fun append_sec fs = fs@[(priv_fun_secN, "0")] val filter_funs = filter (fn (_,n) => n <> "0") val filter_consts = filter (fn (_,n) => n = "0") fun inc_ar (s,n) = (s, Int.toString (1+Option.valOf (Int.fromString n))) in case (#function_spec trac) of NONE => ([],[],[]) | SOME ({public=pub, private=priv}) => let val pub_symbols = rm_special_funs fst (pub@map inc_ar (filter_funs priv)) val pub_funs = filter_funs pub_symbols val pub_consts = filter_consts pub_symbols val priv_consts = append_sec (rm_special_funs fst (filter_consts priv)) in (pub_funs, pub_consts, priv_consts) end end fun get_set_spec (trac:TracProtocol.protocol) = mk_unique (map (fn (s,n) => (s,Option.valOf (Int.fromString n))) (#set_spec trac)) fun set_arity (trac:TracProtocol.protocol) s = case List.find (fn x => fst x = s) (get_set_spec trac) of SOME (_,n) => SOME n | NONE => NONE fun get_enums (trac:TracProtocol.protocol) = mk_unique (TracProtocol.extract_Consts (#type_spec trac)) fun flatten_type_spec (trac:TracProtocol.protocol) = let fun find_type taus tau = case List.find (fn x => fst x = tau) taus of SOME x => snd x | NONE => error ("Type " ^ tau ^ " has not been declared") fun step taus (s,e) = case e of TracProtocol.Union ts => let val es = map (find_type taus) ts fun f es' = mk_unique (List.concat (map TracProtocol.the_Consts es')) in if List.all TracProtocol.is_Consts es then (s,TracProtocol.Consts (f es)) else (s,TracProtocol.Union ts) end | c => (s,c) fun loop taus = let val taus' = map (step taus) taus in if taus = taus' then taus else loop taus' end val flat_type_spec = let val x = loop (#type_spec trac) val errpre = "Couldn't flatten the enumeration types: " in if List.all (fn (_,e) => TracProtocol.is_Consts e) x then let val y = map (fn (s,e) => (s,TracProtocol.the_Consts e)) x in if List.all (not o List.null o snd) y then y else error (errpre ^ "does every type have at least one value?") end else error (errpre ^ "have all types been declared?") end in flat_type_spec end fun is_attack_transaction (tr:TracProtocol.cTransaction) = not (null (#attack_actions tr)) fun get_transaction_name (tr:TracProtocol.cTransaction) = #1 (#transaction tr) fun get_fresh_value_variables (tr:TracProtocol.cTransaction) = map_filter (TracProtocol.maybe_the_Fresh o snd) (#fresh_actions tr) fun get_nonfresh_value_variables (tr:TracProtocol.cTransaction) = map fst (filter (fn x => snd x = "value") (#2 (#transaction tr))) fun get_value_variables (tr:TracProtocol.cTransaction) = get_nonfresh_value_variables tr@get_fresh_value_variables tr fun get_enum_variables (tr:TracProtocol.cTransaction) = mk_unique (filter (fn x => snd x <> "value") (#2 (#transaction tr))) fun get_variable_restrictions (tr:TracProtocol.cTransaction) = let val enum_vars = get_enum_variables tr val value_vars = get_value_variables tr fun enum_member x = List.exists (fn y => x = fst y) fun value_member x = List.exists (fn y => x = y) fun aux [] = ([],[]) | aux ((a,b)::rs) = if enum_member a enum_vars andalso enum_member b enum_vars then let val (es,vs) = aux rs in ((a,b)::es,vs) end else if value_member a value_vars andalso value_member b value_vars then let val (es,vs) = aux rs in (es,(a,b)::vs) end else error ("Ill-formed or ill-typed variable restriction: " ^ a ^ " != " ^ b) in aux (#3 (#transaction tr)) end fun conv_enum_consts trac (t:Trac_Term.cMsg) = let open Trac_Term val enums = get_enums trac fun aux (cFun (f,ts)) = if List.exists (fn x => x = f) enums then if null ts then cEnum f else error ("Enum constant " ^ f ^ " should not have a parameter list") else cFun (f,map aux ts) | aux (cConst c) = if List.exists (fn x => x = c) enums then cEnum c else cConst c | aux (cSet (s,ts)) = cSet (s,map aux ts) | aux (cOccursFact bs) = cOccursFact (aux bs) | aux t = t in aux t end fun val_to_abs_list vs = let open Trac_Term fun aux t = case t of cEnum b => b | _ => error "Invalid val parameter list" in case vs of [] => [] | (cConst "0"::ts) => val_to_abs_list ts | (cFun (s,ps)::ts) => (s, map aux ps)::val_to_abs_list ts | (cSet (s,ps)::ts) => (s, map aux ps)::val_to_abs_list ts | _ => error "Invalid val parameter list" end fun val_to_abs (t:Trac_Term.cMsg) = let open Trac_Term fun aux t = case t of cEnum b => b | _ => error "Invalid val parameter list" fun val_to_abs_list [] = [] | val_to_abs_list (cConst "0"::ts) = val_to_abs_list ts | val_to_abs_list (cFun (s,ps)::ts) = (s, map aux ps)::val_to_abs_list ts | val_to_abs_list (cSet (s,ps)::ts) = (s, map aux ps)::val_to_abs_list ts | val_to_abs_list _ = error "Invalid val parameter list" in case t of cFun (f,ts) => if f = valN then cAbs (val_to_abs_list ts) else cFun (f,map val_to_abs ts) | cSet (s,ts) => cSet (s,map val_to_abs ts) | cOccursFact bs => cOccursFact (val_to_abs bs) | t => t end fun occurs_enc t = let open Trac_Term fun aux [cVar x] = cVar x | aux [cAbs bs] = cAbs bs | aux _ = error "Invalid occurs parameter list" fun enc (cFun (f,ts)) = ( if f = occursN then cOccursFact (aux ts) else cFun (f,map enc ts)) | enc (cSet (s,ts)) = cSet (s,map enc ts) | enc (cOccursFact bs) = cOccursFact (enc bs) | enc t = t in enc t end fun priv_fun_enc trac (Trac_Term.cFun (f,ts)) = ( if is_priv_fun trac f andalso (case ts of Trac_Term.cPrivFunSec::_ => false | _ => true) then Trac_Term.cFun (f,Trac_Term.cPrivFunSec::map (priv_fun_enc trac) ts) else Trac_Term.cFun (f,map (priv_fun_enc trac) ts)) | priv_fun_enc _ t = t fun transform_cMsg trac = priv_fun_enc trac o occurs_enc o val_to_abs o conv_enum_consts trac fun check_no_vars_and_consts (fp:Trac_Term.cMsg list) = let open Trac_Term fun aux (cVar _) = false | aux (cConst _) = false | aux (cFun (_,ts)) = List.all aux ts | aux (cSet (_,ts)) = List.all aux ts | aux (cOccursFact bs) = aux bs | aux _ = true in if List.all aux fp then fp else error "There shouldn't be any cVars and cConsts at this point in the fixpoint translation" end fun split_fp (fp:Trac_Term.cMsg list) = let open Trac_Term fun fa t = case t of cFun (s,_) => s <> timpliesN | _ => true fun fb (t,ts) = case t of cOccursFact (cAbs bs) => bs::ts | _ => ts fun fc (cFun (s, [cAbs bs, cAbs cs]),ts) = if s = timpliesN then (bs,cs)::ts else ts | fc (_,ts) = ts val eq = eq_set (fn ((s,xs),(t,ys)) => s = t andalso eq_set (op =) (xs,ys)) fun eq_pairs ((a,b),(c,d)) = eq (a,c) andalso eq (b,d) val timplies_trancl = let fun trans_step ts = let fun aux (s,t) = map (fn (_,u) => (s,u)) (filter (fn (v,_) => eq (t,v)) ts) in distinct eq_pairs (filter (not o eq) (ts@List.concat (map aux ts))) end fun loop ts = let val ts' = trans_step ts in if eq_set eq_pairs (ts,ts') then ts else loop ts' end in loop end val ti = List.foldl fc [] fp in (filter fa fp, distinct eq (List.foldl fb [] fp@map snd ti), timplies_trancl ti) end fun mk_enum_substs trac (vars:(string * Trac_Term.VarType) list) = let open Trac_Term val flat_type_spec = flatten_type_spec trac val deltas = let fun f (s,EnumType tau) = ( case List.find (fn x => fst x = tau) flat_type_spec of SOME x => map (fn c => (s,c)) (snd x) | NONE => error ("Type " ^ tau ^ " was not found in the type specification")) | f (s,_) = error ("Variable " ^ s ^ " is not of enum type") in list_product (map f vars) end in map (fn d => map (fn (x,t) => (x,cEnum t)) d) deltas end fun ground_enum_variables trac (fp:Trac_Term.cMsg list) = let open Trac_Term fun do_grounding t = map (fn d => subst_apply d t) (mk_enum_substs trac (fv_cMsg t)) in List.concat (map do_grounding fp) end fun transform_fp trac (fp:Trac_Term.cMsg list) = fp |> ground_enum_variables trac |> map (transform_cMsg trac) |> check_no_vars_and_consts |> split_fp fun database_to_hol (db:string * Trac_Term.cMsg list) (trac:TracProtocol.protocol) lthy = let open Trac_Term val errmsg = "Invalid database parameter" fun mkN' n = mkN (#name trac, n) val s_prefix = full_name (mkN' setsN) lthy ^ "." val e_prefix = full_name (mkN' enum_constsN) lthy ^ "." val (s,es) = db val tau = enum_constsT trac lthy val databaseT = databaseT trac lthy val a = Term.Const (s_prefix ^ s, map (fn _ => tau) es ---> databaseT) fun param_to_hol (cVar (x,EnumType _)) = Term.Free (x, tau) | param_to_hol (cVar (x,Untyped)) = Term.Free (x, tau) | param_to_hol (cEnum e) = Term.Const (e_prefix ^ e, tau) | param_to_hol (cConst c) = error (errmsg ^ ": cConst " ^ c) | param_to_hol (cVar (x,ValueType)) = error (errmsg ^ ": cVar (" ^ x ^ ",ValueType)") | param_to_hol _ = error errmsg in fold (fn e => fn b => b $ param_to_hol e) es a end fun abs_to_hol (bs:(string * string list) list) (trac:TracProtocol.protocol) lthy = let val databaseT = databaseT trac lthy fun db_params_to_cEnum (a,cs) = (a, map Trac_Term.cEnum cs) in mk_set databaseT (map (fn db => database_to_hol (db_params_to_cEnum db) trac lthy) bs) end fun cMsg_to_hol (t:Trac_Term.cMsg) lbl varT var_map free_enum_var trac lthy = let open Trac_Term val tT = messageT' varT trac lthy val fT = message_funT trac lthy val enum_constsT = enum_constsT trac lthy val tsT = message_listT' varT trac lthy val VarT = varT --> tT val FunT = [fT, tsT] ---> tT val absT = absT trac lthy val databaseT = databaseT trac lthy val AbsT = absT --> fT val funT = funT trac lthy val FuT = funT --> fT val SetT = databaseT --> fT val enumT = enum_constsT --> funT val VarC = Term.Const (@{const_name "Var"}, VarT) val FunC = Term.Const (@{const_name "Fun"}, FunT) val NilC = Term.Const (@{const_name "Nil"}, tsT) val prot_label = mk_nat lbl fun full_name'' n = full_name' n trac lthy fun mk_enum_const' a = mk_enum_const a trac lthy fun mk_prot_fun_trm f tau = Term.Const ("Transactions.prot_fun." ^ f, tau) fun mk_enum_trm etrm = mk_prot_fun_trm "Fu" FuT $ (Term.Const (full_name'' funN ^ "." ^ enumN, enumT) $ etrm) fun mk_Fu_trm f = mk_prot_fun_trm "Fu" FuT $ Term.Const (full_name'' funN ^ "." ^ f, funT) fun c_to_h s = cMsg_to_hol s lbl varT var_map free_enum_var trac lthy fun c_list_to_h ts = mk_list tT (map c_to_h ts) in case t of cVar x => if free_enum_var x then FunC $ mk_enum_trm (Term.Free (fst x, enum_constsT)) $ NilC else VarC $ var_map x | cConst f => FunC $ mk_Fu_trm f $ NilC | cFun (f,ts) => FunC $ mk_Fu_trm f $ c_list_to_h ts | cSet (s,ts) => FunC $ (mk_prot_fun_trm "Set" SetT $ database_to_hol (s,ts) trac lthy) $ NilC | cAttack => FunC $ (mk_prot_fun_trm "Attack" (natT --> fT) $ prot_label) $ NilC | cAbs bs => FunC $ (mk_prot_fun_trm "Abs" AbsT $ abs_to_hol bs trac lthy) $ NilC | cOccursFact bs => FunC $ mk_prot_fun_trm "OccursFact" fT $ mk_list tT [ FunC $ mk_prot_fun_trm "OccursSec" fT $ NilC, c_to_h bs] | cPrivFunSec => FunC $ mk_Fu_trm priv_fun_secN $ NilC | cEnum a => FunC $ mk_enum_trm (mk_enum_const' a) $ NilC end fun ground_cMsg_to_hol t lbl trac lthy = cMsg_to_hol t lbl (message_varT trac lthy) (fn _ => error "Term not ground") (fn _ => false) trac lthy fun ana_cMsg_to_hol inc_vars t (ana_var_map:string list) = let open Trac_Term fun var_map (x,Untyped) = ( case list_find (fn y => x = y) ana_var_map of SOME (_,n) => if inc_vars then mk_nat (1+n) else mk_nat n | NONE => error ("Analysis variable " ^ x ^ " not found")) | var_map _ = error "Analysis variables must be untyped" val lbl = 0 (* There's no constants in analysis messages requiring labels anyway *) in cMsg_to_hol t lbl natT var_map (fn _ => false) end fun transaction_cMsg_to_hol t lbl (transaction_var_map:string list) trac lthy = let open Trac_Term val varT = message_varT trac lthy val atomT = message_atomT trac lthy val term_typeT = message_term_typeT trac lthy fun TAtom_Value_var n = let val a = Term.Const (@{const_name "Var"}, atomT --> term_typeT) $ Term.Const ("Transactions.prot_atom.Value", atomT) in HOLogic.mk_prod (a, mk_nat n) end fun var_map_err_prefix x = "Transaction variable " ^ x ^ " should be value typed but is actually " fun var_map (x,ValueType) = ( case list_find (fn y => x = y) transaction_var_map of SOME (_,n) => TAtom_Value_var n | NONE => error ("Transaction variable " ^ x ^ " not found")) | var_map (x,EnumType e) = error (var_map_err_prefix x ^ "of enum type " ^ e) | var_map (x,Untyped) = error (var_map_err_prefix x ^ "untyped") in cMsg_to_hol t lbl varT var_map (fn (_,t) => case t of EnumType _ => true | _ => false) trac lthy end fun fp_triple_to_hol (fp,occ,ti) trac lthy = let val prot_label = 0 val tau_abs = absT trac lthy val tau_fp_elem = messageT trac lthy val tau_occ_elem = tau_abs val tau_ti_elem = mk_prodT (tau_abs, tau_abs) fun a_to_h bs = abs_to_hol bs trac lthy fun c_to_h t = ground_cMsg_to_hol t prot_label trac lthy val fp' = mk_list tau_fp_elem (map c_to_h fp) val occ' = mk_list tau_occ_elem (map a_to_h occ) val ti' = mk_list tau_ti_elem (map (mk_prod o map_prod a_to_h) ti) in mk_tuple [fp', occ', ti'] end fun abstract_over_enum_vars enum_vars enum_ineqs trm flat_type_spec trac lthy = let val enum_constsT = enum_constsT trac lthy fun enumlistelemT n = mk_tupleT (replicate n enum_constsT) fun enumlistT n = mk_listT (enumlistelemT n) fun mk_enum_const' a = mk_enum_const a trac lthy fun absfreeprod xs trm = let val tau = enum_constsT val tau_out = Term.fastype_of trm fun absfree' x = absfree (x,enum_constsT) fun aux _ [] = trm | aux _ [x] = absfree' x trm | aux len (x::y::xs) = Term.Const (@{const_name "case_prod"}, [[tau,mk_tupleT (replicate (len-1) tau)] ---> tau_out, mk_tupleT (replicate len tau)] ---> tau_out) $ absfree' x (aux (len-1) (y::xs)) in aux (length xs) xs end fun mk_enum_neq (a,b) = (HOLogic.mk_not o HOLogic.mk_eq) (Term.Free (a, enum_constsT), Term.Free (b, enum_constsT)) fun mk_enum_neqs_list [] = Term.Const (@{const_name "True"}, HOLogic.boolT) | mk_enum_neqs_list [x] = mk_enum_neq x | mk_enum_neqs_list (x::y::xs) = HOLogic.mk_conj (mk_enum_neq x, mk_enum_neqs_list (y::xs)) val enum_types = let fun aux t = if t = "" then get_enums trac else case List.find (fn (s,_) => t = s) flat_type_spec of SOME (_,cs) => cs | NONE => error ("Not an enum type: " ^ t ^ "?") in map (aux o snd) enum_vars end val enumlist_product = let fun mk_enumlist ns = mk_list enum_constsT (map mk_enum_const' ns) fun aux _ [] = mk_enumlist [] | aux _ [ns] = mk_enumlist ns | aux len (ns::ms::elists) = Term.Const ("List.product", [enumlistT 1, enumlistT (len-1)] ---> enumlistT len) $ mk_enumlist ns $ aux (len-1) (ms::elists) in aux (length enum_types) enum_types end val absfp = absfreeprod (map fst enum_vars) trm val eptrm = enumlist_product val typof = Term.fastype_of val evseT = enumlistelemT (length enum_vars) val evslT = enumlistT (length enum_vars) val eneqs = absfreeprod (map fst enum_vars) (mk_enum_neqs_list enum_ineqs) in if null enum_vars then mk_list (typof trm) [trm] else if null enum_ineqs then Term.Const(@{const_name "map"}, [typof absfp, typof eptrm] ---> mk_listT (typof trm)) $ absfp $ eptrm else Term.Const(@{const_name "map"}, [typof absfp, typof eptrm] ---> mk_listT (typof trm)) $ absfp $ (Term.Const(@{const_name "filter"}, [evseT --> HOLogic.boolT, evslT] ---> evslT) $ eneqs $ eptrm) end fun mk_type_of_name lthy pname name ty_args = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, name))), ty_args) fun mk_mt_list t = Term.Const (@{const_name "Nil"}, mk_listT t) fun name_of_typ (Type (s, _)) = s | name_of_typ (TFree _) = error "name_of_type: unexpected TFree" | name_of_typ (TVar _ ) = error "name_of_type: unexpected TVAR" fun prove_UNIV name typ elems thmsN lthy = let val rhs = mk_set typ elems val lhs = Const("Set.UNIV",mk_setT typ) val stmt = mk_Trueprop (mk_eq (lhs,rhs)) val fq_tname = name_of_typ typ fun inst_and_prove_enum thy = let val _ = writeln("Inst enum: "^name) val lthy = Class.instantiation ([fq_tname], [], @{sort enum}) thy val enum_eq = Const("Pure.eq",mk_listT typ --> mk_listT typ --> propT) $Const(@{const_name "enum_class.enum"},mk_listT typ) $(mk_list typ elems) val ((_, (_, enum_def')), lthy) = Specification.definition NONE [] [] ((Binding.name ("enum_"^name),[]), enum_eq) lthy val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy) val enum_def = singleton (Proof_Context.export lthy ctxt_thy) enum_def' val enum_all_eq = Const("Pure.eq", boolT --> boolT --> propT) $(Const(@{const_name "enum_class.enum_all"},(typ --> boolT) --> boolT) $Free("P",typ --> boolT)) $(Const(@{const_name "list_all"},(typ --> boolT) --> (mk_listT typ) --> boolT) $Free("P",typ --> boolT)$(mk_list typ elems)) val ((_, (_, enum_all_def')), lthy) = Specification.definition NONE [] [] ((Binding.name ("enum_all_"^name),[]), enum_all_eq) lthy val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy) val enum_all_def = singleton (Proof_Context.export lthy ctxt_thy) enum_all_def' val enum_ex_eq = Const("Pure.eq", boolT --> boolT --> propT) $(Const(@{const_name "enum_class.enum_ex"},(typ --> boolT) --> boolT) $Free("P",typ --> boolT)) $(Const(@{const_name "list_ex"},(typ --> boolT) --> (mk_listT typ) --> boolT) $Free("P",typ --> boolT)$(mk_list typ elems)) val ((_, (_, enum_ex_def')), lthy) = Specification.definition NONE [] [] ((Binding.name ("enum_ex_"^name),[]), enum_ex_eq) lthy val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy) val enum_ex_def = singleton (Proof_Context.export lthy ctxt_thy) enum_ex_def' in Class.prove_instantiation_exit (fn ctxt => (Class.intro_classes_tac ctxt []) THEN ALLGOALS (simp_tac (ctxt addsimps [Proof_Context.get_thm ctxt (name^"_UNIV"), enum_def, enum_all_def, enum_ex_def]) ) )lthy end fun inst_and_prove_finite thy = let val lthy = Class.instantiation ([fq_tname], [], @{sort finite}) thy in Class.prove_instantiation_exit (fn ctxt => (Class.intro_classes_tac ctxt []) THEN (simp_tac (ctxt addsimps[Proof_Context.get_thm ctxt (name^"_UNIV")])) 1) lthy end in lthy |> ml_isar_wrapper.prove_simple (name^"_UNIV") stmt (fn c => (safe_tac c) THEN (ALLGOALS(simp_tac c)) THEN (ALLGOALS(Metis_Tactic.metis_tac ["full_types"] "combs" c (map (Proof_Context.get_thm c) thmsN))) ) |> Local_Theory.raw_theory inst_and_prove_finite |> Local_Theory.raw_theory inst_and_prove_enum end fun def_types (trac:TracProtocol.protocol) lthy = let val pname = #name trac val defname = mkN(pname, enum_constsN) val _ = info(" Defining "^defname) val tnames = get_enums trac val types = map (fn x => ([],x)) tnames in ([defname], ml_isar_wrapper.define_simple_datatype ([], defname) types lthy) end fun def_sets (trac:TracProtocol.protocol) lthy = let val pname = #name trac val defname = mkN(pname, setsN) val _ = info (" Defining "^defname) val sspec = get_set_spec trac val tfqn = Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))) val ttyp = Type(tfqn, []) val types = map (fn (x,n) => (replicate n ttyp,x)) sspec in lthy |> ml_isar_wrapper.define_simple_datatype ([], defname) types end fun def_funs (trac:TracProtocol.protocol) lthy = let val pname = #name trac val (pub_f, pub_c, priv) = get_funs trac val pub = pub_f@pub_c fun def_atom lthy = let val def_atomname = mkN(pname, atomN) val types = if null pub_c then types else types@[other_pubconsts_typeN] fun define_atom_dt lthy = let val _ = info(" Defining "^def_atomname) in lthy |> ml_isar_wrapper.define_simple_datatype ([], def_atomname) (map (fn x => ([],x)) types) end fun prove_UNIV_atom lthy = let val _ = info (" Proving "^def_atomname^"_UNIV") val thmsN = [def_atomname^".exhaust"] val fqn = Local_Theory.full_name lthy (Binding.name (mkN(pname, atomN))) val typ = Type(fqn, []) in lthy |> prove_UNIV (def_atomname) typ (map (fn c => Const(fqn^"."^c,typ)) types) thmsN end in lthy |> define_atom_dt |> prove_UNIV_atom end fun def_fun_dt lthy = let val def_funname = mkN(pname, funN) val _ = info(" Defining "^def_funname) val types = map (fn x => ([],x)) (map fst (pub@priv)) val ctyp = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), []) in ml_isar_wrapper.define_simple_datatype ([], def_funname) (types@[([ctyp],enumN)]) lthy end fun def_fun_arity lthy = let val fqn_name = Local_Theory.full_name lthy (Binding.name (mkN(pname, funN))) val ctyp = Type(fqn_name, []) fun mk_rec_eq name (fname,arity) = (Free(name,ctyp --> natT) $Const(fqn_name^"."^fname,ctyp), mk_nat((Option.valOf o Int.fromString) arity)) val name = mkN(pname, arityN) val _ = info(" Defining "^name) val ctyp' = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), []) in ml_isar_wrapper.define_simple_fun name ((map (mk_rec_eq name) (pub@priv))@[ (Free(name, ctyp --> natT) $(Const(fqn_name^"."^enumN, ctyp' --> ctyp)$(Term.dummy_pattern ctyp')), mk_nat(0))]) lthy end fun def_public lthy = let val fqn_name = Local_Theory.full_name lthy (Binding.name (mkN(pname, funN))) val ctyp = Type(fqn_name, []) fun mk_rec_eq name t fname = (Free(name, ctyp --> boolT) $Const(fqn_name^"."^fname,ctyp), t) val name = mkN(pname, publicN) val _ = info(" Defining "^name) val ctyp' = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), []) in ml_isar_wrapper.define_simple_fun name ((map (mk_rec_eq name (@{term "False"})) (map fst priv)) @(map (mk_rec_eq name (@{term "True"})) (map fst pub)) @[(Free(name, ctyp --> boolT) $(Const(fqn_name^"."^enumN, ctyp' --> ctyp)$(Term.dummy_pattern ctyp')), @{term "True"})]) lthy end fun def_gamma lthy = let fun optionT t = Type (@{type_name "option"}, [t]) fun mk_Some t = Const (@{const_name "Some"}, t --> optionT t) fun mk_None t = Const (@{const_name "None"}, optionT t) val fqn_name = Local_Theory.full_name lthy (Binding.name (mkN(pname, funN))) val ctyp = Type(fqn_name, []) val atomFQN = Local_Theory.full_name lthy (Binding.name (mkN(pname, atomN))) val atomT = Type(atomFQN, []) fun mk_rec_eq name t fname = (Free(name, ctyp --> optionT atomT) $Const(fqn_name^"."^fname,ctyp), t) val name = mkN(pname, gammaN) val _ = info(" Defining "^name) val ctyp' = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), []) in ml_isar_wrapper.define_simple_fun name ((map (mk_rec_eq name ((mk_Some atomT)$(Const(atomFQN^"."^secret_typeN, atomT)))) (map fst priv)) @(map (mk_rec_eq name ((mk_Some atomT)$(Const(atomFQN^"."^other_pubconsts_typeN, atomT)))) (map fst pub_c)) @[(Free(name, ctyp --> optionT atomT) $(Const(fqn_name^"."^enumN, ctyp' --> ctyp)$(Term.dummy_pattern ctyp')), (mk_Some atomT)$(Const(atomFQN^"."^enum_typeN,atomT)))] @(map (mk_rec_eq name (mk_None atomT)) (map fst pub_f)) ) lthy end fun def_ana lthy = let val pname = #name trac val (pub_f, pub_c, priv) = get_funs trac val pub = pub_f@pub_c val keyT = messageT' natT trac lthy val fqn_name = Local_Theory.full_name lthy (Binding.name (mkN(pname, funN))) val ctyp = Type(fqn_name, []) val ana_outputT = mk_prodT (mk_listT keyT, mk_listT natT) val default_output = mk_prod (mk_list keyT [], mk_list natT []) fun mk_ana_output ks rs = mk_prod (mk_list keyT ks, mk_list natT rs) fun mk_rec_eq name t fname = (Free(name, ctyp --> ana_outputT) $Term.Const(fqn_name^"."^fname,ctyp), t) val name = mkN(pname, anaN) val _ = info(" Defining "^name) val ctyp' = Type(Local_Theory.full_name lthy (Binding.name (mkN(pname, enum_constsN))), []) val ana_spec = let val toInt = Option.valOf o Int.fromString fun ana_arity (f,n) = (if is_priv_fun trac f then (toInt n)-1 else toInt n) fun check_valid_arity ((f,ps),ks,rs) = case List.find (fn g => f = fst g) pub_f of SOME (f',n) => if length ps <> ana_arity (f',n) then error ("Invalid number of parameters in the analysis rule for " ^ f ^ " (expected " ^ Int.toString (ana_arity (f',n)) ^ " but got " ^ Int.toString (length ps) ^ ")") else ((f,ps),ks,rs) | NONE => error (f ^ " is not a declared function symbol of arity greater than zero") val transform_cMsg = transform_cMsg trac val rm_special_funs = rm_special_funs (fn ((f,_),_,_) => f) fun var_to_nat f xs x = let val n = snd (Option.valOf ((list_find (fn y => y = x) xs))) in if is_priv_fun trac f then mk_nat (1+n) else mk_nat n end fun c_to_h f xs t = ana_cMsg_to_hol (is_priv_fun trac f) t xs trac lthy fun keys f ps ks = map (c_to_h f ps o transform_cMsg o Trac_Term.certifyMsg [] []) ks fun results f ps rs = map (var_to_nat f ps) rs fun aux ((f,ps),ks,rs) = (f, mk_ana_output (keys f ps ks) (results f ps rs)) in map (aux o check_valid_arity) (rm_special_funs (#analysis_spec trac)) end val other_funs = filter (fn f => not (List.exists (fn g => f = g) (map fst ana_spec))) (map fst (pub@priv)) in ml_isar_wrapper.define_simple_fun name ((map (fn (f,out) => mk_rec_eq name out f) ana_spec) @(map (mk_rec_eq name default_output) other_funs) @[(Free(name, ctyp --> ana_outputT) $(Term.Const(fqn_name^"."^enumN, ctyp' --> ctyp)$(Term.dummy_pattern ctyp')), default_output)]) lthy end in lthy |> def_atom |> def_fun_dt |> def_fun_arity |> def_public |> def_gamma |> def_ana end fun define_term_model (trac:TracProtocol.protocol) lthy = let val _ = info("Defining term model") in lthy |> snd o def_types trac |> def_sets trac |> def_funs trac end fun define_fixpoint fp trac print lthy = let val fp_name = mkN (#name trac, "fixpoint") val _ = info("Defining fixpoint") val _ = info(" Defining "^fp_name) val fp_triple = transform_fp trac fp val fp_triple_trm = fp_triple_to_hol fp_triple trac lthy val trac = TracProtocol.update_fixed_point trac (SOME fp_triple) in (trac, #2 (ml_isar_wrapper.define_constant_definition' (fp_name, fp_triple_trm) print lthy)) end fun define_protocol print ((trac:TracProtocol.protocol), lthy) = let val _ = if length (#transaction_spec trac) > 1 then info("Defining protocols") else info("Defining protocol") val pname = #name trac val flat_type_spec = flatten_type_spec trac val mk_Transaction = mk_Transaction trac lthy val mk_Send = mk_Send_step trac lthy val mk_Receive = mk_Receive_step trac lthy val mk_InSet = mk_InSet_step trac lthy val mk_NotInSet = mk_NotInSet_step trac lthy val mk_Inequality = mk_Inequality_step trac lthy val mk_Insert = mk_Insert_step trac lthy val mk_Delete = mk_Delete_step trac lthy val star_label = mk_star_label val prot_label = mk_prot_label val certify_transation = TracProtocol.certifyTransaction fun mk_tname i (tr:TracProtocol.transaction_name) = let val x = #1 tr val y = case i of NONE => x | SOME n => mkN(n, x) val z = mkN("transaction", y) in mkN(pname, z) end fun def_transaction name_prefix prot_num (transaction:TracProtocol.cTransaction) lthy = let val defname = mk_tname name_prefix (#transaction transaction) val _ = info(" Defining "^defname) val receives = #receive_actions transaction val checkssingle = #checksingle_actions transaction val checksall = #checkall_actions transaction val updates = #update_actions transaction val sends = #send_actions transaction val fresh = get_fresh_value_variables transaction val attack_signals = #attack_actions transaction val nonfresh_value_vars = get_nonfresh_value_variables transaction val value_vars = get_value_variables transaction val enum_vars = get_enum_variables transaction val (enum_ineqs, value_ineqs) = get_variable_restrictions transaction val transform_cMsg = transform_cMsg trac fun c_to_h trm = transaction_cMsg_to_hol (transform_cMsg trm) prot_num value_vars trac lthy val abstract_over_enum_vars = fn x => fn y => fn z => abstract_over_enum_vars x y z flat_type_spec trac lthy fun mk_transaction_term (rcvs, chcksingle, chckall, upds, snds, frsh, atcks) = let open Trac_Term fun action_filter f (lbl,a) = case f a of SOME x => SOME (lbl,x) | NONE => NONE fun lbl_to_h (TracProtocol.LabelS) = star_label | lbl_to_h (TracProtocol.LabelN) = prot_label prot_num fun lbl_trm_to_h f (lbl,t) = f (lbl_to_h lbl) (c_to_h t) val S1 = map (lbl_trm_to_h mk_Receive) (map_filter (action_filter TracProtocol.maybe_the_Receive) rcvs) val S2 = let fun aux (lbl,TracProtocol.cInequality (x,y)) = SOME (mk_Inequality (lbl_to_h lbl) (c_to_h x) (c_to_h y)) | aux (lbl,TracProtocol.cInSet (e,s)) = SOME (mk_InSet (lbl_to_h lbl) (c_to_h e) (c_to_h s)) | aux (lbl,TracProtocol.cNotInSet (e,s)) = SOME (mk_NotInSet (lbl_to_h lbl) (c_to_h e) (c_to_h s)) | aux _ = NONE in map_filter aux chcksingle end val S3 = let fun arity s = case set_arity trac s of SOME n => n | NONE => error ("Not a set family: " ^ s) fun mk_evs s = map (fn n => ("X" ^ Int.toString n, "")) (0 upto ((arity s) -1)) fun mk_trm (lbl,e,s) = let val ps = map (fn x => cVar (x,Untyped)) (map fst (mk_evs s)) in mk_NotInSet (lbl_to_h lbl) (c_to_h e) (c_to_h (cSet (s,ps))) end fun mk_trms (lbl,(e,s)) = abstract_over_enum_vars (mk_evs s) [] (mk_trm (lbl,e,s)) in map mk_trms (map_filter (action_filter TracProtocol.maybe_the_NotInAny) chckall) end val S4 = map (c_to_h o mk_Value_cVar) frsh val S5 = let fun aux (lbl,TracProtocol.cInsert (e,s)) = SOME (mk_Insert (lbl_to_h lbl) (c_to_h e) (c_to_h s)) | aux (lbl,TracProtocol.cDelete (e,s)) = SOME (mk_Delete (lbl_to_h lbl) (c_to_h e) (c_to_h s)) | aux _ = NONE in map_filter aux upds end val S6 = let val snds' = map_filter (action_filter TracProtocol.maybe_the_Send) snds in map (lbl_trm_to_h mk_Send) (snds'@map (fn (lbl,_) => (lbl,cAttack)) atcks) end in abstract_over_enum_vars enum_vars enum_ineqs (mk_Transaction S1 S2 S3 S4 S5 S6) end fun def_trm trm print lthy = #2 (ml_isar_wrapper.define_constant_definition' (defname, trm) print lthy) val additional_value_ineqs = let open Trac_Term open TracProtocol val poschecks = map_filter (maybe_the_InSet o snd) checkssingle val negchecks_single = map_filter (maybe_the_NotInSet o snd) checkssingle val negchecks_all = map_filter (maybe_the_NotInAny o snd) checksall fun aux' (cVar (x,ValueType),s) (cVar (y,ValueType),t) = if s = t then SOME (x,y) else NONE | aux' _ _ = NONE fun aux (x,cSet (s,ps)) = SOME ( map_filter (aux' (x,cSet (s,ps))) negchecks_single@ map_filter (aux' (x,s)) negchecks_all ) | aux _ = NONE in List.concat (map_filter aux poschecks) end val all_value_ineqs = mk_unique (value_ineqs@additional_value_ineqs) val valvarsprod = filter (fn p => not (List.exists (fn q => p = q orelse swap p = q) all_value_ineqs)) (list_triangle_product (fn x => fn y => (x,y)) nonfresh_value_vars) val transaction_trm0 = mk_transaction_term (receives, checkssingle, checksall, updates, sends, fresh, attack_signals) in if null valvarsprod then def_trm transaction_trm0 print lthy else let val partitions = list_partitions nonfresh_value_vars all_value_ineqs val ps = filter (not o null) (map (filter (fn x => length x > 1)) partitions) fun mk_subst ps = let open Trac_Term fun aux [] = NONE | aux (x::xs) = SOME (map (fn y => (y,cVar (x,ValueType))) xs) in List.concat (map_filter aux ps) end fun apply d = let val ap = TracProtocol.subst_apply_actions d fun f (TracProtocol.cInequality (x,y)) = x <> y | f _ = true val checksingle' = filter (f o snd) (ap checkssingle) in (ap receives, checksingle', ap checksall, ap updates, ap sends, fresh, attack_signals) end val transaction_trms = transaction_trm0::map (mk_transaction_term o apply o mk_subst) ps val transaction_typ = Term.fastype_of transaction_trm0 fun mk_concat_trm tau trms = Term.Const (@{const_name "concat"}, mk_listT tau --> tau) $ mk_list tau trms in def_trm (mk_concat_trm transaction_typ transaction_trms) print lthy end end val def_transactions = let val prots = map (fn (n,pr) => map (fn tr => (n,tr)) pr) (#transaction_spec trac) val lbls = list_upto (length prots) val lbl_prots = List.concat (map (fn i => map (fn tr => (i,tr)) (nth prots i)) lbls) val f = fold (fn (i,(n,tr)) => def_transaction n i (certify_transation tr)) in f lbl_prots end fun def_protocols lthy = let fun mk_prot_def (name,trm) lthy = let val _ = info(" Defining "^name) in #2 (ml_isar_wrapper.define_constant_definition' (name,trm) print lthy) end val prots = #transaction_spec trac val num_prots = length prots val pdefname = mkN(pname, "protocol") fun mk_tnames i = let val trs = case nth prots i of (j,prot) => map (fn tr => (j,tr)) prot in map (fn (j,s) => full_name (mk_tname j (#transaction s)) lthy) trs end val tnames = List.concat (map mk_tnames (list_upto num_prots)) val pnames = let val f = fn i => (Int.toString i,nth prots i) val g = fn (i,(n,_)) => case n of NONE => i | SOME m => m val h = fn s => mkN (pdefname,s) in map (h o g o f) (list_upto num_prots) end val trtyp = prot_transactionT trac lthy val trstyp = mk_listT trtyp fun mk_prot_trm names = Term.Const (@{const_name "concat"}, mk_listT trstyp --> trstyp) $ mk_list trstyp (map (fn x => Term.Const (x, trstyp)) names) val lthy = if num_prots > 1 then fold (fn (i,pname) => mk_prot_def (pname, mk_prot_trm (mk_tnames i))) (map (fn i => (i, nth pnames i)) (list_upto num_prots)) lthy else lthy val pnames' = map (fn n => full_name n lthy) pnames fun mk_prot_trm_with_star i = let fun f j = if j = i then Term.Const (nth pnames' j, trstyp) else (Term.Const (@{const_name "map"}, [trtyp --> trtyp, trstyp] ---> trstyp) $ Term.Const ("Transactions.transaction_star_proj", trtyp --> trtyp) $ Term.Const (nth pnames' j, trstyp)) in Term.Const (@{const_name "concat"}, mk_listT trstyp --> trstyp) $ mk_list trstyp (map f (list_upto num_prots)) end val lthy = if num_prots > 1 then fold (fn (i,pname) => mk_prot_def (pname, mk_prot_trm_with_star i)) (map (fn i => (i, nth pnames i ^ "_with_star")) (list_upto num_prots)) lthy else lthy in mk_prot_def (pdefname, mk_prot_trm (if num_prots > 1 then pnames' else tnames)) lthy end in (trac, lthy |> def_transactions |> def_protocols) end end \ ML\ structure trac = struct open Trac_Term val info = Output.information (* Define global configuration option "trac" *) (* val trac_fp_compute_binary_cfg = let val (trac_fp_compute_path_config, trac_fp_compute_path_setup) = Attrib.config_string (Binding.name "trac_fp_compute") (K "trac_fp_compute") in Context.>>(Context.map_theory trac_fp_compute_path_setup); trac_fp_compute_path_config end val trac_eval_cfg = let val (trac_fp_compute_eval_config, trac_fp_compute_eval) = Attrib.config_bool (Binding.name "trac_fp_compute_eval") (K false) in Context.>>(Context.map_theory trac_fp_compute_eval); trac_fp_compute_eval_config end *) type hide_tvar_tab = (TracProtocol.protocol) Symtab.table fun trac_eq (a, a') = (#name a) = (#name a') fun merge_trac_tab (tab,tab') = Symtab.merge trac_eq (tab,tab') structure Data = Generic_Data ( type T = hide_tvar_tab val empty = Symtab.empty:hide_tvar_tab - val extend = I fun merge(t1,t2) = merge_trac_tab (t1, t2) ); fun update p thy = Context.theory_of ((Data.map (fn tab => Symtab.update (#name p, p) tab) (Context.Theory thy))) fun lookup name thy = (Symtab.lookup ((Data.get o Context.Theory) thy) name,thy) fun mk_abs_filename thy filename = let val filename = Path.explode filename val master_dir = Resources.master_directory thy in Path.implode (if (Path.is_absolute filename) then filename else master_dir + filename) end (* fun exec {trac_path, error_detail} filename = let open OS.FileSys OS.Process val tmpname = tmpName() val err_tmpname = tmpName() fun plural 1 = "" | plural _ = "s" val trac = case trac_path of SOME s => s | NONE => raise error ("trac_fp_compute_path not specified") val cmdline = trac ^ " \"" ^ filename ^ "\" > " ^ tmpname ^ " 2> " ^ err_tmpname in if isSuccess (system cmdline) then (OS.FileSys.remove err_tmpname; tmpname) else let val _ = OS.FileSys.remove tmpname val (msg, rest) = File.read_lines (Path.explode err_tmpname) |> chop error_detail val _ = OS.FileSys.remove err_tmpname val _ = warning ("trac failed on " ^ filename ^ "\nCommand: " ^ cmdline ^ "\n\nOutput:\n" ^ cat_lines (msg @ (if null rest then [] else ["(... " ^ string_of_int (length rest) ^ " more line" ^ plural (length rest) ^ ")"]))) in raise error ("trac failed on " ^ filename) end end *) fun lookup_trac (pname:string) lthy = Option.valOf (fst (lookup pname (Proof_Context.theory_of lthy))) fun def_fp fp_str print (trac, lthy) = let val fp = TracFpParser.parse_str fp_str val (trac,lthy) = trac_definitorial_package.define_fixpoint fp trac print lthy val lthy = Local_Theory.raw_theory (update trac) lthy in (trac, lthy) end fun def_fp_file filename print (trac, lthy) = let val thy = Proof_Context.theory_of lthy val abs_filename = mk_abs_filename thy filename val fp = TracFpParser.parse_file abs_filename val (trac,lthy) = trac_definitorial_package.define_fixpoint fp trac print lthy val lthy = Local_Theory.raw_theory (update trac) lthy in (trac, lthy) end fun def_fp_trac fp_filename print (trac, lthy) = let open OS.FileSys OS.Process val _ = info("Checking protocol specification with trac.") val thy = Proof_Context.theory_of lthy (* val trac = Config.get_global thy trac_binary_cfg *) val abs_filename = mk_abs_filename thy fp_filename (* val fp_file = exec {error_detail=10, trac_path = SOME trac} abs_filename *) (* val fp_raw = File.read (Path.explode fp_file) *) val fp_raw = File.read (Path.explode abs_filename) val fp = TracFpParser.parse_str fp_raw (* val _ = OS.FileSys.remove fp_file *) val _ = if TracFpParser.attack fp then error (" ATTACK found, skipping generating of Isabelle/HOL definitions.\n\n") else info(" No attack found, continue with generating Isabelle/HOL definitions.") val (trac,lthy) = trac_definitorial_package.define_fixpoint fp trac print lthy val lthy = Local_Theory.raw_theory (update trac) lthy in (trac, lthy) end fun def_trac_term_model str lthy = let val trac = TracProtocolParser.parse_str str val lthy = Local_Theory.raw_theory (update trac) lthy val lthy = trac_definitorial_package.define_term_model trac lthy in (trac, lthy) end val def_trac_protocol = trac_definitorial_package.define_protocol fun def_trac str print = def_trac_protocol print o def_trac_term_model str fun def_trac_file filename print lthy = let val trac_raw = File.read (Path.explode filename) val (trac,lthy) = def_trac trac_raw print lthy val lthy = Local_Theory.raw_theory (update trac) lthy in (trac, lthy) end fun def_trac_fp_trac trac_str print lthy = let open OS.FileSys OS.Process val (trac,lthy) = def_trac trac_str print lthy val tmpname = tmpName() val _ = File.write (Path.explode tmpname) trac_str val (trac,lthy) = def_fp_trac tmpname print (trac, lthy) val _ = OS.FileSys.remove tmpname val lthy = Local_Theory.raw_theory (update trac) lthy in lthy end end \ ML\ val fileNameP = Parse.name -- Parse.name val _ = Outer_Syntax.local_theory' @{command_keyword "trac_import"} "Import protocol and fixpoint from trac files." (fileNameP >> (fn (trac_filename, fp_filename) => fn print => trac.def_trac_file trac_filename print #> trac.def_fp_file fp_filename print #> snd)); val _ = Outer_Syntax.local_theory' @{command_keyword "trac_import_trac"} "Import protocol from trac file and compute fixpoint with trac." (fileNameP >> (fn (trac_filename, fp_filename) => fn print => trac.def_trac trac_filename print #> trac.def_fp_trac fp_filename print #> snd)); val _ = Outer_Syntax.local_theory' @{command_keyword "trac_trac"} "Define protocol using trac format and compute fixpoint with trac." (Parse.cartouche >> (fn trac => fn print => trac.def_trac_fp_trac trac print)); val _ = Outer_Syntax.local_theory' @{command_keyword "trac"} "Define protocol and (optionally) fixpoint using trac format." (Parse.cartouche -- Scan.optional Parse.cartouche "" >> (fn (trac,fp) => fn print => if fp = "" then trac.def_trac trac print #> snd else trac.def_trac trac print #> trac.def_fp fp print #> snd)); \ ML\ val name_prefix_parser = Parse.!!! (Parse.name --| Parse.$$$ ":" -- Parse.name) (* Original definition (opt_evaluator) copied from value_command.ml *) val opt_proof_method_choice = Scan.optional (\<^keyword>\[\ |-- Parse.name --| \<^keyword>\]\) "safe"; (* Original definition (locale_expression) copied from parse_spec.ML *) val opt_defs_list = Scan.optional (\<^keyword>\for\ |-- Scan.repeat1 Parse.name >> (fn xs => if length xs > 3 then error "Too many optional arguments" else xs)) []; val security_proof_locale_parser = name_prefix_parser -- opt_defs_list val security_proof_locale_parser_with_method_choice = opt_proof_method_choice -- name_prefix_parser -- opt_defs_list fun protocol_model_setup_proof_state name prefix lthy = let fun f x y z = ([((x,Position.none),((y,true),(Expression.Positional z,[])))],[]) val _ = if name = "" then error "No name given" else () val pexpr = f "stateful_protocol_model" name (protocol_model_interpretation_params prefix) val pdefs = protocol_model_interpretation_defs name val proof_state = Interpretation.global_interpretation_cmd pexpr pdefs lthy in proof_state end fun protocol_security_proof_proof_state manual_proof name prefix opt_defs print lthy = let fun f x y z = ([((x,Position.none),((y,true),(Expression.Positional z,[])))],[]) val _ = if name = "" then error "No name given" else () val num_defs = length opt_defs val pparams = protocol_model_interpretation_params prefix val default_defs = [prefix ^ "_" ^ "protocol", prefix ^ "_" ^ "fixpoint"] fun g locale_name extra_params = f locale_name name (pparams@map SOME extra_params) val (prot_fp_smp_names, pexpr) = if manual_proof then (case num_defs of 0 => (default_defs, g "secure_stateful_protocol'" default_defs) | 1 => (opt_defs, g "secure_stateful_protocol''" opt_defs) | 2 => (opt_defs, g "secure_stateful_protocol'" opt_defs) | _ => (opt_defs, g "secure_stateful_protocol" opt_defs)) else (case num_defs of 0 => (default_defs, g "secure_stateful_protocol''''" default_defs) | 1 => (opt_defs, g "secure_stateful_protocol''" opt_defs) | 2 => (opt_defs, g "secure_stateful_protocol''''" opt_defs) | _ => (opt_defs, g "secure_stateful_protocol'''" opt_defs)) val proof_state = lthy |> declare_protocol_checks print |> Interpretation.global_interpretation_cmd pexpr [] in (prot_fp_smp_names, proof_state) end val _ = Outer_Syntax.local_theory \<^command_keyword>\protocol_model_setup\ "prove interpretation of protocol model locale into global theory" (name_prefix_parser >> (fn (name,prefix) => fn lthy => let val proof_state = protocol_model_setup_proof_state name prefix lthy val meth = let val m = "protocol_model_interpretation" val _ = Output.information ( "Proving protocol model locale instance with proof method " ^ m) in Method.Source (Token.make_src (m, Position.none) []) end in ml_isar_wrapper.prove_state_simple meth proof_state end)); val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\manual_protocol_model_setup\ "prove interpretation of protocol model locale into global theory" (name_prefix_parser >> (fn (name,prefix) => fn lthy => let val proof_state = protocol_model_setup_proof_state name prefix lthy val subgoal_proof = " subgoal by protocol_model_subgoal\n" val _ = Output.information ("Example proof:\n" ^ Active.sendback_markup_command (" apply unfold_locales\n"^ subgoal_proof^ subgoal_proof^ subgoal_proof^ subgoal_proof^ subgoal_proof^ " done\n")) in proof_state end)); val _ = Outer_Syntax.local_theory' \<^command_keyword>\protocol_security_proof\ "prove interpretation of secure protocol locale into global theory" (security_proof_locale_parser_with_method_choice >> (fn params => fn print => fn lthy => let val ((opt_meth_level,(name,prefix)),opt_defs) = params val (defs, proof_state) = protocol_security_proof_proof_state false name prefix opt_defs print lthy val num_defs = length defs val meth = let val m = case opt_meth_level of "safe" => "check_protocol" ^ "'" (* (if num_defs = 1 then "'" else "") *) | "unsafe" => "check_protocol_unsafe" ^ "'" (* (if num_defs = 1 then "'" else "") *) | _ => error ("Invalid option: " ^ opt_meth_level) val _ = Output.information ( "Proving security of protocol " ^ nth defs 0 ^ " with proof method " ^ m) val _ = if num_defs > 1 then Output.information ("Using fixpoint " ^ nth defs 1) else () val _ = if num_defs > 2 then Output.information ("Using SMP set " ^ nth defs 2) else () in Method.Source (Token.make_src (m, Position.none) []) end in ml_isar_wrapper.prove_state_simple meth proof_state end )); val _ = Outer_Syntax.local_theory_to_proof' \<^command_keyword>\manual_protocol_security_proof\ "prove interpretation of secure protocol locale into global theory" (security_proof_locale_parser >> (fn params => fn print => fn lthy => let val ((name,prefix),opt_defs) = params val (defs, proof_state) = protocol_security_proof_proof_state true name prefix opt_defs print lthy val subgoal_proof = let val m = "code_simp" (* case opt_meth_level of "safe" => "code_simp" | "unsafe" => "eval" | _ => error ("Invalid option: " ^ opt_meth_level) *) in " subgoal by " ^ m ^ "\n" end val _ = Output.information ("Example proof:\n" ^ Active.sendback_markup_command (" apply check_protocol_intro\n"^ subgoal_proof^ (if length defs = 1 then "" else subgoal_proof^ subgoal_proof^ subgoal_proof^ subgoal_proof)^ " done\n")) in proof_state end )); \ end diff --git a/thys/Automatic_Refinement/Lib/Named_Sorted_Thms.thy b/thys/Automatic_Refinement/Lib/Named_Sorted_Thms.thy --- a/thys/Automatic_Refinement/Lib/Named_Sorted_Thms.thy +++ b/thys/Automatic_Refinement/Lib/Named_Sorted_Thms.thy @@ -1,74 +1,73 @@ section \Named Theorems with Explicit Filtering and Sorting\ theory Named_Sorted_Thms imports Attr_Comb begin ML \ signature NAMED_SORTED_THMS = sig val member: Proof.context -> thm -> bool val get: Proof.context -> thm list val add_thm: thm -> Context.generic -> Context.generic val del_thm: thm -> Context.generic -> Context.generic val add: attribute val del: attribute val setup: theory -> theory end; functor Named_Sorted_Thms( val name: binding val description: string val sort: Context.generic -> thm list -> thm list val transform: Context.generic -> thm -> thm list (* Raise THM on invalid thm *) ): NAMED_SORTED_THMS = struct structure Data = Generic_Data ( type T = thm Item_Net.T; val empty = Thm.item_net; - val extend = I; val merge = Item_Net.merge; ); val member = Item_Net.member o Data.get o Context.Proof; fun content context = sort context (Item_Net.content (Data.get context)); val get = content o Context.Proof; fun wrap upd = Thm.declaration_attribute (fn thm => fn context => let fun warn (msg,i,thms) = let val ctxt = Context.proof_of context val pt = Pretty.block [ Pretty.str msg, Pretty.brk 1, Pretty.block [Pretty.str "(",Pretty.str (string_of_int i),Pretty.str ")"], Pretty.brk 1, Pretty.block (Pretty.fbreaks (map (Thm.pretty_thm ctxt) thms)) ] in warning (Pretty.string_of pt) end val thms = (transform context thm) handle THM e => (warn e; []) in fold upd thms context end) val add = wrap (Data.map o Item_Net.update) val del = wrap (Data.map o Item_Net.remove) fun add_thm thm = Thm.apply_attribute (add) thm #> snd fun del_thm thm = Thm.apply_attribute (del) thm #> snd val setup = Attrib.setup name (Attrib.add_del add del) ("declaration of " ^ description) #> Global_Theory.add_thms_dynamic (name, content); end; \ end diff --git a/thys/Automatic_Refinement/Lib/Tagged_Solver.thy b/thys/Automatic_Refinement/Lib/Tagged_Solver.thy --- a/thys/Automatic_Refinement/Lib/Tagged_Solver.thy +++ b/thys/Automatic_Refinement/Lib/Tagged_Solver.thy @@ -1,310 +1,309 @@ theory Tagged_Solver imports Refine_Util begin (* TODO/FIXME: A solver is some named entity, and it should be possible to reference it by its short/long name like a constant or a theorem! *) ML \ signature TAGGED_SOLVER = sig type solver = thm list * string * string * (Proof.context -> tactic') val get_solvers: Proof.context -> solver list val declare_solver: thm list -> binding -> string -> (Proof.context -> tactic') -> morphism -> Context.generic -> Context.generic val lookup_solver: string -> Context.generic -> solver option val add_triggers: string -> thm list -> morphism -> Context.generic -> Context.generic val delete_solver: string -> morphism -> Context.generic -> Context.generic val tac_of_solver: Proof.context -> solver -> tactic' val get_potential_solvers: Proof.context -> int -> thm -> solver list val get_potential_tacs: Proof.context -> int -> thm -> tactic' list val solve_greedy_step_tac: Proof.context -> tactic' val solve_greedy_tac: Proof.context -> tactic' val solve_greedy_keep_tac: Proof.context -> tactic' val solve_full_step_tac: Proof.context -> tactic' val solve_full_tac: Proof.context -> tactic' val solve_full_keep_tac: Proof.context -> tactic' val cfg_keep: bool Config.T val cfg_trace: bool Config.T val cfg_full: bool Config.T val cfg_step: bool Config.T val solve_tac: Proof.context -> tactic' val pretty_solvers: Proof.context -> Pretty.T end structure Tagged_Solver : TAGGED_SOLVER = struct type solver = thm list * string * string * (Proof.context -> tactic') structure solvers = Generic_Data ( type T = solver Item_Net.T * solver Symtab.table val empty = (Item_Net.init ((op =) o apply2 #2) (fn p:solver => #1 p |> map Thm.concl_of) , Symtab.empty ) fun merge ((n1,t1),(n2,t2)) = (Item_Net.merge (n1,n2), Symtab.merge ((op =) o apply2 #2) (t1,t2)) - val extend = I ) fun get_solvers ctxt = solvers.get (Context.Proof ctxt) |> #2 |> Symtab.dest |> map #2 fun lookup_solver n context = let val tab = solvers.get context |> #2 in Symtab.lookup tab n end fun add_triggers n thms phi context = case lookup_solver n context of NONE => error ("Undefined solver: " ^ n) | SOME (trigs,n,desc,tac) => let val thms = map (Morphism.thm phi) thms val trigs = thms @ trigs val solver = (trigs,n,desc,tac) in solvers.map (Item_Net.update solver ## Symtab.update (n, solver)) context end fun declare_solver thms n desc tac phi context = let val thms = map (Morphism.thm phi) thms val n = Morphism.binding phi n val n = Context.cases Sign.full_name Proof_Context.full_name context n val _ = if Symtab.defined (solvers.get context |> #2) n then error ("Duplicate solver " ^ n) else () val solver = (thms,n,desc,tac) in solvers.map (Item_Net.update solver ## Symtab.update (n,solver)) context end fun delete_solver n _ context = case lookup_solver n context of NONE => error ("Undefined solver: " ^ n) | SOME solver => solvers.map (Item_Net.remove solver ## Symtab.delete (#2 solver)) context val cfg_keep = Attrib.setup_config_bool @{binding tagged_solver_keep} (K false) val cfg_trace = Attrib.setup_config_bool @{binding tagged_solver_trace} (K false) val cfg_step = Attrib.setup_config_bool @{binding tagged_solver_step} (K false) val cfg_full = Attrib.setup_config_bool @{binding tagged_solver_full} (K false) (* Get potential solvers. Overapproximation caused by net *) fun get_potential_solvers ctxt i st = let val concl = Logic.concl_of_goal (Thm.prop_of st) i val net = solvers.get (Context.Proof ctxt) |> #1 val solvers = Item_Net.retrieve net concl in solvers end fun notrace_tac_of_solver ctxt (thms,_,_,tac) = match_tac ctxt thms THEN' tac ctxt fun trace_tac_of_solver ctxt (thms,name,_,tac) i st = let val _ = tracing ("Trying solver " ^ name) val r = match_tac ctxt thms i st in case Seq.pull r of NONE => (tracing " No trigger"; Seq.empty) | SOME _ => let val r = Seq.maps (tac ctxt i) r in case Seq.pull r of NONE => (tracing (" No solution (" ^ name ^ ")"); Seq.empty) | SOME _ => (tracing (" OK (" ^ name ^ ")"); r) end end fun tac_of_solver ctxt = if Config.get ctxt cfg_trace then trace_tac_of_solver ctxt else notrace_tac_of_solver ctxt fun get_potential_tacs ctxt i st = if i <= Thm.nprems_of st then eq_assume_tac :: ( get_potential_solvers ctxt i st |> map (tac_of_solver ctxt) ) else [] fun solve_greedy_step_tac ctxt i st = (FIRST' (get_potential_tacs ctxt i st)) i st fun solve_full_step_tac ctxt i st = (APPEND_LIST' (get_potential_tacs ctxt i st) i st) (* Try to solve, take first matching tactic, but allow backtracking over its results *) fun solve_greedy_tac ctxt i st = let val tacs = get_potential_tacs ctxt i st in (FIRST' tacs THEN_ALL_NEW_FWD solve_greedy_tac ctxt) i st end (* Try to solve. Allow backtracking over matching tactics. *) fun solve_full_tac ctxt i st = let val tacs = get_potential_tacs ctxt i st in (APPEND_LIST' tacs THEN_ALL_NEW_FWD solve_full_tac ctxt) i st end fun solve_greedy_keep_tac ctxt i st = let val tacs = get_potential_tacs ctxt i st in (FIRST' tacs THEN_ALL_NEW_FWD (TRY o solve_greedy_keep_tac ctxt)) i st end fun solve_full_keep_tac ctxt i st = let val tacs = get_potential_tacs ctxt i st in (APPEND_LIST' tacs THEN_ALL_NEW_FWD (TRY o solve_full_keep_tac ctxt)) i st end fun solve_tac ctxt = case (Config.get ctxt cfg_keep, Config.get ctxt cfg_step, Config.get ctxt cfg_full) of (_,true,false) => solve_greedy_step_tac ctxt | (_,true,true) => solve_full_step_tac ctxt | (true,false,false) => solve_greedy_keep_tac ctxt | (false,false,false) => solve_greedy_tac ctxt | (true,false,true) => solve_full_keep_tac ctxt | (false,false,true) => solve_full_tac ctxt fun pretty_solvers ctxt = let fun pretty_solver (ts,name,desc,_) = Pretty.block ( Pretty.str (name ^ ": " ^ desc) :: Pretty.fbrk :: Pretty.str ("Triggers: ") :: Pretty.commas (map (Thm.pretty_thm ctxt) ts)) val solvers = get_solvers ctxt in Pretty.big_list "Solvers:" (map pretty_solver solvers) end end \ method_setup tagged_solver = \let open Refine_Util val flags = parse_bool_config "keep" Tagged_Solver.cfg_keep || parse_bool_config "trace" Tagged_Solver.cfg_trace || parse_bool_config "full" Tagged_Solver.cfg_full || parse_bool_config "step" Tagged_Solver.cfg_step in parse_paren_lists flags >> (fn _ => fn ctxt => SIMPLE_METHOD' (Tagged_Solver.solve_tac ctxt) ) end \ "Select tactic to solve goal by pattern" term True (* Localization Test *) (* locale foo = fixes A b assumes A: "A x = True" begin definition "B == A" lemma AI: "A x" unfolding A .. lemma A_trig: "A x ==> A x" . lemma BI: "A x ==> B x" unfolding B_def . lemma B_trig: "B x ==> B x" . declaration {* fn phi => Tagged_Solver.declare_solver @{thms A_trig} @{binding "A_solver"} "description" (K (rtac (Morphism.thm phi @{thm AI}))) phi *} ML_val {* Tagged_Solver.pretty_solvers @{context} |> Pretty.writeln *} (* FIXME: Does not work because of improper naming! declaration {* Tagged_Solver.add_triggers "local.A_solver" @{thms A_trig} *} *) declaration {* fn phi => Tagged_Solver.declare_solver @{thms B_trig} @{binding "B_solver"} "description" (K (rtac (Morphism.thm phi @{thm BI}))) phi *} ML_val {* Tagged_Solver.pretty_solvers @{context} |> Pretty.writeln *} end definition "TAG x == True" interpretation tag: foo TAG 1 apply unfold_locales unfolding TAG_def by simp ML_val {* Tagged_Solver.pretty_solvers @{context} |> Pretty.writeln *} definition "TAG' x == True" interpretation tag': foo TAG' 2 apply unfold_locales unfolding TAG'_def by simp interpretation tag2: foo TAG 3 by unfold_locales ML_val {* Tagged_Solver.pretty_solvers @{context} |> Pretty.writeln *} lemma "tag.B undefined" by (tagged_solver (keep)) declaration {* Tagged_Solver.delete_solver "Tagged_Solver.tag.B_solver" *} ML_val {* Tagged_Solver.pretty_solvers @{context} |> Pretty.writeln *} *) end diff --git a/thys/Automatic_Refinement/Parametricity/Param_Tool.thy b/thys/Automatic_Refinement/Parametricity/Param_Tool.thy --- a/thys/Automatic_Refinement/Parametricity/Param_Tool.thy +++ b/thys/Automatic_Refinement/Parametricity/Param_Tool.thy @@ -1,348 +1,347 @@ section \Basic Parametricity Reasoning\ theory Param_Tool imports Relators begin subsection \Auxiliary Lemmas\ lemma tag_both: "\ (Let x f,Let x' f')\R \ \ (f x,f' x')\R" by simp lemma tag_rhs: "\ (c,Let x f)\R \ \ (c,f x)\R" by simp lemma tag_lhs: "\ (Let x f,a)\R \ \ (f x,a)\R" by simp lemma tagged_fun_relD_both: "\ (f,f')\A\B; (x,x')\A \ \ (Let x f,Let x' f')\B" and tagged_fun_relD_rhs: "\ (f,f')\A\B; (x,x')\A \ \ (f x,Let x' f')\B" and tagged_fun_relD_lhs: "\ (f,f')\A\B; (x,x')\A \ \ (Let x f,f' x')\B" and tagged_fun_relD_none: "\ (f,f')\A\B; (x,x')\A \ \ (f x,f' x')\B" by (simp_all add: fun_relD) subsection \ML-Setup\ ML \ signature PARAMETRICITY = sig type param_ruleT = { lhs: term, rhs: term, R: term, rhs_head: term, arity: int } val dest_param_term: term -> param_ruleT val dest_param_rule: thm -> param_ruleT val dest_param_goal: int -> thm -> param_ruleT val safe_fun_relD_tac: Proof.context -> tactic' val adjust_arity: int -> thm -> thm val adjust_arity_tac: int -> Proof.context -> tactic' val unlambda_tac: Proof.context -> tactic' val prepare_tac: Proof.context -> tactic' val fo_rule: thm -> thm (*** Basic tactics ***) val param_rule_tac: Proof.context -> thm -> tactic' val param_rules_tac: Proof.context -> thm list -> tactic' val asm_param_tac: Proof.context -> tactic' (*** Nets of parametricity rules ***) type param_net val net_empty: param_net val net_add: thm -> param_net -> param_net val net_del: thm -> param_net -> param_net val net_add_int: Context.generic -> thm -> param_net -> param_net val net_del_int: Context.generic -> thm -> param_net -> param_net val net_tac: param_net -> Proof.context -> tactic' (*** Default parametricity rules ***) val add_dflt: thm -> Context.generic -> Context.generic val add_dflt_attr: attribute val del_dflt: thm -> Context.generic -> Context.generic val del_dflt_attr: attribute val get_dflt: Proof.context -> param_net (** Configuration **) val cfg_use_asm: bool Config.T val cfg_single_step: bool Config.T (** Setup **) val setup: theory -> theory end structure Parametricity : PARAMETRICITY = struct type param_ruleT = { lhs: term, rhs: term, R: term, rhs_head: term, arity: int } fun dest_param_term t = case strip_all_body t |> Logic.strip_imp_concl |> HOLogic.dest_Trueprop of @{mpat "(?lhs,?rhs):?R"} => let val (rhs_head,arity) = case strip_comb rhs of (c as Const _,l) => (c,length l) | (c as Free _,l) => (c,length l) | (c as Abs _,l) => (c,length l) | _ => raise TERM ("dest_param_term: Head",[t]) in { lhs = lhs, rhs = rhs, R=R, rhs_head = rhs_head, arity = arity } end | t => raise TERM ("dest_param_term: Expected (_,_):_",[t]) val dest_param_rule = dest_param_term o Thm.prop_of fun dest_param_goal i st = if i > Thm.nprems_of st then raise THM ("dest_param_goal",i,[st]) else dest_param_term (Logic.concl_of_goal (Thm.prop_of st) i) fun safe_fun_relD_tac ctxt = let fun t a b = fo_resolve_tac [a] ctxt THEN' resolve_tac ctxt [b] in DETERM o ( t @{thm tag_both} @{thm tagged_fun_relD_both} ORELSE' t @{thm tag_rhs} @{thm tagged_fun_relD_rhs} ORELSE' t @{thm tag_lhs} @{thm tagged_fun_relD_lhs} ORELSE' resolve_tac ctxt @{thms tagged_fun_relD_none} ) end fun adjust_arity i thm = if i = 0 then thm else if i<0 then funpow (~i) (fn thm => thm RS @{thm fun_relI}) thm else funpow i (fn thm => thm RS @{thm fun_relD}) thm fun NTIMES k tac = if k <= 0 then K all_tac else tac THEN' NTIMES (k-1) tac fun adjust_arity_tac n ctxt i st = (if n = 0 then K all_tac else if n>0 then NTIMES n (DETERM o resolve_tac ctxt @{thms fun_relI}) else NTIMES (~n) (safe_fun_relD_tac ctxt)) i st fun unlambda_tac ctxt i st = case try (dest_param_goal i) st of NONE => Seq.empty | SOME g => let val n = Term.strip_abs (#rhs_head g) |> #1 |> length in NTIMES n (resolve_tac ctxt @{thms fun_relI}) i st end fun prepare_tac ctxt = Subgoal.FOCUS (K (PRIMITIVE (Drule.eta_contraction_rule))) ctxt THEN' unlambda_tac ctxt fun could_param_rl rl i st = if i > Thm.nprems_of st then NONE else ( case (try (dest_param_goal i) st, try dest_param_term rl) of (SOME g, SOME r) => if Term.could_unify (#rhs_head g, #rhs_head r) then SOME (#arity r - #arity g) else NONE | _ => NONE ) fun param_rule_tac_aux ctxt rl i st = case could_param_rl (Thm.prop_of rl) i st of SOME adj => (adjust_arity_tac adj ctxt THEN' resolve_tac ctxt [rl]) i st | _ => Seq.empty fun param_rule_tac ctxt rl = prepare_tac ctxt THEN' param_rule_tac_aux ctxt rl fun param_rules_tac ctxt rls = prepare_tac ctxt THEN' FIRST' (map (param_rule_tac_aux ctxt) rls) fun asm_param_tac_aux ctxt i st = if i > Thm.nprems_of st then Seq.empty else let val prems = Logic.prems_of_goal (Thm.prop_of st) i |> tag_list 1 fun tac (n,t) i st = case could_param_rl t i st of SOME adj => (adjust_arity_tac adj ctxt THEN' rprem_tac n ctxt) i st | NONE => Seq.empty in FIRST' (map tac prems) i st end fun asm_param_tac ctxt = prepare_tac ctxt THEN' asm_param_tac_aux ctxt type param_net = (param_ruleT * thm) Item_Net.T local val param_get_key = single o #rhs_head o #1 in val net_empty = Item_Net.init (Thm.eq_thm o apply2 #2) param_get_key end fun wrap_pr_op f context thm = case try (`dest_param_rule) thm of NONE => let val msg = "Ignoring invalid parametricity theorem: " ^ Thm.string_of_thm (Context.proof_of context) thm val _ = warning msg in I end | SOME p => f p val net_add_int = wrap_pr_op Item_Net.update val net_del_int = wrap_pr_op Item_Net.remove val net_add = Item_Net.update o `dest_param_rule val net_del = Item_Net.remove o `dest_param_rule fun net_tac_aux net ctxt i st = if i > Thm.nprems_of st then Seq.empty else let val g = dest_param_goal i st val rls = Item_Net.retrieve net (#rhs_head g) fun tac (r,thm) = adjust_arity_tac (#arity r - #arity g) ctxt THEN' DETERM o resolve_tac ctxt [thm] in FIRST' (map tac rls) i st end fun net_tac net ctxt = prepare_tac ctxt THEN' net_tac_aux net ctxt structure dflt_rules = Generic_Data ( type T = param_net val empty = net_empty - val extend = I val merge = Item_Net.merge ) fun add_dflt thm context = dflt_rules.map (net_add_int context thm) context fun del_dflt thm context = dflt_rules.map (net_del_int context thm) context val add_dflt_attr = Thm.declaration_attribute add_dflt val del_dflt_attr = Thm.declaration_attribute del_dflt val get_dflt = dflt_rules.get o Context.Proof val cfg_use_asm = Attrib.setup_config_bool @{binding param_use_asm} (K true) val cfg_single_step = Attrib.setup_config_bool @{binding param_single_step} (K false) local open Refine_Util val param_modifiers = [Args.add -- Args.colon >> K (Method.modifier add_dflt_attr \<^here>), Args.del -- Args.colon >> K (Method.modifier del_dflt_attr \<^here>), Args.$$$ "only" -- Args.colon >> K {init = Context.proof_map (dflt_rules.map (K net_empty)), attribute = add_dflt_attr, pos = \<^here>}] val param_flags = parse_bool_config "use_asm" cfg_use_asm || parse_bool_config "single_step" cfg_single_step in val parametricity_method = parse_paren_lists param_flags |-- Method.sections param_modifiers >> (fn _ => fn ctxt => let val net2 = get_dflt ctxt val asm_tac = if Config.get ctxt cfg_use_asm then asm_param_tac ctxt else K no_tac val RPT = if Config.get ctxt cfg_single_step then I else REPEAT_ALL_NEW_FWD in SIMPLE_METHOD' ( RPT ( (assume_tac ctxt ORELSE' net_tac net2 ctxt ORELSE' asm_tac) ) ) end ) end fun fo_rule thm = case Thm.concl_of thm of @{mpat "Trueprop ((_,_)\_\_)"} => fo_rule (thm RS @{thm fun_relD}) | _ => thm val param_fo_attr = Scan.succeed (Thm.rule_attribute [] (K fo_rule)) val setup = I #> Attrib.setup @{binding param} (Attrib.add_del add_dflt_attr del_dflt_attr) "declaration of parametricity theorem" #> Global_Theory.add_thms_dynamic (@{binding param}, map #2 o Item_Net.content o dflt_rules.get) #> Method.setup @{binding parametricity} parametricity_method "Parametricity solver" #> Attrib.setup @{binding param_fo} param_fo_attr "Parametricity: Rule in first-order form" end \ setup Parametricity.setup subsection \Convenience Tools\ ML \ (* Prefix p_ or wrong type supresses generation of relAPP *) fun cnv_relAPP t = let fun consider (Var ((name,_),T)) = if String.isPrefix "p_" name then false else ( case T of Type(@{type_name set},[Type(@{type_name prod},_)]) => true | _ => false) | consider _ = true fun strip_rcomb u : term * term list = let fun stripc (x as (f$t, ts)) = if consider t then stripc (f, t::ts) else x | stripc x = x in stripc(u,[]) end; val (f,a) = strip_rcomb t in Relators.list_relAPP a f end fun to_relAPP_conv ctxt = Refine_Util.f_tac_conv ctxt cnv_relAPP (fn goal_ctxt => ALLGOALS (simp_tac (put_simpset HOL_basic_ss goal_ctxt addsimps @{thms relAPP_def}))) val to_relAPP_attr = Thm.rule_attribute [] (fn context => let val ctxt = Context.proof_of context in Conv.fconv_rule (Conv.arg1_conv (to_relAPP_conv ctxt)) end) \ attribute_setup to_relAPP = \Scan.succeed (to_relAPP_attr)\ "Convert relator definition to prefix-form" end diff --git a/thys/Automatic_Refinement/Parametricity/Relators.thy b/thys/Automatic_Refinement/Parametricity/Relators.thy --- a/thys/Automatic_Refinement/Parametricity/Relators.thy +++ b/thys/Automatic_Refinement/Parametricity/Relators.thy @@ -1,979 +1,978 @@ section \Relators\ theory Relators imports "../Lib/Refine_Lib" begin text \ We define the concept of relators. The relation between a concrete type and an abstract type is expressed by a relation of type \('c\'a) set\. For each composed type, say \'a list\, we can define a {\em relator}, that takes as argument a relation for the element type, and returns a relation for the list type. For most datatypes, there exists a {\em natural relator}. For algebraic datatypes, this is the relator that preserves the structure of the datatype, and changes the components. For example, \list_rel::('c\'a) set \ ('c list\'a list) set\ is the natural relator for lists. However, relators can also be used to change the representation, and thus relate an implementation with an abstract type. For example, the relator \list_set_rel::('c\'a) set \ ('c list\'a set) set\ relates lists with the set of their elements. In this theory, we define some basic notions for relators, and then define natural relators for all HOL-types, including the function type. For each relator, we also show a single-valuedness property, and initialize a solver for single-valued properties. \ subsection \Basic Definitions\ text \ For smoother handling of relator unification, we require relator arguments to be applied by a special operator, such that we avoid higher-order unification problems. We try to set up some syntax to make this more transparent, and give relators a type-like prefix-syntax. \ definition relAPP :: "(('c1\'a1) set \ _) \ ('c1\'a1) set \ _" where "relAPP f x \ f x" syntax "_rel_APP" :: "args \ 'a \ 'b" ("\_\_" [0,900] 900) translations "\x,xs\R" == "\xs\(CONST relAPP R x)" "\x\R" == "CONST relAPP R x" ML \ structure Refine_Relators_Thms = struct structure rel_comb_def_rules = Named_Thms ( val name = @{binding refine_rel_defs} val description = "Refinement Framework: " ^ "Relator definitions" ); end \ setup Refine_Relators_Thms.rel_comb_def_rules.setup subsection \Basic HOL Relators\ subsubsection \Function\ definition fun_rel where fun_rel_def_internal: "fun_rel A B \ { (f,f'). \(a,a')\A. (f a, f' a')\B }" abbreviation fun_rel_syn (infixr "\" 60) where "A\B \ \A,B\fun_rel" lemma fun_rel_def[refine_rel_defs]: "A\B \ { (f,f'). \(a,a')\A. (f a, f' a')\B }" by (simp add: relAPP_def fun_rel_def_internal) lemma fun_relI[intro!]: "\\a a'. (a,a')\A \ (f a,f' a')\B\ \ (f,f')\A\B" by (auto simp: fun_rel_def) lemma fun_relD: shows " ((f,f')\(A\B)) \ (\x x'. \ (x,x')\A \ \ (f x, f' x')\B)" apply rule by (auto simp: fun_rel_def) lemma fun_relD1: assumes "(f,f')\Ra\Rr" assumes "f x = r" shows "\x'. (x,x')\Ra \ (r,f' x')\Rr" using assms by (auto simp: fun_rel_def) lemma fun_relD2: assumes "(f,f')\Ra\Rr" assumes "f' x' = r'" shows "\x. (x,x')\Ra \ (f x,r')\Rr" using assms by (auto simp: fun_rel_def) lemma fun_relE1: assumes "(f,f')\Id \ Rv" assumes "t' = f' x" shows "(f x,t')\Rv" using assms by (auto elim: fun_relD) lemma fun_relE2: assumes "(f,f')\Id \ Rv" assumes "t = f x" shows "(t,f' x)\Rv" using assms by (auto elim: fun_relD) subsubsection \Terminal Types\ abbreviation unit_rel :: "(unit\unit) set" where "unit_rel == Id" abbreviation "nat_rel \ Id::(nat\_) set" abbreviation "int_rel \ Id::(int\_) set" abbreviation "bool_rel \ Id::(bool\_) set" subsubsection \Product\ definition prod_rel where prod_rel_def_internal: "prod_rel R1 R2 \ { ((a,b),(a',b')) . (a,a')\R1 \ (b,b')\R2 }" abbreviation prod_rel_syn (infixr "\\<^sub>r" 70) where "a\\<^sub>rb \ \a,b\prod_rel" lemma prod_rel_def[refine_rel_defs]: "(\R1,R2\prod_rel) \ { ((a,b),(a',b')) . (a,a')\R1 \ (b,b')\R2 }" by (simp add: prod_rel_def_internal relAPP_def) lemma prod_relI: "\(a,a')\R1; (b,b')\R2\ \ ((a,b),(a',b'))\\R1,R2\prod_rel" by (auto simp: prod_rel_def) lemma prod_relE: assumes "(p,p')\\R1,R2\prod_rel" obtains a b a' b' where "p=(a,b)" and "p'=(a',b')" and "(a,a')\R1" and "(b,b')\R2" using assms by (auto simp: prod_rel_def) lemma prod_rel_simp[simp]: "((a,b),(a',b'))\\R1,R2\prod_rel \ (a,a')\R1 \ (b,b')\R2" by (auto intro: prod_relI elim: prod_relE) lemma in_Domain_prod_rel_iff[iff]: "(a,b)\Domain (A\\<^sub>rB) \ a\Domain A \ b\Domain B" by (auto simp: prod_rel_def) lemma prod_rel_comp: "(A \\<^sub>r B) O (C \\<^sub>r D) = (A O C) \\<^sub>r (B O D)" unfolding prod_rel_def by auto subsubsection \Option\ definition option_rel where option_rel_def_internal: "option_rel R \ { (Some a,Some a') | a a'. (a,a')\R } \ {(None,None)}" lemma option_rel_def[refine_rel_defs]: "\R\option_rel \ { (Some a,Some a') | a a'. (a,a')\R } \ {(None,None)}" by (simp add: option_rel_def_internal relAPP_def) lemma option_relI: "(None,None)\\R\ option_rel" "\ (a,a')\R \ \ (Some a, Some a')\\R\option_rel" by (auto simp: option_rel_def) lemma option_relE: assumes "(x,x')\\R\option_rel" obtains "x=None" and "x'=None" | a a' where "x=Some a" and "x'=Some a'" and "(a,a')\R" using assms by (auto simp: option_rel_def) lemma option_rel_simp[simp]: "(None,a)\\R\option_rel \ a=None" "(c,None)\\R\option_rel \ c=None" "(Some x,Some y)\\R\option_rel \ (x,y)\R" by (auto intro: option_relI elim: option_relE) subsubsection \Sum\ definition sum_rel where sum_rel_def_internal: "sum_rel Rl Rr \ { (Inl a, Inl a') | a a'. (a,a')\Rl } \ { (Inr a, Inr a') | a a'. (a,a')\Rr }" lemma sum_rel_def[refine_rel_defs]: "\Rl,Rr\sum_rel \ { (Inl a, Inl a') | a a'. (a,a')\Rl } \ { (Inr a, Inr a') | a a'. (a,a')\Rr }" by (simp add: sum_rel_def_internal relAPP_def) lemma sum_rel_simp[simp]: "\a a'. (Inl a, Inl a') \ \Rl,Rr\sum_rel \ (a,a')\Rl" "\a a'. (Inr a, Inr a') \ \Rl,Rr\sum_rel \ (a,a')\Rr" "\a a'. (Inl a, Inr a') \ \Rl,Rr\sum_rel" "\a a'. (Inr a, Inl a') \ \Rl,Rr\sum_rel" unfolding sum_rel_def by auto lemma sum_relI: "(l,l')\Rl \ (Inl l, Inl l') \ \Rl,Rr\sum_rel" "(r,r')\Rr \ (Inr r, Inr r') \ \Rl,Rr\sum_rel" by simp_all lemma sum_relE: assumes "(x,x')\\Rl,Rr\sum_rel" obtains l l' where "x=Inl l" and "x'=Inl l'" and "(l,l')\Rl" | r r' where "x=Inr r" and "x'=Inr r'" and "(r,r')\Rr" using assms by (auto simp: sum_rel_def) subsubsection \Lists\ definition list_rel where list_rel_def_internal: "list_rel R \ {(l,l'). list_all2 (\x x'. (x,x')\R) l l'}" lemma list_rel_def[refine_rel_defs]: "\R\list_rel \ {(l,l'). list_all2 (\x x'. (x,x')\R) l l'}" by (simp add: list_rel_def_internal relAPP_def) lemma list_rel_induct[induct set,consumes 1, case_names Nil Cons]: assumes "(l,l')\\R\ list_rel" assumes "P [] []" assumes "\x x' l l'. \ (x,x')\R; (l,l')\\R\list_rel; P l l' \ \ P (x#l) (x'#l')" shows "P l l'" using assms unfolding list_rel_def apply simp by (rule list_all2_induct) lemma list_rel_eq_listrel: "list_rel = listrel" apply (rule ext) apply safe proof goal_cases case (1 x a b) thus ?case unfolding list_rel_def_internal apply simp apply (induct a b rule: list_all2_induct) apply (auto intro: listrel.intros) done next case 2 thus ?case apply (induct) apply (auto simp: list_rel_def_internal) done qed lemma list_relI: "([],[])\\R\list_rel" "\ (x,x')\R; (l,l')\\R\list_rel \ \ (x#l,x'#l')\\R\list_rel" by (auto simp: list_rel_def) lemma list_rel_simp[simp]: "([],l')\\R\list_rel \ l'=[]" "(l,[])\\R\list_rel \ l=[]" "([],[])\\R\list_rel" "(x#l,x'#l')\\R\list_rel \ (x,x')\R \ (l,l')\\R\list_rel" by (auto simp: list_rel_def) lemma list_relE1: assumes "(l,[])\\R\list_rel" obtains "l=[]" using assms by auto lemma list_relE2: assumes "([],l)\\R\list_rel" obtains "l=[]" using assms by auto lemma list_relE3: assumes "(x#xs,l')\\R\list_rel" obtains x' xs' where "l'=x'#xs'" and "(x,x')\R" and "(xs,xs')\\R\list_rel" using assms apply (cases l') apply auto done lemma list_relE4: assumes "(l,x'#xs')\\R\list_rel" obtains x xs where "l=x#xs" and "(x,x')\R" and "(xs,xs')\\R\list_rel" using assms apply (cases l) apply auto done lemmas list_relE = list_relE1 list_relE2 list_relE3 list_relE4 lemma list_rel_imp_same_length: "(l, l') \ \R\list_rel \ length l = length l'" unfolding list_rel_eq_listrel relAPP_def by (rule listrel_eq_len) lemma list_rel_split_right_iff: "(x#xs,l)\\R\list_rel \ (\y ys. l=y#ys \ (x,y)\R \ (xs,ys)\\R\list_rel)" by (cases l) auto lemma list_rel_split_left_iff: "(l,y#ys)\\R\list_rel \ (\x xs. l=x#xs \ (x,y)\R \ (xs,ys)\\R\list_rel)" by (cases l) auto subsubsection \Sets\ text \Pointwise refinement: The abstract set is the image of the concrete set, and the concrete set only contains elements that have an abstract counterpart\ definition set_rel where set_rel_def_internal: "set_rel R \ {(A,B). (\x\A. \y\B. (x,y)\R) \ (\y\B. \x\A. (x,y)\R)}" term set_rel lemma set_rel_def[refine_rel_defs]: "\R\set_rel \ {(A,B). (\x\A. \y\B. (x,y)\R) \ (\y\B. \x\A. (x,y)\R)}" by (simp add: set_rel_def_internal relAPP_def) lemma set_rel_alt: "\R\set_rel = {(A,B). A \ R\``B \ B \ R``A}" unfolding set_rel_def by auto lemma set_relI[intro?]: assumes "\x. x\A \ \y\B. (x,y)\R" assumes "\y. y\B \ \x\A. (x,y)\R" shows "(A,B)\\R\set_rel" using assms unfolding set_rel_def by blast text \Original definition of \set_rel\ in refinement framework. Abandoned in favour of more symmetric definition above: \ definition old_set_rel where old_set_rel_def_internal: "old_set_rel R \ {(S,S'). S'=R``S \ S\Domain R}" lemma old_set_rel_def[refine_rel_defs]: "\R\old_set_rel \ {(S,S'). S'=R``S \ S\Domain R}" by (simp add: old_set_rel_def_internal relAPP_def) text \Old definition coincides with new definition for single-valued element relations. This is probably the reason why the old definition worked for most applications.\ lemma old_set_rel_sv_eq: "single_valued R \ \R\old_set_rel = \R\set_rel" unfolding set_rel_def old_set_rel_def single_valued_def by blast lemma set_rel_simp[simp]: "({},{})\\R\set_rel" by (auto simp: set_rel_def) lemma set_rel_empty_iff[simp]: "({},y)\\A\set_rel \ y={}" "(x,{})\\A\set_rel \ x={}" by (auto simp: set_rel_def; fastforce)+ lemma set_relD1: "(s,s')\\R\set_rel \ x\s \ \x'\s'. (x,x')\R" unfolding set_rel_def by blast lemma set_relD2: "(s,s')\\R\set_rel \ x'\s' \ \x\s. (x,x')\R" unfolding set_rel_def by blast lemma set_relE1[consumes 2]: assumes "(s,s')\\R\set_rel" "x\s" obtains x' where "x'\s'" "(x,x')\R" using set_relD1[OF assms] .. lemma set_relE2[consumes 2]: assumes "(s,s')\\R\set_rel" "x'\s'" obtains x where "x\s" "(x,x')\R" using set_relD2[OF assms] .. subsection \Automation\ subsubsection \A solver for relator properties\ lemma relprop_triggers: "\R. single_valued R \ single_valued R" "\R. R=Id \ R=Id" "\R. R=Id \ Id=R" "\R. Range R = UNIV \ Range R = UNIV" "\R. Range R = UNIV \ UNIV = Range R" "\R R'. R\R' \ R\R'" by auto ML \ structure relator_props = Named_Thms ( val name = @{binding relator_props} val description = "Additional relator properties" ) structure solve_relator_props = Named_Thms ( val name = @{binding solve_relator_props} val description = "Relator properties that solve goal" ) \ setup relator_props.setup setup solve_relator_props.setup declaration \ Tagged_Solver.declare_solver @{thms relprop_triggers} @{binding relator_props_solver} "Additional relator properties solver" (fn ctxt => (REPEAT_ALL_NEW (CHANGED o ( match_tac ctxt (solve_relator_props.get ctxt) ORELSE' match_tac ctxt (relator_props.get ctxt) )))) \ declaration \ Tagged_Solver.declare_solver [] @{binding force_relator_props_solver} "Additional relator properties solver (instantiate schematics)" (fn ctxt => (REPEAT_ALL_NEW (CHANGED o ( resolve_tac ctxt (solve_relator_props.get ctxt) ORELSE' match_tac ctxt (relator_props.get ctxt) )))) \ lemma relprop_id_orient[relator_props]: "R=Id \ Id=R" and relprop_eq_refl[solve_relator_props]: "t = t" by auto lemma relprop_UNIV_orient[relator_props]: "R=UNIV \ UNIV=R" by auto subsubsection \ML-Level utilities\ ML \ signature RELATORS = sig val mk_relT: typ * typ -> typ val dest_relT: typ -> typ * typ val mk_relAPP: term -> term -> term val list_relAPP: term list -> term -> term val strip_relAPP: term -> term list * term val mk_fun_rel: term -> term -> term val list_rel: term list -> term -> term val rel_absT: term -> typ val rel_concT: term -> typ val mk_prodrel: term * term -> term val is_prodrel: term -> bool val dest_prodrel: term -> term * term val strip_prodrel_left: term -> term list val list_prodrel_left: term list -> term val declare_natural_relator: (string*string) -> Context.generic -> Context.generic val remove_natural_relator: string -> Context.generic -> Context.generic val natural_relator_of: Proof.context -> string -> string option val mk_natural_relator: Proof.context -> term list -> string -> term option val setup: theory -> theory end structure Relators :RELATORS = struct val mk_relT = HOLogic.mk_prodT #> HOLogic.mk_setT fun dest_relT (Type (@{type_name set},[Type (@{type_name prod},[cT,aT])])) = (cT,aT) | dest_relT ty = raise TYPE ("dest_relT",[ty],[]) fun mk_relAPP x f = let val xT = fastype_of x val fT = fastype_of f val rT = range_type fT in Const (@{const_name relAPP},fT-->xT-->rT)$f$x end val list_relAPP = fold mk_relAPP fun strip_relAPP R = let fun aux @{mpat "\?R\?S"} l = aux S (R::l) | aux R l = (l,R) in aux R [] end val rel_absT = fastype_of #> HOLogic.dest_setT #> HOLogic.dest_prodT #> snd val rel_concT = fastype_of #> HOLogic.dest_setT #> HOLogic.dest_prodT #> fst fun mk_fun_rel r1 r2 = let val (r1T,r2T) = (fastype_of r1,fastype_of r2) val (c1T,a1T) = dest_relT r1T val (c2T,a2T) = dest_relT r2T val (cT,aT) = (c1T --> c2T, a1T --> a2T) val rT = mk_relT (cT,aT) in list_relAPP [r1,r2] (Const (@{const_name fun_rel},r1T-->r2T-->rT)) end val list_rel = fold_rev mk_fun_rel fun mk_prodrel (A,B) = @{mk_term "?A \\<^sub>r ?B"} fun is_prodrel @{mpat "_ \\<^sub>r _"} = true | is_prodrel _ = false fun dest_prodrel @{mpat "?A \\<^sub>r ?B"} = (A,B) | dest_prodrel t = raise TERM("dest_prodrel",[t]) fun strip_prodrel_left @{mpat "?A \\<^sub>r ?B"} = strip_prodrel_left A @ [B] | strip_prodrel_left @{mpat (typs) "unit_rel"} = [] | strip_prodrel_left R = [R] val list_prodrel_left = Refine_Util.list_binop_left @{term unit_rel} mk_prodrel structure natural_relators = Generic_Data ( type T = string Symtab.table val empty = Symtab.empty - val extend = I val merge = Symtab.join (fn _ => fn (_,cn) => cn) ) fun declare_natural_relator tcp = natural_relators.map (Symtab.update tcp) fun remove_natural_relator tname = natural_relators.map (Symtab.delete_safe tname) fun natural_relator_of ctxt = Symtab.lookup (natural_relators.get (Context.Proof ctxt)) (* [R1,\,Rn] T is mapped to \R1,\,Rn\ Trel *) fun mk_natural_relator ctxt args Tname = case natural_relator_of ctxt Tname of NONE => NONE | SOME Cname => SOME let val argsT = map fastype_of args val (cTs, aTs) = map dest_relT argsT |> split_list val aT = Type (Tname,aTs) val cT = Type (Tname,cTs) val rT = mk_relT (cT,aT) in list_relAPP args (Const (Cname,argsT--->rT)) end fun natural_relator_from_term (t as Const (name,T)) = let fun err msg = raise TERM (msg,[t]) val (argTs,bodyT) = strip_type T val (conTs,absTs) = argTs |> map (HOLogic.dest_setT #> HOLogic.dest_prodT) |> split_list val (bconT,babsT) = bodyT |> HOLogic.dest_setT |> HOLogic.dest_prodT val (Tcon,bconTs) = dest_Type bconT val (Tcon',babsTs) = dest_Type babsT val _ = Tcon = Tcon' orelse err "Type constructors do not match" val _ = conTs = bconTs orelse err "Concrete types do not match" val _ = absTs = babsTs orelse err "Abstract types do not match" in (Tcon,name) end | natural_relator_from_term t = raise TERM ("Expected constant",[t]) (* TODO: Localize this! *) local fun decl_natrel_aux t context = let fun warn msg = let val tP = Context.cases Syntax.pretty_term_global Syntax.pretty_term context t val m = Pretty.block [ Pretty.str "Ignoring invalid natural_relator declaration:", Pretty.brk 1, Pretty.str msg, Pretty.brk 1, tP ] |> Pretty.string_of val _ = warning m in context end in declare_natural_relator (natural_relator_from_term t) context handle TERM (msg,_) => warn msg | exn => if Exn.is_interrupt exn then Exn.reraise exn else warn "" end in val natural_relator_attr = Scan.repeat1 Args.term >> (fn ts => Thm.declaration_attribute ( fn _ => fold decl_natrel_aux ts) ) end val setup = I #> Attrib.setup @{binding natural_relator} natural_relator_attr "Declare natural relator" end \ setup Relators.setup subsection \Setup\ subsubsection "Natural Relators" declare [[natural_relator unit_rel int_rel nat_rel bool_rel fun_rel prod_rel option_rel sum_rel list_rel ]] (*declaration {* let open Relators in fn _ => declare_natural_relator (@{type_name unit},@{const_name unit_rel}) #> declare_natural_relator (@{type_name fun},@{const_name fun_rel}) #> declare_natural_relator (@{type_name prod},@{const_name prod_rel}) #> declare_natural_relator (@{type_name option},@{const_name option_rel}) #> declare_natural_relator (@{type_name sum},@{const_name sum_rel}) #> declare_natural_relator (@{type_name list},@{const_name list_rel}) end *}*) ML_val \ Relators.mk_natural_relator @{context} [@{term "Ra::('c\'a) set"},@{term "\Rb\option_rel"}] @{type_name prod} |> the |> Thm.cterm_of @{context} ; Relators.mk_fun_rel @{term "\Id\option_rel"} @{term "\Id\list_rel"} |> Thm.cterm_of @{context} \ subsubsection "Additional Properties" lemmas [relator_props] = single_valued_Id subset_refl refl (* TODO: Move *) lemma eq_UNIV_iff: "S=UNIV \ (\x. x\S)" by auto lemma fun_rel_sv[relator_props]: assumes RAN: "Range Ra = UNIV" assumes SV: "single_valued Rv" shows "single_valued (Ra \ Rv)" proof (intro single_valuedI ext impI allI) fix f g h x' assume R1: "(f,g)\Ra\Rv" and R2: "(f,h)\Ra\Rv" from RAN obtain x where AR: "(x,x')\Ra" by auto from fun_relD[OF R1 AR] have "(f x,g x') \ Rv" . moreover from fun_relD[OF R2 AR] have "(f x,h x') \ Rv" . ultimately show "g x' = h x'" using SV by (auto dest: single_valuedD) qed lemmas [relator_props] = Range_Id lemma fun_rel_id[relator_props]: "\R1=Id; R2=Id\ \ R1 \ R2 = Id" by (auto simp: fun_rel_def) lemma fun_rel_id_simp[simp]: "Id\Id = Id" by tagged_solver lemma fun_rel_comp_dist[relator_props]: "(R1\R2) O (R3\R4) \ ((R1 O R3) \ (R2 O R4))" by (auto simp: fun_rel_def) lemma fun_rel_mono[relator_props]: "\ R1\R2; R3\R4 \ \ R2\R3 \ R1\R4" by (force simp: fun_rel_def) lemma prod_rel_sv[relator_props]: "\single_valued R1; single_valued R2\ \ single_valued (\R1,R2\prod_rel)" by (auto intro: single_valuedI dest: single_valuedD simp: prod_rel_def) lemma prod_rel_id[relator_props]: "\R1=Id; R2=Id\ \ \R1,R2\prod_rel = Id" by (auto simp: prod_rel_def) lemma prod_rel_id_simp[simp]: "\Id,Id\prod_rel = Id" by tagged_solver lemma prod_rel_mono[relator_props]: "\ R2\R1; R3\R4 \ \ \R2,R3\prod_rel \ \R1,R4\prod_rel" by (auto simp: prod_rel_def) lemma prod_rel_range[relator_props]: "\Range Ra=UNIV; Range Rb=UNIV\ \ Range (\Ra,Rb\prod_rel) = UNIV" apply (auto simp: prod_rel_def) by (metis Range_iff UNIV_I)+ lemma option_rel_sv[relator_props]: "\single_valued R\ \ single_valued (\R\option_rel)" by (auto intro: single_valuedI dest: single_valuedD simp: option_rel_def) lemma option_rel_id[relator_props]: "R=Id \ \R\option_rel = Id" by (auto simp: option_rel_def) lemma option_rel_id_simp[simp]: "\Id\option_rel = Id" by tagged_solver lemma option_rel_mono[relator_props]: "R\R' \ \R\option_rel \ \R'\option_rel" by (auto simp: option_rel_def) lemma option_rel_range: "Range R = UNIV \ Range (\R\option_rel) = UNIV" apply (auto simp: option_rel_def Range_iff) by (metis Range_iff UNIV_I option.exhaust) lemma option_rel_inter[simp]: "\R1 \ R2\option_rel = \R1\option_rel \ \R2\option_rel" by (auto simp: option_rel_def) lemma option_rel_constraint[simp]: "(x,x)\\UNIV\C\option_rel \ (\v. x=Some v \ v\C)" by (auto simp: option_rel_def) lemma sum_rel_sv[relator_props]: "\single_valued Rl; single_valued Rr\ \ single_valued (\Rl,Rr\sum_rel)" by (auto intro: single_valuedI dest: single_valuedD simp: sum_rel_def) lemma sum_rel_id[relator_props]: "\Rl=Id; Rr=Id\ \ \Rl,Rr\sum_rel = Id" apply (auto elim: sum_relE) apply (case_tac b) apply simp_all done lemma sum_rel_id_simp[simp]: "\Id,Id\sum_rel = Id" by tagged_solver lemma sum_rel_mono[relator_props]: "\ Rl\Rl'; Rr\Rr' \ \ \Rl,Rr\sum_rel \ \Rl',Rr'\sum_rel" by (auto simp: sum_rel_def) lemma sum_rel_range[relator_props]: "\ Range Rl=UNIV; Range Rr=UNIV \ \ Range (\Rl,Rr\sum_rel) = UNIV" apply (auto simp: sum_rel_def Range_iff) by (metis Range_iff UNIV_I sumE) lemma list_rel_sv_iff: "single_valued (\R\list_rel) \ single_valued R" apply (intro iffI[rotated] single_valuedI allI impI) apply (clarsimp simp: list_rel_def) proof - fix x y z assume SV: "single_valued R" assume "list_all2 (\x x'. (x, x') \ R) x y" and "list_all2 (\x x'. (x, x') \ R) x z" thus "y=z" apply (induct arbitrary: z rule: list_all2_induct) apply simp apply (case_tac z) apply force apply (force intro: single_valuedD[OF SV]) done next fix x y z assume SV: "single_valued (\R\list_rel)" assume "(x,y)\R" "(x,z)\R" hence "([x],[y])\\R\list_rel" and "([x],[z])\\R\list_rel" by (auto simp: list_rel_def) with single_valuedD[OF SV] show "y=z" by blast qed lemma list_rel_sv[relator_props]: "single_valued R \ single_valued (\R\list_rel)" by (simp add: list_rel_sv_iff) lemma list_rel_id[relator_props]: "\R=Id\ \ \R\list_rel = Id" by (auto simp add: list_rel_def list_all2_eq[symmetric]) lemma list_rel_id_simp[simp]: "\Id\list_rel = Id" by tagged_solver lemma list_rel_mono[relator_props]: assumes A: "R\R'" shows "\R\list_rel \ \R'\list_rel" proof clarsimp fix l l' assume "(l,l')\\R\list_rel" thus "(l,l')\\R'\list_rel" apply induct using A by auto qed lemma list_rel_range[relator_props]: assumes A: "Range R = UNIV" shows "Range (\R\list_rel) = UNIV" proof (clarsimp simp: eq_UNIV_iff) fix l show "l\Range (\R\list_rel)" apply (induct l) using A[unfolded eq_UNIV_iff] by (auto simp: Range_iff intro: list_relI) qed lemma bijective_imp_sv: "bijective R \ single_valued R" "bijective R \ single_valued (R\)" by (simp_all add: bijective_alt) (* TODO: Move *) declare bijective_Id[relator_props] declare bijective_Empty[relator_props] text \Pointwise refinement for set types:\ lemma set_rel_sv[relator_props]: "single_valued R \ single_valued (\R\set_rel)" unfolding single_valued_def set_rel_def by blast lemma set_rel_id[relator_props]: "R=Id \ \R\set_rel = Id" by (auto simp add: set_rel_def) lemma set_rel_id_simp[simp]: "\Id\set_rel = Id" by tagged_solver lemma set_rel_csv[relator_props]: "\ single_valued (R\) \ \ single_valued ((\R\set_rel)\)" unfolding single_valued_def set_rel_def converse_iff by fast subsection \Invariant and Abstraction\ text \ Quite often, a relation can be described as combination of an abstraction function and an invariant, such that the invariant describes valid values on the concrete domain, and the abstraction function maps valid concrete values to its corresponding abstract value. \ definition build_rel where "build_rel \ I \ {(c,a) . a=\ c \ I c}" abbreviation "br\build_rel" lemmas br_def[refine_rel_defs] = build_rel_def lemma in_br_conv: "(c,a)\br \ I \ a=\ c \ I c" by (auto simp: br_def) lemma brI[intro?]: "\ a=\ c; I c \ \ (c,a)\br \ I" by (simp add: br_def) lemma br_id[simp]: "br id (\_. True) = Id" unfolding build_rel_def by auto lemma br_chain: "(build_rel \ J) O (build_rel \ I) = build_rel (\\\) (\s. J s \ I (\ s))" unfolding build_rel_def by auto lemma br_sv[simp, intro!,relator_props]: "single_valued (br \ I)" unfolding build_rel_def apply (rule single_valuedI) apply auto done lemma converse_br_sv_iff[simp]: "single_valued (converse (br \ I)) \ inj_on \ (Collect I)" by (auto intro!: inj_onI single_valuedI dest: single_valuedD inj_onD simp: br_def) [] lemmas [relator_props] = single_valued_relcomp lemma br_comp_alt: "br \ I O R = { (c,a) . I c \ (\ c,a)\R }" by (auto simp add: br_def) lemma br_comp_alt': "{(c,a) . a=\ c \ I c} O R = { (c,a) . I c \ (\ c,a)\R }" by auto lemma single_valued_as_brE: assumes "single_valued R" obtains \ invar where "R=br \ invar" apply (rule that[of "\x. THE y. (x,y)\R" "\x. x\Domain R"]) using assms unfolding br_def by (auto dest: single_valuedD intro: the_equality[symmetric] theI) lemma sv_add_invar: "single_valued R \ single_valued {(c, a). (c, a) \ R \ I c}" by (auto dest: single_valuedD intro: single_valuedI) lemma br_Image_conv[simp]: "br \ I `` S = {\ x | x. x\S \ I x}" by (auto simp: br_def) subsection \Miscellanneous\ lemma rel_cong: "(f,g)\Id \ (x,y)\Id \ (f x, g y)\Id" by simp lemma rel_fun_cong: "(f,g)\Id \ (f x, g x)\Id" by simp lemma rel_arg_cong: "(x,y)\Id \ (f x, f y)\Id" by simp subsection \Conversion between Predicate and Set Based Relators\ text \ Autoref uses set-based relators of type @{typ \('a\'b) set\}, while the transfer and lifting package of Isabelle/HOL uses predicate based relators of type @{typ \'a \ 'b \ bool\}. This section defines some utilities to convert between the two. \ definition "rel2p R x y \ (x,y)\R" definition "p2rel P \ {(x,y). P x y}" lemma rel2pD: "\rel2p R a b\ \ (a,b)\R" by (auto simp: rel2p_def) lemma p2relD: "\(a,b) \ p2rel R\ \ R a b" by (auto simp: p2rel_def) lemma rel2p_inv[simp]: "rel2p (p2rel P) = P" "p2rel (rel2p R) = R" by (auto simp: rel2p_def[abs_def] p2rel_def) named_theorems rel2p named_theorems p2rel lemma rel2p_dflt[rel2p]: "rel2p Id = (=)" "rel2p (A\B) = rel_fun (rel2p A) (rel2p B)" "rel2p (A\\<^sub>rB) = rel_prod (rel2p A) (rel2p B)" "rel2p (\A,B\sum_rel) = rel_sum (rel2p A) (rel2p B)" "rel2p (\A\option_rel) = rel_option (rel2p A)" "rel2p (\A\list_rel) = list_all2 (rel2p A)" by (auto simp: rel2p_def[abs_def] intro!: ext simp: fun_rel_def rel_fun_def simp: sum_rel_def elim: rel_sum.cases simp: option_rel_def elim: option.rel_cases simp: list_rel_def simp: set_rel_def rel_set_def Image_def ) lemma p2rel_dflt[p2rel]: "p2rel (=) = Id" "p2rel (rel_fun A B) = p2rel A \ p2rel B" "p2rel (rel_prod A B) = p2rel A \\<^sub>r p2rel B" "p2rel (rel_sum A B) = \p2rel A, p2rel B\sum_rel" "p2rel (rel_option A) = \p2rel A\option_rel" "p2rel (list_all2 A) = \p2rel A\list_rel" by (auto simp: p2rel_def[abs_def] simp: fun_rel_def rel_fun_def simp: sum_rel_def elim: rel_sum.cases simp: option_rel_def elim: option.rel_cases simp: list_rel_def ) lemma [rel2p]: "rel2p (\A\set_rel) = rel_set (rel2p A)" unfolding set_rel_def rel_set_def rel2p_def[abs_def] by blast lemma [p2rel]: "left_unique A \ p2rel (rel_set A) = (\p2rel A\set_rel)" unfolding set_rel_def rel_set_def p2rel_def[abs_def] by blast lemma rel2p_comp: "rel2p A OO rel2p B = rel2p (A O B)" by (auto simp: rel2p_def[abs_def] intro!: ext) lemma rel2p_inj[simp]: "rel2p A = rel2p B \ A=B" by (auto simp: rel2p_def[abs_def]; meson) subsection \More Properties\ (* TODO: Do compp-lemmas for other standard relations *) lemma list_rel_compp: "\A O B\list_rel = \A\list_rel O \B\list_rel" using list.rel_compp[of "rel2p A" "rel2p B"] by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *) lemma option_rel_compp: "\A O B\option_rel = \A\option_rel O \B\option_rel" using option.rel_compp[of "rel2p A" "rel2p B"] by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *) lemma prod_rel_compp: "\A O B, C O D\prod_rel = \A,C\prod_rel O \B,D\prod_rel" using prod.rel_compp[of "rel2p A" "rel2p B" "rel2p C" "rel2p D"] by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *) lemma sum_rel_compp: "\A O B, C O D\sum_rel = \A,C\sum_rel O \B,D\sum_rel" using sum.rel_compp[of "rel2p A" "rel2p B" "rel2p C" "rel2p D"] by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *) lemma set_rel_compp: "\A O B\set_rel = \A\set_rel O \B\set_rel" using rel_set_OO[of "rel2p A" "rel2p B"] by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *) lemma map_in_list_rel_conv: shows "(l, map \ l) \ \br \ I\list_rel \ (\x\set l. I x)" by (induction l) (auto simp: in_br_conv) lemma br_set_rel_alt: "(s',s)\\br \ I\set_rel \ (s=\`s' \ (\x\s'. I x))" by (auto simp: set_rel_def br_def) (* TODO: Find proof that does not depend on br, and move to Misc *) lemma finite_Image_sv: "single_valued R \ finite s \ finite (R``s)" by (erule single_valued_as_brE) simp lemma finite_set_rel_transfer: "\(s,s')\\R\set_rel; single_valued R; finite s\ \ finite s'" unfolding set_rel_alt by (blast intro: finite_subset[OF _ finite_Image_sv]) lemma finite_set_rel_transfer_back: "\(s,s')\\R\set_rel; single_valued (R\); finite s'\ \ finite s" unfolding set_rel_alt by (blast intro: finite_subset[OF _ finite_Image_sv]) end diff --git a/thys/Automatic_Refinement/Tool/Autoref_Fix_Rel.thy b/thys/Automatic_Refinement/Tool/Autoref_Fix_Rel.thy --- a/thys/Automatic_Refinement/Tool/Autoref_Fix_Rel.thy +++ b/thys/Automatic_Refinement/Tool/Autoref_Fix_Rel.thy @@ -1,984 +1,983 @@ section \Relator Fixing\ theory Autoref_Fix_Rel imports Autoref_Id_Ops begin ML_val "2 upto 5" subsubsection \Priority tags\ text \ Priority tags are used to influence the ordering of refinement theorems. A priority tag defines two numeric priorities, a major and a minor priority. The major priority is considered first, the minor priority last, i.e., after the homogenity and relator-priority criteria. The default value for both priorities is 0. \ definition PRIO_TAG :: "int \ int \ bool" where [simp]: "PRIO_TAG ma mi \ True" lemma PRIO_TAGI: "PRIO_TAG ma mi" by simp abbreviation "MAJOR_PRIO_TAG i \ PRIO_TAG i 0" abbreviation "MINOR_PRIO_TAG i \ PRIO_TAG 0 i" abbreviation "DFLT_PRIO_TAG \ PRIO_TAG 0 0" text \Some standard tags\ abbreviation "PRIO_TAG_OPTIMIZATION \ MINOR_PRIO_TAG 10" \ \Optimized version of an algorithm, with additional side-conditions\ abbreviation "PRIO_TAG_GEN_ALGO \ MINOR_PRIO_TAG (- 10)" \ \Generic algorithm, considered to be less efficient than default algorithm\ subsection \Solving Relator Constraints\ text \ In this phase, we try to instantiate the annotated relators, using the available refinement rules. \ definition CONSTRAINT :: "'a \ ('c\'a) set \ bool" where [simp]: "CONSTRAINT f R \ True" lemma CONSTRAINTI: "CONSTRAINT f R" by auto ML \ structure Autoref_Rules = Named_Thms ( val name = @{binding autoref_rules_raw} val description = "Refinement Framework: " ^ "Automatic refinement rules" ); \ setup Autoref_Rules.setup text \Generic algorithm tags have to be defined here, as we need them for relator fixing !\ definition PREFER_tag :: "bool \ bool" where [simp, autoref_tag_defs]: "PREFER_tag x \ x" definition DEFER_tag :: "bool \ bool" where [simp, autoref_tag_defs]: "DEFER_tag x \ x" lemma PREFER_tagI: "P \ PREFER_tag P" by simp lemma DEFER_tagI: "P \ DEFER_tag P" by simp lemmas SIDEI = PREFER_tagI DEFER_tagI definition [simp, autoref_tag_defs]: "GEN_OP_tag P == P" lemma GEN_OP_tagI: "P ==> GEN_OP_tag P" by simp abbreviation "SIDE_GEN_OP P == PREFER_tag (GEN_OP_tag P)" text \Shortcut for assuming an operation in a generic algorithm lemma\ abbreviation "GEN_OP c a R \ SIDE_GEN_OP ((c,OP a ::: R) \ R)" definition TYREL :: "('a\'b) set \ bool" where [simp]: "TYREL R \ True" definition TYREL_DOMAIN :: "'a itself \ bool" where [simp]: "TYREL_DOMAIN i \ True" lemma TYREL_RES: "\ TYREL_DOMAIN TYPE('a); TYREL (R::(_\'a) set) \ \ TYREL R" . lemma DOMAIN_OF_TYREL: "TYREL (R::(_\'a) set) \ TYREL_DOMAIN TYPE('a)" by simp lemma TYRELI: "TYREL (R::(_\'a) set)" by simp lemma ty_REL: "TYREL (R::(_\'a) set)" by simp ML \ signature AUTOREF_FIX_REL = sig type constraint = (term * term) list * (term * term) type thm_pairs = (constraint option * thm) list type hom_net = (int * thm) Net.net val thm_pairsD_init: Proof.context -> Proof.context val thm_pairsD_get: Proof.context -> thm_pairs val constraints_of_term: term -> (term * term) list val constraints_of_goal: int -> thm -> (term * term) list val mk_CONSTRAINT: term * term -> term val mk_CONSTRAINT_rl: Proof.context -> constraint -> thm val insert_CONSTRAINTS_tac: Proof.context -> tactic' val constraint_of_thm: Proof.context -> thm -> constraint datatype prio_relpos = PR_FIRST | PR_LAST | PR_BEFORE of string | PR_AFTER of string val declare_prio: string -> term -> prio_relpos -> local_theory -> local_theory val delete_prio: string -> local_theory -> local_theory val print_prios: Proof.context -> unit val compute_hom_net: thm_pairs -> Proof.context -> hom_net val add_hom_rule: thm -> Context.generic -> Context.generic val del_hom_rule: thm -> Context.generic -> Context.generic val get_hom_rules: Proof.context -> thm list val add_tyrel_rule: thm -> Context.generic -> Context.generic val del_tyrel_rule: thm -> Context.generic -> Context.generic val get_tyrel_rules: Proof.context -> thm list val insert_tyrel_tac : Proof.context -> int -> int -> tactic' val solve_tyrel_tac : Proof.context -> tactic' val tyrel_tac : Proof.context -> itactic val internal_hom_tac: Proof.context -> itactic val internal_spec_tac: Proof.context -> itactic val internal_solve_tac: Proof.context -> itactic val guess_relators_tac: Proof.context -> itactic val pretty_constraint: Proof.context -> constraint -> Pretty.T val pretty_constraints: Proof.context -> constraint list -> Pretty.T val pretty_thm_pair: Proof.context -> (constraint option * thm) -> Pretty.T val pretty_thm_pairs: Proof.context -> thm_pairs -> Pretty.T val analyze: Proof.context -> int -> int -> thm -> bool val pretty_failure: Proof.context -> int -> int -> thm -> Pretty.T val try_solve_tac: Proof.context -> tactic' val solve_step_tac: Proof.context -> tactic' val phase: Autoref_Phases.phase val setup: theory -> theory end structure Autoref_Fix_Rel :AUTOREF_FIX_REL = struct type constraint = (term * term) list * (term * term) type thm_pairs = (constraint option * thm) list type hom_net = (int * thm) Net.net (*********************) (* Constraints *) (*********************) local fun fix_loose_bvars env t = if Term.is_open t then let val frees = tag_list 0 env |> map (fn (i,(n,T)) => Free (":"^string_of_int i ^ "_" ^ n,T)) in subst_bounds (frees, t) end else t fun constraints env @{mpat "OP ?f ::: ?R"} = ( Term.is_open R andalso raise TERM ("Loose bvar in relator",[R]); [(fix_loose_bvars env f,R)] ) | constraints _ (Free _) = [] | constraints _ (Bound _) = [] | constraints env @{mpat "?f ::: _"} = constraints env f | constraints env @{mpat "?f$?x"} = constraints env x @ constraints env f | constraints env @{mpat "PROTECT (\x. PROTECT ?t)"} = constraints ((x,x_T)::env) t | constraints _ @{mpat "PROTECT PROTECT"} = [] | constraints _ t = raise TERM ("constraints_of_term",[t]) in val constraints_of_term = constraints [] end fun constraints_of_goal i st = case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop ((_,?a)\_)"} => constraints_of_term a | _ => raise THM ("constraints_of_goal",i,[st]) fun mk_CONSTRAINT (f,R) = let val fT = fastype_of f val RT = fastype_of R val res = Const (@{const_name CONSTRAINT},fT --> RT --> HOLogic.boolT) $f$R in res end; (* Types of f and R must match! *) fun mk_CONSTRAINT_rl ctxt (ps,c) = let val ps = map (mk_CONSTRAINT #> HOLogic.mk_Trueprop) ps val c = mk_CONSTRAINT c |> HOLogic.mk_Trueprop val g = Logic.list_implies (ps,c) in Goal.prove ctxt [] [] g (fn {context = goal_ctxt, ...} => resolve_tac goal_ctxt @{thms CONSTRAINTI} 1) end; (* Internal use for hom-patterns, f and R are unified *) fun mk_CONSTRAINT_rl_atom ctxt (f,R) = let val ts = map (SOME o Thm.cterm_of ctxt) [f,R] val idx = Term.maxidx_term f (Term.maxidx_of_term R) + 1 in infer_instantiate' ctxt ts (Thm.incr_indexes idx @{thm CONSTRAINTI}) end; fun insert_CONSTRAINTS_tac ctxt i st = let val cs = constraints_of_goal i st |> map (mk_CONSTRAINT #> HOLogic.mk_Trueprop #> Thm.cterm_of ctxt) in Refine_Util.insert_subgoals_tac cs i st end fun constraint_of_thm ctxt thm = let exception NO_REL of term open Autoref_Tagging fun extract_entry t = case Logic.strip_imp_concl (strip_all_body t) of @{mpat "Trueprop ((_,?f)\_)"} => SOME (fst (strip_app f),t) | _ => NONE fun relator_of t = let (*val _ = tracing (Syntax.string_of_term @{context} t)*) val t = strip_all_body t val prems = Logic.strip_imp_prems t val concl = Logic.strip_imp_concl t in case concl of @{mpat "Trueprop ((_,?t)\?R)"} => let val (f,args) = strip_app t in case f of @{mpat "OP ?f:::?rel"} => (f,rel) | _ => let val rels = map_filter extract_entry prems fun find_rel t = case filter (fn (t',_) => t=t') rels of [(_,t)] => snd (relator_of t) | _ => raise NO_REL t val argrels = map find_rel args val rel = fold Relators.mk_fun_rel (rev argrels) R in (f,rel) end end | _ => raise THM ("constraint_of_thm: Invalid concl",~1,[thm]) end val (f,rel) = relator_of (Thm.prop_of thm) handle exc as (NO_REL t) => ( warning ( "Could not infer unique higher-order relator for " ^ "refinement rule: \n" ^ Thm.string_of_thm ctxt thm ^ "\n for argument: " ^ Syntax.string_of_term ctxt t ); Exn.reraise exc) (* Extract GEN_OP-tags *) fun genop_cs @{mpat "Trueprop (SIDE_GEN_OP ((_,OP ?f ::: _) \ ?R))"} = if has_Var f then NONE else SOME (f,R) | genop_cs _ = NONE val gen_ops = Thm.prems_of thm |> map_filter genop_cs in (gen_ops,(f,rel)) end (*********************) (* Priorities *) (*********************) structure Rel_Prio_List = Prio_List ( type item = string * term val eq = (op =) o apply2 fst ) structure Rel_Prio = Generic_Data ( type T = Rel_Prio_List.T val empty = Rel_Prio_List.empty val merge = Rel_Prio_List.merge - val extend = I ) fun pretty_rel_prio ctxt (s,t) = Pretty.block [ Pretty.str s, Pretty.str ":", Pretty.brk 1, Syntax.pretty_term ctxt t ] fun print_prios ctxt = let val rpl = Rel_Prio.get (Context.Proof ctxt) in (map (pretty_rel_prio ctxt) rpl) |> Pretty.big_list "Relator Priorities" |> Pretty.string_of |> warning end datatype prio_relpos = PR_FIRST | PR_LAST | PR_BEFORE of string | PR_AFTER of string fun declare_prio name pat0 relpos lthy = let val pat1 = Proof_Context.cert_term lthy pat0 val pat2 = singleton (Variable.export_terms (Proof_Context.augment pat1 lthy) lthy) pat1 in lthy |> Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => let val item = (name, Morphism.term phi pat2) in Rel_Prio.map (fn rpl => case relpos of PR_FIRST => Rel_Prio_List.add_first rpl item | PR_LAST => Rel_Prio_List.add_last rpl item | PR_BEFORE n => Rel_Prio_List.add_before rpl item (n,Term.dummy) | PR_AFTER n => Rel_Prio_List.add_after rpl item (n,Term.dummy) ) end) end fun delete_prio name = Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => Rel_Prio.map (Rel_Prio_List.delete (name, Term.dummy))) local fun relators_of R = let fun f @{mpat "?R1.0\?R2.0"} = f R1 @ f R2 | f R = [R] in f R |> map Refine_Util.anorm_term |> distinct (op =) end fun dest_prio_tag @{mpat "Trueprop (PRIO_TAG ?ma ?mi)"} = apply2 (#2 o HOLogic.dest_number) (ma,mi) | dest_prio_tag t = raise TERM ("dest_prio_tag",[t]) fun get_tagged_prios thm = let val prems = Thm.prems_of thm fun r [] = (0,0) | r (prem::prems) = ( case try dest_prio_tag prem of NONE => r prems | SOME p => p ) in r prems end fun prio_order_of ctxt (SOME (_,(_,R)),thm) = let val rels = relators_of R val hom = length rels val (major_prio,minor_prio) = get_tagged_prios thm val rpl = Rel_Prio.get (Context.Proof ctxt) val matches = Pattern.matches (Proof_Context.theory_of ctxt) fun prefer ((_,p1),(_,p2)) = matches (p2,p1) fun prio_of R = Rel_Prio_List.prio_of (fn (_,pat) => matches (pat,R)) prefer rpl + 1 val prio = fold (fn R => fn s => prio_of R + s) rels 0 in (major_prio, (hom,(prio,minor_prio))) end | prio_order_of _ _ = raise Match val prio_order = prod_ord (rev_order o int_ord) (prod_ord int_ord (prod_ord (rev_order o int_ord) (rev_order o int_ord))) fun annotate_thm_pair ctxt (SOME (ps,(f,R)),thm) = let open Autoref_Tagging Conv fun warn () = warning ("Error annotating refinement theorem: " ^ Thm.string_of_thm ctxt thm ) val R_cert = Thm.cterm_of ctxt R fun cnv ctxt ct = (case Thm.term_of ct of @{mpat "OP _ ::: _"} => all_conv | @{mpat "OP _"} => mk_rel_ANNOT_conv ctxt R_cert | @{mpat "_ $ _"} => arg1_conv (cnv ctxt) | _ => mk_OP_conv then_conv mk_rel_ANNOT_conv ctxt R_cert ) ct (*val _ = tracing ("ANNOT: " ^ @{make_string} thm)*) val thm = (fconv_rule (rhs_conv cnv ctxt)) thm val thm = case try (fconv_rule (rhs_conv cnv ctxt)) thm of NONE => (warn (); thm) | SOME thm => thm (*val _ = tracing ("RES: " ^ @{make_string} thm)*) in (SOME (ps,(f,R)),thm) end | annotate_thm_pair _ p = p in fun compute_thm_pairs ctxt = let val rules = Autoref_Rules.get ctxt fun add_o p = (prio_order_of ctxt p,p) val pairs = rules |> map (fn thm => (try (constraint_of_thm ctxt) thm,thm)) val spairs = filter (is_some o #1) pairs |> map add_o |> sort (prio_order o apply2 #1) |> map #2 val npairs = filter (is_none o #1) pairs in spairs@npairs |> map (annotate_thm_pair ctxt) end end structure thm_pairsD = Autoref_Data ( type T = thm_pairs val compute = compute_thm_pairs val prereq = [] ) val thm_pairsD_init = thm_pairsD.init val thm_pairsD_get = thm_pairsD.get structure hom_rules = Named_Sorted_Thms ( val name = @{binding autoref_hom} val description = "Autoref: Homogenity rules" val sort = K I val transform = K ( fn thm => case Thm.concl_of thm of @{mpat "Trueprop (CONSTRAINT _ _)"} => [thm] | _ => raise THM ("Invalid homogenity rule",~1,[thm]) ) ) val add_hom_rule = hom_rules.add_thm val del_hom_rule = hom_rules.del_thm val get_hom_rules = hom_rules.get local open Relators fun repl @{mpat "?R\?S"} ctab = let val (R,ctab) = repl R ctab val (S,ctab) = repl S ctab in (mk_fun_rel R S,ctab) end | repl R ctab = let val (args,R) = strip_relAPP R val (args,ctab) = fold_map repl args ctab val (ctxt,tab) = ctab val (R,(ctxt,tab)) = case Termtab.lookup tab R of SOME R => (R,(ctxt,tab)) | NONE => let val aT = fastype_of R |> strip_type |> #2 |> HOLogic.dest_setT |> HOLogic.dest_prodT |> #2 val (cT,ctxt) = yield_singleton Variable.invent_types @{sort type} ctxt val cT = TFree cT val T = map fastype_of args ---> HOLogic.mk_setT (HOLogic.mk_prodT (cT,aT)) val (R',ctxt) = yield_singleton Variable.variant_fixes "R" ctxt val R' = list_relAPP args (Free (R',T)) val tab = Termtab.update (R,R') tab in (R',(ctxt,tab)) end in (R,(ctxt,tab)) end fun hom_pat_of_rel ctxt R = let val (R,(ctxt',_)) = repl R (ctxt,Termtab.empty) val R = singleton (Variable.export_terms ctxt' ctxt) R in Refine_Util.anorm_term R end in fun compute_hom_net pairs ctxt = let val cs = map_filter #1 pairs val cs' = map (fn (_,(f,R)) => (f,hom_pat_of_rel ctxt R)) cs val thms = get_hom_rules ctxt @ map (mk_CONSTRAINT_rl_atom ctxt) cs' val thms = map (Thm.cprop_of #> Thm.trivial) thms val net = Tactic.build_net thms in net end end structure hom_netD = Autoref_Data ( type T = hom_net fun compute ctxt = compute_hom_net (thm_pairsD.get ctxt) ctxt val prereq = [ thm_pairsD.init ] ) structure tyrel_rules = Named_Sorted_Thms ( val name = @{binding autoref_tyrel} val description = "Autoref: Type-based relator fixing rules" val sort = K I val transform = K ( fn thm => case Thm.prop_of thm of @{mpat "Trueprop (TYREL _)"} => [thm] | _ => raise THM ("Invalid tyrel-rule",~1,[thm]) ) ) val add_tyrel_rule = tyrel_rules.add_thm val del_tyrel_rule = tyrel_rules.del_thm val get_tyrel_rules = tyrel_rules.get local (*fun rel_annots @{mpat "_ ::: ?R"} = [R] | rel_annots @{mpat "?f$?x"} = rel_annots f @ rel_annots x | rel_annots @{mpat "PROTECT (\_. PROTECT ?t)"} = rel_annots t | rel_annots @{mpat "PROTECT PROTECT"} = [] | rel_annots (Free _) = [] | rel_annots (Bound _) = [] | rel_annots t = raise TERM ("rel_annots",[t]) *) fun add_relators t acc = let open Relators val (args,_) = strip_relAPP t val res = fold add_relators args acc val res = insert (op =) t res in res end fun add_relators_of_subgoal st i acc = case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop (CONSTRAINT _ ?R)"} => add_relators R acc | _ => acc in fun insert_tyrel_tac ctxt i j k st = let fun get_constraint t = let val T = fastype_of t val res = Const (@{const_name TYREL}, T --> HOLogic.boolT) $ t in res |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt end val relators = fold (add_relators_of_subgoal st) (i upto j) [] val tyrels = map get_constraint relators in Refine_Util.insert_subgoals_tac tyrels k st end end fun solve_tyrel_tac ctxt = let fun mk_tac rl = resolve_tac ctxt @{thms TYREL_RES} THEN' match_tac ctxt [rl RS @{thm DOMAIN_OF_TYREL}] THEN' resolve_tac ctxt [rl] val tac = FIRST' (map mk_tac (tyrel_rules.get ctxt)) in DETERM o tac ORELSE' (TRY o resolve_tac ctxt @{thms TYRELI}) end fun tyrel_tac ctxt i j = (insert_tyrel_tac ctxt i j THEN_ALL_NEW_FWD solve_tyrel_tac ctxt) i fun internal_hom_tac ctxt = let val hom_net = hom_netD.get ctxt in Seq.INTERVAL (TRY o DETERM o resolve_from_net_tac ctxt hom_net) end fun internal_spec_tac ctxt = let val pairs = thm_pairsD.get ctxt val net = pairs |> map_filter (fst #> map_option (snd #> mk_CONSTRAINT_rl_atom ctxt)) |> Tactic.build_net in fn i => fn j => REPEAT (CHANGED (Seq.INTERVAL (DETERM o Anti_Unification.specialize_net_tac ctxt net) i j) ) end fun apply_to_constraints tac = let fun no_CONSTRAINT_tac i st = case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop (CONSTRAINT _ _)"} => Seq.empty | _ => Seq.single st in Seq.INTERVAL (no_CONSTRAINT_tac ORELSE' tac) end fun internal_solve_tac ctxt = let val pairs = thm_pairsD.get ctxt val net = pairs |> map_filter (fst #> map_option (mk_CONSTRAINT_rl ctxt)) |> Tactic.build_net val s_tac = SOLVED' (REPEAT_ALL_NEW (resolve_from_net_tac ctxt net)) in apply_to_constraints s_tac ORELSE_INTERVAL apply_to_constraints (TRY o DETERM o s_tac) end fun guess_relators_tac ctxt = let val pairs = thm_pairsD.get ctxt val net = pairs |> map_filter (fst #> map_option (mk_CONSTRAINT_rl ctxt)) |> Tactic.build_net val hom_net = hom_netD.get ctxt fun hom_tac i j = Seq.INTERVAL (TRY o DETERM o resolve_from_net_tac ctxt hom_net) i j fun spec_tac i j = REPEAT (CHANGED (Seq.INTERVAL (DETERM o Anti_Unification.specialize_net_tac ctxt net) i j) ) val solve_tac = let val s_tac = SOLVED' (REPEAT_ALL_NEW (resolve_from_net_tac ctxt net)) in apply_to_constraints s_tac ORELSE_INTERVAL apply_to_constraints (TRY o DETERM o s_tac) end in Seq.INTERVAL (insert_CONSTRAINTS_tac ctxt) THEN_INTERVAL hom_tac THEN_INTERVAL spec_tac THEN_INTERVAL (tyrel_tac ctxt) THEN_INTERVAL solve_tac end (*********************) (* Pretty Printing *) (*********************) fun pretty_constraint_atom ctxt (f,R) = Pretty.block [ Syntax.pretty_term ctxt f, Pretty.str " :: ", Syntax.pretty_typ ctxt (fastype_of f), Pretty.str " ::: ", Syntax.pretty_term ctxt R] fun pretty_constraint ctxt (ps,(f,R)) = case ps of [] => pretty_constraint_atom ctxt (f,R) | _ => Pretty.block [ map (pretty_constraint_atom ctxt) ps |> Pretty.separate "; " |> Pretty.enclose "\" "\", Pretty.brk 1, Pretty.str "\", Pretty.brk 1, pretty_constraint_atom ctxt (f,R) ] fun pretty_constraints ctxt l = Pretty.big_list "Constraints" (map (pretty_constraint ctxt) l) fun pretty_thm_pair ctxt (c,thm) = Pretty.block [ case c of NONE => Pretty.str "NONE" | SOME c => pretty_constraint ctxt c, Pretty.brk 2, Pretty.str "---", Pretty.brk 2, Thm.pretty_thm ctxt thm ] fun pretty_thm_pairs ctxt pairs = Pretty.big_list "Thm-Pairs" (map (pretty_thm_pair ctxt) pairs) local fun unifies ctxt (t1, t2) = Term.could_unify (t1, t2) andalso let val idx1 = Term.maxidx_of_term t1 val t2 = Logic.incr_indexes ([], [], idx1 + 1) t2 val idx2 = Term.maxidx_of_term t2 in can (Pattern.unify (Context.Proof ctxt) (t1,t2)) (Envir.empty idx2) end fun analyze_possible_problems ctxt (f,R) = let fun strange_aux sf R = ( if sf then let val T = fastype_of R in case try (HOLogic.dest_prodT o HOLogic.dest_setT) T of SOME _ => [] | NONE => [Pretty.block [ Pretty.str "Strange relator type, expected plain relation: ", Syntax.pretty_term (Config.put show_types true ctxt) R ]] end else [] ) @ ( case R of @{mpat "\?R\?S"} => strange_aux true R @ strange_aux false S | Var (_,T) => ( case try (HOLogic.dest_prodT o HOLogic.dest_setT) (#2 (strip_type T)) of SOME (TFree _,_) => [Pretty.block [ Pretty.str "Fixed concrete type on schematic relator: ", Syntax.pretty_term (Config.put show_types true ctxt) R ]] | _ => [] ) | _ => [] ) val strange = case strange_aux true R of [] => NONE | l => SOME (Pretty.block l) val folded_relator = let fun match (Type (name,args)) R = let val (Rargs,Rhd) = Relators.strip_relAPP R in if is_Var Rhd then [] else if length args <> length Rargs then [Pretty.block [ Pretty.str "Type/relator arity mismatch:", Pretty.brk 1, Pretty.block [ Pretty.str name, Pretty.str "/", Pretty.str (string_of_int (length args)) ], Pretty.brk 1,Pretty.str "vs.",Pretty.brk 1, Pretty.block [ Syntax.pretty_term ctxt Rhd, Pretty.str "/", Pretty.str (string_of_int (length Rargs)) ] ]] else args ~~ Rargs |> map (uncurry match) |> flat end | match _ _ = [] in case match (fastype_of f) R of [] => NONE | l => SOME (Pretty.block (Pretty.fbreaks l @ [Pretty.fbrk, Pretty.str ("Explanation: This may be due to using polymorphic " ^ "relators like Id on non-terminal types." ^ "A problem usually occurs when " ^ "this relator has to be matched against a fully unfolded one." ^ "This warning is also issued on partially parametric relators " ^ "like br. However, the refinement rules are usually set up to " ^ "compensate for this, so this is probably not the cause for an " ^ "unsolved constraint") ])) end val issues = [strange, folded_relator] |> map_filter I in case issues of [] => NONE | l => SOME (Pretty.big_list "Possible problems" l) end fun pretty_try_candidates ctxt i st = if i > Thm.nprems_of st then Pretty.str "Goal number out of range" else case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop (CONSTRAINT ?f ?R)"} => let val pairs = thm_pairsD.get ctxt val st = Drule.zero_var_indexes st val pt_hd = Pretty.block [ Pretty.str "Head: ", Pretty.fbrk, pretty_constraint_atom ctxt (f,R) ] fun isc (SOME (ps,(fp,R)),_) = if unifies ctxt (f,fp) then SOME (ps,(fp,R)) else NONE | isc _ = NONE val candidates = pairs |> map_filter isc fun try_c c = let val pt1 = Pretty.block [ Pretty.str "Trying ", pretty_constraint ctxt c ] val rl = mk_CONSTRAINT_rl ctxt c |> Drule.zero_var_indexes val res = (SOLVED' (resolve_tac ctxt [rl])) i st |> Seq.pull |> is_some val pt2 = (if res then Pretty.str "OK" else Pretty.str "ERR") in Pretty.block [pt1,Pretty.fbrk,pt2] end val res = Pretty.block ( Pretty.fbreaks [pt_hd, Pretty.big_list "Solving Attempts" (map try_c candidates)] ) in res end | _ => Pretty.str "Unexpected goal format" exception ERR of Pretty.T fun analyze' ctxt i j st = let val As = Logic.strip_horn (Thm.prop_of st) |> #1 |> drop (i-1) |> take (j-i+1) |> map (strip_all_body #> Logic.strip_imp_concl) val Cs = map_filter ( fn @{mpat "Trueprop (CONSTRAINT ?f ?R)"} => SOME (f,R) | @{mpat "Trueprop ((_,_)\_)"} => NONE | t => raise ERR (Pretty.block [ Pretty.str "Internal: Unexpected goal format: ", Syntax.pretty_term ctxt t ]) ) As val Cs_problems = map (fn c => case analyze_possible_problems ctxt c of NONE => pretty_constraint_atom ctxt c | SOME p => Pretty.block [pretty_constraint_atom ctxt c,Pretty.fbrk,p] ) Cs val Cs_pretty = Pretty.big_list "Constraints" Cs_problems in case Cs of [] => () | _ => raise ERR (Pretty.block [ Pretty.str "Could not infer all relators, some constraints remaining", Pretty.fbrk, Cs_pretty, Pretty.fbrk, Pretty.block [ Pretty.str "Trying to solve first constraint", Pretty.fbrk, pretty_try_candidates ctxt i st ] ]) end in fun analyze ctxt i j st = can (analyze' ctxt i j) st fun pretty_failure ctxt i j st = (analyze' ctxt i j st; Pretty.str "No failure") handle ERR p => p fun try_solve_tac ctxt i st = if i > Thm.nprems_of st then (tracing "Goal number out of range"; Seq.empty) else case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop (CONSTRAINT ?f ?R)"} => let val pairs = thm_pairsD.get ctxt val st = Drule.zero_var_indexes st val pt = Pretty.block [ Pretty.str "Head: ", Pretty.fbrk, pretty_constraint_atom ctxt (f,R) ] val _ = tracing (Pretty.string_of pt) val _ = case analyze_possible_problems ctxt (f,R) of NONE => () | SOME p => tracing (Pretty.string_of p) fun isc (SOME (ps,(fp,R)),_) = if unifies ctxt (f,fp) then SOME (ps,(fp,R)) else NONE | isc _ = NONE val net = pairs |> map_filter (fst #> map_option (mk_CONSTRAINT_rl ctxt)) |> Tactic.build_net val candidates = pairs |> map_filter isc fun try_c c = let val _ = Pretty.block [ Pretty.str "Trying ", pretty_constraint ctxt c ] |> Pretty.string_of |> tracing val rl = mk_CONSTRAINT_rl ctxt c |> Drule.zero_var_indexes val res = (SOLVED' (resolve_tac ctxt [rl] THEN_ALL_NEW (REPEAT_ALL_NEW (resolve_from_net_tac ctxt net))) ) i st |> Seq.pull |> is_some val _ = (if res then Pretty.str "OK" else Pretty.str "ERR") |> Pretty.string_of |> tracing in () end val _ = map try_c candidates in Seq.single st end | _ => Seq.empty end fun solve_step_tac ctxt = let val pairs = thm_pairsD.get ctxt val net = pairs |> map_filter (fst #> map_option (mk_CONSTRAINT_rl ctxt)) |> Tactic.build_net in resolve_from_net_tac ctxt net end val phase = { init = thm_pairsD.init #> hom_netD.init, tac = guess_relators_tac, analyze = analyze, pretty_failure = pretty_failure } val setup = hom_rules.setup #> tyrel_rules.setup end \ setup Autoref_Fix_Rel.setup end diff --git a/thys/Automatic_Refinement/Tool/Autoref_Phases.thy b/thys/Automatic_Refinement/Tool/Autoref_Phases.thy --- a/thys/Automatic_Refinement/Tool/Autoref_Phases.thy +++ b/thys/Automatic_Refinement/Tool/Autoref_Phases.thy @@ -1,226 +1,225 @@ section \Infrastructure for Multi-Phase Methods\ theory Autoref_Phases imports "../Lib/Refine_Lib" begin ML \ signature AUTOREF_PHASES = sig type phase = { init: Proof.context -> Proof.context, tac: Proof.context -> int -> int -> tactic, analyze: Proof.context -> int -> int -> thm -> bool, pretty_failure: Proof.context -> int -> int -> thm -> Pretty.T } val register_phase: string -> int -> phase -> morphism -> Context.generic -> Context.generic val delete_phase: string -> morphism -> Context.generic -> Context.generic val get_phases: Proof.context -> (string * int * phase) list val get_phase: string -> Proof.context -> (string * int * phase) option val init_phase: (string * int * phase) -> Proof.context -> Proof.context val init_phases: (string * int * phase) list -> Proof.context -> Proof.context val init_data: Proof.context -> Proof.context val declare_solver: thm list -> binding -> string -> (Proof.context -> tactic') -> morphism -> Context.generic -> Context.generic val phase_tac: (string * int * phase) -> Proof.context -> tactic' val phases_tac: (string * int * phase) list -> Proof.context -> tactic' val all_phases_tac: Proof.context -> tactic' val phases_tacN: string list -> Proof.context -> tactic' val phase_tacN: string -> Proof.context -> tactic' val cfg_debug: bool Config.T val cfg_trace: bool Config.T val cfg_keep_goal: bool Config.T end structure Autoref_Phases :AUTOREF_PHASES = struct type phase = { init: Proof.context -> Proof.context, tac: Proof.context -> int -> int -> tactic, analyze: Proof.context -> int -> int -> thm -> bool, pretty_failure: Proof.context -> int -> int -> thm -> Pretty.T } fun phase_order ((_,i1,_), (_,i2,_)) = (int_ord (i1,i2)) structure phase_data = Generic_Data ( type T = (string * int * phase) list val empty = [] val merge = Ord_List.merge phase_order - val extend = I ) val cfg_debug = Attrib.setup_config_bool @{binding autoref_dbg} (K false) val cfg_trace = Attrib.setup_config_bool @{binding autoref_trace} (K false) val cfg_keep_goal = Attrib.setup_config_bool @{binding autoref_keep_goal} (K false) fun register_phase n i p _ = phase_data.map (Ord_List.insert phase_order (n,i,p)) fun delete_phase n _ = phase_data.map (filter (curry (op =) n o #1)) val get_phases = phase_data.get o Context.Proof fun get_phase name ctxt = phase_data.get (Context.Proof ctxt) |> find_first (curry (op =) name o #1) fun init_phase (_,_,p) ctxt = #init p ctxt val init_phases = fold init_phase structure autoref_state = Proof_Data ( type T = bool fun init _ = false ) (* TODO: Workaround to have enough data for solvers in context *) fun init_data ctxt = if autoref_state.get ctxt then ctxt else let val ctxt = init_phases (get_phases ctxt) ctxt val ctxt = autoref_state.put true ctxt in ctxt end fun declare_solver triggers name desc tac phi context = let val name_s = Morphism.binding phi name |> Context.cases Sign.full_name Proof_Context.full_name context fun tac' ctxt = if autoref_state.get ctxt then tac ctxt else let val _ = warning ("Autoref-Solver " ^ name_s ^ " invoked outside autoref context." ^ " Initializing new context (slow)") in tac (init_data ctxt) end in Tagged_Solver.declare_solver triggers name desc tac' phi context end local fun handle_fail_tac pname p ctxt i j st = let val dbg_info = Config.get ctxt cfg_debug val keep_goal = Config.get ctxt cfg_keep_goal val prt_term = Syntax.pretty_term ctxt; fun pretty_subgoal (n, A) = Pretty.markup (Markup.subgoal "") [Pretty.str (" " ^ string_of_int n ^ ". "), prt_term A]; fun pretty_subgoals () = let val (As,_) = Logic.strip_horn (Thm.prop_of st) val As = drop (i - 1) As |> take (j - i + 1) in map pretty_subgoal (1 upto length As ~~ As) |> Pretty.fbreaks |> Pretty.block end; in if dbg_info then let val pt = #pretty_failure p ctxt i j st val _ = tracing ("Phase \"" ^ pname ^ "\" failed" ) val _ = tracing (Pretty.string_of pt) val _ = tracing "Remaining goals:" val _ = tracing (Pretty.string_of (pretty_subgoals ())) in () end else (); if keep_goal then Seq.single st else Seq.empty end fun ite_succeed_tac p tac1 tac2 ctxt i j st = if #analyze p ctxt i j st then tac1 ctxt i j st else tac2 ctxt i j st fun do_phase (pname,_,p) tac1 ctxt = let val do_trace = Config.get ctxt cfg_trace fun tr msg tac ctxt i j st = (if do_trace then tracing msg else (); tac ctxt i j st) fun ptac ctxt i j = DETERM (#tac p ctxt i j) THEN ((PRIMITIVE (Drule.zero_var_indexes))) fun timed_ptac ctxt i j = let val tac = ptac ctxt i j in fn st => let val start = Timing.start () val res = tac st val timing = Timing.result start val _ = if do_trace then Timing.message timing |> tracing else () in res end end in ( tr ("Phase \"" ^ pname ^ "\"") timed_ptac ctxt) THEN_INTERVAL ite_succeed_tac p ( tr ("Success (Phase \"" ^ pname ^ "\")") tac1) ( tr ("Fail (Phase \"" ^ pname ^ "\")") (handle_fail_tac pname p)) ctxt end fun do_phases [] _ = (fn _ => fn _ => Seq.single) | do_phases (p::ps) ctxt = do_phase p (do_phases ps) ctxt fun is_sorted _ [] = true | is_sorted _ [_] = true | is_sorted ord (a::b::l) = ord (a,b) <> GREATER andalso is_sorted ord (b::l) in fun phase_tac p ctxt = let val ctxt = init_phase p ctxt in SINGLE_INTERVAL (do_phase p (fn _ => fn _ => fn _ => all_tac) ctxt) end fun phases_tac ps ctxt = let val ctxt = init_phases ps ctxt in SINGLE_INTERVAL (do_phases ps ctxt) end fun all_phases_tac ctxt = phases_tac (get_phases ctxt) ctxt fun get_phase_err ctxt name = case get_phase name ctxt of NONE => error ("Unknown phase: " ^ name) | SOME p => p fun phase_tacN name ctxt = phase_tac (get_phase_err ctxt name) ctxt fun phases_tacN names ctxt = let val ps = map (get_phase_err ctxt) names val _ = if is_sorted phase_order ps then () else warning "Non-standard phase order" in phases_tac ps ctxt end end end \ end diff --git a/thys/Collections/ICF/tools/Locale_Code.thy b/thys/Collections/ICF/tools/Locale_Code.thy --- a/thys/Collections/ICF/tools/Locale_Code.thy +++ b/thys/Collections/ICF/tools/Locale_Code.thy @@ -1,386 +1,385 @@ section \Code Generation from Locales\ theory Locale_Code imports ICF_Tools Ord_Code_Preproc begin text \ Provides a simple mechanism to prepare code equations for constants stemming from locale interpretations. The usage pattern is as follows: \setup Locale_Code.checkpoint\ is called before a series of interpretations, and afterwards, \setup Locale_Code.prepare\ is called. Afterwards, the code generator will correctly recognize expressions involving terms from the locale interpretation. \ text \Tag to indicate pattern deletion\ definition LC_DEL :: "'a \ unit" where "LC_DEL a \ ()" ML \ signature LOCALE_CODE = sig type pat_eq = cterm * thm list val open_block: theory -> theory val close_block: theory -> theory val del_pat: cterm -> theory -> theory val add_pat_eq: cterm -> thm list -> theory -> theory val lc_decl_eq: thm list -> local_theory -> local_theory val lc_decl_del: term -> local_theory -> local_theory val setup: theory -> theory val get_unf_ss: theory -> simpset val tracing_enabled: bool Unsynchronized.ref end structure Locale_Code :LOCALE_CODE = struct open ICF_Tools val tracing_enabled = Unsynchronized.ref false; type pat_eq = cterm * thm list type block_data = {idx:int, del_pats: cterm list, add_pateqs: pat_eq list} val closed_block = {idx = ~1, del_pats=[], add_pateqs=[]}; fun init_block idx = {idx = idx, del_pats=[], add_pateqs=[]}; fun is_open ({idx,...}:block_data) = idx <> ~1; fun assert_open bd = if is_open bd then () else error "Locale_Code: No open block"; fun assert_closed bd = if is_open bd then error "Locale_Code: Block already open" else (); fun merge_bd (bd1,bd2) = ( if is_open bd1 orelse is_open bd2 then error "Locale_Code: Merge with open block" else (); closed_block ); fun bd_add_del_pats ps {idx,del_pats,add_pateqs} = {idx = idx, del_pats = ps@del_pats, add_pateqs = add_pateqs}; fun bd_add_add_pateqs pes {idx,del_pats,add_pateqs} = {idx = idx, del_pats = del_pats, add_pateqs = pes@add_pateqs}; structure BlockData = Theory_Data ( type T = block_data val empty = (closed_block) - val extend = I val merge = merge_bd ); structure FoldSSData = Oc_Simpset ( val prio = 5; val name = "Locale_Code"; ); fun add_unf_thms thms thy = let val ctxt = Proof_Context.init_global thy val thms = map Thm.symmetric thms in FoldSSData.map (fn ss => put_simpset ss ctxt |> sss_add thms |> simpset_of ) thy end val get_unf_ss = FoldSSData.get; (* First order match with fixed head *) fun match_fixed_head (pat,obj) = let (* Match heads *) val inst = Thm.first_order_match (chead_of pat, chead_of obj); val pat = Thm.instantiate_cterm inst pat; (* Now match whole pattern *) val inst = Thm.first_order_match (pat, obj); in inst end; val matches_fixed_head = can match_fixed_head; (* First order match of heads only *) fun match_heads (pat,obj) = Thm.first_order_match (chead_of pat, chead_of obj); val matches_heads = can match_heads; val pat_nargs = Thm.term_of #> strip_comb #> #2 #> length; (* Adjust a theorem to exactly match pattern *) fun norm_thm_pat (thm,pat) = let val thm = norm_def_thm thm; val na_pat = pat_nargs pat; val lhs = Thm.lhs_of thm; val na_lhs = pat_nargs lhs; val lhs' = if na_lhs > na_pat then funpow (na_lhs - na_pat) Thm.dest_fun lhs else lhs; val inst = Thm.first_order_match (lhs',pat); in Thm.instantiate inst thm end; fun del_pat_matches cpat (epat,_) = if pat_nargs cpat = 0 then matches_heads (cpat,epat) else matches_fixed_head (cpat,epat); (* Pattern-Eqs from specification *) local datatype action = ADD of (cterm * thm list) | DEL of cterm fun filter_pat_eq thy thms pat = let val cpat = Thm.global_cterm_of thy pat; in if (pat_nargs cpat = 0) then NONE else let val thms' = fold (fn thm => fn acc => case try norm_thm_pat (thm, cpat) of NONE => acc | SOME thm => thm::acc ) thms []; in case thms' of [] => NONE | _ => SOME (ADD (cpat,thms')) end end; fun process_actions acc [] = acc | process_actions acc (ADD peq::acts) = process_actions (peq::acc) acts | process_actions acc (DEL cpat::acts) = let val acc' = filter (not o curry renames_cterm cpat o fst) acc; val _ = if length acc = length acc' then warning ("Locale_Code: LC_DEL without effect: " ^ @{make_string} cpat) else (); in process_actions acc' acts end; fun pat_eqs_of_spec thy {rough_classification = Spec_Rules.Equational _, terms = pats, rules = thms, ...} = map_filter (filter_pat_eq thy thms) pats | pat_eqs_of_spec thy {rough_classification = Spec_Rules.Unknown, terms = [Const (@{const_name LC_DEL},_)$pat], ...} = [(DEL (Thm.global_cterm_of thy pat))] | pat_eqs_of_spec _ _ = []; in fun pat_eqs_of_specs thy specs = map (pat_eqs_of_spec thy) specs |> flat |> rev |> process_actions []; end; fun is_proper_pat cpat = let val pat = Thm.term_of cpat; val (f,args) = strip_comb pat; in is_Const f andalso args <> [] andalso not (is_Var (hd (rev args))) end; (* Instantiating pattern-eq *) local (* Get constant name for instantiation pattern *) fun inst_name lthy pat = let val (fname,params) = case strip_comb pat of ((Const (fname,_)),params) => (fname,params) | _ => raise TERM ("inst_name: Expected pattern",[pat]); fun pname (Const (n,_)) = Long_Name.base_name n | pname (s$t) = pname s ^ "_" ^ pname t | pname _ = Name.uu; in space_implode "_" (Long_Name.base_name fname::map pname params) |> gen_variant (can (Proof_Context.read_const {proper = true, strict = false} lthy)) end; in fun inst_pat_eq (cpat,thms) = wrap_lthy_result_global (fn lthy => let val (((instT,inst),thms),lthy) = Variable.import true thms lthy; val cpat = Thm.instantiate_cterm (instT, inst) cpat; val pat = Thm.term_of cpat; val name = inst_name lthy pat; val ((_,(_,def_thm)),lthy) = Local_Theory.define ((Binding.name name,NoSyn), ((Binding.name (Thm.def_name name),[]),pat)) lthy; val thms' = map (Local_Defs.fold lthy [def_thm]) thms; in ((def_thm,thms'),lthy) end) (fn m => fn (def_thm,thms') => (Morphism.thm m def_thm, map (Morphism.thm m) thms')) #> (fn ((def_thm,thms'),thy) => let val thy = thy |> add_unf_thms [def_thm] |> Code.declare_default_eqns_global (map (rpair true) thms'); in thy end) end (* Bookkeeping *) fun new_specs thy = let val bd = BlockData.get thy; val _ = assert_open bd; val ctxt = Proof_Context.init_global thy; val srules = Spec_Rules.get ctxt; val res = take (length srules - #idx bd) srules; in res end fun open_block thy = let val bd = BlockData.get thy; val _ = assert_closed bd; val ctxt = Proof_Context.init_global thy; val idx = length (Spec_Rules.get ctxt); val thy = BlockData.map (K (init_block idx)) thy; in thy end; fun process_block bd thy = let fun filter_del_pats cpat peqs = let val peqs' = filter (not o del_pat_matches cpat) peqs val _ = if length peqs = length peqs' then warning ("Locale_Code: No pattern-eqs matching filter: " ^ @{make_string} cpat) else (); in peqs' end; fun filter_add_pats (orig_pat,_) = forall (fn (add_pat,_) => not (renames_cterm (orig_pat,add_pat))) (#add_pateqs bd); val specs = new_specs thy; val peqs = pat_eqs_of_specs thy specs |> fold filter_del_pats (#del_pats bd) |> filter filter_add_pats; val peqs = peqs @ #add_pateqs bd; val peqs = rev peqs; (* Important: Process equations in the order in that they have been added! *) val _ = if !tracing_enabled then map (fn peq => (tracing (@{make_string} peq); ())) peqs else []; val thy = thy |> fold inst_pat_eq peqs; in thy end; fun close_block thy = let val bd = BlockData.get thy; val _ = assert_open bd; val thy = process_block bd thy |> BlockData.map (K closed_block); in thy end; fun del_pat cpat thy = let val bd = BlockData.get thy; val _ = assert_open bd; val bd = bd_add_del_pats [cpat] bd; val thy = BlockData.map (K bd) thy; in thy end; fun add_pat_eq cpat thms thy = let val _ = is_proper_pat cpat orelse raise CTERM ("add_pat_eq: Not a proper pattern",[cpat]); fun ntp thm = case try norm_thm_pat (thm,cpat) of NONE => raise THM ("add_pat_eq: Theorem does not match pattern",~1,[thm]) | SOME thm => thm; val thms = map ntp thms; val thy = BlockData.map (bd_add_add_pateqs [(cpat,thms)]) thy; in thy end; local fun cpat_of_thm thm = let fun strip ct = case Thm.term_of ct of (_$Var _) => strip (Thm.dest_fun ct) | _ => ct; in strip (Thm.lhs_of thm) end; fun adjust_length (cpat1,cpat2) = let val n1 = cpat1 |> Thm.term_of |> strip_comb |> #2 |> length; val n2 = cpat2 |> Thm.term_of |> strip_comb |> #2 |> length; in if n1>n2 then (funpow (n1-n2) Thm.dest_fun cpat1, cpat2) else (cpat1, funpow (n2-n1) Thm.dest_fun cpat2) end fun find_match cpat cpat' = SOME (cpat,rename_cterm (cpat',cpat)) handle Pattern.MATCH => (case Thm.term_of cpat' of _$_ => find_match (Thm.dest_fun cpat) (Thm.dest_fun cpat') | _ => NONE ); (* Common head of definitional theorems *) fun comp_head thms = case map norm_def_thm thms of [] => NONE | thm::thms => let fun ch [] r = SOME r | ch (thm::thms) (cpat,acc) = let val cpat' = cpat_of_thm thm; val (cpat,cpat') = adjust_length (cpat,cpat') in case find_match cpat cpat' of NONE => NONE | SOME (cpat,inst) => ch thms (cpat, Drule.instantiate_normalize inst thm :: acc) end; in ch thms (cpat_of_thm thm,[thm]) end; in fun lc_decl_eq thms lthy = case comp_head thms of SOME (cpat,thms) => let val _ = if !tracing_enabled then tracing ("decl_eq: " ^ @{make_string} cpat ^ ": " ^ @{make_string} thms) else (); fun decl m = let val cpat'::thms' = Morphism.fact m (Drule.mk_term cpat :: thms); val cpat' = Drule.dest_term cpat'; in Context.mapping (BlockData.map (bd_add_add_pateqs [(cpat',thms')])) I end in lthy |> Local_Theory.declaration {syntax = false, pervasive = false} decl end | NONE => raise THM ("Locale_Code.lc_decl_eq: No common pattern",~1,thms); end; fun lc_decl_del pat = let val ty = fastype_of pat; val dpat = Const (@{const_name LC_DEL},ty --> @{typ unit})$pat; in Spec_Rules.add Binding.empty Spec_Rules.Unknown [dpat] [] end (* Package setup *) val setup = FoldSSData.setup; end \ setup Locale_Code.setup attribute_setup lc_delete = \ Parse.and_list1' ICF_Tools.parse_cpat >> (fn cpats => Thm.declaration_attribute (K (Context.mapping (fold Locale_Code.del_pat cpats) I))) \ "Locale_Code: Delete patterns for current block" attribute_setup lc_add = \ Parse.and_list1' (ICF_Tools.parse_cpat -- Attrib.thms) >> (fn peqs => Thm.declaration_attribute (K (Context.mapping (fold (uncurry Locale_Code.add_pat_eq) peqs) I))) \ "Locale_Code: Add pattern-eqs for current block" end diff --git a/thys/Collections/ICF/tools/Ord_Code_Preproc.thy b/thys/Collections/ICF/tools/Ord_Code_Preproc.thy --- a/thys/Collections/ICF/tools/Ord_Code_Preproc.thy +++ b/thys/Collections/ICF/tools/Ord_Code_Preproc.thy @@ -1,110 +1,108 @@ section \Functrans simpset for Code Preprocessing\ theory Ord_Code_Preproc imports Main ICF_Tools begin ML \ signature ORD_CODE_PREPROC = sig val add: int * string * (theory -> thm -> thm) -> theory -> theory val rem: string -> theory -> theory val get: theory -> (int * string * (theory -> thm -> thm)) list val setup: theory -> theory val trace_enabled: bool Unsynchronized.ref end structure Ord_Code_Preproc: ORD_CODE_PREPROC = struct val trace_enabled = Unsynchronized.ref false val do_sort = sort (rev_order o int_ord o apply2 #1) structure Data = Theory_Data ( type T = (int * string * (theory -> thm -> thm)) list val empty = [] - val extend = I val merge = (op @) #> do_sort #> distinct ((=) o apply2 #2) ); val get = Data.get fun add tr = Data.map (fn l => do_sort (tr::l)) fun rem name = Data.map (filter (fn (_,n,_) => n <>name)) local fun trace_ft ft thy thms = if !trace_enabled then let val res = ft thy thms; val (m1,m2) = case res of NONE => ("NF: ","") | SOME thms => ("Preproc: REW: "," --> " ^ @{make_string} thms); val _ = tracing (m1 ^ @{make_string} thms ^ m2); in res end else ft thy thms; fun s_functrans ctxt thms = let val thy = Proof_Context.theory_of ctxt; val trs = Data.get thy; val process = fold (fn (_,_,tr) => fn thm => tr thy thm) trs; val process' = fold (fn (_,name,tr) => fn thm => let val thm' = tr thy thm; val _ = if !trace_enabled andalso not (Thm.eq_thm (thm,thm')) then tracing ("Preproc "^name^": " ^ @{make_string} thm ^ " --> " ^ @{make_string} thm') else (); in thm' end ) trs; fun rew_ch acc ch [] = if ch then SOME acc else NONE | rew_ch acc ch (thm::thms) = let val thm' = process' thm; val ch = ch orelse not (Thm.eq_thm (thm,thm')); in rew_ch (thm'::acc) ch thms end; in rew_ch [] false thms end; in val functrans = ("Functrans_ss.functrans", Code_Preproc.simple_functrans ((*trace_ft*) (s_functrans))); end; val setup = Code_Preproc.add_functrans functrans; end signature OC_SIMPSET = sig val get: theory -> simpset val map: (simpset -> simpset) -> theory -> theory val setup: theory -> theory end functor Oc_Simpset(val prio:int val name:string): OC_SIMPSET = struct structure Data = Theory_Data ( type T = simpset val empty = empty_ss - val extend = I val merge = Raw_Simplifier.merge_ss ); val get = Data.get val map = Data.map local fun trans_fun thy thm = let val ss = Proof_Context.init_global thy |> put_simpset (get thy) in simplify ss thm end; in val setup = Ord_Code_Preproc.add (prio, name, trans_fun); end end \ setup Ord_Code_Preproc.setup end diff --git a/thys/Collections/ICF/tools/Record_Intf.thy b/thys/Collections/ICF/tools/Record_Intf.thy --- a/thys/Collections/ICF/tools/Record_Intf.thy +++ b/thys/Collections/ICF/tools/Record_Intf.thy @@ -1,162 +1,161 @@ section \Automation for Record Based Interfaces\ theory Record_Intf imports Main ICF_Tools Ord_Code_Preproc begin text \The ICF uses coercions to simulate multiple inheritance of operation records\ declare [[coercion_enabled]] lemma icf_rec_def_rule: "\sel B = x; A\B \ \ sel A = x " by auto ML_val Context.mapping ML \ signature RECORD_INTF = sig val get_unf_ss: Context.generic -> simpset val get_unf_thms: Context.generic -> thm list val add_unf_thms: thm list -> Context.generic -> Context.generic val add_unf_thms_global: thm list -> theory -> theory val icf_rec_def: thm -> Context.generic -> Context.generic val icf_rec_def_attr: attribute context_parser val icf_locales_tac: Proof.context -> tactic val setup: theory -> theory end; structure Record_Intf: RECORD_INTF = struct open ICF_Tools; structure Data = Generic_Data ( type T = simpset; val empty = HOL_basic_ss (*addsimprocs [Record.simproc, Record.upd_simproc]*); - val extend = I; val merge = Raw_Simplifier.merge_ss; ); structure CppSS = Oc_Simpset ( val prio = 2; val name = "Record_Intf"; ); fun get_unf_ss context = Data.get context val get_unf_thms = Data.get #> Raw_Simplifier.dest_ss #> #simps #> map #2 fun add_unf_thms thms context = let val ctxt = Context.proof_of context fun add ss = simpset_of (put_simpset ss ctxt addsimps thms) in context |> Data.map add |> Context.mapping (CppSS.map add) I end fun add_unf_thms_global thms = Context.theory_map (add_unf_thms thms); (* Gather select_conv-, defs- and simps-theorems for given type *) fun gather_conv_thms ctxt typ = let val thy = Proof_Context.theory_of ctxt val infos = Record.dest_recTs typ |> map fst |> map Long_Name.qualifier |> map (Record.the_info thy); val cs = map #select_convs infos |> flat |> map (Thm.transfer thy); val ds = map #defs infos @ map #simps infos |> flat |> map (Thm.transfer thy); in (cs,ds) end (* Gather select_conv theorems type of constant defined by def_thm *) fun gather_conv_thms_dt ctxt def_thm = def_thm |> Thm.prop_of |> Logic.dest_equals |> fst |> fastype_of |> gather_conv_thms ctxt; (* Generate code-unfold theorems for definition and remove definition from code equations. *) local fun unf_thms_of def_thm context = let val ctxt = Context.proof_of context; val def_thm = norm_def_thm def_thm; val (conv_thms, simp_thms) = gather_conv_thms_dt ctxt def_thm; val ss = put_simpset (get_unf_ss context) ctxt addsimps simp_thms (*val simp_thms = icf_rec_unf.get ctxt @ simp_thms;*) val unf_thms = conv_thms |> map ( chead_of_thm #> inst_meta_cong ctxt #> (fn thm => thm OF [def_thm]) #> simplify ss ) |> filter (not o Thm.is_reflexive); in unf_thms end; in fun icf_rec_def def_thm context = let val unf_thms = unf_thms_of def_thm context; val eqn_heads = the_list (try (fst o dest_Const o fst o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of o Local_Defs.meta_rewrite_rule (Context.proof_of context)) def_thm) in context |> add_unf_thms unf_thms |> not (null eqn_heads) ? Context.mapping (fold Code.declare_aborting_global eqn_heads) I end; end val icf_rec_def_attr : attribute context_parser = Scan.succeed (Thm.declaration_attribute icf_rec_def); fun icf_locales_tac ctxt = let val ss = put_simpset (get_unf_ss (Context.Proof ctxt)) ctxt val wits = Locale.get_witnesses ctxt val thms = map (simplify ss) wits; in ALLGOALS (TRY o (simp_tac ss THEN' resolve_tac ctxt thms)) end fun setup_simprocs thy = let val ctxt = Proof_Context.init_global thy val ss = put_simpset HOL_basic_ss ctxt addsimprocs [Record.simproc, Record.upd_simproc] |> simpset_of in Data.map (K ss) (Context.Theory thy) |> Context.the_theory end val setup = Global_Theory.add_thms_dynamic (@{binding icf_rec_unf}, get_unf_thms) #> CppSS.setup #> setup_simprocs; end; \ setup \Record_Intf.setup\ text \ Sets up unfolding for an operation record definition. New operation record definitions should be declared as \[icf_rec_def]\. \ attribute_setup icf_rec_def = \Record_Intf.icf_rec_def_attr\ "ICF: Setup unfolding for record definition" method_setup icf_locales = \ Scan.succeed (fn ctxt => SIMPLE_METHOD (Record_Intf.icf_locales_tac ctxt)) \ "ICF: Normalize records and discharge locale subgoals" end diff --git a/thys/Conditional_Transfer_Rule/CTR/CTR_Relators.ML b/thys/Conditional_Transfer_Rule/CTR/CTR_Relators.ML --- a/thys/Conditional_Transfer_Rule/CTR/CTR_Relators.ML +++ b/thys/Conditional_Transfer_Rule/CTR/CTR_Relators.ML @@ -1,226 +1,225 @@ (* Title: CTR/CTR_Relators.ML Author: Mihails Milehins Copyright 2021 (C) Mihails Milehins Implementation of the functionality associated with the ctr relators, including the command ctr_relator for registering the ctr relators. *) signature CTR_RELATORS = sig structure RelatorData: GENERIC_DATA val get_relator_data_generic : Context.generic -> RelatorData.T val get_relator_data_proof : Proof.context -> RelatorData.T val get_relator_data_global : theory -> RelatorData.T val relator_of_generic : Context.generic -> Symtab.key -> term option val relator_of_proof : Proof.context -> Symtab.key -> term option val relator_of_global : theory -> Symtab.key -> term option val update_relator : Symtab.key -> term -> local_theory -> local_theory val process_ctr_relator : string -> Proof.context -> local_theory val pr_of_typ : Proof.context -> ((string * sort) * term) list -> typ -> term val bnf_relator_of_type_name : Proof.context -> string -> term option end; structure CTR_Relators : CTR_RELATORS = struct (**** Data ****) (*** Data container ***) structure RelatorData = Generic_Data ( type T = term Symtab.table val empty = Symtab.empty - val extend = I val merge = Symtab.merge (K true) ); (*** Generic operations on the relator data ***) val get_relator_data_generic = RelatorData.get; val get_relator_data_proof = Context.Proof #> get_relator_data_generic; val get_relator_data_global = Context.Theory #> get_relator_data_generic; fun relator_of_generic context = context |> get_relator_data_generic |> Symtab.lookup #> ( context |> Context.theory_of |> (Morphism.transfer_morphism #> Morphism.term) |> Option.map ); val relator_of_proof = Context.Proof #> relator_of_generic; val relator_of_global = Context.Theory #> relator_of_generic; fun update_relator k rel = Local_Theory.declaration {pervasive=true, syntax=false} (fn phi => (k, Morphism.term phi rel) |> Symtab.update |> RelatorData.map); (**** User input analysis ****) fun mk_msg_ctr_relator msg = "ctr_relator: " ^ msg; val mk_msg_not_const = "the input must be a constant term"; val mk_msg_not_body_bool = "the body of the type of the input must be bool"; val mk_msg_not_binders_2 = "the type of the input must have more than two binders"; val mk_msg_not_binders_binrelT = "all of the binders associated with the type of the input" ^ "except the last two must be the binary relation types"; val mk_msg_no_dup_binrelT = "the types of the binders of the binary relations associated " ^ "with the type of the input must have no duplicates"; val mk_msg_not_binders_binrelT_ftv_stv = "the types of the binders of the binary relation types associated " ^ "with the input type must be either free type variables or " ^ "schematic type variables"; val mk_msg_not_type_constructor = "the last two binders of the input type must be " ^ "the results of an application of a type constructor"; val mk_msg_not_identical_type_constructors = "the type constructors that are associated with the last two binders " ^ "of the input type must be identical"; val mk_msg_not_identical_input_types = "the sequences of the input types to the type constructors that are " ^ "associated with the last two binders of the input type must be " ^ "identical to the sequences of the types formed by concatenating the " ^ "type variables associated with the left hand side and the right " ^ "hand side of the binary relation types, respectively"; (**** Command for the registration of ctr relators ****) fun relator_type_name_of_type T = let val _ = T |> body_type |> curry op= HOLogic.boolT orelse error (mk_msg_ctr_relator mk_msg_not_body_bool) val binders = binder_types T val n = length binders val _ = n |> (fn n => n > 2) orelse error (mk_msg_ctr_relator mk_msg_not_binders_2) val (relTs, (mainT_lhs, mainT_rhs)) = binders |> chop (n - 2) ||> chop 1 ||> apfst the_single ||> apsnd the_single val _ = relTs |> map HOLogic.is_binrelT |> List.all I orelse error (mk_msg_ctr_relator mk_msg_not_binders_binrelT) val (lhs_tvars, rhs_tvars) = relTs |> map HOLogic.dest_binrelT |> split_list val tvars = lhs_tvars @ rhs_tvars val _ = tvars |> has_duplicates op= |> not orelse error (mk_msg_ctr_relator mk_msg_no_dup_binrelT) val _ = tvars |> map (fn T => is_TVar T orelse is_TFree T) |> List.all I orelse error (mk_msg_ctr_relator mk_msg_not_binders_binrelT_ftv_stv) val _ = is_Type mainT_lhs orelse error (mk_msg_ctr_relator mk_msg_not_type_constructor) val _ = is_Type mainT_rhs orelse error (mk_msg_ctr_relator mk_msg_not_type_constructor) val mainT_lhs = dest_Type mainT_lhs val mainT_rhs = dest_Type mainT_rhs val _ = op= (apply2 #1 (mainT_lhs, mainT_rhs)) orelse error (mk_msg_ctr_relator mk_msg_not_identical_type_constructors) val _ = lhs_tvars = #2 mainT_lhs orelse error (mk_msg_ctr_relator mk_msg_not_identical_input_types) val _ = rhs_tvars = #2 mainT_rhs orelse error (mk_msg_ctr_relator mk_msg_not_identical_input_types) in #1 mainT_lhs end; fun process_ctr_relator args ctxt = let val t = Syntax.read_term ctxt args val _ = is_Const t orelse error (mk_msg_ctr_relator mk_msg_not_const) val c = relator_type_name_of_type (type_of t) in update_relator c t ctxt end; val _ = Outer_Syntax.local_theory \<^command_keyword>\ctr_relator\ "registration of the ctr relators" (Parse.const >> process_ctr_relator); (**** ctr relators combined with the bnf relators ****) fun bnf_relator_of_type_name ctxt c = let fun bnf_relator_of_type_name ctxt c = let val relator_of_bnf = BNF_Def.rel_of_bnf #> strip_comb #> #1 #> dest_Const #> #1 #> Syntax.read_term ctxt #> Logic.varify_global in c |> BNF_Def.bnf_of ctxt |> Option.map relator_of_bnf end in case relator_of_proof ctxt c of SOME t => SOME t | NONE => bnf_relator_of_type_name ctxt c end; (**** Conversion of a type to a parametricity relation ****) (* The algorithm follows an outline of an algorithm for a similar purpose suggested in section 4.1 of the Ph.D. thesis of Ondřej Kunčar titled "Types, Abstraction and Parametric Polymorphism in Higher-Order Logic". *) fun pr_of_typ ctxt ftv_spec_relt T = let fun pr_of_typ _ trel (TFree ftv_spec) = trel ftv_spec | pr_of_typ _ _ (Type (c, [])) = Const ( \<^const_name>\HOL.eq\, HOLogic.mk_binrelT (Type (c, []), Type (c, [])) ) | pr_of_typ relator_of_type_name trel (Type (c, Ts)) = let val constt = relator_of_type_name c handle Option => raise TYPE ("pr_of_typ: no relator", [Type (c, Ts)], []) val constT = type_of constt val binders = constT |> binder_types |> take (length Ts) val argts = map (pr_of_typ relator_of_type_name trel) Ts val argTs = map type_of argts val tyenv_match = Type.typ_matches (Proof_Context.tsig_of ctxt) (binders, argTs) Vartab.empty handle Type.TYPE_MATCH => raise TYPE ("pr_of_typ: invalid relator", [Type (c, Ts)], []) val constt = constt |> dest_Const ||> K (Envir.subst_type tyenv_match constT) |> Const in list_comb (constt, argts) end | pr_of_typ _ _ T = raise TYPE ("pr_of_typ: type", single T, []) val trel = AList.lookup op= ftv_spec_relt #> the in pr_of_typ (bnf_relator_of_type_name ctxt #> the) trel T end; end; \ No newline at end of file diff --git a/thys/Conditional_Transfer_Rule/CTR/Tests/CTR_Tests.thy b/thys/Conditional_Transfer_Rule/CTR/Tests/CTR_Tests.thy --- a/thys/Conditional_Transfer_Rule/CTR/Tests/CTR_Tests.thy +++ b/thys/Conditional_Transfer_Rule/CTR/Tests/CTR_Tests.thy @@ -1,257 +1,256 @@ (* Title: CTR/Tests/CTR_Tests.thy Author: Mihails Milehins Copyright 2021 (C) Mihails Milehins A test suite for the sub-framework CTR. *) section\A test suite for CTR\ theory CTR_Tests imports "../CTR" "../../IML_UT/IML_UT" Complex_Main keywords "ctr_test" :: thy_defn begin subsection\Background\ ML\ type ctr_test_data = { ctr_type : string, synthesis : (string * thm list option) option, elems: (string, string, Facts.ref) Element.ctxt list, type_specs : (string * string) list, thm_specs : ((binding option * thm) * mixfix) list }; structure CTRTestData = Generic_Data ( type T = ctr_test_data Symtab.table val empty = Symtab.empty - val extend = I val merge = Symtab.merge (K true) ); val get_ctr_test_data_generic = CTRTestData.get; val get_ctr_test_data_proof = Context.Proof #> get_ctr_test_data_generic; val get_ctr_test_data_global = Context.Theory #> get_ctr_test_data_generic; fun test_data_of_generic context = context |> get_ctr_test_data_generic |> Symtab.lookup; val ctr_test_data_of_proof = Context.Proof #> test_data_of_generic; (*oversimplified: to be used with care*) fun update_ctr_test_data k ctr_test_data = Local_Theory.declaration {pervasive=true, syntax=false} (fn _ => (k, ctr_test_data) |> Symtab.update |> CTRTestData.map); fun process_ctr_test_data (k, args) (lthy : local_theory) = let fun preprocess_thm_specs lthy = map (apfst (apsnd (singleton (Attrib.eval_thms lthy)))) fun process_ctrs_impl (CTR.ALG_PP _) (lthy : local_theory) = lthy | process_ctrs_impl (CTR.ALG_RP (((synthesis, elems), type_specs), thm_specs)) (lthy : local_theory) = let val thm_specs' = preprocess_thm_specs lthy thm_specs val synthesis' = Option.map (apsnd (Option.map ((single #> Attrib.eval_thms lthy)))) synthesis val data : ctr_test_data = { ctr_type = "relativization", synthesis = synthesis', elems = elems, type_specs = type_specs, thm_specs = thm_specs' } in update_ctr_test_data k data lthy end in process_ctrs_impl args lthy end; val ctr_test_parser = Parse.string -- CTR.ctr_parser; val _ = Outer_Syntax.local_theory \<^command_keyword>\ctr_test\ "test setup for the command ctr" (ctr_test_parser >> process_ctr_test_data); \ ud \order.mono\ ud mono' \mono\ definition mono_ow :: "'a set \ ('b \ 'b \ bool) \ ('a \ 'a \ bool) \ ('a \ 'b) \ bool" where "mono_ow UB leb lea f \ \x\UB. \y\UB. lea x y \ leb (f x) (f y)" typedef 'a K = \{xs::'a list. length xs = 2}\ by (simp add: Ex_list_of_length) definition KK :: "'a K \ 'a K \ bool" where "KK k1 k2 \ k1 = k2" typedef 'a L = \{xs::'a list. length xs = 2}\ by (simp add: Ex_list_of_length) definition LL :: "'a L \ 'a L \ bool" where "LL k1 k2 \ k1 = k2" definition rel_L :: "('a::group_add \ 'b::group_add \ bool) \ 'a::group_add L \ 'b::group_add L \ bool" where "rel_L A b c = True" ctr_relator rel_L definition not_binders_binrelT :: "('a \ 'b \ bool) \ ('c \ bool) \ 'a \ 'b \ bool" where "not_binders_binrelT R1 R2 a b = True" definition no_dup_binrelT :: "('a \ 'b \ bool) \ ('c \ 'a \ bool) \ 'a \ 'b \ bool" where "no_dup_binrelT R1 R2 a b = True" definition not_binders_binrelT_ftv_stv :: "('a \ 'b \ bool) \ (nat \ 'c \ bool) \ 'a \ 'b \ bool" where "not_binders_binrelT_ftv_stv R1 R2 a b = True" definition not_type_constructor_lhs :: "('a \ 'b \ bool) \ ('c \ 'd \ bool) \ 'a \ 'a K \ bool" where "not_type_constructor_lhs R1 R2 a b = True" definition not_type_constructor_rhs :: "('a \ 'b \ bool) \ ('c \ 'd \ bool) \ 'a K \ 'e \ bool" where "not_type_constructor_rhs R1 R2 a b = True" definition not_identical_type_constructors :: "('a \ 'b \ bool) \ ('c \ 'd \ bool) \ 'a K \ 'e L \ bool" where "not_identical_type_constructors R1 R2 a b = True" definition not_identical_type_constructors_lhs :: "('a \ 'b \ bool) \ ('c \ 'd \ bool) \ 'a K \ 'b K \ bool" where "not_identical_type_constructors_lhs R1 R2 a b = True" definition not_identical_type_constructors_rhs :: "('a \ 'b \ bool) \ 'a K \ 'c K \ bool" where "not_identical_type_constructors_rhs R1 a b = True" subsection\Test data\ lemma mono_ow_transfer': includes lifting_syntax assumes [transfer_domain_rule, transfer_rule]: "Domainp B = (\x. x \ UB)" and [transfer_rule]: "right_total B" shows "((A ===> A ===> (=)) ===> (B ===> B ===> (=)) ===> (B ===> A) ===> (=)) (mono_ow UB) mono.with" unfolding mono_ow_def mono.with_def by (transfer_prover_start, transfer_step+) simp ctr_test "mono_with" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'b\bool\) and (?'a B) in mono_ow': mono.with_def ctr_test "exI" relativization in mono_ow'': exI ctr_test "binrel" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b A) and (?'a B) in mono_ow': mono.with_def ctr_test "binrel_ftv" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::nat\'b\bool\) and (?'a B) in mono_ow': mono.with_def ctr_test "dup_stvs" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'b\bool\) and (?'b B) in mono_ow': mono.with_def ctr_test "dup_binrel_ftvs" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'d\bool\) and (?'a B) in mono_ow': mono.with_def ctr_test "no_relator" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'b\bool\) and (?'a B) in KK_def ctr_test "invalid_relator" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'b\bool\) and (?'a B) in LL_def subsection\Tests\ subsubsection\\process_relativization\\ ML_file\CTR_TEST_PROCESS_RELATIVIZATION.ML\ context includes lifting_syntax begin ML\ val ctr_test_process_relativization_test_results = ctr_test_process_relativization.execute_test_suite_process_relativization @{context} \ ML\ val _ = ctr_test_process_relativization_test_results |> UT_Test_Suite.output_test_results true \ end subsubsection\\process_ctr_relator\\ ML_file\CTR_TEST_PROCESS_CTR_RELATOR.ML\ ML\ val ctr_test_process_ctr_relator_test_results = ctr_test_process_ctr_relator.execute_test_suite_process_ctr_relator @{context} \ ML\ val _ = ctr_test_process_ctr_relator_test_results |> UT_Test_Suite.output_test_results true \ end \ No newline at end of file diff --git a/thys/Conditional_Transfer_Rule/UD/UD_Consts.ML b/thys/Conditional_Transfer_Rule/UD/UD_Consts.ML --- a/thys/Conditional_Transfer_Rule/UD/UD_Consts.ML +++ b/thys/Conditional_Transfer_Rule/UD/UD_Consts.ML @@ -1,36 +1,35 @@ (* Title: UD/UD_Consts.ML Author: Mihails Milehins Copyright 2021 (C) Mihails Milehins The following infrastructure allows for the exclusion of arbitrary constants from being unoverloaded during the invocation of the algorithm associated with the UD. *) signature UD_CONSTS = sig structure ConstsData : THEORY_DATA val const_of_key : theory -> Symtab.key -> term option val update_const : Symtab.key -> term -> theory -> theory val remove_const : Symtab.key -> theory -> theory val get_keys : theory -> Symtab.key list end; structure UD_Consts : UD_CONSTS = struct structure ConstsData = Theory_Data ( type T = term Symtab.table val empty = Symtab.empty - val extend = I val merge = Symtab.merge (K true) ) val const_of_key = Symtab.lookup o ConstsData.get fun update_const k v = ConstsData.map (Symtab.update (k, v)) fun remove_const k = ConstsData.map (Symtab.delete k) val get_keys = Symtab.keys o ConstsData.get end; \ No newline at end of file diff --git a/thys/Constructor_Funs/constructor_funs.ML b/thys/Constructor_Funs/constructor_funs.ML --- a/thys/Constructor_Funs/constructor_funs.ML +++ b/thys/Constructor_Funs/constructor_funs.ML @@ -1,184 +1,183 @@ signature CONSTRUCTOR_FUNS = sig val mk_funs: Ctr_Sugar.ctr_sugar -> local_theory -> local_theory val mk_funs_typ: typ -> local_theory -> local_theory val mk_funs_cmd: string -> local_theory -> local_theory val enabled: bool Config.T val conv: Proof.context -> conv val constructor_funs_plugin: string val setup: theory -> theory end structure Constructor_Funs : CONSTRUCTOR_FUNS = struct val enabled = Attrib.setup_config_bool @{binding "constructor_funs"} (K false) structure Data = Generic_Data ( type T = term list * (int * thm) list * Symtab.set val empty = ([], [], Symtab.empty) fun merge ((ts1, unfolds1, s1), (ts2, unfolds2, s2)) = (ts1 @ ts2, unfolds1 @ unfolds2, Symtab.merge op = (s1, s2)) - val extend = I ) fun lenient_unvarify t = (* type variables in records are not schematic *) Logic.unvarify_global t handle TERM _ => t fun mk_funs {T, ctrs, ...} lthy = let val typ_name = fst (dest_Type T) fun mk_fun ctr lthy = let val (name, typ) = dest_Const (lenient_unvarify ctr) val (typs, _) = strip_type typ val len = length typs in if len > 0 then let val base_name = Long_Name.base_name name val binding = Binding.name base_name val args = Name.invent_names (Name.make_context [base_name]) Name.uu typs |> map Free val lhs = list_comb (Free (base_name, typ), args) val rhs = list_comb (Const (name, typ), args) val def = Logic.mk_equals (lhs, rhs) val ((term, (_, def_thm)), lthy') = Specification.definition NONE [] [] ((binding, []), def) lthy val unfold_thm = @{thm Pure.symmetric} OF [Local_Defs.abs_def_rule lthy' def_thm] in (SOME (term, (len, unfold_thm)), lthy') end else (NONE, lthy) end fun morph_unfold phi (len, thm) = (len, Morphism.thm phi thm) fun upd (ts', unfolds') = Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Data.map (fn (ts, unfolds, s) => (map (Morphism.term phi) ts' @ ts, map (morph_unfold phi) unfolds' @ unfolds, Symtab.update_new (typ_name, ()) s))) val exists = Symtab.defined (#3 (Data.get (Context.Proof lthy))) typ_name val warn = Pretty.separate "" [Syntax.pretty_typ lthy T, Pretty.str "already processed"] |> Pretty.block val _ = if exists then warning (Pretty.string_of warn) else () in if exists then lthy else (snd o Local_Theory.begin_nested) lthy |> Proof_Context.concealed |> Local_Theory.map_background_naming (Name_Space.mandatory_path typ_name #> Name_Space.mandatory_path "constructor_fun") |> fold_map mk_fun ctrs |>> map_filter I |>> split_list |-> upd |> Local_Theory.end_nested end fun mk_funs_typ typ lthy = mk_funs (the (Ctr_Sugar.ctr_sugar_of lthy (fst (dest_Type typ)))) lthy fun mk_funs_cmd s lthy = mk_funs_typ (Proof_Context.read_type_name {proper = true, strict = false} lthy s) lthy fun comb_conv ctxt cv1 cv2 ct = let val (f, xs) = strip_comb (Thm.term_of ct) val f = Thm.cterm_of ctxt f val xs = map (Thm.cterm_of ctxt) xs val f' = cv1 f val xs' = map cv2 xs in fold (fn x => fn f => Thm.combination f x) xs' f' end fun conv ctxt = let val (_, unfolds, _) = Data.get (Context.Proof ctxt) val unfolds = map (apsnd (Thm.transfer' ctxt)) unfolds fun full_conv ct = let val (_, xs) = strip_comb (Thm.term_of ct) val actual_len = length xs fun head_conv ct = let fun can_rewrite (len, thm) = Option.map (pair len) (try (Conv.rewr_conv thm) ct) val _ = get_first can_rewrite unfolds in case get_first can_rewrite unfolds of NONE => Conv.all_conv ct | SOME (target_len, thm) => if target_len = actual_len then Conv.all_conv ct else thm end in comb_conv ctxt head_conv full_conv ct end in full_conv end fun functrans ctxt thms = let val (consts, _, _) = Data.get (Context.Proof ctxt) val conv = Conv.arg_conv (conv ctxt) fun apply_conv thm = let val thm' = Conv.fconv_rule conv thm val prop = Thm.prop_of thm val head = Logic.dest_equals prop |> fst |> strip_comb |> fst val protected = exists (fn const => Pattern.matches (Proof_Context.theory_of ctxt) (const, head)) consts in if protected orelse Thm.prop_of thm aconv Thm.prop_of thm' then (false, thm) else (true, thm') end val (changeds, thms') = split_list (map apply_conv thms) in if exists I changeds then SOME thms' else NONE end val code_functrans = Code_Preproc.simple_functrans (fn ctxt => if Config.get ctxt enabled then functrans ctxt else K NONE) val constructor_funs_plugin = Plugin_Name.declare_setup @{binding constructor_funs} (** setup **) val _ = Outer_Syntax.local_theory @{command_keyword "constructor_funs"} "defines constructor functions for a datatype and sets up the code generator" (Scan.repeat1 Args.embedded_inner_syntax >> fold mk_funs_cmd) val setup = Code_Preproc.add_functrans ("constructor_funs", code_functrans) #> Ctr_Sugar.ctr_sugar_interpretation constructor_funs_plugin (mk_funs_typ o #T) end \ No newline at end of file diff --git a/thys/Core_DOM/common/preliminaries/Hiding_Type_Variables.thy b/thys/Core_DOM/common/preliminaries/Hiding_Type_Variables.thy --- a/thys/Core_DOM/common/preliminaries/Hiding_Type_Variables.thy +++ b/thys/Core_DOM/common/preliminaries/Hiding_Type_Variables.thy @@ -1,584 +1,583 @@ (*********************************************************************************** * Copyright (c) 2018 Achim D. Brucker * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * * * Redistributions of source code must retain the above copyright notice, this * list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above copyright notice, * this list of conditions and the following disclaimer in the documentation * and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * SPDX-License-Identifier: BSD-2-Clause * Repository: https://git.logicalhacking.com/adbrucker/isabelle-hacks/ * Dependencies: None (assert.thy is used for testing the theory but it is * not required for providing the functionality of this hack) ***********************************************************************************) (* This file is based on commit 8a5e95421521c36ab71ab2711435a9bc0fa2c5cc from upstream (https://git.logicalhacking.com/adbrucker/isabelle-hacks/). Merely the dependency to Assert.thy has been removed by disabling the example section (which include assert checks). *) section\Hiding Type Variables\ text\ This theory\footnote{This theory can be used ``stand-alone,'' i.e., this theory is not specific to the DOM formalization. The latest version is part of the ``Isabelle Hacks'' repository: \url{https://git.logicalhacking.com/adbrucker/isabelle-hacks/}.} implements a mechanism for declaring default type variables for data types. This comes handy for complex data types with many type variables.\ theory "Hiding_Type_Variables" imports Main keywords "register_default_tvars" "update_default_tvars_mode"::thy_decl begin (*<*) section\Implementation\ subsection\Theory Managed Data Structure\ ML\ signature HIDE_TVAR = sig datatype print_mode = print_all | print | noprint datatype tvar_subst = right | left datatype parse_mode = parse | noparse type hide_varT = { name: string, tvars: typ list, typ_syn_tab : (string * typ list*string) Symtab.table, print_mode: print_mode, parse_mode: parse_mode } val parse_print_mode : string -> print_mode val parse_parse_mode : string -> parse_mode val register : string -> print_mode option -> parse_mode option -> theory -> theory val update_mode : string -> print_mode option -> parse_mode option -> theory -> theory val lookup : theory -> string -> hide_varT option val hide_tvar_tr' : string -> Proof.context -> term list -> term val hide_tvar_ast_tr : Proof.context -> Ast.ast list -> Ast.ast val hide_tvar_subst_ast_tr : tvar_subst -> Proof.context -> Ast.ast list -> Ast.ast val hide_tvar_subst_return_ast_tr : tvar_subst -> Proof.context -> Ast.ast list -> Ast.ast end structure Hide_Tvar : HIDE_TVAR = struct datatype print_mode = print_all | print | noprint datatype tvar_subst = right | left datatype parse_mode = parse | noparse type hide_varT = { name: string, tvars: typ list, typ_syn_tab : (string * typ list*string) Symtab.table, print_mode: print_mode, parse_mode: parse_mode } type hide_tvar_tab = (hide_varT) Symtab.table fun hide_tvar_eq (a, a') = (#name a) = (#name a') fun merge_tvar_tab (tab,tab') = Symtab.merge hide_tvar_eq (tab,tab') structure Data = Generic_Data ( type T = hide_tvar_tab val empty = Symtab.empty:hide_tvar_tab - val extend = I fun merge(t1,t2) = merge_tvar_tab (t1, t2) ); fun parse_print_mode "print_all" = print_all | parse_print_mode "print" = print | parse_print_mode "noprint" = noprint | parse_print_mode s = error("Print mode not supported: "^s) fun parse_parse_mode "parse" = parse | parse_parse_mode "noparse" = noparse | parse_parse_mode s = error("Parse mode not supported: "^s) fun update_mode typ_str print_mode parse_mode thy = let val ctx = Toplevel.context_of(Toplevel.theory_toplevel thy) val typ = Syntax.parse_typ ctx typ_str (* no type checking *) val name = case typ of Type(name,_) => name | _ => error("Complex type not (yet) supported.") fun update tab = let val old_entry = (case Symtab.lookup tab name of SOME t => t | NONE => error ("Type shorthand not registered: "^name)) val print_m = case print_mode of SOME m => m | NONE => #print_mode old_entry val parse_m = case parse_mode of SOME m => m | NONE => #parse_mode old_entry val entry = { name = name, tvars = #tvars old_entry, typ_syn_tab = #typ_syn_tab old_entry, print_mode = print_m, parse_mode = parse_m } in Symtab.update (name,entry) tab end in Context.theory_of ( (Data.map update) (Context.Theory thy)) end fun lookup thy name = let val tab = (Data.get o Context.Theory) thy in Symtab.lookup tab name end fun obtain_normalized_vname lookup_table vname = case List.find (fn e => fst e = vname) lookup_table of SOME (_,idx) => (lookup_table, Int.toString idx) | NONE => let fun max_idx [] = 0 | max_idx ((_,idx)::lt) = Int.max(idx,max_idx lt) val idx = (max_idx lookup_table ) + 1 in ((vname,idx)::lookup_table, Int.toString idx) end fun normalize_typvar_type lt (Type (a, Ts)) = let fun switch (a,b) = (b,a) val (Ts', lt') = fold_map (fn t => fn lt => switch (normalize_typvar_type lt t)) Ts lt in (lt', Type (a, Ts')) end | normalize_typvar_type lt (TFree (vname, S)) = let val (lt, vname) = obtain_normalized_vname lt (vname) in (lt, TFree( vname, S)) end | normalize_typvar_type lt (TVar (xi, S)) = let val (lt, vname) = obtain_normalized_vname lt (Term.string_of_vname xi) in (lt, TFree( vname, S)) end fun normalize_typvar_type' t = snd ( normalize_typvar_type [] t) fun mk_p s = s (* "("^s^")" *) fun key_of_type (Type(a, TS)) = mk_p (a^String.concat(map key_of_type TS)) | key_of_type (TFree (vname, _)) = mk_p vname | key_of_type (TVar (xi, _ )) = mk_p (Term.string_of_vname xi) val key_of_type' = key_of_type o normalize_typvar_type' fun normalize_typvar_term lt (Const (a, t)) = (lt, Const(a, t)) | normalize_typvar_term lt (Free (a, t)) = let val (lt, vname) = obtain_normalized_vname lt a in (lt, Free(vname,t)) end | normalize_typvar_term lt (Var (xi, t)) = let val (lt, vname) = obtain_normalized_vname lt (Term.string_of_vname xi) in (lt, Free(vname,t)) end | normalize_typvar_term lt (Bound (i)) = (lt, Bound(i)) | normalize_typvar_term lt (Abs(s,ty,tr)) = let val (lt,tr) = normalize_typvar_term lt tr in (lt, Abs(s,ty,tr)) end | normalize_typvar_term lt (t1$t2) = let val (lt,t1) = normalize_typvar_term lt t1 val (lt,t2) = normalize_typvar_term lt t2 in (lt, t1$t2) end fun normalize_typvar_term' t = snd(normalize_typvar_term [] t) fun key_of_term (Const(s,_)) = if String.isPrefix "\<^type>" s then Lexicon.unmark_type s else "" | key_of_term (Free(s,_)) = s | key_of_term (Var(xi,_)) = Term.string_of_vname xi | key_of_term (Bound(_)) = error("Bound() not supported in key_of_term") | key_of_term (Abs(_,_,_)) = error("Abs() not supported in key_of_term") | key_of_term (t1$t2) = (key_of_term t1)^(key_of_term t2) val key_of_term' = key_of_term o normalize_typvar_term' fun hide_tvar_tr' tname ctx terms = let val mtyp = Syntax.parse_typ ctx tname (* no type checking *) val (fq_name, _) = case mtyp of Type(s,ts) => (s,ts) | _ => error("Complex type not (yet) supported.") val local_name_of = hd o rev o String.fields (fn c => c = #".") fun hide_type tname = Syntax.const("(_) "^tname) val reg_type_as_term = Term.list_comb(Const(Lexicon.mark_type tname,dummyT),terms) val key = key_of_term' reg_type_as_term val actual_tvars_key = key_of_term reg_type_as_term in case lookup (Proof_Context.theory_of ctx) fq_name of NONE => raise Match | SOME e => let val (tname,default_tvars_key) = case Symtab.lookup (#typ_syn_tab e) key of NONE => (local_name_of tname, "") | SOME (s,_,tv) => (local_name_of s,tv) in case (#print_mode e) of print_all => hide_type tname | print => if default_tvars_key=actual_tvars_key then hide_type tname else raise Match | noprint => raise Match end end fun hide_tvar_ast_tr ctx ast= let val thy = Proof_Context.theory_of ctx fun parse_ast ((Ast.Constant const)::[]) = (const,NONE) | parse_ast ((Ast.Constant sort)::(Ast.Constant const)::[]) = (const,SOME sort) | parse_ast _ = error("AST type not supported.") val (decorated_name, decorated_sort) = parse_ast ast val name = Lexicon.unmark_type decorated_name val default_info = case lookup thy name of NONE => error("No default type vars registered: "^name) | SOME e => e val _ = if #parse_mode default_info = noparse then error("Default type vars disabled (option noparse): "^name) else () fun name_of_tvar tvar = case tvar of (TFree(n,_)) => n | _ => error("Unsupported type structure.") val type_vars_ast = let fun mk_tvar n = case decorated_sort of NONE => Ast.Variable(name_of_tvar n) | SOME sort => Ast.Appl([Ast.Constant("_ofsort"), Ast.Variable(name_of_tvar n), Ast.Constant(sort)]) in map mk_tvar (#tvars default_info) end in Ast.Appl ((Ast.Constant decorated_name)::type_vars_ast) end fun register typ_str print_mode parse_mode thy = let val ctx = Toplevel.context_of(Toplevel.theory_toplevel thy) val typ = Syntax.parse_typ ctx typ_str val (name,tvars) = case typ of Type(name,tvars) => (name,tvars) | _ => error("Unsupported type structure.") val base_typ = Syntax.read_typ ctx typ_str val (base_name,base_tvars) = case base_typ of Type(name,tvars) => (name,tvars) | _ => error("Unsupported type structure.") val base_key = key_of_type' base_typ val base_tvar_key = key_of_type base_typ val print_m = case print_mode of SOME m => m | NONE => print_all val parse_m = case parse_mode of SOME m => m | NONE => parse val entry = { name = name, tvars = tvars, typ_syn_tab = Symtab.empty:((string * typ list * string) Symtab.table), print_mode = print_m, parse_mode = parse_m } val base_entry = if name = base_name then { name = "", tvars = [], typ_syn_tab = Symtab.empty:((string * typ list * string) Symtab.table), print_mode = noprint, parse_mode = noparse } else case lookup thy base_name of SOME e => e | NONE => error ("No entry found for "^base_name^ " (via "^name^")") val base_entry = { name = #name base_entry, tvars = #tvars base_entry, typ_syn_tab = Symtab.update (base_key, (name, base_tvars, base_tvar_key)) (#typ_syn_tab (base_entry)), print_mode = #print_mode base_entry, parse_mode = #parse_mode base_entry } fun reg tab = let val tab = Symtab.update_new(name, entry) tab val tab = if name = base_name then tab else Symtab.update(base_name, base_entry) tab in tab end val thy = Sign.print_translation [(Lexicon.mark_type name, hide_tvar_tr' name)] thy in Context.theory_of ( (Data.map reg) (Context.Theory thy)) handle Symtab.DUP _ => error("Type shorthand already registered: "^name) end fun hide_tvar_subst_ast_tr hole ctx (ast::[]) = let val thy = Proof_Context.theory_of ctx val (decorated_name, args) = case ast of (Ast.Appl ((Ast.Constant s)::args)) => (s, args) | _ => error "Error in obtaining type constructor." val name = Lexicon.unmark_type decorated_name val default_info = case lookup thy name of NONE => error("No default type vars registered: "^name) | SOME e => e val _ = if #parse_mode default_info = noparse then error("Default type vars disabled (option noparse): "^name) else () fun name_of_tvar tvar = case tvar of (TFree(n,_)) => n | _ => error("Unsupported type structure.") val type_vars_ast = map (fn n => Ast.Variable(name_of_tvar n)) (#tvars default_info) val type_vars_ast = case hole of right => (List.rev(List.drop(List.rev type_vars_ast, List.length args)))@args | left => args@List.drop(type_vars_ast, List.length args) in Ast.Appl ((Ast.Constant decorated_name)::type_vars_ast) end | hide_tvar_subst_ast_tr _ _ _ = error("hide_tvar_subst_ast_tr: empty AST.") fun hide_tvar_subst_return_ast_tr hole ctx (retval::constructor::[]) = hide_tvar_subst_ast_tr hole ctx [Ast.Appl (constructor::retval::[])] | hide_tvar_subst_return_ast_tr _ _ _ = error("hide_tvar_subst_return_ast_tr: error in parsing AST") end \ subsection\Register Parse Translations\ syntax "_tvars_wildcard" :: "type \ type" ("'('_') _") syntax "_tvars_wildcard_retval" :: "type \ type \ type" ("'('_, _') _") syntax "_tvars_wildcard_sort" :: "sort \ type \ type" ("'('_::_') _") syntax "_tvars_wildcard_right" :: "type \ type" ("_ '_..") syntax "_tvars_wildcard_left" :: "type \ type" ("_ ..'_") parse_ast_translation\ [ (@{syntax_const "_tvars_wildcard_sort"}, Hide_Tvar.hide_tvar_ast_tr), (@{syntax_const "_tvars_wildcard"}, Hide_Tvar.hide_tvar_ast_tr), (@{syntax_const "_tvars_wildcard_retval"}, Hide_Tvar.hide_tvar_subst_return_ast_tr Hide_Tvar.right), (@{syntax_const "_tvars_wildcard_right"}, Hide_Tvar.hide_tvar_subst_ast_tr Hide_Tvar.right), (@{syntax_const "_tvars_wildcard_left"}, Hide_Tvar.hide_tvar_subst_ast_tr Hide_Tvar.left) ] \ subsection\Register Top-Level Isar Commands\ ML\ val modeP = (Parse.$$$ "(" |-- (Parse.name --| Parse.$$$ "," -- Parse.name --| Parse.$$$ ")")) val typ_modeP = Parse.typ -- (Scan.optional modeP ("print_all","parse")) val _ = Outer_Syntax.command @{command_keyword "register_default_tvars"} "Register default variables (and hiding mechanims) for a type." (typ_modeP >> (fn (typ,(print_m,parse_m)) => (Toplevel.theory (Hide_Tvar.register typ (SOME (Hide_Tvar.parse_print_mode print_m)) (SOME (Hide_Tvar.parse_parse_mode parse_m)))))); val _ = Outer_Syntax.command @{command_keyword "update_default_tvars_mode"} "Update print and/or parse mode or the default type variables for a certain type." (typ_modeP >> (fn (typ,(print_m,parse_m)) => (Toplevel.theory (Hide_Tvar.update_mode typ (SOME (Hide_Tvar.parse_print_mode print_m)) (SOME (Hide_Tvar.parse_parse_mode parse_m)))))); \ (* section\Examples\ subsection\Print Translation\ datatype ('a, 'b) hide_tvar_foobar = hide_tvar_foo 'a | hide_tvar_bar 'b type_synonym ('a, 'b, 'c, 'd) hide_tvar_baz = "('a+'b, 'a \ 'b) hide_tvar_foobar" definition hide_tvar_f::"('a, 'b) hide_tvar_foobar \ ('a, 'b) hide_tvar_foobar \ ('a, 'b) hide_tvar_foobar" where "hide_tvar_f a b = a" definition hide_tvar_g::"('a, 'b, 'c, 'd) hide_tvar_baz \ ('a, 'b, 'c, 'd) hide_tvar_baz \ ('a, 'b, 'c, 'd) hide_tvar_baz" where "hide_tvar_g a b = a" assert[string_of_thm_equal, thm_def="hide_tvar_f_def", str="hide_tvar_f (a::('a, 'b) hide_tvar_foobar) (b::('a, 'b) hide_tvar_foobar) = a"] assert[string_of_thm_equal, thm_def="hide_tvar_g_def", str="hide_tvar_g (a::('a + 'b, 'a \ 'b) hide_tvar_foobar) (b::('a + 'b, 'a \ 'b) hide_tvar_foobar) = a"] register_default_tvars "('alpha, 'beta) hide_tvar_foobar" (print_all,parse) register_default_tvars "('alpha, 'beta, 'gamma, 'delta) hide_tvar_baz" (print_all,parse) update_default_tvars_mode "_ hide_tvar_foobar" (noprint,noparse) assert[string_of_thm_equal, thm_def="hide_tvar_f_def", str="hide_tvar_f (a::('a, 'b) hide_tvar_foobar) (b::('a, 'b) hide_tvar_foobar) = a"] assert[string_of_thm_equal, thm_def="hide_tvar_g_def", str="hide_tvar_g (a::('a + 'b, 'a \ 'b) hide_tvar_foobar) (b::('a + 'b, 'a \ 'b) hide_tvar_foobar) = a"] update_default_tvars_mode "_ hide_tvar_foobar" (print_all,noparse) assert[string_of_thm_equal, thm_def="hide_tvar_f_def", str="hide_tvar_f (a::(_) hide_tvar_foobar) (b::(_) hide_tvar_foobar) = a"] assert[string_of_thm_equal, thm_def="hide_tvar_g_def", str="hide_tvar_g (a::(_) hide_tvar_baz) (b::(_) hide_tvar_baz) = a"] subsection\Parse Translation\ update_default_tvars_mode "_ hide_tvar_foobar" (print_all,parse) declare [[show_types]] definition hide_tvar_A :: "'x \ (('x::linorder) hide_tvar_foobar) .._" where "hide_tvar_A x = hide_tvar_foo x" assert[string_of_thm_equal, thm_def="hide_tvar_A_def", str="hide_tvar_A (x::'x) = hide_tvar_foo x"] definition hide_tvar_A' :: "'x \ (('x,'b) hide_tvar_foobar) .._" where "hide_tvar_A' x = hide_tvar_foo x" assert[string_of_thm_equal, thm_def="hide_tvar_A'_def", str="hide_tvar_A' (x::'x) = hide_tvar_foo x"] definition hide_tvar_B' :: "(_) hide_tvar_foobar \ (_) hide_tvar_foobar \ (_) hide_tvar_foobar" where "hide_tvar_B' x y = x" assert[string_of_thm_equal, thm_def="hide_tvar_A'_def", str="hide_tvar_A' (x::'x) = hide_tvar_foo x"] definition hide_tvar_B :: "(_) hide_tvar_foobar \ (_) hide_tvar_foobar \ (_) hide_tvar_foobar" where "hide_tvar_B x y = x" assert[string_of_thm_equal, thm_def="hide_tvar_B_def", str="hide_tvar_B (x::(_) hide_tvar_foobar) (y::(_) hide_tvar_foobar) = x"] definition hide_tvar_C :: "(_) hide_tvar_baz \ (_) hide_tvar_foobar \ (_) hide_tvar_baz" where "hide_tvar_C x y = x" assert[string_of_thm_equal, thm_def="hide_tvar_C_def", str="hide_tvar_C (x::(_) hide_tvar_baz) (y::(_) hide_tvar_foobar) = x"] definition hide_tvar_E :: "(_::linorder) hide_tvar_baz \ (_::linorder) hide_tvar_foobar \ (_::linorder) hide_tvar_baz" where "hide_tvar_E x y = x" assert[string_of_thm_equal, thm_def="hide_tvar_C_def", str="hide_tvar_C (x::(_) hide_tvar_baz) (y::(_) hide_tvar_foobar) = x"] definition hide_tvar_X :: "(_, 'retval::linorder) hide_tvar_baz \ (_,'retval) hide_tvar_foobar \ (_,'retval) hide_tvar_baz" where "hide_tvar_X x y = x" *) (*>*) subsection\Introduction\ text\ When modelling object-oriented data models in HOL with the goal of preserving \<^emph>\extensibility\ (e.g., as described in~\cite{brucker.ea:extensible:2008-b,brucker:interactive:2007}) one needs to define type constructors with a large number of type variables. This can reduce the readability of the overall formalization. Thus, we use a short-hand notation in cases were the names of the type variables are known from the context. In more detail, this theory sets up both configurable print and parse translations that allows for replacing @{emph \all\} type variables by \(_)\, e.g., a five-ary constructor \('a, 'b, 'c, 'd, 'e) hide_tvar_foo\ can be shorted to \(_) hide_tvar_foo\. The use of this shorthand in output (printing) and input (parsing) is, on a per-type basis, user-configurable using the top-level commands \register_default_tvars\ (for registering the names of the default type variables and the print/parse mode) and \update_default_tvars_mode\ (for changing the print/parse mode dynamically). The input also supports short-hands for declaring default sorts (e.g., \(_::linorder)\ specifies that all default variables need to be instances of the sort (type class) @{class \linorder\} and short-hands of overriding a suffice (or prefix) of the default type variables. For example, \('state) hide_tvar_foo _.\ is a short-hand for \('a, 'b, 'c, 'd, 'state) hide_tvar_foo\. In this document, we omit the implementation details (we refer the interested reader to theory file) and continue directly with a few examples. \ subsection\Example\ text\Given the following type definition:\ datatype ('a, 'b) hide_tvar_foobar = hide_tvar_foo 'a | hide_tvar_bar 'b type_synonym ('a, 'b, 'c, 'd) hide_tvar_baz = "('a+'b, 'a \ 'b) hide_tvar_foobar" text\We can register default values for the type variables for the abstract data type as well as the type synonym:\ register_default_tvars "('alpha, 'beta) hide_tvar_foobar" (print_all,parse) register_default_tvars "('alpha, 'beta, 'gamma, 'delta) hide_tvar_baz" (print_all,parse) text\This allows us to write\ definition hide_tvar_f::"(_) hide_tvar_foobar \ (_) hide_tvar_foobar \ (_) hide_tvar_foobar" where "hide_tvar_f a b = a" definition hide_tvar_g::"(_) hide_tvar_baz \ (_) hide_tvar_baz \ (_) hide_tvar_baz" where "hide_tvar_g a b = a" text\Instead of specifying the type variables explicitely. This makes, in particular for type constructors with a large number of type variables, definitions much more concise. This syntax is also used in the output of antiquotations, e.g., @{term[show_types] "x = hide_tvar_g"}. Both the print translation and the parse translation can be disabled for each type individually:\ update_default_tvars_mode "_ hide_tvar_foobar" (noprint,noparse) update_default_tvars_mode "_ hide_tvar_foobar" (noprint,noparse) text\ Now, Isabelle's interactive output and the antiquotations will show all type variables, e.g., @{term[show_types] "x = hide_tvar_g"}.\ end diff --git a/thys/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy b/thys/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy --- a/thys/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy +++ b/thys/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy @@ -1,584 +1,583 @@ (*********************************************************************************** * Copyright (c) 2018 Achim D. Brucker * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * * * Redistributions of source code must retain the above copyright notice, this * list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above copyright notice, * this list of conditions and the following disclaimer in the documentation * and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * SPDX-License-Identifier: BSD-2-Clause * Repository: https://git.logicalhacking.com/adbrucker/isabelle-hacks/ * Dependencies: None (assert.thy is used for testing the theory but it is * not required for providing the functionality of this hack) ***********************************************************************************) (* This file is based on commit 8a5e95421521c36ab71ab2711435a9bc0fa2c5cc from upstream (https://git.logicalhacking.com/adbrucker/isabelle-hacks/). Merely the dependency to Assert.thy has been removed by disabling the example section (which include assert checks). *) section\Hiding Type Variables\ text\ This theory\footnote{This theory can be used ``stand-alone,'' i.e., this theory is not specific to the DOM formalization. The latest version is part of the ``Isabelle Hacks'' repository: \url{https://git.logicalhacking.com/adbrucker/isabelle-hacks/}.} implements a mechanism for declaring default type variables for data types. This comes handy for complex data types with many type variables.\ theory "Hiding_Type_Variables" imports Main keywords "register_default_tvars" "update_default_tvars_mode"::thy_decl begin (*<*) section\Implementation\ subsection\Theory Managed Data Structure\ ML\ signature HIDE_TVAR = sig datatype print_mode = print_all | print | noprint datatype tvar_subst = right | left datatype parse_mode = parse | noparse type hide_varT = { name: string, tvars: typ list, typ_syn_tab : (string * typ list*string) Symtab.table, print_mode: print_mode, parse_mode: parse_mode } val parse_print_mode : string -> print_mode val parse_parse_mode : string -> parse_mode val register : string -> print_mode option -> parse_mode option -> theory -> theory val update_mode : string -> print_mode option -> parse_mode option -> theory -> theory val lookup : theory -> string -> hide_varT option val hide_tvar_tr' : string -> Proof.context -> term list -> term val hide_tvar_ast_tr : Proof.context -> Ast.ast list -> Ast.ast val hide_tvar_subst_ast_tr : tvar_subst -> Proof.context -> Ast.ast list -> Ast.ast val hide_tvar_subst_return_ast_tr : tvar_subst -> Proof.context -> Ast.ast list -> Ast.ast end structure Hide_Tvar : HIDE_TVAR = struct datatype print_mode = print_all | print | noprint datatype tvar_subst = right | left datatype parse_mode = parse | noparse type hide_varT = { name: string, tvars: typ list, typ_syn_tab : (string * typ list*string) Symtab.table, print_mode: print_mode, parse_mode: parse_mode } type hide_tvar_tab = (hide_varT) Symtab.table fun hide_tvar_eq (a, a') = (#name a) = (#name a') fun merge_tvar_tab (tab,tab') = Symtab.merge hide_tvar_eq (tab,tab') structure Data = Generic_Data ( type T = hide_tvar_tab val empty = Symtab.empty:hide_tvar_tab - val extend = I fun merge(t1,t2) = merge_tvar_tab (t1, t2) ); fun parse_print_mode "print_all" = print_all | parse_print_mode "print" = print | parse_print_mode "noprint" = noprint | parse_print_mode s = error("Print mode not supported: "^s) fun parse_parse_mode "parse" = parse | parse_parse_mode "noparse" = noparse | parse_parse_mode s = error("Parse mode not supported: "^s) fun update_mode typ_str print_mode parse_mode thy = let val ctx = Toplevel.context_of(Toplevel.theory_toplevel thy) val typ = Syntax.parse_typ ctx typ_str (* no type checking *) val name = case typ of Type(name,_) => name | _ => error("Complex type not (yet) supported.") fun update tab = let val old_entry = (case Symtab.lookup tab name of SOME t => t | NONE => error ("Type shorthand not registered: "^name)) val print_m = case print_mode of SOME m => m | NONE => #print_mode old_entry val parse_m = case parse_mode of SOME m => m | NONE => #parse_mode old_entry val entry = { name = name, tvars = #tvars old_entry, typ_syn_tab = #typ_syn_tab old_entry, print_mode = print_m, parse_mode = parse_m } in Symtab.update (name,entry) tab end in Context.theory_of ( (Data.map update) (Context.Theory thy)) end fun lookup thy name = let val tab = (Data.get o Context.Theory) thy in Symtab.lookup tab name end fun obtain_normalized_vname lookup_table vname = case List.find (fn e => fst e = vname) lookup_table of SOME (_,idx) => (lookup_table, Int.toString idx) | NONE => let fun max_idx [] = 0 | max_idx ((_,idx)::lt) = Int.max(idx,max_idx lt) val idx = (max_idx lookup_table ) + 1 in ((vname,idx)::lookup_table, Int.toString idx) end fun normalize_typvar_type lt (Type (a, Ts)) = let fun switch (a,b) = (b,a) val (Ts', lt') = fold_map (fn t => fn lt => switch (normalize_typvar_type lt t)) Ts lt in (lt', Type (a, Ts')) end | normalize_typvar_type lt (TFree (vname, S)) = let val (lt, vname) = obtain_normalized_vname lt (vname) in (lt, TFree( vname, S)) end | normalize_typvar_type lt (TVar (xi, S)) = let val (lt, vname) = obtain_normalized_vname lt (Term.string_of_vname xi) in (lt, TFree( vname, S)) end fun normalize_typvar_type' t = snd ( normalize_typvar_type [] t) fun mk_p s = s (* "("^s^")" *) fun key_of_type (Type(a, TS)) = mk_p (a^String.concat(map key_of_type TS)) | key_of_type (TFree (vname, _)) = mk_p vname | key_of_type (TVar (xi, _ )) = mk_p (Term.string_of_vname xi) val key_of_type' = key_of_type o normalize_typvar_type' fun normalize_typvar_term lt (Const (a, t)) = (lt, Const(a, t)) | normalize_typvar_term lt (Free (a, t)) = let val (lt, vname) = obtain_normalized_vname lt a in (lt, Free(vname,t)) end | normalize_typvar_term lt (Var (xi, t)) = let val (lt, vname) = obtain_normalized_vname lt (Term.string_of_vname xi) in (lt, Free(vname,t)) end | normalize_typvar_term lt (Bound (i)) = (lt, Bound(i)) | normalize_typvar_term lt (Abs(s,ty,tr)) = let val (lt,tr) = normalize_typvar_term lt tr in (lt, Abs(s,ty,tr)) end | normalize_typvar_term lt (t1$t2) = let val (lt,t1) = normalize_typvar_term lt t1 val (lt,t2) = normalize_typvar_term lt t2 in (lt, t1$t2) end fun normalize_typvar_term' t = snd(normalize_typvar_term [] t) fun key_of_term (Const(s,_)) = if String.isPrefix "\<^type>" s then Lexicon.unmark_type s else "" | key_of_term (Free(s,_)) = s | key_of_term (Var(xi,_)) = Term.string_of_vname xi | key_of_term (Bound(_)) = error("Bound() not supported in key_of_term") | key_of_term (Abs(_,_,_)) = error("Abs() not supported in key_of_term") | key_of_term (t1$t2) = (key_of_term t1)^(key_of_term t2) val key_of_term' = key_of_term o normalize_typvar_term' fun hide_tvar_tr' tname ctx terms = let val mtyp = Syntax.parse_typ ctx tname (* no type checking *) val (fq_name, _) = case mtyp of Type(s,ts) => (s,ts) | _ => error("Complex type not (yet) supported.") val local_name_of = hd o rev o String.fields (fn c => c = #".") fun hide_type tname = Syntax.const("(_) "^tname) val reg_type_as_term = Term.list_comb(Const(Lexicon.mark_type tname,dummyT),terms) val key = key_of_term' reg_type_as_term val actual_tvars_key = key_of_term reg_type_as_term in case lookup (Proof_Context.theory_of ctx) fq_name of NONE => raise Match | SOME e => let val (tname,default_tvars_key) = case Symtab.lookup (#typ_syn_tab e) key of NONE => (local_name_of tname, "") | SOME (s,_,tv) => (local_name_of s,tv) in case (#print_mode e) of print_all => hide_type tname | print => if default_tvars_key=actual_tvars_key then hide_type tname else raise Match | noprint => raise Match end end fun hide_tvar_ast_tr ctx ast= let val thy = Proof_Context.theory_of ctx fun parse_ast ((Ast.Constant const)::[]) = (const,NONE) | parse_ast ((Ast.Constant sort)::(Ast.Constant const)::[]) = (const,SOME sort) | parse_ast _ = error("AST type not supported.") val (decorated_name, decorated_sort) = parse_ast ast val name = Lexicon.unmark_type decorated_name val default_info = case lookup thy name of NONE => error("No default type vars registered: "^name) | SOME e => e val _ = if #parse_mode default_info = noparse then error("Default type vars disabled (option noparse): "^name) else () fun name_of_tvar tvar = case tvar of (TFree(n,_)) => n | _ => error("Unsupported type structure.") val type_vars_ast = let fun mk_tvar n = case decorated_sort of NONE => Ast.Variable(name_of_tvar n) | SOME sort => Ast.Appl([Ast.Constant("_ofsort"), Ast.Variable(name_of_tvar n), Ast.Constant(sort)]) in map mk_tvar (#tvars default_info) end in Ast.Appl ((Ast.Constant decorated_name)::type_vars_ast) end fun register typ_str print_mode parse_mode thy = let val ctx = Toplevel.context_of(Toplevel.theory_toplevel thy) val typ = Syntax.parse_typ ctx typ_str val (name,tvars) = case typ of Type(name,tvars) => (name,tvars) | _ => error("Unsupported type structure.") val base_typ = Syntax.read_typ ctx typ_str val (base_name,base_tvars) = case base_typ of Type(name,tvars) => (name,tvars) | _ => error("Unsupported type structure.") val base_key = key_of_type' base_typ val base_tvar_key = key_of_type base_typ val print_m = case print_mode of SOME m => m | NONE => print_all val parse_m = case parse_mode of SOME m => m | NONE => parse val entry = { name = name, tvars = tvars, typ_syn_tab = Symtab.empty:((string * typ list * string) Symtab.table), print_mode = print_m, parse_mode = parse_m } val base_entry = if name = base_name then { name = "", tvars = [], typ_syn_tab = Symtab.empty:((string * typ list * string) Symtab.table), print_mode = noprint, parse_mode = noparse } else case lookup thy base_name of SOME e => e | NONE => error ("No entry found for "^base_name^ " (via "^name^")") val base_entry = { name = #name base_entry, tvars = #tvars base_entry, typ_syn_tab = Symtab.update (base_key, (name, base_tvars, base_tvar_key)) (#typ_syn_tab (base_entry)), print_mode = #print_mode base_entry, parse_mode = #parse_mode base_entry } fun reg tab = let val tab = Symtab.update_new(name, entry) tab val tab = if name = base_name then tab else Symtab.update(base_name, base_entry) tab in tab end val thy = Sign.print_translation [(Lexicon.mark_type name, hide_tvar_tr' name)] thy in Context.theory_of ( (Data.map reg) (Context.Theory thy)) handle Symtab.DUP _ => error("Type shorthand already registered: "^name) end fun hide_tvar_subst_ast_tr hole ctx (ast::[]) = let val thy = Proof_Context.theory_of ctx val (decorated_name, args) = case ast of (Ast.Appl ((Ast.Constant s)::args)) => (s, args) | _ => error "Error in obtaining type constructor." val name = Lexicon.unmark_type decorated_name val default_info = case lookup thy name of NONE => error("No default type vars registered: "^name) | SOME e => e val _ = if #parse_mode default_info = noparse then error("Default type vars disabled (option noparse): "^name) else () fun name_of_tvar tvar = case tvar of (TFree(n,_)) => n | _ => error("Unsupported type structure.") val type_vars_ast = map (fn n => Ast.Variable(name_of_tvar n)) (#tvars default_info) val type_vars_ast = case hole of right => (List.rev(List.drop(List.rev type_vars_ast, List.length args)))@args | left => args@List.drop(type_vars_ast, List.length args) in Ast.Appl ((Ast.Constant decorated_name)::type_vars_ast) end | hide_tvar_subst_ast_tr _ _ _ = error("hide_tvar_subst_ast_tr: empty AST.") fun hide_tvar_subst_return_ast_tr hole ctx (retval::constructor::[]) = hide_tvar_subst_ast_tr hole ctx [Ast.Appl (constructor::retval::[])] | hide_tvar_subst_return_ast_tr _ _ _ = error("hide_tvar_subst_return_ast_tr: error in parsing AST") end \ subsection\Register Parse Translations\ syntax "_tvars_wildcard" :: "type \ type" ("'('_') _") syntax "_tvars_wildcard_retval" :: "type \ type \ type" ("'('_, _') _") syntax "_tvars_wildcard_sort" :: "sort \ type \ type" ("'('_::_') _") syntax "_tvars_wildcard_right" :: "type \ type" ("_ '_..") syntax "_tvars_wildcard_left" :: "type \ type" ("_ ..'_") parse_ast_translation\ [ (@{syntax_const "_tvars_wildcard_sort"}, Hide_Tvar.hide_tvar_ast_tr), (@{syntax_const "_tvars_wildcard"}, Hide_Tvar.hide_tvar_ast_tr), (@{syntax_const "_tvars_wildcard_retval"}, Hide_Tvar.hide_tvar_subst_return_ast_tr Hide_Tvar.right), (@{syntax_const "_tvars_wildcard_right"}, Hide_Tvar.hide_tvar_subst_ast_tr Hide_Tvar.right), (@{syntax_const "_tvars_wildcard_left"}, Hide_Tvar.hide_tvar_subst_ast_tr Hide_Tvar.left) ] \ subsection\Register Top-Level Isar Commands\ ML\ val modeP = (Parse.$$$ "(" |-- (Parse.name --| Parse.$$$ "," -- Parse.name --| Parse.$$$ ")")) val typ_modeP = Parse.typ -- (Scan.optional modeP ("print_all","parse")) val _ = Outer_Syntax.command @{command_keyword "register_default_tvars"} "Register default variables (and hiding mechanims) for a type." (typ_modeP >> (fn (typ,(print_m,parse_m)) => (Toplevel.theory (Hide_Tvar.register typ (SOME (Hide_Tvar.parse_print_mode print_m)) (SOME (Hide_Tvar.parse_parse_mode parse_m)))))); val _ = Outer_Syntax.command @{command_keyword "update_default_tvars_mode"} "Update print and/or parse mode or the default type variables for a certain type." (typ_modeP >> (fn (typ,(print_m,parse_m)) => (Toplevel.theory (Hide_Tvar.update_mode typ (SOME (Hide_Tvar.parse_print_mode print_m)) (SOME (Hide_Tvar.parse_parse_mode parse_m)))))); \ (* section\Examples\ subsection\Print Translation\ datatype ('a, 'b) hide_tvar_foobar = hide_tvar_foo 'a | hide_tvar_bar 'b type_synonym ('a, 'b, 'c, 'd) hide_tvar_baz = "('a+'b, 'a \ 'b) hide_tvar_foobar" definition hide_tvar_f::"('a, 'b) hide_tvar_foobar \ ('a, 'b) hide_tvar_foobar \ ('a, 'b) hide_tvar_foobar" where "hide_tvar_f a b = a" definition hide_tvar_g::"('a, 'b, 'c, 'd) hide_tvar_baz \ ('a, 'b, 'c, 'd) hide_tvar_baz \ ('a, 'b, 'c, 'd) hide_tvar_baz" where "hide_tvar_g a b = a" assert[string_of_thm_equal, thm_def="hide_tvar_f_def", str="hide_tvar_f (a::('a, 'b) hide_tvar_foobar) (b::('a, 'b) hide_tvar_foobar) = a"] assert[string_of_thm_equal, thm_def="hide_tvar_g_def", str="hide_tvar_g (a::('a + 'b, 'a \ 'b) hide_tvar_foobar) (b::('a + 'b, 'a \ 'b) hide_tvar_foobar) = a"] register_default_tvars "('alpha, 'beta) hide_tvar_foobar" (print_all,parse) register_default_tvars "('alpha, 'beta, 'gamma, 'delta) hide_tvar_baz" (print_all,parse) update_default_tvars_mode "_ hide_tvar_foobar" (noprint,noparse) assert[string_of_thm_equal, thm_def="hide_tvar_f_def", str="hide_tvar_f (a::('a, 'b) hide_tvar_foobar) (b::('a, 'b) hide_tvar_foobar) = a"] assert[string_of_thm_equal, thm_def="hide_tvar_g_def", str="hide_tvar_g (a::('a + 'b, 'a \ 'b) hide_tvar_foobar) (b::('a + 'b, 'a \ 'b) hide_tvar_foobar) = a"] update_default_tvars_mode "_ hide_tvar_foobar" (print_all,noparse) assert[string_of_thm_equal, thm_def="hide_tvar_f_def", str="hide_tvar_f (a::(_) hide_tvar_foobar) (b::(_) hide_tvar_foobar) = a"] assert[string_of_thm_equal, thm_def="hide_tvar_g_def", str="hide_tvar_g (a::(_) hide_tvar_baz) (b::(_) hide_tvar_baz) = a"] subsection\Parse Translation\ update_default_tvars_mode "_ hide_tvar_foobar" (print_all,parse) declare [[show_types]] definition hide_tvar_A :: "'x \ (('x::linorder) hide_tvar_foobar) .._" where "hide_tvar_A x = hide_tvar_foo x" assert[string_of_thm_equal, thm_def="hide_tvar_A_def", str="hide_tvar_A (x::'x) = hide_tvar_foo x"] definition hide_tvar_A' :: "'x \ (('x,'b) hide_tvar_foobar) .._" where "hide_tvar_A' x = hide_tvar_foo x" assert[string_of_thm_equal, thm_def="hide_tvar_A'_def", str="hide_tvar_A' (x::'x) = hide_tvar_foo x"] definition hide_tvar_B' :: "(_) hide_tvar_foobar \ (_) hide_tvar_foobar \ (_) hide_tvar_foobar" where "hide_tvar_B' x y = x" assert[string_of_thm_equal, thm_def="hide_tvar_A'_def", str="hide_tvar_A' (x::'x) = hide_tvar_foo x"] definition hide_tvar_B :: "(_) hide_tvar_foobar \ (_) hide_tvar_foobar \ (_) hide_tvar_foobar" where "hide_tvar_B x y = x" assert[string_of_thm_equal, thm_def="hide_tvar_B_def", str="hide_tvar_B (x::(_) hide_tvar_foobar) (y::(_) hide_tvar_foobar) = x"] definition hide_tvar_C :: "(_) hide_tvar_baz \ (_) hide_tvar_foobar \ (_) hide_tvar_baz" where "hide_tvar_C x y = x" assert[string_of_thm_equal, thm_def="hide_tvar_C_def", str="hide_tvar_C (x::(_) hide_tvar_baz) (y::(_) hide_tvar_foobar) = x"] definition hide_tvar_E :: "(_::linorder) hide_tvar_baz \ (_::linorder) hide_tvar_foobar \ (_::linorder) hide_tvar_baz" where "hide_tvar_E x y = x" assert[string_of_thm_equal, thm_def="hide_tvar_C_def", str="hide_tvar_C (x::(_) hide_tvar_baz) (y::(_) hide_tvar_foobar) = x"] definition hide_tvar_X :: "(_, 'retval::linorder) hide_tvar_baz \ (_,'retval) hide_tvar_foobar \ (_,'retval) hide_tvar_baz" where "hide_tvar_X x y = x" *) (*>*) subsection\Introduction\ text\ When modelling object-oriented data models in HOL with the goal of preserving \<^emph>\extensibility\ (e.g., as described in~\cite{brucker.ea:extensible:2008-b,brucker:interactive:2007}) one needs to define type constructors with a large number of type variables. This can reduce the readability of the overall formalization. Thus, we use a short-hand notation in cases were the names of the type variables are known from the context. In more detail, this theory sets up both configurable print and parse translations that allows for replacing @{emph \all\} type variables by \(_)\, e.g., a five-ary constructor \('a, 'b, 'c, 'd, 'e) hide_tvar_foo\ can be shorted to \(_) hide_tvar_foo\. The use of this shorthand in output (printing) and input (parsing) is, on a per-type basis, user-configurable using the top-level commands \register_default_tvars\ (for registering the names of the default type variables and the print/parse mode) and \update_default_tvars_mode\ (for changing the print/parse mode dynamically). The input also supports short-hands for declaring default sorts (e.g., \(_::linorder)\ specifies that all default variables need to be instances of the sort (type class) @{class \linorder\} and short-hands of overriding a suffice (or prefix) of the default type variables. For example, \('state) hide_tvar_foo _.\ is a short-hand for \('a, 'b, 'c, 'd, 'state) hide_tvar_foo\. In this document, we omit the implementation details (we refer the interested reader to theory file) and continue directly with a few examples. \ subsection\Example\ text\Given the following type definition:\ datatype ('a, 'b) hide_tvar_foobar = hide_tvar_foo 'a | hide_tvar_bar 'b type_synonym ('a, 'b, 'c, 'd) hide_tvar_baz = "('a+'b, 'a \ 'b) hide_tvar_foobar" text\We can register default values for the type variables for the abstract data type as well as the type synonym:\ register_default_tvars "('alpha, 'beta) hide_tvar_foobar" (print_all,parse) register_default_tvars "('alpha, 'beta, 'gamma, 'delta) hide_tvar_baz" (print_all,parse) text\This allows us to write\ definition hide_tvar_f::"(_) hide_tvar_foobar \ (_) hide_tvar_foobar \ (_) hide_tvar_foobar" where "hide_tvar_f a b = a" definition hide_tvar_g::"(_) hide_tvar_baz \ (_) hide_tvar_baz \ (_) hide_tvar_baz" where "hide_tvar_g a b = a" text\Instead of specifying the type variables explicitely. This makes, in particular for type constructors with a large number of type variables, definitions much more concise. This syntax is also used in the output of antiquotations, e.g., @{term[show_types] "x = hide_tvar_g"}. Both the print translation and the parse translation can be disabled for each type individually:\ update_default_tvars_mode "_ hide_tvar_foobar" (noprint,noparse) update_default_tvars_mode "_ hide_tvar_foobar" (noprint,noparse) text\ Now, Isabelle's interactive output and the antiquotations will show all type variables, e.g., @{term[show_types] "x = hide_tvar_g"}.\ end diff --git a/thys/Deriving/Comparator_Generator/comparator_generator.ML b/thys/Deriving/Comparator_Generator/comparator_generator.ML --- a/thys/Deriving/Comparator_Generator/comparator_generator.ML +++ b/thys/Deriving/Comparator_Generator/comparator_generator.ML @@ -1,643 +1,642 @@ (* Title: Deriving class instances for datatypes Author: Christian Sternagel and René Thiemann Maintainer: Christian Sternagel and René Thiemann License: LGPL *) signature COMPARATOR_GENERATOR = sig type info = {map : term, (* take % x. x, if there is no map *) pcomp : term, (* partial comparator *) comp : term, (* full comparator *) comp_def : thm option, (* definition of comparator, important for nesting *) map_comp : thm option, (* compositionality of map, important for nesting *) partial_comp_thms : thm list, (* first eq, then sym, finally trans *) comp_thm : thm, (* comparator acomp \ \ \ comparator (full_comp acomp \) *) used_positions : bool list} (* registers @{term comparator_of :: "some_type :: linorder comparator"} where some_type must just be a type without type-arguments *) val register_comparator_of : string -> local_theory -> local_theory val register_foreign_comparator : typ -> (* type-constant without type-variables *) term -> (* comparator for type *) thm -> (* comparator thm for provided comparator *) local_theory -> local_theory val register_foreign_partial_and_full_comparator : string -> (* long type name *) term -> (* map function, should be \x. x, if there is no map *) term -> (* partial comparator of type ('a => order, 'b)ty => ('a,'b)ty => order, where 'a is used, 'b is unused *) term -> (* (full) comparator of type ('a \ 'a \ order) \ ('a,'b)ty \ ('a,'b)ty \ order, where 'a is used, 'b is unused *) thm option -> (* comp_def, should be full_comp = pcomp o map acomp ..., important for nesting *) thm option -> (* map compositionality, important for nesting *) thm -> (* partial eq thm for full comparator *) thm -> (* partial sym thm for full comparator *) thm -> (* partial trans thm for full comparator *) thm -> (* full thm: comparator a-comp => comparator (full_comp a-comp) *) bool list -> (*used positions*) local_theory -> local_theory datatype comparator_type = Linorder | BNF val generate_comparators_from_bnf_fp : string -> (* name of type *) local_theory -> ((term * thm list) list * (* partial comparators + simp-rules *) (term * thm) list) * (* non-partial comparator + def_rule *) local_theory val generate_comparator : comparator_type -> string -> (* name of type *) local_theory -> local_theory val get_info : Proof.context -> string -> info option (* ensures that the info will be available on later requests *) val ensure_info : comparator_type -> string -> local_theory -> local_theory end structure Comparator_Generator : COMPARATOR_GENERATOR = struct open Generator_Aux datatype comparator_type = BNF | Linorder val debug = false fun debug_out s = if debug then writeln s else () val orderT = @{typ order} fun compT T = T --> T --> orderT val orderify = map_atyps (fn T => T --> orderT) fun pcompT T = orderify T --> T --> orderT type info = {map : term, pcomp : term, comp : term, comp_def : thm option, map_comp : thm option, partial_comp_thms : thm list, comp_thm : thm, used_positions : bool list}; structure Data = Generic_Data ( type T = info Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge (fn (info1 : info, info2 : info) => #comp info1 = #comp info2); ); fun add_info T info = Data.map (Symtab.update_new (T, info)) val get_info = Context.Proof #> Data.get #> Symtab.lookup fun the_info ctxt tyco = (case get_info ctxt tyco of SOME info => info | NONE => error ("no comparator information available for type " ^ quote tyco)) fun declare_info tyco m p c c_def m_comp p_thms c_thm used_pos = Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => add_info tyco {map = Morphism.term phi m, pcomp = Morphism.term phi p, comp = Morphism.term phi c, comp_def = Option.map (Morphism.thm phi) c_def, map_comp = Option.map (Morphism.thm phi) m_comp, partial_comp_thms = Morphism.fact phi p_thms, comp_thm = Morphism.thm phi c_thm, used_positions = used_pos}) val EQ = 0 val SYM = 1 val TRANS = 2 fun register_foreign_partial_and_full_comparator tyco m p c c_def m_comp eq_thm sym_thm trans_thm c_thm = declare_info tyco m p c c_def m_comp [eq_thm, sym_thm, trans_thm] c_thm fun mk_infer_const name ctxt c = infer_type ctxt (Const (name, dummyT) $ c) val mk_eq_comp = mk_infer_const @{const_name eq_comp} val mk_peq_comp = mk_infer_const @{const_name peq_comp} val mk_sym_comp = mk_infer_const @{const_name sym_comp} val mk_psym_comp = mk_infer_const @{const_name psym_comp} val mk_trans_comp = mk_infer_const @{const_name trans_comp} val mk_ptrans_comp = mk_infer_const @{const_name ptrans_comp} val mk_comp = mk_infer_const @{const_name comparator} fun default_comp T = absdummy T (absdummy T @{term Eq}) (*%_ _. Eq*) fun register_foreign_comparator T comp comp_thm lthy = let val tyco = (case T of Type (tyco, []) => tyco | _ => error "expected type constant") val eq = @{thm comp_to_peq_comp} OF [comp_thm] val sym = @{thm comp_to_psym_comp} OF [comp_thm] val trans = @{thm comp_to_ptrans_comp} OF [comp_thm] in register_foreign_partial_and_full_comparator tyco (HOLogic.id_const T) comp comp NONE NONE eq sym trans comp_thm [] lthy end fun register_comparator_of tyco lthy = let val T = Type (tyco, []) val comp = Const (@{const_name comparator_of}, compT T) val comp_thm = Thm.instantiate' [SOME (Thm.ctyp_of lthy T)] [] @{thm comparator_of} in register_foreign_comparator T comp comp_thm lthy end fun generate_comparators_from_bnf_fp tyco lthy = let val (tycos, Ts) = mutual_recursive_types tyco lthy val _ = map (fn tyco => "generating comparator for type " ^ quote tyco) tycos |> cat_lines |> writeln val (tfrees, used_tfrees) = type_parameters (hd Ts) lthy val used_positions = map (member (op =) used_tfrees o TFree) tfrees val cs = map (subT "comp") used_tfrees val comp_Ts = map compT used_tfrees val arg_comps = map Free (cs ~~ comp_Ts) val dep_tycos = fold (add_used_tycos lthy) tycos [] val XTys = Bnf_Access.bnf_types lthy tycos val inst_types = typ_subst_atomic (XTys ~~ Ts) val cTys = map (map (map inst_types)) (Bnf_Access.constr_argument_types lthy tycos) val map_simps = Bnf_Access.map_simps lthy tycos val case_simps = Bnf_Access.case_simps lthy tycos val maps = Bnf_Access.map_terms lthy tycos val map_comp_thms = Bnf_Access.map_comps lthy tycos val t_ixs = 0 upto (length Ts - 1) val compNs = (*TODO: clashes in presence of same type names in different theories*) map (Long_Name.base_name) tycos |> map (fn s => "comparator_" ^ s) fun gen_vars prefix = map (fn (i, pty) => Free (prefix ^ ints_to_subscript [i], pty)) (t_ixs ~~ Ts) (* primrec definitions of partial comparators *) fun mk_pcomp (tyco, T) = ("partial_comparator_" ^ Long_Name.base_name tyco, pcompT T) fun constr_terms lthy = Bnf_Access.constr_terms lthy #> map (apsnd (map freeify_tvars o fst o strip_type) o dest_Const) fun generate_pcomp_eqs lthy (tyco, T) = let val constrs = constr_terms lthy tyco fun comp_arg T x y = let val m = Generator_Aux.create_map default_comp (K o Free o mk_pcomp) () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #pcomp oo the_info) tycos ((K o K) ()) T lthy val p = Generator_Aux.create_partial () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #pcomp oo the_info) tycos ((K o K) ()) T lthy in p $ (m $ x) $ y |> infer_type lthy end fun generate_eq lthy (c_T as (cN, Ts)) = let val arg_Ts' = map orderify Ts val c = Const (cN, arg_Ts' ---> orderify T) val (y, (xs, ys)) = Name.variant "y" (Variable.names_of lthy) |>> Free o rpair T ||> (fn ctxt => Name.invent_names ctxt "x" (arg_Ts' @ Ts) |> map Free) ||> chop (length Ts) val k = find_index (curry (op =) c_T) constrs val cases = constrs |> map_index (fn (i, (_, Ts')) => if i < k then fold_rev absdummy Ts' @{term Gt} else if k < i then fold_rev absdummy Ts' @{term Lt} else @{term comp_lex} $ HOLogic.mk_list orderT (@{map 3} comp_arg Ts xs ys) |> lambdas ys) val lhs = Free (mk_pcomp (tyco, T)) $ list_comb (c, xs) $ y val rhs = list_comb (singleton (Bnf_Access.case_consts lthy) tyco, cases) $ y in HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy end in map (generate_eq lthy) constrs end val eqs = map (generate_pcomp_eqs lthy) (tycos ~~ Ts) |> flat val bindings = tycos ~~ Ts |> map mk_pcomp |> map (fn (name, T) => (Binding.name name, SOME T, NoSyn)) val ((pcomps, pcomp_simps), lthy) = lthy |> Local_Theory.begin_nested |> snd |> (BNF_LFP_Rec_Sugar.primrec false [] bindings (map (fn t => ((Binding.empty_atts, t), [], [])) eqs)) |> Local_Theory.end_nested_result (fn phi => fn (pcomps, _, pcomp_simps) => (map (Morphism.term phi) pcomps, map (Morphism.fact phi) pcomp_simps)) (* definitions of comparators via partial comparators and maps *) fun generate_comp_def tyco lthy = let val cs = map (subT "comp") used_tfrees val arg_Ts = map compT used_tfrees val args = map Free (cs ~~ arg_Ts) val (pcomp, m) = AList.lookup (op =) (tycos ~~ (pcomps ~~ maps)) tyco |> the val ts = tfrees |> map TFree |> map (fn T => AList.lookup (op =) (used_tfrees ~~ args) T |> the_default (default_comp T)) val rhs = HOLogic.mk_comp (pcomp, list_comb (m, ts)) |> infer_type lthy val abs_def = lambdas args rhs val name = "comparator_" ^ Long_Name.base_name tyco val ((comp, (_, prethm)), lthy) = Local_Theory.define ((Binding.name name, NoSyn), (Binding.empty_atts, abs_def)) lthy val eq = Logic.mk_equals (list_comb (comp, args), rhs) val thm = Goal.prove lthy (map (fst o dest_Free) args) [] eq (fn {context = ctxt, ...} => unfold_tac ctxt [prethm]) in Local_Theory.note ((Binding.name (name ^ "_def"), []), [thm]) lthy |>> the_single o snd |>> `(K comp) end val ((comps, comp_defs), lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_comp_def tycos |>> split_list |> Local_Theory.end_nested_result (fn phi => fn (comps, comp_defs) => (map (Morphism.term phi) comps, map (Morphism.thm phi) comp_defs)) (* alternative simp-rules for comparators *) val full_comps = map (list_comb o rpair arg_comps) comps fun generate_comp_simps (tyco, T) lthy = let val constrs = constr_terms lthy tyco fun comp_arg T x y = let fun create_comp (T as TFree _) = AList.lookup (op =) (used_tfrees ~~ arg_comps) T |> the_default (HOLogic.id_const dummyT) | create_comp (Type (tyco, Ts)) = (case AList.lookup (op =) (tycos ~~ comps) tyco of SOME c => list_comb (c, arg_comps) | NONE => let val {comp = c, used_positions = up, ...} = the_info lthy tyco val ts = (up ~~ Ts) |> map_filter (fn (b, T) => if b then SOME (create_comp T) else NONE) in list_comb (c, ts) end) | create_comp T = error ("unexpected schematic variable " ^ quote (Syntax.string_of_typ lthy T)) val comp = create_comp T in comp $ x $ y |> infer_type lthy end fun generate_eq_thm lthy (c_T as (_, Ts)) = let val (xs, ctxt) = Variable.names_of lthy |> fold_map (fn T => Name.variant "x" #>> Free o rpair T) Ts fun mk_const (c, Ts) = Const (c, Ts ---> T) val comp_const = AList.lookup (op =) (tycos ~~ comps) tyco |> the val lhs = list_comb (comp_const, arg_comps) $ list_comb (mk_const c_T, xs) val k = find_index (curry (op =) c_T) constrs fun mk_eq c ys rhs = let val y = list_comb (mk_const c, ys) val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs $ y, rhs)) in (ys, eq |> infer_type lthy) end val ((ys, eqs), _) = fold_map (fn (i, c as (_, Ts')) => fn ctxt => let val (ys, ctxt) = fold_map (fn T => Name.variant "y" #>> Free o rpair T) Ts' ctxt in (if i < k then mk_eq c ys @{term Gt} else if k < i then mk_eq c ys @{term Lt} else @{term comp_lex} $ HOLogic.mk_list orderT (@{map 3} comp_arg Ts xs ys) |> mk_eq c ys, ctxt) end) (tag_list 0 constrs) ctxt |> apfst (apfst flat o split_list) val dep_comp_defs = map_filter (#comp_def o the_info lthy) dep_tycos val dep_map_comps = map_filter (#map_comp o the_info lthy) dep_tycos val thms = prove_multi_future lthy (map (fst o dest_Free) (xs @ ys) @ cs) [] eqs (fn {context = ctxt, ...} => Goal.conjunction_tac 1 THEN unfold_tac ctxt (@{thms id_apply o_def} @ flat case_simps @ flat pcomp_simps @ dep_map_comps @ comp_defs @ dep_comp_defs @ flat map_simps)) in thms end val thms = map (generate_eq_thm lthy) constrs |> flat val simp_thms = map (Local_Defs.unfold lthy @{thms comp_lex_unfolds}) thms val name = "comparator_" ^ Long_Name.base_name tyco in lthy |> Local_Theory.note ((Binding.name (name ^ "_simps"), @{attributes [simp, code]}), simp_thms) |> snd |> (fn lthy => (thms, lthy)) end val (comp_simps, lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_comp_simps (tycos ~~ Ts) |> Local_Theory.end_nested_result (fn phi => map (Morphism.fact phi)) (* partial theorems *) val set_funs = Bnf_Access.set_terms lthy tycos val x_vars = gen_vars "x" val free_names = map (fst o dest_Free) (x_vars @ arg_comps) val xi_vars = map_index (fn (i, _) => map_index (fn (j, pty) => Free ("x" ^ ints_to_subscript [i, j], pty)) used_tfrees) Ts fun mk_eq_sym_trans_thm' mk_eq_sym_trans' = map_index (fn (i, ((set_funs, x), xis)) => let fun create_cond ((set_t, xi), c) = let val rhs = mk_eq_sym_trans' lthy c $ xi |> HOLogic.mk_Trueprop val lhs = HOLogic.mk_mem (xi, set_t $ x) |> HOLogic.mk_Trueprop in Logic.all xi (Logic.mk_implies (lhs, rhs)) end val used_sets = map (the o AList.lookup (op =) (map TFree tfrees ~~ set_funs)) used_tfrees val conds = map create_cond (used_sets ~~ xis ~~ arg_comps) val concl = mk_eq_sym_trans' lthy (nth full_comps i) $ x |> HOLogic.mk_Trueprop in Logic.list_implies (conds, concl) |> infer_type lthy end) (set_funs ~~ x_vars ~~ xi_vars) val induct_thms = Bnf_Access.induct_thms lthy tycos val set_simps = Bnf_Access.set_simps lthy tycos val case_thms = Bnf_Access.case_thms lthy tycos val distinct_thms = Bnf_Access.distinct_thms lthy tycos val inject_thms = Bnf_Access.inject_thms lthy tycos val rec_info = (the_info lthy, #used_positions, tycos) val split_IHs = split_IHs rec_info val unknown_value = false (* effect of choosing false / true not yet visible *) fun induct_tac ctxt f = ((DETERM o Induction.induction_tac ctxt false (map (fn x => [SOME (NONE, (x, unknown_value))]) x_vars) [] [] (SOME induct_thms) []) THEN_ALL_NEW (fn i => Subgoal.SUBPROOF (fn {context = ctxt, prems = prems, params = iparams, ...} => f (i - 1) ctxt prems iparams) ctxt i)) 1 fun recursor_tac kind = std_recursor_tac rec_info used_tfrees (fn info => nth (#partial_comp_thms info) kind) fun instantiate_IHs IHs pre_conds = map (fn IH => OF_option IH (replicate (Thm.nprems_of IH - length pre_conds) NONE @ map SOME pre_conds)) IHs fun get_v_i vs k = nth vs k |> snd |> SOME (* partial eq-theorem *) val _ = debug_out "Partial equality" val eq_thms' = mk_eq_sym_trans_thm' mk_peq_comp fun eq_solve_tac i ctxt IH_prems xs = let val (i, j) = ind_case_to_idxs cTys i val k = length IH_prems - length arg_comps val pre_conds = drop k IH_prems val IH = take k IH_prems val comp_simps = nth comp_simps i val case_thm = nth case_thms i val distinct_thms = nth distinct_thms i val inject_thms = nth inject_thms i val set_thms = nth set_simps i in (* after induction *) resolve_tac ctxt @{thms peq_compI} 1 THEN Subgoal.FOCUS (fn focus => let val y = #params focus |> hd val yt = y |> snd |> Thm.term_of val ctxt = #context focus val pre_cond = map (fn pre_cond => Local_Defs.unfold ctxt set_thms pre_cond) pre_conds val IH = instantiate_IHs IH pre_cond val xs_tys = map (fastype_of o Thm.term_of o snd) xs val IHs = split_IHs xs_tys IH fun sub_case_tac j' (ctxt, y_simp, _) = if j = j' then unfold_tac ctxt (y_simp @ comp_simps) THEN unfold_tac ctxt @{thms comp_lex_eq} THEN unfold_tac ctxt (@{thms in_set_simps} @ inject_thms @ @{thms refl_True}) THEN conjI_tac @{thms conj_weak_cong} ctxt xs (fn ctxt' => fn k => resolve_tac ctxt @{thms peq_compD} 1 THEN recursor_tac EQ pre_cond (nth xs_tys k) (nth IHs k) ctxt') else (* different constructors *) unfold_tac ctxt (y_simp @ distinct_thms @ comp_simps @ @{thms order.simps}) in mk_case_tac ctxt [[SOME yt]] case_thm sub_case_tac end ) ctxt 1 end val eq_thms' = prove_multi_future lthy free_names [] eq_thms' (fn {context = ctxt, ...} => induct_tac ctxt eq_solve_tac) val _ = debug_out (@{make_string} eq_thms') (* partial symmetry-theorem *) val _ = debug_out "Partial symmetry" val sym_thms' = mk_eq_sym_trans_thm' mk_psym_comp fun sym_solve_tac i ctxt IH_prems xs = let val (i, j) = ind_case_to_idxs cTys i val k = length IH_prems - length arg_comps val pre_conds = drop k IH_prems val IH = take k IH_prems val comp_simps = nth comp_simps i val case_thm = nth case_thms i val set_thms = nth set_simps i in (* after induction *) resolve_tac ctxt @{thms psym_compI} 1 THEN Subgoal.FOCUS (fn focus => let val y = #params focus |> hd val yt = y |> snd |> Thm.term_of val ctxt = #context focus val pre_cond = map (fn pre_cond => Local_Defs.unfold ctxt set_thms pre_cond) pre_conds val IH = instantiate_IHs IH pre_cond val xs_tys = map (fastype_of o Thm.term_of o snd) xs val IHs = split_IHs xs_tys IH fun sub_case_tac j' (ctxt, y_simp, ys) = if j = j' then unfold_tac ctxt (y_simp @ comp_simps) THEN resolve_tac ctxt @{thms comp_lex_sym} 1 THEN unfold_tac ctxt (@{thms length_nth_simps forall_finite}) THEN conjI_tac @{thms conjI} ctxt xs (fn ctxt' => fn k => resolve_tac ctxt' [infer_instantiate' ctxt' [NONE, get_v_i xs k, get_v_i ys k] @{thm psym_compD}] 1 THEN recursor_tac SYM pre_cond (nth xs_tys k) (nth IHs k) ctxt') else (* different constructors *) unfold_tac ctxt (y_simp @ comp_simps @ @{thms invert_order.simps}) in mk_case_tac ctxt [[SOME yt]] case_thm sub_case_tac end ) ctxt 1 end val sym_thms' = prove_multi_future lthy free_names [] sym_thms' (fn {context = ctxt, ...} => induct_tac ctxt sym_solve_tac) val _ = debug_out (@{make_string} sym_thms') (* partial transitivity-theorem *) val _ = debug_out "Partial transitivity" val trans_thms' = mk_eq_sym_trans_thm' mk_ptrans_comp fun trans_solve_tac i ctxt IH_prems xs = let val (i, j) = ind_case_to_idxs cTys i val k = length IH_prems - length arg_comps val pre_conds = drop k IH_prems val IH = take k IH_prems val comp_simps = nth comp_simps i val case_thm = nth case_thms i val set_thms = nth set_simps i in (* after induction *) resolve_tac ctxt @{thms ptrans_compI} 1 THEN Subgoal.FOCUS (fn focus => let val y = nth (#params focus) 0 val z = nth (#params focus) 1 val yt = y |> snd |> Thm.term_of val zt = z |> snd |> Thm.term_of val ctxt = #context focus val pre_cond = map (fn pre_cond => Local_Defs.unfold ctxt set_thms pre_cond) pre_conds val IH = instantiate_IHs IH pre_cond val xs_tys = map (fastype_of o Thm.term_of o snd) xs val IHs = split_IHs xs_tys IH fun sub_case_tac j' (ctxt, y_simp, ys) = let fun sub_case_tac' j'' (ctxt, z_simp, zs) = if j = j' andalso j = j'' then unfold_tac ctxt (y_simp @ z_simp @ comp_simps) THEN resolve_tac ctxt @{thms comp_lex_trans} 1 THEN unfold_tac ctxt (@{thms length_nth_simps forall_finite}) THEN conjI_tac @{thms conjI} ctxt xs (fn ctxt' => fn k => resolve_tac ctxt' [infer_instantiate' ctxt' [NONE, get_v_i xs k, get_v_i ys k, get_v_i zs k] @{thm ptrans_compD}] 1 THEN recursor_tac TRANS pre_cond (nth xs_tys k) (nth IHs k) ctxt') else (* different constructors *) unfold_tac ctxt (y_simp @ z_simp @ comp_simps @ @{thms trans_order_different}) in mk_case_tac ctxt [[SOME zt]] case_thm sub_case_tac' end in mk_case_tac ctxt [[SOME yt]] case_thm sub_case_tac end ) ctxt 1 end val trans_thms' = prove_multi_future lthy free_names [] trans_thms' (fn {context = ctxt, ...} => induct_tac ctxt trans_solve_tac) val _ = debug_out (@{make_string} trans_thms') (* total theorems *) fun mk_eq_sym_trans_thm mk_eq_sym_trans compI2 compE2 thms' = let val conds = map (fn c => mk_eq_sym_trans lthy c |> HOLogic.mk_Trueprop) arg_comps val thms = map (fn i => mk_eq_sym_trans lthy (nth full_comps i) |> HOLogic.mk_Trueprop |> (fn concl => Logic.list_implies (conds,concl))) t_ixs val thms = prove_multi_future lthy free_names [] thms (fn {context = ctxt, ...} => ALLGOALS Goal.conjunction_tac THEN Method.intros_tac ctxt (@{thm conjI} :: compI2 :: thms') [] THEN ALLGOALS (eresolve_tac ctxt [compE2])) in thms end val eq_thms = mk_eq_sym_trans_thm mk_eq_comp @{thm eq_compI2} @{thm eq_compD2} eq_thms' val sym_thms = mk_eq_sym_trans_thm mk_sym_comp @{thm sym_compI2} @{thm sym_compD2} sym_thms' val trans_thms = mk_eq_sym_trans_thm mk_trans_comp @{thm trans_compI2} @{thm trans_compD2} trans_thms' val _ = debug_out "full comparator thms" fun mk_comp_thm (i, ((e, s), t)) = let val conds = map (fn c => mk_comp lthy c |> HOLogic.mk_Trueprop) arg_comps fun from_comp thm i = thm OF replicate (Thm.prems_of thm |> length) (nth @{thms comparator_imp_eq_sym_trans} i) val nearly_thm = @{thm eq_sym_trans_imp_comparator} OF [from_comp e EQ, from_comp s SYM, from_comp t TRANS] val thm = mk_comp lthy (nth full_comps i) |> HOLogic.mk_Trueprop |> (fn concl => Logic.list_implies (conds, concl)) in Goal.prove_future lthy free_names [] thm (K (resolve_tac lthy [nearly_thm] 1 THEN ALLGOALS (assume_tac lthy))) end val comp_thms = map_index mk_comp_thm (eq_thms ~~ sym_thms ~~ trans_thms) val (_, lthy) = fold_map (fn (thm, cname) => Local_Theory.note ((Binding.name cname, []), [thm])) (comp_thms ~~ compNs) lthy val _ = debug_out (@{make_string} comp_thms) val pcomp_thms = map (fn ((e, s), t) => [e, s, t]) (eq_thms' ~~ sym_thms' ~~ trans_thms') val (_, lthy) = fold_map (fn (thms, cname) => Local_Theory.note ((Binding.name (cname ^ "_pointwise"), []), thms)) (pcomp_thms ~~ compNs) lthy in ((pcomps ~~ pcomp_simps, comps ~~ comp_defs), lthy) ||> fold (fn (((((((tyco, map), pcomp), comp), comp_def), map_comp), pcomp_thms), comp_thm) => declare_info tyco map pcomp comp (SOME comp_def) (SOME map_comp) pcomp_thms comp_thm used_positions) (tycos ~~ maps ~~ pcomps ~~ comps ~~ comp_defs ~~ map_comp_thms ~~ pcomp_thms ~~ comp_thms) end fun generate_comparator gen_type tyco lthy = let val _ = is_some (get_info lthy tyco) andalso error ("type " ^ quote tyco ^ " does already have a comparator") in case gen_type of BNF => generate_comparators_from_bnf_fp tyco lthy |> snd | Linorder => register_comparator_of tyco lthy end fun ensure_info gen_type tyco lthy = (case get_info lthy tyco of SOME _ => lthy | NONE => generate_comparator gen_type tyco lthy) fun generate_comparator_cmd tyco param = Named_Target.theory_map ( if param = "linorder" then generate_comparator Linorder tyco else if param = "" then generate_comparator BNF tyco else error ("unknown parameter, expecting no parameter for BNF-datatypes, " ^ "or \"linorder\" for types which are already in linorder")) val _ = Theory.setup (Derive_Manager.register_derive "comparator" "generate comparators for given types, options: (linorder) or ()" generate_comparator_cmd) end diff --git a/thys/Deriving/Equality_Generator/equality_generator.ML b/thys/Deriving/Equality_Generator/equality_generator.ML --- a/thys/Deriving/Equality_Generator/equality_generator.ML +++ b/thys/Deriving/Equality_Generator/equality_generator.ML @@ -1,519 +1,518 @@ (* Title: Deriving class instances for datatypes Author: Christian Sternagel and René Thiemann Maintainer: Christian Sternagel and René Thiemann License: LGPL *) signature EQUALITY_GENERATOR = sig type info = {map : term, (* take % x. x, if there is no map *) pequality : term, (* partial equality *) equality : term, (* full equality *) equality_def : thm option, (* definition of equality, important for nesting *) map_comp : thm option, (* compositionality of map, important for nesting *) partial_equality_thm : thm, (* partial version of equality thm *) equality_thm : thm, (* equality acomp \ \ \ equality (full_comp acomp \) *) used_positions : bool list} (* registers @{term equality_of :: "some_type :: linorder equality"} where some_type must just be a type without type-arguments *) val register_equality_of : string -> local_theory -> local_theory val register_foreign_equality : typ -> (* type-constant without type-variables *) term -> (* equality for type *) thm -> (* equality thm for provided equality *) local_theory -> local_theory val register_foreign_partial_and_full_equality : string -> (* long type name *) term -> (* map function, should be \x. x, if there is no map *) term -> (* partial equality of type ('a => order, 'b)ty => ('a,'b)ty => order, where 'a is used, 'b is unused *) term -> (* (full) equality of type ('a \ 'a \ order) \ ('a,'b)ty \ ('a,'b)ty \ order, where 'a is used, 'b is unused *) thm option -> (* comp_def, should be full_comp = pcomp o map acomp ..., important for nesting *) thm option -> (* map compositionality, important for nesting *) thm -> (* partial eq thm for full equality *) thm -> (* full thm: equality a-comp => equality (full_comp a-comp) *) bool list -> (*used positions*) local_theory -> local_theory datatype equality_type = EQ | BNF val generate_equalitys_from_bnf_fp : string -> (* name of type *) local_theory -> ((term * thm list) list * (* partial equalitys + simp-rules *) (term * thm) list) * (* non-partial equality + def_rule *) local_theory val generate_equality : equality_type -> string -> (* name of type *) local_theory -> local_theory val get_info : Proof.context -> string -> info option (* ensures that the info will be available on later requests *) val ensure_info : equality_type -> string -> local_theory -> local_theory end structure Equality_Generator : EQUALITY_GENERATOR = struct open Generator_Aux datatype equality_type = BNF | EQ val debug = false fun debug_out s = if debug then writeln s else () val boolT = @{typ bool} fun compT T = T --> T --> boolT val orderify = map_atyps (fn T => T --> boolT) fun pcompT T = orderify T --> T --> boolT type info = {map : term, pequality : term, equality : term, equality_def : thm option, map_comp : thm option, partial_equality_thm : thm, equality_thm : thm, used_positions : bool list}; structure Data = Generic_Data ( type T = info Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge (fn (info1 : info, info2 : info) => #equality info1 = #equality info2); ); fun add_info T info = Data.map (Symtab.update_new (T, info)) val get_info = Context.Proof #> Data.get #> Symtab.lookup fun the_info ctxt tyco = (case get_info ctxt tyco of SOME info => info | NONE => error ("no equality information available for type " ^ quote tyco)) fun declare_info tyco m p c c_def m_comp p_thm c_thm used_pos = Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => add_info tyco {map = Morphism.term phi m, pequality = Morphism.term phi p, equality = Morphism.term phi c, equality_def = Option.map (Morphism.thm phi) c_def, map_comp = Option.map (Morphism.thm phi) m_comp, partial_equality_thm = Morphism.thm phi p_thm, equality_thm = Morphism.thm phi c_thm, used_positions = used_pos}) fun register_foreign_partial_and_full_equality tyco m p c c_def m_comp eq_thm c_thm = declare_info tyco m p c c_def m_comp eq_thm c_thm val mk_equality = mk_infer_const @{const_name equality} val mk_pequality = mk_infer_const @{const_name pequality} fun default_comp T = absdummy T (absdummy T @{term True}) (*%_ _. True*) fun register_foreign_equality T comp comp_thm lthy = let val tyco = (case T of Type (tyco, []) => tyco | _ => error "expected type constant with no arguments") val eq = @{thm equalityD2} OF [comp_thm] in register_foreign_partial_and_full_equality tyco (HOLogic.id_const T) comp comp NONE NONE eq comp_thm [] lthy end fun register_equality_of tyco lthy = let val (T,_) = typ_and_vs_of_typname (Proof_Context.theory_of lthy) tyco @{sort type} val comp = HOLogic.eq_const T val comp_thm = Thm.instantiate' [SOME (Thm.ctyp_of lthy T)] [] @{thm eq_equality} in register_foreign_equality T comp comp_thm lthy end fun generate_equalitys_from_bnf_fp tyco lthy = let val (tycos, Ts) = mutual_recursive_types tyco lthy val _ = map (fn tyco => "generating equality for type " ^ quote tyco) tycos |> cat_lines |> writeln val (tfrees, used_tfrees) = type_parameters (hd Ts) lthy val used_positions = map (member (op =) used_tfrees o TFree) tfrees val cs = map (subT "eq") used_tfrees val comp_Ts = map compT used_tfrees val arg_comps = map Free (cs ~~ comp_Ts) val dep_tycos = fold (add_used_tycos lthy) tycos [] val XTys = Bnf_Access.bnf_types lthy tycos val inst_types = typ_subst_atomic (XTys ~~ Ts) val cTys = map (map (map inst_types)) (Bnf_Access.constr_argument_types lthy tycos) val map_simps = Bnf_Access.map_simps lthy tycos val case_simps = Bnf_Access.case_simps lthy tycos val maps = Bnf_Access.map_terms lthy tycos val map_comp_thms = Bnf_Access.map_comps lthy tycos val t_ixs = 0 upto (length Ts - 1) val compNs = (*TODO: clashes in presence of same type names in different theories*) map (Long_Name.base_name) tycos |> map (fn s => "equality_" ^ s) fun gen_vars prefix = map (fn (i, pty) => Free (prefix ^ ints_to_subscript [i], pty)) (t_ixs ~~ Ts) (* primrec definitions of partial equalitys *) fun mk_pcomp (tyco, T) = ("partial_equality_" ^ Long_Name.base_name tyco, pcompT T) fun constr_terms lthy = Bnf_Access.constr_terms lthy #> map (apsnd (map freeify_tvars o fst o strip_type) o dest_Const) fun generate_pcomp_eqs lthy (tyco, T) = let val constrs = constr_terms lthy tyco fun comp_arg T x y = let val m = Generator_Aux.create_map default_comp (K o Free o mk_pcomp) () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #pequality oo the_info) tycos ((K o K) ()) T lthy val p = Generator_Aux.create_partial () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #pequality oo the_info) tycos ((K o K) ()) T lthy in p $ (m $ x) $ y |> infer_type lthy end fun generate_eq lthy (c_T as (cN, Ts)) = let val arg_Ts' = map orderify Ts val c = Const (cN, arg_Ts' ---> orderify T) val (y, (xs, ys)) = Name.variant "y" (Variable.names_of lthy) |>> Free o rpair T ||> (fn ctxt => Name.invent_names ctxt "x" (arg_Ts' @ Ts) |> map Free) ||> chop (length Ts) val k = find_index (curry (op =) c_T) constrs val cases = constrs |> map_index (fn (i, (_, Ts')) => if i < k then fold_rev absdummy Ts' @{term False} else if k < i then fold_rev absdummy Ts' @{term False} else @{term list_all_eq} $ HOLogic.mk_list boolT (@{map 3} comp_arg Ts xs ys) |> lambdas ys) val lhs = Free (mk_pcomp (tyco, T)) $ list_comb (c, xs) $ y val rhs = list_comb (singleton (Bnf_Access.case_consts lthy) tyco, cases) $ y in HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy end in map (generate_eq lthy) constrs end val eqs = map (generate_pcomp_eqs lthy) (tycos ~~ Ts) |> flat val bindings = tycos ~~ Ts |> map mk_pcomp |> map (fn (name, T) => (Binding.name name, SOME T, NoSyn)) val ((pcomps, pcomp_simps), lthy) = lthy |> Local_Theory.begin_nested |> snd |> (BNF_LFP_Rec_Sugar.primrec false [] bindings (map (fn t => ((Binding.empty_atts, t), [], [])) eqs)) |> Local_Theory.end_nested_result (fn phi => fn (pcomps, _, pcomp_simps) => (map (Morphism.term phi) pcomps, map (Morphism.fact phi) pcomp_simps)) (* definitions of equalitys via partial equalitys and maps *) fun generate_comp_def tyco lthy = let val cs = map (subT "eq") used_tfrees val arg_Ts = map compT used_tfrees val args = map Free (cs ~~ arg_Ts) val (pcomp, m) = AList.lookup (op =) (tycos ~~ (pcomps ~~ maps)) tyco |> the val ts = tfrees |> map TFree |> map (fn T => AList.lookup (op =) (used_tfrees ~~ args) T |> the_default (default_comp T)) val rhs = HOLogic.mk_comp (pcomp, list_comb (m, ts)) |> infer_type lthy val abs_def = lambdas args rhs val name = "equality_" ^ Long_Name.base_name tyco val ((comp, (_, prethm)), lthy) = Local_Theory.define ((Binding.name name, NoSyn), (Binding.empty_atts, abs_def)) lthy val eq = Logic.mk_equals (list_comb (comp, args), rhs) val thm = Goal.prove lthy (map (fst o dest_Free) args) [] eq (fn {context = ctxt, ...} => unfold_tac ctxt [prethm]) in Local_Theory.note ((Binding.name (name ^ "_def"), []), [thm]) lthy |>> the_single o snd |>> `(K comp) end val ((comps, comp_defs), lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_comp_def tycos |>> split_list |> Local_Theory.end_nested_result (fn phi => fn (comps, comp_defs) => (map (Morphism.term phi) comps, map (Morphism.thm phi) comp_defs)) (* alternative simp-rules for equalitys *) val full_comps = map (list_comb o rpair arg_comps) comps fun generate_comp_simps (tyco, T) lthy = let val constrs = constr_terms lthy tyco fun comp_arg T x y = let fun create_comp (T as TFree _) = AList.lookup (op =) (used_tfrees ~~ arg_comps) T |> the_default (HOLogic.id_const dummyT) | create_comp (Type (tyco, Ts)) = (case AList.lookup (op =) (tycos ~~ comps) tyco of SOME c => list_comb (c, arg_comps) | NONE => let val {equality = c, used_positions = up, ...} = the_info lthy tyco val ts = (up ~~ Ts) |> map_filter (fn (b, T) => if b then SOME (create_comp T) else NONE) in list_comb (c, ts) end) | create_comp T = error ("unexpected schematic variable " ^ quote (Syntax.string_of_typ lthy T)) val comp = create_comp T in comp $ x $ y |> infer_type lthy end fun generate_eq_thm lthy (c_T as (_, Ts)) = let val (xs, ctxt) = Variable.names_of lthy |> fold_map (fn T => Name.variant "x" #>> Free o rpair T) Ts fun mk_const (c, Ts) = Const (c, Ts ---> T) val comp_const = AList.lookup (op =) (tycos ~~ comps) tyco |> the val lhs = list_comb (comp_const, arg_comps) $ list_comb (mk_const c_T, xs) val k = find_index (curry (op =) c_T) constrs fun mk_eq c ys rhs = let val y = list_comb (mk_const c, ys) val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs $ y, rhs)) in (ys, eq |> infer_type lthy) end val ((ys, eqs), _) = fold_map (fn (i, c as (_, Ts')) => fn ctxt => let val (ys, ctxt) = fold_map (fn T => Name.variant "y" #>> Free o rpair T) Ts' ctxt in (if i < k then mk_eq c ys @{term False} else if k < i then mk_eq c ys @{term False} else @{term list_all_eq} $ HOLogic.mk_list boolT (@{map 3} comp_arg Ts xs ys) |> mk_eq c ys, ctxt) end) (tag_list 0 constrs) ctxt |> apfst (apfst flat o split_list) val dep_comp_defs = map_filter (#equality_def o the_info lthy) dep_tycos val dep_map_comps = map_filter (#map_comp o the_info lthy) dep_tycos val thms = prove_multi_future lthy (map (fst o dest_Free) (xs @ ys) @ cs) [] eqs (fn {context = ctxt, ...} => Goal.conjunction_tac 1 THEN unfold_tac ctxt (@{thms id_apply o_def} @ flat case_simps @ flat pcomp_simps @ dep_map_comps @ comp_defs @ dep_comp_defs @ flat map_simps)) in thms end val thms = map (generate_eq_thm lthy) constrs |> flat val simp_thms = map (Local_Defs.unfold lthy @{thms list_all_eq_unfold}) thms val name = "equality_" ^ Long_Name.base_name tyco in lthy |> Local_Theory.note ((Binding.name (name ^ "_simps"), @{attributes [simp, code]}), simp_thms) |> snd |> (fn lthy => (thms, lthy)) end val (comp_simps, lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_comp_simps (tycos ~~ Ts) |> Local_Theory.end_nested_result (fn phi => map (Morphism.fact phi)) (* partial theorems *) val set_funs = Bnf_Access.set_terms lthy tycos val x_vars = gen_vars "x" val free_names = map (fst o dest_Free) (x_vars @ arg_comps) val xi_vars = map_index (fn (i, _) => map_index (fn (j, pty) => Free ("x" ^ ints_to_subscript [i, j], pty)) used_tfrees) Ts fun mk_eq_thm' mk_eq' = map_index (fn (i, ((set_funs, x), xis)) => let fun create_cond ((set_t, xi), c) = let val rhs = mk_eq' lthy c $ xi |> HOLogic.mk_Trueprop val lhs = HOLogic.mk_mem (xi, set_t $ x) |> HOLogic.mk_Trueprop in Logic.all xi (Logic.mk_implies (lhs, rhs)) end val used_sets = map (the o AList.lookup (op =) (map TFree tfrees ~~ set_funs)) used_tfrees val conds = map create_cond (used_sets ~~ xis ~~ arg_comps) val concl = mk_eq' lthy (nth full_comps i) $ x |> HOLogic.mk_Trueprop in Logic.list_implies (conds, concl) |> infer_type lthy end) (set_funs ~~ x_vars ~~ xi_vars) val induct_thms = Bnf_Access.induct_thms lthy tycos val set_simps = Bnf_Access.set_simps lthy tycos val case_thms = Bnf_Access.case_thms lthy tycos val distinct_thms = Bnf_Access.distinct_thms lthy tycos val inject_thms = Bnf_Access.inject_thms lthy tycos val rec_info = (the_info lthy, #used_positions, tycos) val split_IHs = split_IHs rec_info val unknown_value = false (* effect of choosing false / true not yet visible *) fun induct_tac ctxt f = ((DETERM o Induction.induction_tac ctxt false (map (fn x => [SOME (NONE, (x, unknown_value))]) x_vars) [] [] (SOME induct_thms) []) THEN_ALL_NEW (fn i => Subgoal.SUBPROOF (fn {context = ctxt, prems = prems, params = iparams, ...} => f (i - 1) ctxt prems iparams) ctxt i)) 1 val recursor_tac = std_recursor_tac rec_info used_tfrees (fn info => #partial_equality_thm info) fun instantiate_IHs IHs pre_conds = map (fn IH => OF_option IH (replicate (Thm.nprems_of IH - length pre_conds) NONE @ map SOME pre_conds)) IHs (* partial eq-theorem *) val _ = debug_out "Partial equality" val eq_thms' = mk_eq_thm' mk_pequality fun eq_solve_tac i ctxt IH_prems xs = let val (i, j) = ind_case_to_idxs cTys i val k = length IH_prems - length arg_comps val pre_conds = drop k IH_prems val IH = take k IH_prems val comp_simps = nth comp_simps i val case_thm = nth case_thms i val distinct_thms = nth distinct_thms i val inject_thms = nth inject_thms i val set_thms = nth set_simps i in (* after induction *) resolve_tac ctxt @{thms pequalityI} 1 THEN Subgoal.FOCUS (fn focus => let val y = #params focus |> hd val yt = y |> snd |> Thm.term_of val ctxt = #context focus val pre_cond = map (fn pre_cond => Local_Defs.unfold ctxt set_thms pre_cond) pre_conds val IH = instantiate_IHs IH pre_cond val xs_tys = map (fastype_of o Thm.term_of o snd) xs val IHs = split_IHs xs_tys IH fun sub_case_tac j' (ctxt, y_simp, _) = if j = j' then unfold_tac ctxt (y_simp @ comp_simps) THEN unfold_tac ctxt @{thms list_all_eq} THEN unfold_tac ctxt (@{thms in_set_simps} @ inject_thms @ @{thms refl_True}) THEN conjI_tac @{thms conj_weak_cong} ctxt xs (fn ctxt' => fn k => resolve_tac ctxt @{thms pequalityD} 1 THEN recursor_tac pre_cond (nth xs_tys k) (nth IHs k) ctxt') else (* different constructors *) unfold_tac ctxt (y_simp @ distinct_thms @ comp_simps @ @{thms bool.simps}) in mk_case_tac ctxt [[SOME yt]] case_thm sub_case_tac end ) ctxt 1 end val eq_thms' = prove_multi_future lthy free_names [] eq_thms' (fn {context = ctxt, ...} => induct_tac ctxt eq_solve_tac) val _ = debug_out (@{make_string} eq_thms') (* total theorems *) fun mk_eq_sym_trans_thm mk_eq_sym_trans compI2 compE2 thms' = let val conds = map (fn c => mk_eq_sym_trans lthy c |> HOLogic.mk_Trueprop) arg_comps val thms = map (fn i => mk_eq_sym_trans lthy (nth full_comps i) |> HOLogic.mk_Trueprop |> (fn concl => Logic.list_implies (conds,concl))) t_ixs val thms = prove_multi_future lthy free_names [] thms (fn {context = ctxt, ...} => ALLGOALS Goal.conjunction_tac THEN Method.intros_tac ctxt (@{thm conjI} :: compI2 :: thms') [] THEN ALLGOALS (eresolve_tac ctxt [compE2])) in thms end val eq_thms = mk_eq_sym_trans_thm mk_equality @{thm equalityI2} @{thm equalityD2} eq_thms' val _ = debug_out "full equality thms" fun mk_comp_thm (i, e) = let val conds = map (fn c => mk_equality lthy c |> HOLogic.mk_Trueprop) arg_comps val nearly_thm = e val thm = mk_equality lthy (nth full_comps i) |> HOLogic.mk_Trueprop |> (fn concl => Logic.list_implies (conds, concl)) in Goal.prove_future lthy free_names [] thm (K (resolve_tac lthy [nearly_thm] 1 THEN ALLGOALS (assume_tac lthy))) end val comp_thms = map_index mk_comp_thm eq_thms val (_, lthy) = fold_map (fn (thm, cname) => Local_Theory.note ((Binding.name cname, []), [thm])) (comp_thms ~~ compNs) lthy val _ = debug_out (@{make_string} comp_thms) val (_, lthy) = fold_map (fn (thm, cname) => Local_Theory.note ((Binding.name (cname ^ "_pointwise"), []), [thm])) (eq_thms' ~~ compNs) lthy in ((pcomps ~~ pcomp_simps, comps ~~ comp_defs), lthy) ||> fold (fn (((((((tyco, map), pcomp), comp), comp_def), map_comp) , peq_thm), comp_thm) => declare_info tyco map pcomp comp (SOME comp_def) (SOME map_comp) peq_thm comp_thm used_positions) (tycos ~~ maps ~~ pcomps ~~ comps ~~ comp_defs ~~ map_comp_thms ~~ eq_thms' ~~ comp_thms) end fun generate_equality gen_type tyco lthy = let val _ = is_some (get_info lthy tyco) andalso error ("type " ^ quote tyco ^ " does already have a equality") in case gen_type of BNF => generate_equalitys_from_bnf_fp tyco lthy |> snd | EQ => register_equality_of tyco lthy end fun ensure_info gen_type tyco lthy = (case get_info lthy tyco of SOME _ => lthy | NONE => generate_equality gen_type tyco lthy) fun generate_equality_cmd tyco param = Named_Target.theory_map ( if param = "eq" then generate_equality EQ tyco else if param = "" then generate_equality BNF tyco else error ("unknown parameter, expecting no parameter for BNF-datatypes, " ^ "or \"eq\" for types where the built-in equality \"=\" should be used.")) val _ = Theory.setup (Derive_Manager.register_derive "equality" "generate an equality function, options are () and (eq)" generate_equality_cmd) end diff --git a/thys/Deriving/Hash_Generator/hash_generator.ML b/thys/Deriving/Hash_Generator/hash_generator.ML --- a/thys/Deriving/Hash_Generator/hash_generator.ML +++ b/thys/Deriving/Hash_Generator/hash_generator.ML @@ -1,413 +1,412 @@ (* Title: Deriving class instances for datatypes Author: Christian Sternagel and René Thiemann Maintainer: Christian Sternagel and René Thiemann License: LGPL *) signature HASHCODE_GENERATOR = sig type info = {map : term, (* take % x. x, if there is no map *) phash : term, (* partial hash *) hash : term, (* full hash *) hash_def : thm option, (* definition of hash, important for nesting *) map_comp : thm option, (* hashositionality of map, important for nesting *) used_positions : bool list} (* registers some type which is already instance of hashcode class in hash generator where some type must just be a type without type-arguments *) val register_hash_of : string -> local_theory -> local_theory val register_foreign_hash : typ -> (* type-constant without type-variables *) term -> (* hash-function for type *) local_theory -> local_theory val register_foreign_partial_and_full_hash : string -> (* long type name *) term -> (* map function, should be \x. x, if there is no map *) term -> (* partial hash-function of type (hashcode, 'b)ty => hashcode, where 'a is used, 'b is unused *) term -> (* (full) hash-function of type ('a \ hashcode) \ ('a,'b)ty \ hashcode, where 'a is used, 'b is unused *) thm option -> (* hash_def, should be full_hash = phash o map ahash ..., important for nesting *) thm option -> (* map compositionality, important for nesting *) bool list -> (*used positions*) local_theory -> local_theory datatype hash_type = HASHCODE | BNF val generate_hashs_from_bnf_fp : string -> (* name of type *) local_theory -> ((term * thm list) list * (* partial hashs + simp-rules *) (term * thm) list) * (* non-partial hash + def_rule *) local_theory val generate_hash : hash_type -> string -> (* name of type *) local_theory -> local_theory (* construct hashcode instance for datatype *) val hashable_instance : string -> theory -> theory val get_info : Proof.context -> string -> info option (* ensures that the info will be available on later requests *) val ensure_info : hash_type -> string -> local_theory -> local_theory end structure Hashcode_Generator : HASHCODE_GENERATOR = struct open Generator_Aux datatype hash_type = BNF | HASHCODE val hash_name = @{const_name "hashcode"} val hashS = @{sort hashable} val hashT = @{typ hashcode} fun hashfunT T = T --> hashT val hashify = map_atyps (fn _ => hashT) fun phashfunT T = hashify T --> hashT val max_int = 2147483648 (* 2 ^^ 31 *) fun int_of_string s = fold (fn c => fn i => (1792318057 * i + Char.ord c) mod max_int) (String.explode s) 0 (* all numbers in int_of_string and create_factors are primes (31-bit) *) fun create_factor ty_name con_name i = (1444315237 * int_of_string ty_name + 1336760419 * int_of_string con_name + 2044890737 * (i + 1) ) mod max_int fun create_hashes ty_name con_name Ts = map (fn i => HOLogic.mk_number hashT (create_factor ty_name con_name i)) (0 upto length Ts) |> HOLogic.mk_list hashT fun create_def_size _ = 10 type info = {map : term, phash : term, hash : term, hash_def : thm option, map_comp : thm option, used_positions : bool list}; structure Data = Generic_Data ( type T = info Symtab.table; val empty = Symtab.empty; - val extend = I; val merge = Symtab.merge (fn (info1 : info, info2 : info) => #hash info1 = #hash info2); ); fun add_info T info = Data.map (Symtab.update_new (T, info)) val get_info = Context.Proof #> Data.get #> Symtab.lookup fun the_info ctxt tyco = (case get_info ctxt tyco of SOME info => info | NONE => error ("no hash_code information available for type " ^ quote tyco)) fun declare_info tyco m p c c_def m_hash used_pos = Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => add_info tyco {map = Morphism.term phi m, phash = Morphism.term phi p, hash = Morphism.term phi c, hash_def = Option.map (Morphism.thm phi) c_def, map_comp = Option.map (Morphism.thm phi) m_hash, used_positions = used_pos}) fun register_foreign_partial_and_full_hash tyco m p c c_def m_hash eq_thm c_thm = declare_info tyco m p c c_def m_hash eq_thm c_thm fun default_hash T = absdummy T @{term "0 :: hashcode"} (*%_. 0*) fun register_foreign_hash T hash lthy = let val tyco = (case T of Type (tyco, []) => tyco | _ => error "expected type constant with no arguments") in register_foreign_partial_and_full_hash tyco (HOLogic.id_const T) hash hash NONE NONE [] lthy end fun register_hash_of tyco lthy = let val _ = is_class_instance (Proof_Context.theory_of lthy) tyco hashS orelse error ("type " ^ quote tyco ^ " is not an instance of class \"hashable\"") val (T,_) = typ_and_vs_of_typname (Proof_Context.theory_of lthy) tyco @{sort type} val hash = Const (hash_name, hashfunT T) in register_foreign_hash T hash lthy end fun generate_hashs_from_bnf_fp tyco lthy = let val (tycos, Ts) = mutual_recursive_types tyco lthy val _ = map (fn tyco => "generating hash-function for type " ^ quote tyco) tycos |> cat_lines |> writeln val (tfrees, used_tfrees) = type_parameters (hd Ts) lthy val used_positions = map (member (op =) used_tfrees o TFree) tfrees val cs = map (subT "h") used_tfrees val hash_Ts = map hashfunT used_tfrees val arg_hashs = map Free (cs ~~ hash_Ts) val dep_tycos = fold (add_used_tycos lthy) tycos [] val map_simps = Bnf_Access.map_simps lthy tycos val case_simps = Bnf_Access.case_simps lthy tycos val maps = Bnf_Access.map_terms lthy tycos val map_comp_thms = Bnf_Access.map_comps lthy tycos (* primrec definitions of partial hashs *) fun mk_phash (tyco, T) = ("partial_hash_code_" ^ Long_Name.base_name tyco, phashfunT T) fun constr_terms lthy = Bnf_Access.constr_terms lthy #> map (apsnd (map freeify_tvars o fst o strip_type) o dest_Const) fun generate_phash_eqs lthy (tyco, T) = let val constrs = constr_terms lthy tyco fun hash_arg T x = let val m = Generator_Aux.create_map default_hash (K o Free o mk_phash) () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #phash oo the_info) tycos ((K o K) ()) T lthy val p = Generator_Aux.create_partial () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #phash oo the_info) tycos ((K o K) ()) T lthy in p $ (m $ x) |> infer_type lthy end fun generate_eq lthy (cN, Ts) = let val arg_Ts' = map hashify Ts val c = Const (cN, arg_Ts' ---> hashify T) val xs = Name.invent_names (Variable.names_of lthy) "x" (arg_Ts') |> map Free val lhs = Free (mk_phash (tyco, T)) $ list_comb (c, xs) val rhs = @{term hash_combine} $ HOLogic.mk_list hashT (@{map 2} hash_arg Ts xs) $ create_hashes tyco cN Ts in HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy end in map (generate_eq lthy) constrs end val eqs = map (generate_phash_eqs lthy) (tycos ~~ Ts) |> flat val bindings = tycos ~~ Ts |> map mk_phash |> map (fn (name, T) => (Binding.name name, SOME T, NoSyn)) val ((phashs, phash_simps), lthy) = lthy |> Local_Theory.begin_nested |> snd |> BNF_LFP_Rec_Sugar.primrec false [] bindings (map (fn t => ((Binding.empty_atts, t), [], [])) eqs) |> Local_Theory.end_nested_result (fn phi => fn (phashs, _, phash_simps) => (map (Morphism.term phi) phashs, map (Morphism.fact phi) phash_simps)) (* definitions of hashs via partial hashs and maps *) fun generate_hash_def tyco lthy = let val cs = map (subT "h") used_tfrees val arg_Ts = map hashfunT used_tfrees val args = map Free (cs ~~ arg_Ts) val (phash, m) = AList.lookup (op =) (tycos ~~ (phashs ~~ maps)) tyco |> the val ts = tfrees |> map TFree |> map (fn T => AList.lookup (op =) (used_tfrees ~~ args) T |> the_default (default_hash T)) val rhs = HOLogic.mk_comp (phash, list_comb (m, ts)) |> infer_type lthy val abs_def = lambdas args rhs val name = "hash_code_" ^ Long_Name.base_name tyco val ((hash, (_, prethm)), lthy) = Local_Theory.define ((Binding.name name, NoSyn), (Binding.empty_atts, abs_def)) lthy val eq = Logic.mk_equals (list_comb (hash, args), rhs) val thm = Goal.prove lthy (map (fst o dest_Free) args) [] eq (fn {context = ctxt, ...} => unfold_tac ctxt [prethm]) in Local_Theory.note ((Binding.name (name ^ "_def"), []), [thm]) lthy |>> the_single o snd |>> `(K hash) end val ((hashs, hash_defs), lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_hash_def tycos |>> split_list |> Local_Theory.end_nested_result (fn phi => fn (hashs, hash_defs) => (map (Morphism.term phi) hashs, map (Morphism.thm phi) hash_defs)) (* alternative simp-rules for hashs *) fun generate_hash_simps (tyco, T) lthy = let val constrs = constr_terms lthy tyco fun hash_arg T x = let fun create_hash (T as TFree _) = AList.lookup (op =) (used_tfrees ~~ arg_hashs) T |> the_default (HOLogic.id_const dummyT) | create_hash (Type (tyco, Ts)) = (case AList.lookup (op =) (tycos ~~ hashs) tyco of SOME c => list_comb (c, arg_hashs) | NONE => let val {hash = c, used_positions = up, ...} = the_info lthy tyco val ts = (up ~~ Ts) |> map_filter (fn (b, T) => if b then SOME (create_hash T) else NONE) in list_comb (c, ts) end) | create_hash T = error ("unexpected schematic variable " ^ quote (Syntax.string_of_typ lthy T)) val hash = create_hash T in hash $ x |> infer_type lthy end fun generate_eq_thm lthy (c_T as (cN, Ts)) = let val xs = Variable.names_of lthy |> fold_map (fn T => Name.variant "x" #>> Free o rpair T) Ts |> fst fun mk_const (c, Ts) = Const (c, Ts ---> T) val hash_const = AList.lookup (op =) (tycos ~~ hashs) tyco |> the val lhs = list_comb (hash_const, arg_hashs) $ list_comb (mk_const c_T, xs) val rhs = @{term hash_combine} $ HOLogic.mk_list hashT (@{map 2} hash_arg Ts xs) $ create_hashes tyco cN Ts val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy val dep_hash_defs = map_filter (#hash_def o the_info lthy) dep_tycos val dep_map_comps = map_filter (#map_comp o the_info lthy) dep_tycos val thms = prove_multi_future lthy (map (fst o dest_Free) xs @ cs) [] [eq] (fn {context = ctxt, ...} => Goal.conjunction_tac 1 THEN unfold_tac ctxt (@{thms id_apply o_def} @ flat case_simps @ flat phash_simps @ dep_map_comps @ hash_defs @ dep_hash_defs @ flat map_simps)) in thms end val thms = map (generate_eq_thm lthy) constrs |> flat val simp_thms = map (Local_Defs.unfold lthy @{thms hash_combine_unfold}) thms val name = "hash_code_" ^ Long_Name.base_name tyco in lthy |> Local_Theory.note ((Binding.name (name ^ "_simps"), @{attributes [simp, code]}), simp_thms) |> snd |> (fn lthy => (thms, lthy)) end val lthy = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_hash_simps (tycos ~~ Ts) |> snd |> Local_Theory.end_nested in ((phashs ~~ phash_simps, hashs ~~ hash_defs), lthy) ||> fold (fn (((((tyco, map), phash), hash), hash_def), map_comp) => declare_info tyco map phash hash (SOME hash_def) (SOME map_comp) used_positions) (tycos ~~ maps ~~ phashs ~~ hashs ~~ hash_defs ~~ map_comp_thms) end fun generate_hash gen_type tyco lthy = let val _ = is_some (get_info lthy tyco) andalso error ("type " ^ quote tyco ^ " does already have a hash") in case gen_type of BNF => generate_hashs_from_bnf_fp tyco lthy |> snd | HASHCODE => register_hash_of tyco lthy end fun ensure_info gen_type tyco lthy = (case get_info lthy tyco of SOME _ => lthy | NONE => generate_hash gen_type tyco lthy) fun dest_hash ctxt tname = (case get_info ctxt tname of SOME {hash = c, ...} => let val Ts = fastype_of c |> strip_type |> fst |> `((fn x => x - 1) o length) |> uncurry take in (c, Ts) end | NONE => error ("no hash info for type " ^ quote tname)) fun all_tys hash free_types = let val Ts = fastype_of hash |> strip_type |> fst |> List.last |> dest_Type |> snd in rename_types (Ts ~~ free_types) end fun mk_hash_rhs c Ts = list_comb (c, map (fn T => Const (hash_name, T)) Ts) fun mk_hash_def T rhs = Logic.mk_equals (Const (hash_name, hashfunT T), rhs) fun hashable_instance tname thy = let val _ = is_class_instance thy tname hashS andalso error ("type " ^ quote tname ^ " is already an instance of class \"hashcode\"") val _ = writeln ("deriving \"hashable\" instance for type " ^ quote tname) val thy = Named_Target.theory_map (ensure_info BNF tname) thy val {used_positions = us, ...} = the (get_info (Named_Target.theory_init thy) tname) val (_, xs) = typ_and_vs_of_used_typname tname us hashS val (_, (hashs_thm,lthy)) = Class.instantiation ([tname], xs, hashS) thy |> (fn ctxt => let val (c, Ts) = dest_hash ctxt tname val typ_mapping = all_tys c (map TFree xs) val hash_rhs = mk_hash_rhs c Ts val hash_def = mk_hash_def dummyT hash_rhs |> typ_mapping |> infer_type ctxt val ty = Term.fastype_of (snd (Logic.dest_equals hash_def)) |> Term.dest_Type |> snd |> hd val ty_it = Type (@{type_name itself}, [ty]) val hashs_rhs = lambda (Free ("x",ty_it)) (HOLogic.mk_number @{typ nat} (create_def_size tname)) val hashs_def = mk_def (ty_it --> @{typ nat}) @{const_name def_hashmap_size} hashs_rhs val basename = Long_Name.base_name tname in Generator_Aux.define_overloaded_generic ((Binding.name ("hashcode_" ^ basename ^ "_def"), @{attributes [code]}), hash_def) ctxt ||> define_overloaded ("def_hashmap_size_" ^ basename ^ "_def", hashs_def) end) in Class.prove_instantiation_exit (fn ctxt => Class.intro_classes_tac ctxt [] THEN unfold_tac ctxt [hashs_thm] THEN simp_tac ctxt 1 ) lthy end fun generate_hash_cmd tyco param = Named_Target.theory_map ( if param = "hashcode" then generate_hash HASHCODE tyco else if param = "" then generate_hash BNF tyco else error ("unknown parameter, expecting no parameter for BNF-datatypes, " ^ "or \"hashcode\" for types where the class-instance hashcode should be used.")) val _ = Theory.setup (Derive_Manager.register_derive "hash_code" "generate a hash function, options are () and (hashcode)" generate_hash_cmd #> Derive_Manager.register_derive "hashable" "register types in class hashable" (fn tyname => K (hashable_instance tyname))) end diff --git a/thys/Deriving/derive_manager.ML b/thys/Deriving/derive_manager.ML --- a/thys/Deriving/derive_manager.ML +++ b/thys/Deriving/derive_manager.ML @@ -1,65 +1,64 @@ signature DERIVE_MANAGER = sig (* identifier, description, (fn dtyp_name => param => derive-method) *) val register_derive : string -> string -> (string -> string -> theory -> theory) -> theory -> theory (* identifier, description, (fn dtyp_name => param => derive-method) *) val derive : string -> string -> string -> theory -> theory val derive_cmd : string -> string -> string -> theory -> theory (* print all registered deriving-methods *) val print_info : theory -> unit end structure Derive_Manager : DERIVE_MANAGER = struct structure Derive_Data = Theory_Data ( type T = (string * (string -> string -> theory -> theory)) Symtab.table (* descr * derive-fun *) val empty = Symtab.empty - val extend = I val merge = Symtab.merge (K true) ) val derive_options = Derive_Data.get #> Symtab.dest #> map (fn (id, (descr, _)) => (id, descr)) (* FIXME: possibly use Pretty function for presentation. *) fun print_info thy = let val _ = writeln "The following sorts can be derived" val _ = derive_options thy |> sort_by fst |> map (fn (id,descr) => writeln (id ^ ": " ^ descr)) in () end fun register_derive id descr f thy = if Symtab.defined (Derive_Data.get thy) id then error ("Identifier " ^ quote id ^ " already in use for " ^ quote "deriving") else Derive_Data.map (Symtab.update_new (id, (descr, f))) thy fun gen_derive prep id dtname param thy = (case Symtab.lookup (Derive_Data.get thy) id of NONE => error ("No handler to derive sort " ^ quote id ^ " is registered. Try " ^ quote "print_derives" ^ " to see available sorts.") | SOME (_, f) => f (prep thy dtname) param thy) val derive = gen_derive (K I) fun derive_cmd id param dtname = gen_derive (fn thy => fst o dest_Type o Syntax.parse_typ (Proof_Context.init_global thy)) id dtname param (* TODO: also check for alternative of *) (* NB: Proof_Context.read_type_name_proper ctxt false could be an alternative. *) val _ = Outer_Syntax.command @{command_keyword print_derives} "lists all registered sorts which can be derived" (Scan.succeed (Toplevel.theory (tap print_info))) val _ = Outer_Syntax.command @{command_keyword derive} "derives some sort" (Parse.parname -- Parse.name -- Scan.repeat1 Parse.type_const >> (fn ((param, s), tycons) => Toplevel.theory (fold (derive_cmd s param) tycons))) end diff --git a/thys/Dict_Construction/class_graph.ML b/thys/Dict_Construction/class_graph.ML --- a/thys/Dict_Construction/class_graph.ML +++ b/thys/Dict_Construction/class_graph.ML @@ -1,340 +1,339 @@ signature CLASS_GRAPH = sig type selector = typ -> term type node = {class: string, qname: string, selectors: selector Symtab.table, make: typ -> term, data_thms: thm list, cert: typ -> term, cert_thms: thm * thm * thm list} val dict_typ: node -> typ -> typ type edge = {super_selector: selector, subclass: thm} type path = edge list type ev val class_of: ev -> class val node_of: ev -> node val parents_of: ev -> (edge * ev) Symtab.table val find_path': ev -> (ev -> 'a option) -> (path * 'a) option val find_path: ev -> class -> path option val fold_path: path -> typ -> term -> term val ensure_class: class -> local_theory -> (ev * local_theory) val edges: local_theory -> class -> edge Symtab.table option val node: local_theory -> class -> node option val all_edges: local_theory -> edge Symreltab.table val all_nodes: local_theory -> node Symtab.table val pretty_ev: Proof.context -> ev -> Pretty.T (* utilities *) val mangle: string -> string val param_sorts: string -> class -> theory -> class list list val super_classes: class -> theory -> string list end structure Class_Graph: CLASS_GRAPH = struct open Dict_Construction_Util val mangle = translate_string (fn x => if x = "." then "_" else if x = "_" then "__" else x) fun param_sorts tyco class thy = let val algebra = Sign.classes_of thy in Sorts.mg_domain algebra tyco [class] |> map (filter (Class.is_class thy)) end fun super_classes class thy = let val algebra = Sign.classes_of thy in Sorts.super_classes algebra class |> Sorts.minimize_sort algebra |> filter (Class.is_class thy) |> sort fast_string_ord end type selector = typ -> term type node = {class: string, qname: string, selectors: selector Symtab.table, make: typ -> term, data_thms: thm list, cert: typ -> term, cert_thms: thm * thm * thm list} type edge = {super_selector: selector, subclass: thm} type path = edge list abstype ev = Evidence of class * node * (edge * ev) Symtab.table with fun class_of (Evidence (class, _, _)) = class fun node_of (Evidence (_, node, _)) = node fun parents_of (Evidence (_, _, tab)) = tab fun mk_evidence class node tab = Evidence (class, node, tab) fun find_path' ev is_goal = case is_goal ev of SOME a => SOME ([], a) | NONE => let fun f (_, (edge, ev)) = Option.map (apfst (cons edge)) (find_path' ev is_goal) in Symtab.get_first f (parents_of ev) end fun find_path ev goal = find_path' ev (fn ev => if class_of ev = goal then SOME () else NONE) |> Option.map fst fun pretty_ev ctxt (Evidence (class, {qname, ...}, tab)) = let val typ = @{typ 'a} fun mk_super ({super_selector, ...}, super_ev) = Pretty.block [Pretty.str "selector:", Pretty.brk 1, Syntax.pretty_term ctxt (super_selector typ), Pretty.fbrk, pretty_ev ctxt super_ev] val supers = Symtab.dest tab |> map (fn (_, super) => mk_super super) |> Pretty.big_list "super classes" in Pretty.block [Pretty.str "Evidence for ", Syntax.pretty_sort ctxt [class], Pretty.str ": ", Syntax.pretty_typ ctxt (Type (qname, [typ])), Pretty.str (" (qname = " ^ qname ^ ")"), Pretty.fbrk, supers] end end structure Classes = Generic_Data ( type T = (edge Symtab.table * node) Symtab.table val empty = Symtab.empty fun merge (t1, t2) = if Symtab.is_empty t1 andalso Symtab.is_empty t2 then Symtab.empty else error "merging not supported" - val extend = I ) fun node lthy class = Symtab.lookup (Classes.get (Context.Proof lthy)) class |> Option.map snd fun edges lthy class = Symtab.lookup (Classes.get (Context.Proof lthy)) class |> Option.map fst val all_nodes = Context.Proof #> Classes.get #> Symtab.map (K snd) val all_edges = Context.Proof #> Classes.get #> Symtab.map (K fst) #> symreltab_of_symtab fun dict_typ {qname, ...} typ = Type (qname, [typ]) fun fold_path path typ = fold (fn {super_selector = s, ...} => fn acc => s typ $ acc) path fun mk_super_selector' qualified qname super_ev typ = let val {class = super_class, qname = super_qname, ...} = node_of super_ev val raw_name = mangle super_class ^ "__super" val name = if qualified then Long_Name.append qname raw_name else raw_name in (name, Type (qname, [typ]) --> Type (super_qname, [typ])) end fun mk_node class info super_evs lthy = let fun print_info ctxt = Pretty.block [Pretty.str "Defining record for class ", Syntax.pretty_sort ctxt [class]] |> Pretty.writeln val name = mangle class ^ "__dict" val qname = Local_Theory.full_name lthy (Binding.name name) val tvar = @{typ 'a} val typ = Type (qname, [tvar]) fun mk_field name ftyp = (Binding.name name, ftyp) val params = #params info |> map (fn (name', ftyp) => let val ftyp' = typ_subst_atomic [(TFree ("'a", [class]), @{typ 'a})] ftyp val field_name = mangle name' ^ "__field" val field = mk_field field_name ftyp' fun sel tvar' = Const (Long_Name.append qname field_name, typ_subst_atomic [(tvar, tvar')] (typ --> ftyp')) in (field, (name', sel)) end) val (fields, selectors) = split_list params val super_params = Symtab.dest super_evs |> map (fn (_, super_ev) => let val {cert = raw_super_cert, qname = super_qname, ...} = node_of super_ev val (field_name, _) = mk_super_selector' false qname super_ev tvar val field = mk_field field_name (Type (super_qname, [tvar])) fun sel typ = Const (mk_super_selector' true qname super_ev typ) fun super_cert dict = raw_super_cert tvar $ (sel tvar $ dict) val raw_edge = (class_of super_ev, sel) in (field, raw_edge, super_cert) end) val (super_fields, raw_edges, super_certs) = split_list3 super_params val all_fields = super_fields @ fields fun make typ' = Const (Long_Name.append qname "Dict", typ_subst_atomic [(tvar, typ')] (map #2 all_fields ---> typ)) val cert_name = name ^ "__cert" val cert_binding = Binding.name cert_name val cert_body = let fun local_param_eq ((_, typ), (name, sel)) dict = HOLogic.mk_eq (sel tvar $ dict, Const (name, typ)) in map local_param_eq params @ super_certs end val cert_var_name = "dict" val cert_term = Abs (cert_var_name, typ, List.foldr HOLogic.mk_conj @{term True} (map (fn x => x (Bound 0)) cert_body)) fun prove_thms (cert, cert_def) lthy = let val var = Free (cert_var_name, typ) fun tac ctxt = Local_Defs.unfold_tac ctxt [cert_def] THEN blast_tac ctxt 1 fun prove prop = Goal.prove_future lthy [cert_var_name] [] prop (fn {context, ...} => tac context) fun mk_dest_props raw_prop = HOLogic.mk_Trueprop (cert $ var) ==> HOLogic.mk_Trueprop (raw_prop var) fun mk_intro_cond raw_prop = HOLogic.mk_Trueprop (raw_prop var) val dests = map (fn raw_prop => prove (mk_dest_props raw_prop)) cert_body val intro = prove (map mk_intro_cond cert_body ===> HOLogic.mk_Trueprop (cert $ var)) val (dests', (intro', lthy')) = note_thms Binding.empty dests lthy ||> note_thm Binding.empty intro val (param_dests, super_dests) = chop (length params) dests' fun pre_edges phi = let fun mk_edge thm (sc, sel) = (sc, {super_selector = sel, subclass = Morphism.thm phi thm}) in Symtab.make (map2 mk_edge super_dests raw_edges) end in ((param_dests, pre_edges, intro'), lthy') end val constructor = (((Binding.empty, Binding.name "Dict"), all_fields), NoSyn) val datatyp = (([(NONE, (@{typ 'a}, @{sort type}))], Binding.name name), NoSyn) val dtspec = (Ctr_Sugar.default_ctr_options, [(((datatyp, [constructor]), (Binding.empty, Binding.empty, Binding.empty)), [])]) val (((raw_cert, raw_cert_def), (param_dests, pre_edges, intro)), (lthy', lthy)) = lthy |> tap print_info |> BNF_FP_Def_Sugar.co_datatypes BNF_Util.Least_FP BNF_LFP.construct_lfp dtspec (* FIXME ideally BNF would return a fp_sugar value right here so that I can avoid constructing long names by hand above *) |> (snd o Local_Theory.begin_nested) |> Local_Theory.define ((cert_binding, NoSyn), ((Thm.def_binding cert_binding, []), cert_term)) |>> apsnd snd |> (fn (raw_cert, lthy) => prove_thms raw_cert lthy |>> pair raw_cert) ||> `Local_Theory.end_nested val phi = Proof_Context.export_morphism lthy lthy' fun cert typ = subst_TVars [(("'a", 0), typ)] (Morphism.term phi raw_cert) val cert_def = Morphism.thm phi raw_cert_def val edges = pre_edges phi val param_dests' = map (Morphism.thm phi) param_dests val intro' = Morphism.thm phi intro val data_thms = BNF_FP_Def_Sugar.fp_sugar_of lthy' qname |> the |> #fp_ctr_sugar |> #ctr_sugar |> #sel_thmss |> flat |> map safe_mk_meta_eq val node = {class = class, qname = qname, selectors = Symtab.make selectors, make = make, data_thms = data_thms, cert = cert, cert_thms = (cert_def, intro', param_dests')} in (node, edges, lthy') end fun ensure_class class lthy = if not (Class.is_class (Proof_Context.theory_of lthy) class) then error ("not a proper class: " ^ class) else let val thy = Proof_Context.theory_of lthy val super_classes = super_classes class thy fun collect_super mk_node = let val (super_evs, lthy') = fold_map ensure_class super_classes lthy val raw_tab = Symtab.make (super_classes ~~ super_evs) val (node, edges, lthy'') = mk_node raw_tab lthy' val tab = zip_symtabs pair edges raw_tab val ev = mk_evidence class node tab in (ev, edges, lthy'') end in case Symtab.lookup (Classes.get (Context.Proof lthy)) class of SOME (edge_tab, node) => if super_classes = Symtab.keys edge_tab then let val (ev, _, lthy') = collect_super (fn _ => fn lthy => (node, edge_tab, lthy)) in (ev, lthy') end else (* This happens when a new subclass relationship is established which subsumes or augments previous superclasses. *) error "class with different super classes" | NONE => let val ax_info = Axclass.get_info thy class val (ev, edges, lthy') = collect_super (mk_node class ax_info) val upd = Symtab.update_new (class, (edges, node_of ev)) in (ev, Local_Theory.declaration {pervasive = false, syntax = false} (K (Classes.map upd)) lthy') end end end diff --git a/thys/Dict_Construction/dict_construction.ML b/thys/Dict_Construction/dict_construction.ML --- a/thys/Dict_Construction/dict_construction.ML +++ b/thys/Dict_Construction/dict_construction.ML @@ -1,935 +1,934 @@ signature DICT_CONSTRUCTION = sig datatype cert_proof = Cert | Skip type const type 'a sccs = (string * 'a) list list val annotate_code_eqs: local_theory -> string list -> (const sccs * local_theory) val new_names: local_theory -> const sccs -> (string * const) sccs val symtab_of_sccs: 'a sccs -> 'a Symtab.table val axclass: class -> local_theory -> Class_Graph.node * local_theory val instance: (string * const) Symtab.table -> string -> class -> local_theory -> term * local_theory val term: term Symreltab.table -> (string * const) Symtab.table -> term -> local_theory -> (term * local_theory) val consts: (string * const) Symtab.table -> cert_proof -> (string * const) list -> local_theory -> local_theory (* certification *) type const_info = {fun_info: Function.info option, inducts: thm list option, base_thms: thm list, base_certs: thm list, simps: thm list, code_thms: thm list, (* old defining theorems *) congs: thm list option} type fun_target = (string * class) list * (term * term) type dict_thms = {base_thms: thm list, def_thm: thm} type dict_target = (string * class) list * (term * string * class) val prove_fun_cert: fun_target list -> const_info -> cert_proof -> local_theory -> thm list val prove_dict_cert: dict_target -> dict_thms -> local_theory -> thm val the_info: Proof.context -> string -> const_info (* utilities *) val normalizer_conv: Proof.context -> conv val cong_of_const: Proof.context -> string -> thm option val get_code_eqs: Proof.context -> string -> thm list val group_code_eqs: Proof.context -> string list -> (string * (((string * sort) list * typ) * ((term list * term) * thm option) list)) list list end structure Dict_Construction: DICT_CONSTRUCTION = struct open Class_Graph open Dict_Construction_Util (* FIXME copied from skip_proof.ML *) val (_, make_thm_cterm) = Context.>>> (Context.map_theory_result (Thm.add_oracle (@{binding cert_oracle}, I))) fun make_thm ctxt prop = make_thm_cterm (Thm.cterm_of ctxt prop) fun cheat_tac ctxt i st = resolve_tac ctxt [make_thm ctxt (Var (("A", 0), propT))] i st (** utilities **) val normalizer_conv = Axclass.overload_conv fun cong_of_const ctxt name = let val head = Thm.concl_of #> Logic.dest_equals #> fst #> strip_comb #> fst #> dest_Const #> fst fun applicable thm = try head thm = SOME name in Function_Context_Tree.get_function_congs ctxt |> filter applicable |> try hd end fun group_code_eqs ctxt consts = let val thy = Proof_Context.theory_of ctxt val graph = #eqngr (Code_Preproc.obtain true { ctxt = ctxt, consts = consts, terms = [] }) fun mk_eqs name = name |> Code_Preproc.cert graph |> Code.equations_of_cert thy ||> these ||> map (apsnd fst o apfst (apsnd fst o apfst (map fst))) |> pair name in map (map mk_eqs) (rev (Graph.strong_conn graph)) end fun get_code_eqs ctxt const = AList.lookup op = (flat (group_code_eqs ctxt [const])) const |> the |> snd |> map snd |> cat_options |> map (Conv.fconv_rule (normalizer_conv ctxt)) (** certification **) datatype cert_proof = Cert | Skip type const_info = {fun_info: Function.info option, inducts: thm list option, base_thms: thm list, base_certs: thm list, simps: thm list, code_thms: thm list, congs: thm list option} fun map_const_info f1 f2 f3 f4 f5 f6 f7 {fun_info, inducts, base_thms, base_certs, simps, code_thms, congs} = {fun_info = f1 fun_info, inducts = f2 inducts, base_thms = f3 base_thms, base_certs = f4 base_certs, simps = f5 simps, code_thms = f6 code_thms, congs = f7 congs} fun morph_const_info phi = map_const_info (Option.map (Function_Common.transform_function_data phi)) (Option.map (map (Morphism.thm phi))) (map (Morphism.thm phi)) (map (Morphism.thm phi)) (map (Morphism.thm phi)) I (* sic *) (Option.map (map (Morphism.thm phi))) type fun_target = (string * class) list * (term * term) type dict_thms = {base_thms: thm list, def_thm: thm} type dict_target = (string * class) list * (term * string * class) fun fun_cert_tac base_thms base_certs simps code_thms = SOLVED' o Subgoal.FOCUS (fn {prems, context = ctxt, concl, ...} => let val _ = if_debug ctxt (fn () => tracing ("Proving " ^ Syntax.string_of_term ctxt (Thm.term_of concl))) fun is_ih prem = Thm.prop_of prem |> Logic.strip_imp_concl |> HOLogic.dest_Trueprop |> can HOLogic.dest_eq val (ihs, certs) = partition is_ih prems val super_certs = all_edges ctxt |> Symreltab.dest |> map (#subclass o snd) val param_dests = all_nodes ctxt |> Symtab.dest |> maps (#3 o #cert_thms o snd) val congs = Function_Context_Tree.get_function_congs ctxt @ map safe_mk_meta_eq @{thms cong} val simp_context = (clear_simpset ctxt) addsimps (certs @ super_certs @ base_certs @ base_thms @ param_dests) addloop ("overload", CONVERSION o changed_conv o Axclass.overload_conv) val ihs = map (Simplifier.asm_full_simplify simp_context) ihs val ih_tac = resolve_tac ctxt ihs THEN_ALL_NEW (TRY' (SOLVED' (Simplifier.asm_full_simp_tac simp_context))) val unfold_new = ANY' (map (CONVERSION o rewr_lhs_head_conv) simps) val normalize = CONVERSION (normalizer_conv ctxt) val unfold_old = ANY' (map (CONVERSION o rewr_rhs_head_conv) code_thms) val simp = CONVERSION (lhs_conv (Simplifier.asm_full_rewrite simp_context)) fun walk_congs i = i |> ((resolve_tac ctxt @{thms refl} ORELSE' SOLVED' (Simplifier.asm_full_simp_tac simp_context) ORELSE' ih_tac ORELSE' Method.assm_tac ctxt ORELSE' (resolve_tac ctxt @{thms meta_eq_to_obj_eq} THEN' fo_resolve_tac congs ctxt)) THEN_ALL_NEW walk_congs) val tacs = [unfold_new, normalize, unfold_old, simp, walk_congs] in EVERY' tacs 1 end) fun dict_cert_tac class def_thm base_thms = SOLVED' o Subgoal.FOCUS (fn {prems, context = ctxt, ...} => let val (intro, sels) = case node ctxt class of SOME {cert_thms = (_, intro, _), data_thms = sels, ...} => (intro, sels) | NONE => error ("class " ^ class ^ " is not defined") val apply_intro = resolve_tac ctxt [intro] val unfold_dict = CONVERSION (Conv.rewr_conv def_thm |> Conv.arg_conv |> lhs_conv) val normalize = CONVERSION (normalizer_conv ctxt) val smash_sels = CONVERSION (lhs_conv (Conv.rewrs_conv sels)) val solve = resolve_tac ctxt (@{thm HOL.refl} :: base_thms) val finally = resolve_tac ctxt prems val tacs = [apply_intro, unfold_dict, normalize, smash_sels, solve, finally] in EVERY (map (ALLGOALS' ctxt) tacs) end) fun prepare_dicts classes names lthy = let val sorts = Symtab.make_list classes fun mk_dicts (param_name, (tvar, class)) = case node lthy class of NONE => error ("unknown class " ^ class) | SOME {cert, qname, ...} => let val sort = the (Symtab.lookup sorts tvar) val param = Free (param_name, Type (qname, [TFree (tvar, sort)])) in (param, HOLogic.mk_Trueprop (cert dummyT $ param)) end val dict_names = Name.invent_names names "a" classes val names = fold Name.declare (map fst dict_names) names val (dict_params, prems) = split_list (map mk_dicts dict_names) in (dict_params, prems, names) end fun prepare_fun_goal targets lthy = let fun mk_eq (classes, (lhs, rhs)) names = let val (lhs_name, _) = dest_Const lhs val (rhs_name, rhs_typ) = dest_Const rhs val (dict_params, prems, names) = prepare_dicts classes names lthy val param_names = fst (strip_type rhs_typ) |> map (K dummyT) |> Name.invent_names names "a" val names = fold Name.declare (map fst param_names) names val params = map Free param_names val lhs = list_comb (Const (lhs_name, dummyT), dict_params @ params) val rhs = list_comb (Const (rhs_name, dummyT), params) val eq = Const (@{const_name HOL.eq}, dummyT) $ lhs $ rhs val all_params = dict_params @ params val eq :: rest = Syntax.check_terms lthy (eq :: prems @ all_params) val (prems, all_params) = unappend (prems, all_params) rest val eq = if is_some (Axclass.inst_of_param (Proof_Context.theory_of lthy) rhs_name) then Thm.cterm_of lthy eq |> conv_result (Conv.arg_conv (normalizer_conv lthy)) else eq val prop = prems ===> HOLogic.mk_Trueprop eq in ((all_params, prop), names) end in fold_map mk_eq targets Name.context |> fst |> split_list end fun prepare_dict_goal (classes, (term, _, class)) lthy = let val cert = case node lthy class of NONE => error ("unknown class " ^ class) | SOME {cert, ...} => cert dummyT val names = Name.context val (dict_params, prems, _) = prepare_dicts classes names lthy val (term_name, _) = dest_Const term val dict = list_comb (Const (term_name, dummyT), dict_params) val prop = prems ===> HOLogic.mk_Trueprop (cert $ dict) val prop :: dict_params = Syntax.check_terms lthy (prop :: dict_params) in (dict_params, prop) end fun prove_fun_cert targets {inducts, base_thms, base_certs, simps, code_thms, ...} proof lthy = let (* the props contain dictionary certs as prems we can't exclude them from the induction because the dicts are part of the function definition excluding them would mean that applying the induction rules becomes tricky or impossible proper fix would be if fun, akin to inductive, supported a "for" clause that marks parameters as "not changing" *) val (argss, props) = prepare_fun_goal targets lthy val frees = flat argss |> map (fst o dest_Free) (* we first prove the extensional variant (easier to prove), and then derive the contracted variant abs_def can't deal with premises, so we use our own version here *) val tac = case proof of Cert => fun_cert_tac base_thms base_certs simps code_thms | Skip => cheat_tac val long_thms = prove_common' lthy frees [] props (fn {context, ...} => maybe_induct_tac inducts argss [] context THEN ALLGOALS' context (tac context)) in map (contract lthy) long_thms end fun prove_dict_cert target {base_thms, def_thm} lthy = let val (args, prop) = prepare_dict_goal target lthy val frees = map (fst o dest_Free) args val (_, (_, _, class)) = target in prove' lthy frees [] prop (fn {context, ...} => dict_cert_tac class def_thm base_thms context 1) end (** background data **) type definitions = {instantiations: (term * thm) Symreltab.table, (* key: (class, tyco) *) constants: (string * (thm option * const_info)) Symtab.table (* key: constant name *) } structure Definitions = Generic_Data ( type T = definitions val empty = {instantiations = Symreltab.empty, constants = Symtab.empty} - val extend = I fun merge ({instantiations = i1, constants = c1}, {instantiations = i2, constants = c2}) = if Symreltab.is_empty i1 andalso Symtab.is_empty c1 andalso Symreltab.is_empty i2 andalso Symtab.is_empty c2 then empty else error "merging not supported" ) fun map_definitions map_insts map_consts = Definitions.map (fn {instantiations, constants} => {instantiations = map_insts instantiations, constants = map_consts constants}) fun the_info ctxt name = Symtab.lookup (#constants (Definitions.get (Context.Proof ctxt))) name |> the |> snd |> snd fun add_instantiation (class, tyco) term cert = let fun upd phi = map_definitions (fn tab => if Symreltab.defined tab (class, tyco) then error ("Duplicate instantiation " ^ quote tyco ^ " :: " ^ quote class) else tab |> Symreltab.update ((class, tyco), (Morphism.term phi term, Morphism.thm phi cert))) I in Local_Theory.declaration {pervasive = false, syntax = false} upd end fun add_constant name name' (cert, info) lthy = let val qname = Local_Theory.full_name lthy (Binding.name name') fun upd phi = map_definitions I (fn tab => if Symtab.defined tab name then error ("Duplicate constant " ^ quote name) else tab |> Symtab.update (name, (qname, (Option.map (Morphism.thm phi) cert, morph_const_info phi info)))) in Local_Theory.declaration {pervasive = false, syntax = false} upd lthy |> Local_Theory.note ((Binding.empty, @{attributes [dict_construction_specs]}), #simps info) |> snd end (** classes **) fun axclass class = ensure_class class #>> node_of (** grouping and annotating constants **) datatype const = Fun of {dicts: ((string * class) * typ) list, certs: term list, param_typs: typ list, typ: typ, (* typified *) new_typ: typ, eqs: {params: term list, rhs: term, thm: thm} list, info: Function_Common.info option, cong: thm option} | Constructor | Classparam of {class: class, typ: typ, (* varified *) selector: term (* varified *)} type 'a sccs = (string * 'a) list list fun symtab_of_sccs x = Symtab.make (flat x) fun raw_dict_params tparams lthy = let fun mk_dict tparam class lthy = let val (node, lthy') = axclass class lthy val targ = TFree (tparam, @{sort type}) val typ = dict_typ node targ val cert = #cert node targ in ((((tparam, class), typ), cert), lthy') end fun mk_dicts (tparam, sort) = fold_map (mk_dict tparam) (filter (Class.is_class (Proof_Context.theory_of lthy)) sort) in fold_map mk_dicts tparams lthy |>> flat end fun dict_params context dicts = let fun dict_param ((_, class), typ) = Name.variant (mangle class) #>> rpair typ #>> Free in fold_map dict_param dicts context end fun get_sel class param typ lthy = let val ({selectors, ...}, lthy') = axclass class lthy in case Symtab.lookup selectors param of NONE => error ("unknown class parameter " ^ param) | SOME sel => (sel typ, lthy') end fun annotate_const name ((tparams, typ), raw_eqs) lthy = if Code.is_constr (Proof_Context.theory_of lthy) name then ((name, Constructor), lthy) else if null raw_eqs then (* this detection is reliable, because code equations with overloaded heads are not allowed *) let val (_, class) = the_single tparams ||> the_single val (selector, thy') = get_sel class name (TVar (("'a", 0), @{sort type})) lthy val typ = range_type (fastype_of selector) in ((name, Classparam {class = class, typ = typ, selector = selector}), thy') end else let val info = try (Function.get_info lthy) (Const (name, typ)) val cong = cong_of_const lthy name val ((raw_dicts, certs), lthy') = raw_dict_params tparams lthy |>> split_list val dict_typs = map snd raw_dicts val typ' = typify_typ typ fun mk_eq ((raw_params, rhs), SOME thm) = let val norm = normalizer_conv lthy' val transform = Thm.cterm_of lthy' #> conv_result norm #> typify val params = map transform raw_params in if has_duplicates (op =) (flat (map all_frees' params)) then (warning "ignoring code equation with non-linear pattern"; NONE) else SOME {params = params, rhs = rhs, thm = Conv.fconv_rule norm thm} end | mk_eq _ = error "no theorem" val const = Fun {dicts = raw_dicts, certs = certs, typ = typ', param_typs = binder_types typ', new_typ = dict_typs ---> typ', eqs = map_filter mk_eq raw_eqs, info = info, cong = cong} in ((name, const), lthy') end fun annotate_code_eqs lthy consts = fold_map (fold_map (uncurry annotate_const)) (group_code_eqs lthy consts) lthy (** instances and terms **) fun mk_path [] _ _ lthy = (NONE, lthy) | mk_path ((class, term) :: rest) typ goal lthy = let val (ev, lthy') = ensure_class class lthy in case find_path ev goal of SOME path => (SOME (fold_path path typ term), lthy') | NONE => mk_path rest typ goal lthy' end fun instance consts tyco class lthy = case Symreltab.lookup (#instantiations (Definitions.get (Context.Proof lthy))) (class, tyco) of SOME (inst, _) => (inst, lthy) | NONE => let val thy = Proof_Context.theory_of lthy val tparam_sorts = param_sorts tyco class thy fun print_info ctxt = let val tvars = Name.invent_list [] Name.aT (length tparam_sorts) ~~ tparam_sorts |> map TFree in [Pretty.str "Defining instance ", Syntax.pretty_typ ctxt (Type (tyco, tvars)), Pretty.str " :: ", Syntax.pretty_sort ctxt [class]] |> Pretty.block |> Pretty.writeln end val ({make, ...}, lthy) = axclass class lthy val name = mangle class ^ "__instance__" ^ mangle tyco val tparams = Name.invent_names Name.context Name.aT tparam_sorts val ((dict_params, _), lthy) = raw_dict_params tparams lthy |>> map fst |>> dict_params (Name.make_context [name]) val dict_context = Symreltab.make (flat_right tparams ~~ dict_params) val {params, ...} = Axclass.get_info thy class val (super_fields, lthy) = fold_map (obtain_dict dict_context consts (Type (tyco, map TFree tparams))) (super_classes class thy) lthy val tparams' = map (TFree o rpair @{sort type} o fst) tparams val typ_inst = (TFree ("'a", [class]), Type (tyco, tparams')) fun mk_field (field, typ) = let val param = Axclass.param_of_inst thy (field, tyco) (* check: did we already define all required fields? *) (* if not: abort (else we would run into an infinite loop) *) val _ = case Symtab.lookup (#constants (Definitions.get (Context.Proof lthy))) param of NONE => (* necessary for zero_nat *) if Code.is_constr thy param then () else error ("cyclic dependency: " ^ param ^ " not yet defined in the definition of " ^ tyco ^ " :: " ^ class) | SOME _ => () in term dict_context consts (Const (param, typ_subst_atomic [typ_inst] typ)) end val (fields, lthy) = fold_map mk_field params lthy val rhs = list_comb (make (Type (tyco, tparams')), super_fields @ fields) val typ = map fastype_of dict_params ---> fastype_of rhs val head = Free (name, typ) val lhs = list_comb (head, dict_params) val term = Logic.mk_equals (lhs, rhs) val (def, (lthy', lthy)) = lthy |> tap print_info |> (snd o Local_Theory.begin_nested) |> define_params_nosyn term ||> `Local_Theory.end_nested val phi = Proof_Context.export_morphism lthy lthy' val def = Morphism.thm phi def val base_thms = Definitions.get (Context.Proof lthy') |> #constants |> Symtab.dest |> map (apsnd fst o snd) |> map_filter snd val target = (flat_right tparams, (Morphism.term phi head, tyco, class)) val args = {base_thms = base_thms, def_thm = def} val thm = prove_dict_cert target args lthy' val const = Const (Local_Theory.full_name lthy' (Binding.name name), typ) in (const, add_instantiation (class, tyco) const thm lthy') end and obtain_dict dict_context consts = let val dict_context' = Symreltab.dest dict_context fun for_class (Type (tyco, args)) class lthy = let val inst_param_sorts = param_sorts tyco class (Proof_Context.theory_of lthy) val (raw_inst, lthy') = instance consts tyco class lthy val (const_name, _) = dest_Const raw_inst val (inst_args, lthy'') = fold_map for_sort (inst_param_sorts ~~ args) lthy' val head = Sign.mk_const (Proof_Context.theory_of lthy'') (const_name, args) in (list_comb (head, flat inst_args), lthy'') end | for_class (TFree (name, _)) class lthy = let val available = map_filter (fn ((tp, class), term) => if tp = name then SOME (class, term) else NONE) dict_context' val (path, lthy') = mk_path available (TFree (name, @{sort type})) class lthy in case path of SOME term => (term, lthy') | NONE => error "no path found" end | for_class (TVar _) _ _ = error "unexpected type variable" and for_sort (sort, typ) = fold_map (for_class typ) sort in for_class end and term dict_context consts term lthy = let fun traverse (t as Const (name, typ)) lthy = (case Symtab.lookup consts name of NONE => error ("unknown constant " ^ name) | SOME (_, Constructor) => (typify t, lthy) | SOME (_, Classparam {class, typ = typ', selector}) => let val subst = Sign.typ_match (Proof_Context.theory_of lthy) (typ', typ) Vartab.empty val (_, targ) = the (Vartab.lookup subst ("'a", 0)) val (dict, lthy') = obtain_dict dict_context consts targ class lthy in (subst_TVars [(("'a", 0), targ)] selector $ dict, lthy') end | SOME (name', Fun {dicts = dicts, typ = typ', new_typ, ...}) => let val subst = Type.raw_match (Logic.varifyT_global typ', typ) Vartab.empty |> Vartab.dest |> map (apsnd snd) fun lookup tparam = the (AList.lookup (op =) subst (tparam, 0)) val (dicts, lthy') = fold_map (uncurry (obtain_dict dict_context consts o lookup)) (map fst dicts) lthy val typ = typ_subst_TVars subst (Logic.varifyT_global new_typ) val head = case Symtab.lookup (#constants (Definitions.get (Context.Proof lthy))) name of NONE => Free (name', typ) | SOME (n, _) => Const (n, typ) val res = list_comb (head, dicts) in (res, lthy') end) | traverse (f $ x) lthy = let val (f', lthy') = traverse f lthy val (x', lthy'') = traverse x lthy' in (f' $ x', lthy'') end | traverse (Abs (name, typ, term)) lthy = let val (term', lthy') = traverse term lthy in (Abs (name, typify_typ typ, term'), lthy') end | traverse (Free (name, typ)) lthy = (Free (name, typify_typ typ), lthy) | traverse (Var (name, typ)) lthy = (Var (name, typify_typ typ), lthy) | traverse (Bound n) lthy = (Bound n, lthy) in traverse term lthy end (** group of constants **) fun new_names lthy consts = let val (all_names, all_consts) = split_list (flat consts) val all_frees = map (fn Fun {eqs, ...} => eqs | _ => []) all_consts |> flat |> map #params |> flat |> map all_frees' |> flat val context = fold Name.declare (all_names @ all_frees) (Variable.names_of lthy) fun new_name (name, const) context = let val (name', context') = Name.variant (mangle name) context in ((name, (name', const)), context') end in fst (fold_map (fold_map new_name) consts context) end fun consts consts proof group lthy = let val fun_config = Function_Common.FunctionConfig {sequential=true, default=NONE, domintros=false, partials=false} fun pat_completeness_auto ctxt = Pat_Completeness.pat_completeness_tac ctxt 1 THEN auto_tac ctxt val all_names = map fst group val pretty_consts = map (pretty_const lthy) all_names |> Pretty.commas fun print_info msg = Pretty.str (msg ^ " ") :: pretty_consts |> Pretty.block |> Pretty.writeln val _ = print_info "Redefining constant(s)" fun process_eqs (name, Fun {dicts, param_typs, new_typ, eqs, info, cong, ...}) lthy = let val new_name = case Symtab.lookup consts name of NONE => error ("no new name for " ^ name) | SOME (n, _) => n val all_frees = map #params eqs |> flat |> map all_frees' |> flat val context = Name.make_context (all_names @ all_frees) val (dict_params, context') = dict_params context dicts fun adapt_params param_typs params = let val real_params = dict_params @ params val ext_params = drop (length params) param_typs |> map typify_typ |> Name.invent_names context' "e0" |> map Free in (real_params, ext_params) end fun mk_eq {params, rhs, thm} lthy = let val (real_params, ext_params) = adapt_params param_typs params val lhs' = list_comb (Free (new_name, new_typ), real_params @ ext_params) val (rhs', lthy') = term (Symreltab.make (map fst dicts ~~ dict_params)) consts rhs lthy val rhs'' = list_comb (rhs', ext_params) in ((HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs', rhs'')), thm), lthy') end val is_fun = length param_typs + length dicts > 0 in fold_map mk_eq eqs lthy |>> rpair (new_typ, is_fun) |>> SOME |>> pair ((name, new_name, map fst dicts), {info = info, cong = cong}) end | process_eqs (name, _) lthy = ((((name, name, []), {info = NONE, cong = NONE}), NONE), lthy) val (items, lthy') = fold_map process_eqs group lthy val ((metas, infos), ((eqs, code_thms), (new_typs, is_funs))) = items |> map_filter (fn (meta, eqs) => Option.map (pair meta) eqs) |> split_list ||> split_list ||> apfst (flat #> split_list #>> map typify) ||> apsnd split_list |>> split_list val _ = if_debug lthy (fn () => if null code_thms then () else map (Syntax.pretty_term lthy o Thm.prop_of) code_thms |> Pretty.big_list "Equations:" |> Pretty.string_of |> tracing) val is_fun = case distinct (op =) is_funs of [b] => b | [] => false | _ => error "unsupported feature: mixed non-function and function definitions" fun mk_binding (_, new_name, _) typ = (Binding.name new_name, SOME typ, NoSyn) val bindings = map2 mk_binding metas new_typs val {constants, instantiations} = Definitions.get (Context.Proof lthy') val base_thms = Symtab.dest constants |> map (apsnd fst o snd) |> map_filter snd val base_certs = Symreltab.dest instantiations |> map (snd o snd) val consts = Sign.consts_of (Proof_Context.theory_of lthy') fun prove_eq_fun (info as {simps = SOME simps, fs, inducts = SOME inducts, ...}) lthy = let fun mk_target (name, _, classes) new = (classes, (new, Const (Consts.the_const consts name))) val targets = map2 mk_target metas fs val args = {fun_info = SOME info, inducts = SOME inducts, simps = simps, base_thms = base_thms, base_certs = base_certs, code_thms = code_thms, congs = NONE} in (prove_fun_cert targets args proof lthy, args) end fun prove_eq_def defs lthy = let fun mk_target (name, _, classes) new = (classes, (new, Const (Consts.the_const consts name))) val targets = map2 mk_target metas (map (fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) defs) val args = {fun_info = NONE, inducts = NONE, simps = defs, base_thms = base_thms, base_certs = base_certs, code_thms = code_thms, congs = NONE} in (prove_fun_cert targets args proof lthy, args) end fun add_constants ((((name, name', _), _), SOME _) :: xs) ((thm :: thms), info) = add_constant name name' (SOME thm, info) #> add_constants xs (thms, info) | add_constants ((((name, name', _), _), NONE) :: xs) (thms, info) = add_constant name name' (NONE, info) #> add_constants xs (thms, info) | add_constants [] _ = I fun prove_termination new_info ctxt = let val termination_ctxt = ctxt addsimps (@{thms equal} @ base_thms) addloop ("overload", CONVERSION o changed_conv o Axclass.overload_conv) val fallback_tac = Function_Common.termination_prover_tac true termination_ctxt val tac = case try hd (cat_options (map #info infos)) of SOME old_info => HEADGOAL (Transfer_Termination.termination_tac new_info old_info ctxt) | NONE => no_tac in Function.prove_termination NONE (tac ORELSE fallback_tac) ctxt end fun prove_cong data lthy = let fun rewr_cong thm cong = if Thm.nprems_of thm > 0 then (warning "No fundef_cong rule can be derived; this will likely not work later"; NONE) else (print_info "Porting fundef_cong rule for "; SOME (Local_Defs.fold lthy [thm] cong)) val congs' = map2 (Option.mapPartial o rewr_cong) (fst data) (map #cong infos) |> cat_options fun add_congs phi = fold Function_Context_Tree.add_function_cong (map (Morphism.thm phi) congs') val data' = apsnd (map_const_info I I I I I I (K (SOME congs'))) data in (data', Local_Theory.declaration {pervasive = false, syntax = false} add_congs lthy) end fun mk_fun lthy = let val specs = map (fn eq => (((Binding.empty, []), eq), [], [])) eqs val (info, lthy') = Function.add_function bindings specs fun_config pat_completeness_auto lthy |-> prove_termination val simps = the (#simps info) val (_, lthy'') = (* [simp del] is required because otherwise non-matching function definitions (e.g. divmod_nat) make the simplifier loop separate step because otherwise we'll get tons of warnings because the psimp rules are not added to the simpset *) Local_Theory.note ((Binding.empty, @{attributes [simp del]}), simps) lthy' fun prove_eq phi = prove_eq_fun (Function_Common.transform_function_data phi info) in (((simps, #inducts info), prove_eq), lthy'') end fun mk_def lthy = let val (defs, lthy') = fold_map define_params_nosyn eqs lthy fun prove_eq phi = prove_eq_def (map (Morphism.thm phi) defs) in (((defs, NONE), prove_eq), lthy') end in if null eqs then lthy' else let (* the redefinition itself doesn't have a sort constraint, but the equality prop may have one; hence the proof needs to happen after exiting the local theory target conceptually, everything happening locally would be great, but the type checker won't allow us to add sort constraints to TFrees after they have been declared *) val ((side, prove_eq), (lthy', lthy)) = lthy' |> (snd o Local_Theory.begin_nested) |> (if is_fun then mk_fun else mk_def) |-> (fn ((simps, inducts), prove_eq) => apfst (rpair prove_eq) o Side_Conditions.mk_side simps inducts) ||> `Local_Theory.end_nested val phi = Proof_Context.export_morphism lthy lthy' in lthy' |> `(prove_eq phi) |>> apfst (on_thms_complete (fn () => print_info "Proved equivalence for")) |-> prove_cong |-> add_constants items end end fun const_raw (binding, raw_consts) proof lthy = let val _ = if proof = Skip then warning "Skipping certificate proofs" else () val (name, _) = Syntax.read_terms lthy raw_consts |> map dest_Const |> split_list val (eqs, lthy) = annotate_code_eqs lthy name val tab = symtab_of_sccs (new_names lthy eqs) val lthy = fold (consts tab proof) eqs lthy val {instantiations, constants} = Definitions.get (Context.Proof lthy) val thms = map (snd o snd) (Symreltab.dest instantiations) @ map_filter (fst o snd o snd) (Symtab.dest constants) in snd (Local_Theory.note (binding, thms) lthy) end (** setup **) val parse_flags = Scan.optional (Args.parens (Parse.reserved "skip" >> K Skip)) Cert val _ = Outer_Syntax.local_theory @{command_keyword "declassify"} "redefines a constant after applying the dictionary construction" (parse_flags -- Parse_Spec.opt_thm_name ":" -- Scan.repeat1 Parse.const >> (fn ((flags, def_binding), consts) => const_raw (def_binding, consts) flags)) end \ No newline at end of file diff --git a/thys/Dict_Construction/side_conditions.ML b/thys/Dict_Construction/side_conditions.ML --- a/thys/Dict_Construction/side_conditions.ML +++ b/thys/Dict_Construction/side_conditions.ML @@ -1,240 +1,239 @@ signature SIDE_CONDITIONS = sig type predicate = {f: term, index: int, inductive: Inductive.result, alt: thm option} val transform_predicate: morphism -> predicate -> predicate val get_predicate: Proof.context -> term -> predicate option val set_alt: term -> thm -> Context.generic -> Context.generic val is_total: Proof.context -> term -> bool val mk_side: thm list -> thm list option -> local_theory -> predicate list * local_theory val time_limit: real Config.T end structure Side_Conditions : SIDE_CONDITIONS = struct open Dict_Construction_Util val time_limit = Attrib.setup_config_real @{binding side_conditions_time_limit} (K 5.0) val inductive_config = {quiet_mode = true, verbose = true, alt_name = Binding.empty, coind = false, no_elim = false, no_ind = false, skip_mono = false} type predicate = {f: term, index: int, inductive: Inductive.result, alt: thm option} fun transform_predicate phi {f, index, inductive, alt} = {f = Morphism.term phi f, index = index, inductive = Inductive.transform_result phi inductive, alt = Option.map (Morphism.thm phi) alt} structure Predicates = Generic_Data ( type T = predicate Item_Net.T val empty = Item_Net.init (op aconv o apply2 #f) (single o #f) val merge = Item_Net.merge - val extend = I ) fun get_predicate ctxt t = Item_Net.retrieve (Predicates.get (Context.Proof ctxt)) t |> try hd |> Option.map (transform_predicate (Morphism.transfer_morphism (Proof_Context.theory_of ctxt))) fun is_total ctxt t = let val SOME {alt = SOME alt, ...} = get_predicate ctxt t val (_, rhs) = Logic.dest_equals (Thm.prop_of alt) in rhs = @{term True} end (* must be of the form [f_side ?x ?y = True] *) fun set_alt t thm context = let val thm = safe_mk_meta_eq thm val (lhs, _) = Logic.dest_equals (Thm.prop_of thm) val {f, index, inductive, ...} = hd (Item_Net.retrieve (Predicates.get context) t) val pred = nth (#preds inductive) index val (arg_typs, _) = strip_type (fastype_of pred) val args = Name.invent_names (Variable.names_of (Context.proof_of context)) "x" arg_typs |> map Free val new_pred = {f = f, index = index, inductive = inductive, alt = SOME thm} in if Pattern.matches (Context.theory_of context) (lhs, list_comb (pred, args)) then Predicates.map (Item_Net.update new_pred) context else error "Alternative is not fully general" end fun apply_simps ctxt clear thms t = let val ctxt' = Context_Position.not_really ctxt |> clear ? put_simpset HOL_ss in conv_result (Simplifier.asm_full_rewrite (ctxt' addsimps thms)) t end fun apply_alts ctxt = Item_Net.content (Predicates.get (Context.Proof ctxt)) |> map #alt |> cat_options |> apply_simps ctxt true fun apply_intros ctxt = Item_Net.content (Predicates.get (Context.Proof ctxt)) |> map #inductive |> maps #intrs |> apply_simps ctxt false fun dest_head (Free (name, typ)) = (name, typ) | dest_head (Const (name, typ)) = (Long_Name.base_name name, typ) val sideN = "_side" fun mk_side simps inducts lthy = let val thy = Proof_Context.theory_of lthy val ((_, simps), names) = Variable.import true simps lthy ||> Variable.names_of val (lhss, rhss) = map (HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) simps |> split_list val heads = map (`dest_head o (fst o strip_comb)) lhss fun mk_typ t = binder_types t ---> @{typ bool} val sides = map (apfst (suffix sideN) o apsnd mk_typ o fst) heads fun mk_pred_app pred (f, xs) = let val pred_typs = binder_types (fastype_of pred) val exp_param_count = length pred_typs val f_typs = take exp_param_count (binder_types (fastype_of f)) val pred' = Envir.subst_term_types (fold (Sign.typ_match thy) (pred_typs ~~ f_typs) Vartab.empty) pred val diff = exp_param_count - length xs in if diff > 0 then let val bounds = map Bound (0 upto diff - 1) val alls = map (K ("x", dummyT)) (0 upto diff - 1) val prop = Logic.list_all (alls, HOLogic.mk_Trueprop (list_comb (pred', xs @ bounds))) in prop (* fishy *) end else HOLogic.mk_Trueprop (list_comb (pred', take exp_param_count xs)) end fun mk_cond f xs = if is_Abs f then (* do not look this up in the Item_Net, it'll only end in tears *) NONE else case get_predicate lthy f of NONE => (case find_index (equal f o snd) heads of ~1 => NONE (* in this case we don't know anything about f; it may be a constructor *) | index => SOME (mk_pred_app (Free (nth sides index)) (f, xs))) | SOME {index, inductive = {preds, ...}, ...} => SOME (mk_pred_app (nth preds index) (f, xs)) fun mk_atom f = (* in this branch, if f has a non-const-true predicate, it is most likely that there is a missing congruence rule *) the_list (mk_cond f []) fun mk_cong t _ cs = let val cs' = maps (fn (ctx, ts) => map (Congruences.export_term_ctx ctx) ts) (tl cs) val (f, xs) = strip_comb t val cs = mk_cond f xs in the_list cs @ cs' end val rules = map (Congruences.import_rule lthy) (Function.get_congs lthy) val premss = map (Congruences.import_term lthy rules) rhss |> map (Congruences.fold_tree mk_atom mk_cong) val concls = map Free sides ~~ map (snd o strip_comb) lhss |> map (HOLogic.mk_Trueprop o list_comb) val time = Time.fromReal (Config.get lthy time_limit) val intros = map Logic.list_implies (premss ~~ concls) |> Syntax.check_terms lthy |> map (apply_alts lthy o Thm.cterm_of lthy) |> Par_List.map (with_timeout time (apply_intros lthy o Thm.cterm_of lthy)) val inds = map (rpair NoSyn o apfst Binding.name) (distinct op = sides) val (result, lthy') = Inductive.add_inductive inductive_config inds [] (map (pair (Binding.empty, [])) intros) [] lthy fun mk_impartial_goal pred names = let val param_typs = binder_types (fastype_of pred) val (args, names) = fold_map (fn typ => apfst (Free o rpair typ) o Name.variant "x") param_typs names val goal = HOLogic.mk_Trueprop (list_comb (pred, args)) in ((goal, args), names) end val ((props, instss), _) = fold_map mk_impartial_goal (#preds result) names |>> split_list val frees = flat instss |> map (fst o dest_Free) fun tactic {context = ctxt, ...} = let val simp_context = put_simpset HOL_ss (Context_Position.not_really ctxt) addsimps (#intrs result) in maybe_induct_tac inducts instss [] ctxt THEN PARALLEL_ALLGOALS (Nitpick_Util.DETERM_TIMEOUT time o asm_full_simp_tac simp_context) end val alts = try (Goal.prove_common lthy' NONE frees [] props) tactic |> Option.map (map (mk_eq o Thm.close_derivation \<^here>)) val _ = if is_none alts then Pretty.str "Potentially underspecified function(s): " :: Pretty.commas (map (Syntax.pretty_term lthy o snd) (distinct op = heads)) |> Pretty.block |> Pretty.string_of |> warning else () fun mk_pred n t = {f = t, index = n, inductive = result, alt = Option.map (fn alts => nth alts n) alts} val preds = map_index (fn (n, (_, t)) => mk_pred n t) (distinct op = heads) val lthy'' = Local_Theory.declaration {pervasive = false, syntax = false} (fn phi => fold (Predicates.map o Item_Net.update o transform_predicate phi) preds) lthy' in (preds, lthy'') end end \ No newline at end of file diff --git a/thys/Generic_Deriving/derive_util.ML b/thys/Generic_Deriving/derive_util.ML --- a/thys/Generic_Deriving/derive_util.ML +++ b/thys/Generic_Deriving/derive_util.ML @@ -1,324 +1,321 @@ signature DERIVE_UTIL = sig type ctr_info = (string * (string * typ list) list) list type rep_type_info = {repname : string, rep_type : typ, tFrees_mapping : (typ * typ) list, from_info : Function_Common.info option, to_info : Function_Common.info option} type comb_type_info = {combname : string, combname_full : string, comb_type : typ, ctr_type : typ, inConst : term, inConst_free : term, inConst_type : typ, rep_type_instantiated : typ} type type_info = {tname : string, uses_metadata : bool, tfrees : (typ * sort) list, mutual_tnames : string list, mutual_Ts : typ list, mutual_ctrs : ctr_info, mutual_sels : (string * string list list) list, is_rec : bool, is_mutually_rec : bool, rep_info : rep_type_info, comb_info : comb_type_info option, iso_thm : thm option} type class_info = {classname : string, class : sort, params : (class * (string * typ)) list option, class_law : thm option, class_law_const : term option, ops : term list option, transfer_law : (string * thm list) list option, axioms : thm list option, axioms_def : thm option, class_def : thm option, equivalence_thm : thm option} type instance_info = {defs : thm list} val is_typeT : typ -> bool val insert_application : term -> term -> term val add_tvars : string -> string list -> string val replace_tfree : string list -> string -> string -> string val ctrs_arguments : ctr_info -> typ list val collect_tfrees : ctr_info -> (typ * sort) list val collect_tfree_names : ctr_info -> string list val combs_to_list : term -> term list val get_tvar : typ list -> typ val not_instantiated : theory -> string -> class -> bool (* version of add_fun that doesn't throw away info *) val add_fun' : (binding * typ option * mixfix) list -> Specification.multi_specs -> Function_Common.function_config -> local_theory -> (Function_Common.info * Proof.context) val add_conversion_info : Function_Common.info -> Function_Common.info -> type_info -> type_info val add_iso_info : thm option -> type_info -> type_info val has_class_law : string -> theory -> bool val zero_tvarsT : typ -> typ val zero_tvars : term -> term val get_superclasses : sort -> string -> theory -> string list val tagged_function_termination_tac : Proof.context -> Function.info * local_theory val get_mapping_function : Proof.context -> typ -> term val is_polymorphic : typ -> bool (* determines all mutual recursive types of a given BNF-least-fixpoint-type *) val mutual_recursive_types : string -> Proof.context -> string list * typ list val freeify_tvars : typ -> typ (* delivers a full type from a type name by instantiating the type-variables of that type with different variables of a given sort, also returns the chosen variables as second component *) val typ_and_vs_of_typname : theory -> string -> sort -> typ * (string * sort) list val constr_terms : Proof.context -> string -> term list end structure Derive_Util : DERIVE_UTIL = struct type ctr_info = (string * (string * typ list) list) list type rep_type_info = {repname : string, rep_type : typ, tFrees_mapping : (typ * typ) list, from_info : Function_Common.info option, to_info : Function_Common.info option} type comb_type_info = {combname : string, combname_full : string, comb_type : typ, ctr_type : typ, inConst : term, inConst_free : term, inConst_type : typ, rep_type_instantiated : typ} type type_info = {tname : string, uses_metadata : bool, tfrees : (typ * sort) list, mutual_tnames : string list, mutual_Ts : typ list, mutual_ctrs : ctr_info, mutual_sels : (string * string list list) list, is_rec : bool, is_mutually_rec : bool, rep_info : rep_type_info, comb_info : comb_type_info option, iso_thm : thm option} type class_info = {classname : string, class : sort, params : (class * (string * typ)) list option, class_law : thm option, class_law_const : term option, ops : term list option, transfer_law : (string * thm list) list option, axioms : thm list option, axioms_def : thm option, class_def : thm option, equivalence_thm : thm option} type instance_info = {defs : thm list} val is_typeT = fn (Type _) => true | _ => false fun insert_application (t1 $ t2) t3 = insert_application t1 (insert_application t2 t3) | insert_application t t3 = t $ t3 fun add_tvars tname tvar_names = let fun zip_tvars [] = "" | zip_tvars [x] = x | zip_tvars (x::xs) = x ^ ", " ^ (zip_tvars xs) in case tvar_names of [] => tname | xs => "(" ^ zip_tvars xs ^ ") " ^ tname end (* replace tfree by replacement_name if it occurs in tfree_names *) fun replace_tfree tfree_names replacement_name tfree = (case List.find (curry (op =) tfree) tfree_names of SOME _ => replacement_name | NONE => tfree) (* Operations on constructor information *) val ctrs_arguments = (map (fn l => map snd (snd l))) #> flat #> flat fun collect_tfrees ctrs = map (fn (t,s) => (TFree (t,s),s)) (fold Term.add_tfreesT (ctrs_arguments ctrs) []) fun collect_tfree_names ctrs = fold Term.add_tfree_namesT (ctrs_arguments ctrs) [] fun not_instantiated thy tname class = null (Thm.thynames_of_arity thy (tname, class)) fun combs_to_list t = let fun combs_to_list_aux (t1 $ t2) = t2 :: (combs_to_list_aux t1) | combs_to_list_aux t = [t] in rev (combs_to_list_aux t) end fun get_tvar ts = case ts of [] => TFree ("'a", \<^sort>\type\) | (t::ts) => case t of T as TFree _ => T | Type (_,xs) => get_tvar (xs@ts) | _ => get_tvar ts fun add_fun' binding specs config lthy = let fun pat_completeness_auto ctxt = Pat_Completeness.pat_completeness_tac ctxt 1 THEN auto_tac ctxt fun prove_termination lthy = Function.prove_termination NONE (Function_Common.termination_prover_tac false lthy) lthy in lthy |> (Function.add_function binding specs config) pat_completeness_auto |> snd |> prove_termination end fun add_conversion_info from_info to_info (ty_info : type_info) = let val {tname, uses_metadata, tfrees, mutual_tnames, mutual_Ts, mutual_ctrs, mutual_sels, is_rec, is_mutually_rec, rep_info, comb_info, iso_thm} = ty_info val {repname, rep_type, tFrees_mapping, ...} = rep_info in {tname = tname, uses_metadata = uses_metadata, tfrees = tfrees, mutual_tnames = mutual_tnames, mutual_Ts = mutual_Ts, mutual_ctrs = mutual_ctrs, mutual_sels = mutual_sels, is_rec = is_rec, is_mutually_rec = is_mutually_rec, rep_info = {repname = repname, rep_type = rep_type, tFrees_mapping = tFrees_mapping, from_info = SOME from_info, to_info = SOME to_info} , comb_info = comb_info, iso_thm = iso_thm} : type_info end fun add_iso_info iso_thm (ty_info : type_info) = let val {tname, uses_metadata, tfrees, mutual_tnames, mutual_Ts, mutual_ctrs, mutual_sels, is_rec, is_mutually_rec, rep_info, comb_info, ...} = ty_info in {tname = tname, uses_metadata = uses_metadata, tfrees = tfrees, mutual_tnames = mutual_tnames, mutual_Ts = mutual_Ts, mutual_ctrs = mutual_ctrs, mutual_sels = mutual_sels, is_rec = is_rec, is_mutually_rec = is_mutually_rec, rep_info = rep_info, comb_info = comb_info, iso_thm = iso_thm} : type_info end fun has_class_law classname thy = let val class = Syntax.parse_sort (Proof_Context.init_global thy) classname |> hd in is_some (Class.rules thy class |> fst) end fun zero_tvarsT (Type (s,ts)) = Type (s, map zero_tvarsT ts) | zero_tvarsT (TVar ((n,_),s)) = TVar ((n,0),s) | zero_tvarsT T = T fun zero_tvars t = map_types zero_tvarsT t fun unique [] = [] | unique (x::xs) = let fun remove (_,[]) = [] | remove (x,y::ys) = if x = y then remove(x,ys) else y::remove(x,ys) in x::unique(remove(x,xs)) end fun get_superclasses class classname thy = let val all_classes = (Class.these_params thy class) |> map (snd #> fst) val superclasses = filter (curry (op =) classname #> not) all_classes in unique superclasses end fun tagged_function_termination_tac ctxt = let val prod_simp_thm = @{thm size_tagged_prod_simp} fun measure_tac ctxt = Function_Relation.relation_infer_tac ctxt ((Const (\<^const_name>\measure\,dummyT)) $ (Const (\<^const_name>\size\,dummyT))) fun prove_termination ctxt = auto_tac (Simplifier.add_simp prod_simp_thm ctxt) in Function.prove_termination NONE ((HEADGOAL (measure_tac ctxt)) THEN (prove_termination ctxt)) ctxt end fun get_mapping_function lthy T = let val map_thms = BNF_GFP_Rec_Sugar.map_thms_of_type lthy T val map_const = Thm.full_prop_of (hd map_thms) |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst |> strip_comb |> fst |> dest_Const |> apsnd (K dummyT) |> Const in map_const end fun is_polymorphic T = not (null (Term.add_tfreesT T [])) (* Code copied from generator_aux.ML in AFP entry Deriving by Sternagel and Thiemann *) fun typ_and_vs_of_typname thy typ_name sort = let val ar = Sign.arity_number thy typ_name val sorts = map (K sort) (1 upto ar) val ty_vars = Name.invent_names (Name.make_context [typ_name]) "a" sorts val ty = Type (typ_name,map TFree ty_vars) in (ty,ty_vars) end val freeify_tvars = map_type_tvar (TFree o apfst fst) fun mutual_recursive_types tyco lthy = (case BNF_FP_Def_Sugar.fp_sugar_of lthy tyco of SOME sugar => if Sign.arity_number (Proof_Context.theory_of lthy) tyco - BNF_Def.live_of_bnf (#fp_bnf sugar) > 0 then error "only datatypes without dead type parameters are supported" else if #fp sugar = BNF_Util.Least_FP then sugar |> #fp_res |> #Ts |> `(map (fst o dest_Type)) ||> map freeify_tvars else error "only least fixpoints are supported" | NONE => error ("type " ^ quote tyco ^ " does not appear to be a new style datatype")) (* Code copied from bnf_access.ML in AFP entry Deriving by Sternagel and Thiemann *) fun constr_terms lthy = BNF_FP_Def_Sugar.fp_sugar_of lthy #> the #> #fp_ctr_sugar #> #ctr_sugar #> #ctrs end structure Type_Data = Theory_Data ( type T = Derive_Util.type_info Symreltab.table; val empty = Symreltab.empty; - val extend = I; fun merge data : T = Symreltab.merge (K true) data; ); structure Class_Data = Theory_Data ( type T = Derive_Util.class_info Symtab.table; val empty = Symtab.empty; - val extend = I; fun merge data : T = Symtab.merge (K true) data; ); structure Instance_Data = Theory_Data ( type T = Derive_Util.instance_info Symreltab.table; val empty = Symreltab.empty; - val extend = I; fun merge data : T = Symreltab.merge (K true) data; ); \ No newline at end of file diff --git a/thys/IMP2/lib/named_simpsets.ML b/thys/IMP2/lib/named_simpsets.ML --- a/thys/IMP2/lib/named_simpsets.ML +++ b/thys/IMP2/lib/named_simpsets.ML @@ -1,161 +1,160 @@ (* Named simpsets. Derived from named_theorems.ML *) signature NAMED_SIMPSETS = sig val get: Proof.context -> string -> simpset val clear: string -> Context.generic -> Context.generic val map: string -> (simpset -> simpset) -> Context.generic -> Context.generic val map_ctxt: string -> (Proof.context -> Proof.context) -> Context.generic -> Context.generic val put: string -> Proof.context -> Proof.context val get_all: Proof.context -> simpset Name_Space.table val add_simp: string -> thm -> Context.generic -> Context.generic val del_simp: string -> thm -> Context.generic -> Context.generic val add_cong: string -> thm -> Context.generic -> Context.generic val del_cong: string -> thm -> Context.generic -> Context.generic val add_split: string -> thm -> Context.generic -> Context.generic val del_split: string -> thm -> Context.generic -> Context.generic val add_attr: string -> attribute val del_attr: string -> attribute val add_cong_attr: string -> attribute val del_cong_attr: string -> attribute val add_split_attr: string -> attribute val del_split_attr: string -> attribute val check: Proof.context -> xstring * Position.T -> string val declare: binding -> simpset option -> local_theory -> local_theory val declare_cmd: binding -> (xstring * Position.T) option -> local_theory -> local_theory end; structure Named_Simpsets: NAMED_SIMPSETS = struct (* context data *) structure Data = Generic_Data ( type T = simpset Name_Space.table; val empty: T = Name_Space.empty_table "named-simpset"; - val extend = I; val merge : T * T -> T = Name_Space.join_tables (K merge_ss); ); val content = Name_Space.get o Data.get val get = content o Context.Proof; val get_all = Data.get o Context.Proof fun put name ctxt = put_simpset (get ctxt name) ctxt fun map name f context = (content context name; Data.map (Name_Space.map_table_entry name f) context); fun map_ctxt name f context = map name (simpset_map (Context.proof_of context) f) context (* maintain content *) fun clear name = map_ctxt name clear_simpset; fun add_simp name thm = map_ctxt name (Simplifier.add_simp thm) fun del_simp name thm = map_ctxt name (Simplifier.del_simp thm) fun add_cong name thm = map_ctxt name (Simplifier.add_cong thm) fun del_cong name thm = map_ctxt name (Simplifier.del_cong thm) fun add_split name thm = map_ctxt name (Splitter.add_split thm) fun del_split name thm = map_ctxt name (Splitter.del_split thm) val add_attr = Thm.declaration_attribute o add_simp; val del_attr = Thm.declaration_attribute o del_simp; val add_cong_attr = Thm.declaration_attribute o add_cong; val del_cong_attr = Thm.declaration_attribute o del_cong; val add_split_attr = Thm.declaration_attribute o add_split; val del_split_attr = Thm.declaration_attribute o del_split; (* check *) fun check ctxt = let val context = Context.Proof ctxt in Name_Space.check context (Data.get context) #> #1 end (* declaration *) fun new_entry binding init = let fun decl _ context = let val sstab = Data.get context val ss = the_default (Raw_Simplifier.clear_simpset (Context.proof_of context) |> simpset_of) init val (_,sstab) = Name_Space.define context true (binding,ss) sstab in Data.put sstab context end in Local_Theory.declaration {syntax=false, pervasive=true} decl end fun declare binding init lthy = let val lthy' = lthy |> new_entry binding init in (lthy') end; fun declare_cmd binding init_src lthy = let val init = Option.map (get lthy o check lthy) init_src in declare binding init lthy end val named_simpset_attr = (Args.context -- Scan.lift (Parse.position Args.embedded)) :|-- (fn (ctxt,raw_binding) => let val name = check ctxt raw_binding in (Scan.lift (Args.$$$ "simp") |-- Attrib.add_del (add_attr name) (del_attr name)) || (Scan.lift (Args.$$$ "cong") |-- Attrib.add_del (add_cong_attr name) (del_cong_attr name)) || (Scan.lift (Args.$$$ "split") |-- Attrib.add_del (add_split_attr name) (del_split_attr name)) || Attrib.add_del (add_attr name) (del_attr name) end ) val _ = Theory.setup (Attrib.setup \<^binding>\named_ss\ named_simpset_attr "Modify named simpsets") val put_named_simpset_attr = (Args.context -- Scan.lift (Parse.position Args.embedded)) >> (fn (ctxt,raw_binding) => let val name = check ctxt raw_binding val attr = Thm.declaration_attribute (fn _ => Context.map_proof (put name)) in attr end) val _ = Theory.setup (Attrib.setup \<^binding>\put_named_ss\ put_named_simpset_attr "Activate named simpset") (* ML antiquotation *) val _ = Theory.setup (ML_Antiquotation.inline \<^binding>\named_simpset\ (Args.context -- Scan.lift (Parse.position Args.embedded) >> (fn (ctxt, name) => ML_Syntax.print_string (check ctxt name)))); end; diff --git a/thys/IMP2/parser/Parser.thy b/thys/IMP2/parser/Parser.thy --- a/thys/IMP2/parser/Parser.thy +++ b/thys/IMP2/parser/Parser.thy @@ -1,690 +1,689 @@ section \Parser\ theory Parser imports "../basic/Syntax" begin subsection \Tagging\ text \We define a few tag constants. They are inserted by the parser, and tag certain situations, like parameter passing or inlined commands. \ definition Inline :: "com \ com" where "Inline c = c" definition Params :: "com \ com" where "Params c \ c" text \Assignment commands to assign the return value. The VCG will add a renaming, such that the assigned variable name rather the \G_ret\ will be used for the VCs\ definition "AssignIdx_retv x i rv \ AssignIdx x i (V rv)" definition "ArrayCpy_retv x rv \ ArrayCpy x rv" abbreviation "Assign_retv x rv \ AssignIdx_retv x (N 0) rv" subsection \Parser for IMP Programs\ text \The parser also understands annotated programs. However, the basic parser will leave the annotations uninterpreted, and it's up to the client of the parser to interpret them. \ abbreviation (input) While_Annot :: "'a \ bexp \ com \ com" where "While_Annot I \ While" (* Note: Still a very early prototype *) abbreviation (input) VARIABLEI :: "string \ string" where "VARIABLEI x \ x" (* Used to mark integer variables *) abbreviation (input) VARIABLEA :: "string \ string" where "VARIABLEA x \ x" (* Used to mark array variables *) syntax "_annotated_term" :: "logic \ _ \ _ \ logic" (* Annotated term: term string pos *) ML \ structure Term_Annot : sig (* Annotate terms *) val annotate_term: term -> string * Position.T -> term val dest_annotated_term: term -> (string * Position.T) * term (* Annotation = annotated dummy term *) val annotation: string * Position.T -> term val dest_annotation: term -> term (* Checking for annotations in Term *) val is_annotated_term: term -> bool val has_annotations: term -> bool (* Removing annotations *) val strip_annotations: term -> term (* Replaces annotated terms by dummy term *) val strip_annotated_terms: term -> term (* Parsing *) (* Parse cartouche (independent of term annotations)*) val parse_cartouche: (string * Position.T) parser (* Parse cartouche into annotation *) val parse_annotation: term parser (* Parse cartouche into annotation of syntax constant (used to get typed annotations) *) val parse_annotate: string -> term parser (* Read term from cartouche and position *) val read_term: Proof.context -> string * Position.T -> term (* Read annotation part of annotated term as term *) val read_annotation_as_term: Proof.context -> term -> term * term end = struct fun annotate_term t (str,pos) = let val pos = Free (Term_Position.encode pos,dummyT) val str = Free (str,dummyT) val c = Const (@{syntax_const "_annotated_term"}, dummyT --> dummyT --> dummyT --> dummyT) in c$t$str$pos end fun dest_annotated_term (Const (@{syntax_const "_annotated_term"},_)$t$Free (str,_)$Free (pos,_)) = let val pos = case Term_Position.decode pos of SOME pos => pos | NONE => raise TERM ("dest_term_annot: invalid pos",[t]) in ((str,pos),t) end | dest_annotated_term t = raise TERM("dest_annot",[t]) val is_annotated_term = can dest_annotated_term val has_annotations = Term.exists_subterm is_annotated_term val annotation = annotate_term Term.dummy val dest_annotation = dest_annotated_term #> #2 val parse_cartouche = Parse.position Parse.cartouche >> apfst cartouche val parse_annotation = parse_cartouche >> annotation fun parse_annotate n = parse_cartouche >> annotate_term (Const (n,dummyT)) fun read_term_tk ctxt tk = Args.term (Context.Proof ctxt, [tk]) |> #1 fun read_term ctxt spos = let val tk = Symbol_Pos.explode spos |> Token.read_cartouche in read_term_tk ctxt tk end fun read_annotation_as_term ctxt = dest_annotated_term #>> read_term ctxt (* Strip one level of term annotations. *) fun strip_annotations (Const (@{syntax_const "_annotated_term"},_)$t$_$_) = t | strip_annotations (a$b) = strip_annotations a $ strip_annotations b | strip_annotations (Abs (x,T,t)) = Abs (x,T,strip_annotations t) | strip_annotations t = t fun strip_annotated_terms (Const (@{syntax_const "_annotated_term"},_)$_$_$_) = Term.dummy | strip_annotated_terms (a$b) = strip_annotated_terms a $ strip_annotated_terms b | strip_annotated_terms (Abs (x,T,t)) = Abs (x,T,strip_annotated_terms t) | strip_annotated_terms t = t end \ ML \ structure IMP_Syntax = struct fun antf t = ( exists_type is_TFree t andalso raise TERM("This won't support polymorphism in commands!",[t]); t) val mk_varname = HOLogic.mk_string (*fun mk_aexp_V x = antf(@{term V})$x fun mk_aexp_Vidx x i = @{const Vidx}$x$i val mk_aexp_V' = mk_aexp_V o mk_var *) fun mk_aexp_const i = \<^Const>\N\ $ HOLogic.mk_number @{typ int} i fun mk_var_i x = Const (@{const_abbrev VARIABLEI}, dummyT) $ mk_varname x fun mk_var_a x = Const (@{const_abbrev VARIABLEA}, dummyT) $ mk_varname x (* Caution: This must match the Isabelle function is_global! *) fun is_global "" = true | is_global s = nth_string s 0 = "G" val is_local = not o is_global (* Expressions *) datatype rval = RV_AEXP of term | RV_VAR of string fun rv_t (RV_AEXP t) = t | rv_t (RV_VAR x) = \<^Const>\Vidx\ $ mk_var_i x $ mk_aexp_const 0 val rv_var = RV_VAR fun rv_var_idx x i = RV_AEXP (\<^Const>\Vidx\ $ mk_var_a x $ rv_t i) (*fun rv_int t = RV_AEXP (@{const N} $ (rv_t t))*) val rv_int' = RV_AEXP o mk_aexp_const fun rv_unop f t = RV_AEXP (f $ rv_t t) fun rv_binop f a b = RV_AEXP (f $ rv_t a $ rv_t b) fun rv_BC t = RV_AEXP \<^Const>\Bc for t\ fun rv_BC' true = rv_BC \<^Const>\True\ | rv_BC' false = rv_BC \<^Const>\False\ fun rv_not t = RV_AEXP \<^Const>\Not for \rv_t t\\ (* TODO: Add other constructors here *) (* TODO: Interface for variable tagging mk_var_xxx is not clear! *) (* Commands*) val mk_Skip = \<^Const>\SKIP\ fun mk_Assign x t = antf(@{term Assign})$x$t fun mk_AssignIdx x i t = @{Const AssignIdx}$x$i$t fun mk_ArrayCpy d s = \<^Const>\ArrayCpy for d s\ fun mk_ArrayInit d = \<^Const>\ArrayClear for d\ fun mk_Scope c = \<^Const>\Scope for c\ fun mk_Seq c1 c2 = \<^Const>\Seq for c1 c2\ fun mk_Inline t = \<^Const>\Inline for t\ fun mk_Params t = \<^Const>\Params for t\ val While_Annot_c = Const (@{const_abbrev While_Annot}, dummyT --> @{typ "bexp \ com \ com"}) fun mk_If b t e = \<^Const>\If for \rv_t b\ t e\ fun mk_While_annot annots b c = While_Annot_c $ annots $ rv_t b $ c fun mk_pcall name = \<^Const>\PCall for \HOLogic.mk_string name\\ (* Derived Constructs *) datatype varkind = VAL | ARRAY type impvar = string * varkind datatype lval = LV_IDX of string * term | LV_VAR of string fun lv_idx x rv = LV_IDX (x, rv_t rv) fun mk_lr_assign (LV_IDX (x,i)) rv = mk_AssignIdx (mk_var_a x) i (rv_t rv) | mk_lr_assign (LV_VAR x) (RV_AEXP e) = mk_Assign (mk_var_i x) e | mk_lr_assign (LV_VAR x) (RV_VAR v) = mk_ArrayCpy (mk_var_i x) (mk_var_i v) fun list_Seq [] = mk_Skip | list_Seq [c] = c | list_Seq (c::cs) = mk_Seq c (list_Seq cs) fun mk_AssignIdx_retv x i y = \<^Const>\AssignIdx_retv for x i y\ fun mk_ArrayCpy_retv d s = \<^Const>\ArrayCpy_retv for d s\ fun mk_Assign_retv x t = antf(@{term Assign_retv})$x$t fun mk_assign_from_retv (LV_IDX (x,i)) y = mk_AssignIdx_retv (mk_var_a x) i (mk_var_i y) | mk_assign_from_retv (LV_VAR x) y = mk_ArrayCpy_retv (mk_var_i x) (mk_var_i y) fun param_varnames n = map (fn i => "G_par_"^Int.toString i) (1 upto n) fun zip_with_param_names xs = (param_varnames (length xs)) ~~ xs fun zip_with_param_lvs xs = map LV_VAR (param_varnames (length xs)) ~~ xs fun zip_with_param_rvs xs = map RV_VAR (param_varnames (length xs)) ~~ xs fun ret_varnames n = map (fn i => "G_ret_"^Int.toString i) (1 upto n) fun zip_with_ret_names xs = (ret_varnames (length xs)) ~~ xs fun zip_with_ret_lvs xs = map LV_VAR (ret_varnames (length xs)) ~~ xs fun zip_with_ret_rvs xs = map RV_VAR (ret_varnames (length xs)) ~~ xs fun mk_params ress name_t args = let val param_assigns = zip_with_param_lvs args |> map (uncurry mk_lr_assign) val res_assigns = zip_with_ret_names ress |> map (fn (rv,res) => mk_assign_from_retv res rv) val res = param_assigns @ [mk_Params name_t] @ res_assigns |> list_Seq in res end end \ (* Syntax constants to discriminate annotation types *) syntax "_invariant_annotation" :: "_" "_variant_annotation" :: "_" "_relation_annotation" :: "_" ML \ structure IMP_Parser = struct fun scan_if_then_else scan1 scan2 scan3 xs = let val r = SOME (Scan.catch scan1 xs) handle Fail _ => NONE in case r of NONE => scan3 xs | SOME (a,xs) => scan2 a xs end infixr 0 ||| infix 5 --- fun (g,p) ||| e = scan_if_then_else g p e fun lastg (g,p) = g :|-- p datatype op_kind = Binop | Unop (* val int_c = @{const N} val bool_c = @{const Bc} val var_c = @{const V} *) type op_decl = op_kind * (string * term) fun name_eq_op_decl ((k,(a,_)), ((k',(b,_)))) = k=k' andalso a=b fun is_binop ((Binop,_):op_decl) = true | is_binop _ = false fun is_unop ((Unop,_):op_decl) = true | is_unop _ = false structure Opr_Data = Generic_Data ( type T = op_decl list Inttab.table val empty = Inttab.empty val merge = Inttab.merge_list name_eq_op_decl - val extend = I ) fun tab_add_unop (p,n,f) = Inttab.insert_list name_eq_op_decl (p,(Unop,(n,f))) fun tab_add_binop (p,n,f) = Inttab.insert_list name_eq_op_decl (p,(Binop,(n,f))) val add_unop = Opr_Data.map o tab_add_unop val add_binop = Opr_Data.map o tab_add_binop val parse_varname = (Parse.short_ident || Parse.term_var) local fun parse_level parse_opr op_decls = let open IMP_Syntax val binops = filter is_binop op_decls |> map (fn (_,(k,c)) => Parse.$$$ k >> (K c)) val unops = filter is_unop op_decls |> map (fn (_,(k,c)) => Parse.$$$ k >> (K c)) val bopg = Parse.group (fn () => "Binary operator") (Scan.first binops) val uopg = Parse.group (fn () => "Unary operator") (Scan.first unops) fun mk_right a ([]) = a | mk_right a (((f,b)::fxs)) = mk_right (rv_binop f a b) fxs val parse_bop = (parse_opr, fn a => Scan.repeat (bopg -- parse_opr) >> mk_right a) val parse_unop = (uopg, fn f => parse_opr >> (fn x => rv_unop f x)) val parse = (parse_bop ||| lastg parse_unop) in parse end fun parse_levels lvls = let open IMP_Syntax val parse_int = Parse.nat >> rv_int' val parse_var = parse_varname >> rv_var val pbc = Parse.keyword_markup (true,Markup.keyword3) val parse_bool = pbc "true" >> (K (rv_BC' true)) || pbc "false" >> (K (rv_BC' false)) fun parse [] xs = (parse_int || parse_varidx || parse_var || parse_bool || (Parse.$$$ "(" |-- parse lvls --| Parse.$$$ ")")) xs | parse (lv::lvs) xs = (parse_level (parse lvs) lv) xs and parse_varidx xs = ((parse_varname -- Args.bracks (parse lvls)) >> (fn (n,i) => rv_var_idx n i)) xs in parse lvls end in val parse_exp_tab = Inttab.dest #> map snd #> parse_levels val parse_exp = Context.Proof #> Opr_Data.get #> parse_exp_tab end (* TODO/FIXME: Going through the Args.term parser feels like a hack *) fun read_term_pos ctxt spos = Args.term (Context.Proof ctxt, [Token.make_string spos]) |> fst fun parse_proc_name ctxt = Parse.$$$ "rec" |-- Parse.name >> IMP_Syntax.mk_pcall || Parse.name >> Syntax.read_term ctxt (*|| Parse.position Parse.name >> (read_term_pos ctxt)*) fun parse_args ctxt = Args.parens (Parse.enum "," (parse_exp ctxt)) fun parse_lhs ctxt = parse_varname -- Args.bracks (parse_exp ctxt) >> uncurry IMP_Syntax.lv_idx || parse_varname >> IMP_Syntax.LV_VAR fun parse_multiret_lhs ctxt = Args.parens (Parse.enum "," (parse_lhs ctxt)) fun parse_rhs_call ctxt = parse_proc_name ctxt -- parse_args ctxt fun g_parse_call_assign ctxt = (parse_lhs ctxt --| Parse.$$$ "=", fn lhs => (parse_rhs_call ctxt >> (fn (f,args) => IMP_Syntax.mk_params [lhs] f args) || (parse_exp ctxt >> (fn rhs => IMP_Syntax.mk_lr_assign lhs rhs)))) fun g_parse_multiret_call ctxt = ( (parse_multiret_lhs ctxt --| Parse.$$$ "=", fn ress => parse_rhs_call ctxt >> (fn (f,args) => IMP_Syntax.mk_params ress f args))) fun g_parse_void_call ctxt = (parse_rhs_call ctxt, fn (f,args) => Scan.succeed (IMP_Syntax.mk_params [] f args)) val fixed_keywords = ["(",")","{","}","true","false","[]","[","]", "if","else","while","scope","skip","=",";",",", "call", "sreturn", "inline","clear","rec", "@invariant", "@variant", "@relation", "__term"] fun parse_command ctxt = let val pkw = Parse.keyword_markup (true,Markup.keyword1) val pcm = Parse.keyword_markup (true,Markup.keyword2) val g_parse_skip = (pcm "skip", fn _ => Scan.succeed @{term SKIP}) fun g_parse_block p = (Parse.$$$ "{", fn _ => p --| Parse.$$$ "}") val g_parse_clear = (pcm "clear", fn _ => parse_varname --| Parse.$$$ "[]" >> (IMP_Syntax.mk_ArrayInit o IMP_Syntax.mk_var_a)) val parse_invar_annotation = (pkw "@invariant", fn _ => Term_Annot.parse_annotate @{syntax_const "_invariant_annotation"}) val parse_var_annotation = (pkw "@variant", fn _ => Term_Annot.parse_annotate @{syntax_const "_variant_annotation"}) val parse_rel_annotation = (pkw "@relation", fn _ => Term_Annot.parse_annotate @{syntax_const "_relation_annotation"}) val parse_while_annots = Scan.repeat (parse_invar_annotation ||| parse_var_annotation ||| lastg parse_rel_annotation) >> HOLogic.mk_tuple fun parse_atomic_com xs = ( g_parse_call_assign ctxt ||| g_parse_multiret_call ctxt ||| g_parse_void_call ctxt ||| g_parse_skip ||| g_parse_clear ||| lastg (g_parse_block parse_com) ) xs and parse_com1 xs = ( (pkw "if", fn _ => pkw "(" |-- parse_exp ctxt --| pkw ")" -- parse_com1 -- scan_if_then_else (pkw "else") (K parse_com1) (Scan.succeed IMP_Syntax.mk_Skip) >> (fn ((b,t),e) => IMP_Syntax.mk_If b t e)) ||| (pkw "while", fn _ => pkw "(" |-- parse_exp ctxt --| pkw ")" -- parse_while_annots -- parse_com1 >> (fn ((b,annots),c) => IMP_Syntax.mk_While_annot annots b c)) ||| (pkw "scope", fn _ => parse_com1 >> IMP_Syntax.mk_Scope) ||| (pkw "__term", fn _ => Term_Annot.parse_cartouche >> Term_Annot.read_term ctxt) ||| (pkw "inline", fn _ => Parse.position Parse.name >> (IMP_Syntax.mk_Inline o read_term_pos ctxt)) ||| parse_atomic_com ) xs and parse_com xs = ( parse_com1 -- (Scan.unless (Parse.$$$ ";") (Scan.succeed NONE) || Parse.$$$ ";" |-- parse_com >> SOME ) >> (fn (s,SOME t) => IMP_Syntax.mk_Seq s t | (s,NONE) => s) ) xs in parse_com end fun parse_all ctxt p src = let val src = map Token.init_assignable src val (res,_) = Scan.catch (Scan.finite Token.stopper (p --| Scan.ahead Parse.eof)) src val rp = map Token.reports_of_value src |> flat val _ = Context_Position.reports ctxt rp (* val src = map Token.closure src |> @{print} *) in res end val keywords_of_tab : op_decl list Inttab.table -> string list = Inttab.dest_list #> map (snd#>snd#>fst) fun keywords ctxt = let val kws = ctxt |> Context.Proof |> Opr_Data.get |> keywords_of_tab val kws = (kws @ fixed_keywords) |> Symtab.make_set |> Symtab.keys |> map (fn x => ((x,Position.none),Keyword.no_spec)) in Keyword.add_keywords kws Keyword.empty_keywords end fun parse_pos_text p ctxt (pos,text) = Token.explode (keywords ctxt) pos text |> filter Token.is_proper |> parse_all ctxt (p ctxt) fun parse_sympos p ctxt xs = let val kws = keywords ctxt val tks = Token.tokenize kws {strict=true} xs val rp = map (Token.reports kws) tks |> flat (* TODO: More detailed report AFTER parsing! *) val _ = Context_Position.reports_text ctxt rp in tks |> filter Token.is_proper |> parse_all ctxt (p ctxt) end fun variables_of t = let fun add (Const (@{const_abbrev VARIABLEI},_)$x) = (Symtab.default (HOLogic.dest_string x,IMP_Syntax.VAL)) | add (Const (@{const_abbrev VARIABLEA},_)$x) = (Symtab.update (HOLogic.dest_string x,IMP_Syntax.ARRAY)) | add (a$b) = add a #> add b | add (Abs (_,_,t)) = add t | add _ = I in add t Symtab.empty |> Symtab.dest end fun merge_variables vars = let fun add (x,IMP_Syntax.VAL) = Symtab.default (x,IMP_Syntax.VAL) | add (x,IMP_Syntax.ARRAY) = Symtab.update (x,IMP_Syntax.ARRAY) in fold add vars Symtab.empty |> Symtab.dest end fun parse_command_at ctxt spos = let val syms = spos |> Symbol_Pos.explode |> Symbol_Pos.cartouche_content val res = parse_sympos parse_command ctxt syms val vars = variables_of res in (vars,res) end (* From Makarius: Protect a term such that it "survives" the subsequent translation phase *) fun mark_term (Const (c, T)) = Const (Lexicon.mark_const c, T) | mark_term (Free (x, T)) = Const (Lexicon.mark_fixed x, T) | mark_term (t $ u) = mark_term t $ mark_term u | mark_term (Abs (x, T, b)) = Abs (x, T, mark_term b) | mark_term a = a; fun cartouche_tr ctxt args = let fun err () = raise TERM ("imp",args) fun parse spos = let val (_,t) = parse_command_at ctxt spos val t = if Term_Annot.has_annotations t then (warning "Stripped annotations from program"; Term_Annot.strip_annotated_terms t) else t val t = Syntax.check_term ctxt t |> mark_term in t end in (case args of [(c as Const (@{syntax_const "_constrain"}, _)) $ Free (s, _) $ p] => (case Term_Position.decode_position p of SOME (pos, _) => c $ parse (s,pos) $ p | NONE => err ()) | _ => err ()) end end \ syntax "_Imp" :: "cartouche_position \ logic" ("\<^imp>_") parse_translation \ [(@{syntax_const "_Imp"}, IMP_Parser.cartouche_tr)] \ term \\<^imp>\skip\\ declaration \K ( I #> IMP_Parser.add_unop (31,"-",@{term "Unop uminus"}) #> IMP_Parser.add_binop (25,"*",@{term "Binop (*)"}) #> IMP_Parser.add_binop (25,"/",@{term "Binop (div)"}) #> IMP_Parser.add_binop (25,"mod",@{term "Binop (mod)"}) #> IMP_Parser.add_binop (21,"+",@{term "Binop (+)"}) #> IMP_Parser.add_binop (21,"-",@{term "Binop (-)"}) #> IMP_Parser.add_binop (11,"<",@{term "Cmpop (<)"}) #> IMP_Parser.add_binop (11,"\",@{term "Cmpop (\)"}) #> IMP_Parser.add_binop (11,">",@{term "Cmpop (>)"}) #> IMP_Parser.add_binop (11,"\",@{term "Cmpop (\)"}) #> IMP_Parser.add_binop (11,"==",@{term "Cmpop (=)"}) #> IMP_Parser.add_binop (11,"\",@{term "Cmpop (\)"}) #> IMP_Parser.add_unop (7,"\",@{term "Not"}) #> IMP_Parser.add_binop (5,"\",@{term "BBinop (\)"}) #> IMP_Parser.add_binop (3,"\",@{term "BBinop (\)"}) )\ subsection \Examples\ experiment begin definition \p1 \ \<^imp>\ x = 42 \\ ML_val \Syntax.read_term @{context} "p1"\ term p1 term \\<^imp>\ x=y; \ \Variable assignment / array copy\ a[i] = x; \ \Assign array index\ clear a[]; \ \Array initialization\ a = b[i]; \ \Array indexing\ b = a[1] + x*a[a[i]+1]; p1(); \ \Function call, ignore return value\ p1(x,b+1,y[a]); \ \Function call with parameters\ a[i]=p1(); \ \Return value assigned to \a[i]\\ a=p1(); \ \Returns array (also works for value)\ (a,b,c) = p1(a,b); \ \Multiple return values\ \ \Special syntax for recursive calls. TODO: Get rid of this? \ rec p(); rec p(a,b); a = rec p(a,b); (a,b,c) = rec p(a,b); skip \\ term \ \<^imp>\ a = 1; if (true) a=a; if (false) skip else {skip; skip}; while (n > 0) @invariant \not interpreted here\ @variant \not interpreted here\ @relation \not interpreted here\ { a = a + a; __term \SKIP;; p1\; inline p1; y = p1(); scope { n=0 }; n = n - 1 } \\ end term "\<^imp>\ a=1; while (n>0) { a=a+a; n=n-1 } \" subsubsection \Parameter Passing\ experiment begin text \The parser generates parameter and return value passing code, using the global variables \G_par_i\ and \G_ret_i\. To illustrate this, we first define an example procedure. Its signature would be \(int,int) f (int p1, int p2)\ \ definition "f \ \<^imp>\scope { p1 = G_par_1; p2 = G_par_2; G_ret_1=x1+x2; G_ret_2=x1-x2 }\" text \The parser generates the corresponding caller-side code for the invocation of this procedure:\ term \\<^imp>\(x1,x2) = f(a,b+1)\\ end end diff --git a/thys/Isabelle_C/C11-FrontEnd/examples/C1.thy b/thys/Isabelle_C/C11-FrontEnd/examples/C1.thy --- a/thys/Isabelle_C/C11-FrontEnd/examples/C1.thy +++ b/thys/Isabelle_C/C11-FrontEnd/examples/C1.thy @@ -1,864 +1,870 @@ (****************************************************************************** * Isabelle/C * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) chapter \Example: Annotation Navigation and Context Serialization\ theory C1 imports "../C_Main" "HOL-ex.Cartouche_Examples" begin text \ Operationally, the \<^theory_text>\C\ command can be thought of as behaving as \<^theory_text>\ML\, where it is for example possible to recursively nest C code in C. Generally, the present chapter assumes a familiarity with all advance concepts of ML as described in \<^file>\~~/src/HOL/Examples/ML.thy\, as well as the concept of ML antiquotations (\<^file>\~~/src/Doc/Implementation/ML.thy\). However, even if \<^theory_text>\C\ might resemble to \<^theory_text>\ML\, we will now see in detail that there are actually subtle differences between the two commands.\ section \Setup of ML Antiquotations Displaying the Environment (For Debugging) \ ML\ fun print_top make_string f _ (_, (value, _, _)) _ = tap (fn _ => writeln (make_string value)) o f fun print_top' _ f _ _ env = tap (fn _ => writeln ("ENV " ^ C_Env.string_of env)) o f fun print_stack s make_string stack _ _ thy = let val () = Output.information ("SHIFT " ^ (case s of NONE => "" | SOME s => "\"" ^ s ^ "\" ") ^ Int.toString (length stack - 1) ^ " +1 ") val () = stack |> split_list |> #2 |> map_index I |> app (fn (i, (value, pos1, pos2)) => writeln (" " ^ Int.toString (length stack - i) ^ " " ^ make_string value ^ " " ^ Position.here pos1 ^ " " ^ Position.here pos2)) in thy end fun print_stack' s _ stack _ env thy = let val () = Output.information ("SHIFT " ^ (case s of NONE => "" | SOME s => "\"" ^ s ^ "\" ") ^ Int.toString (length stack - 1) ^ " +1 ") val () = writeln ("ENV " ^ C_Env.string_of env) in thy end \ setup \ML_Antiquotation.inline @{binding print_top} (Args.context >> K ("print_top " ^ ML_Pretty.make_string_fn ^ " I"))\ setup \ML_Antiquotation.inline @{binding print_top'} (Args.context >> K ("print_top' " ^ ML_Pretty.make_string_fn ^ " I"))\ setup \ML_Antiquotation.inline @{binding print_stack} (Scan.peek (fn _ => Scan.option Args.text) >> (fn name => ("print_stack " ^ (case name of NONE => "NONE" | SOME s => "(SOME \"" ^ s ^ "\")") ^ " " ^ ML_Pretty.make_string_fn)))\ setup \ML_Antiquotation.inline @{binding print_stack'} (Scan.peek (fn _ => Scan.option Args.text) >> (fn name => ("print_stack' " ^ (case name of NONE => "NONE" | SOME s => "(SOME \"" ^ s ^ "\")") ^ " " ^ ML_Pretty.make_string_fn)))\ declare[[C_lexer_trace]] section \Introduction to C Annotations: Navigating in the Parsing Stack\ subsection \Basics\ text \ Since the present theory \<^file>\C1.thy\ is depending on \<^theory>\Isabelle_C.C_Lexer_Language\ and \<^theory>\Isabelle_C.C_Parser_Language\, the syntax one is writing in the \<^theory_text>\C\ command is C11. Additionally, \<^file>\C1.thy\ also depends on \<^theory>\Isabelle_C.C_Parser_Annotation\, making it possible to write commands in C comments, called annotation commands, such as \<^theory_text>\\setup\. \ C \ \Nesting ML code in C comments\ \ int a = (((0))); /*@ highlight */ /*@ \setup \@{print_stack}\ */ /*@ \setup \@{print_top}\ */ \ text \ In terms of execution order, nested annotation commands are not pre-filtered out of the C code, but executed when the C code is still being parsed. Since the parser implemented is a LALR parser \<^footnote>\\<^url>\https://en.wikipedia.org/wiki/LALR\\, C tokens are uniquely read and treated from left to right. Thus, each nested command is (supposed by default to be) executed when the parser has already read all C tokens before the comment associated to the nested command, so when the parser is in a particular intermediate parsing step (not necessarily final) \<^footnote>\\<^url>\https://en.wikipedia.org/wiki/Shift-reduce_parser\\. \ text \The command \<^theory_text>\\setup\ is similar to the command \<^theory_text>\setup\ except that the former takes a function with additional arguments. These arguments are precisely depending on the current parsing state. To better examine these arguments, it is convenient to use ML antiquotations (be it for printing, or for doing any regular ML actions like PIDE reporting). Note that, in contrast with \<^theory_text>\setup\, the return type of the \<^theory_text>\\setup\ function is not \<^ML_type>\theory -> theory\ but \<^ML_type>\Context.generic -> Context.generic\. \ C \ \Positional navigation: referring to any previous parsed sub-tree in the stack\ \ int a = (((0 + 5))) /*@@ \setup \print_top @{make_string} I\ @ highlight */ * 4; float b = 7 / 3; \ text \The special \@\ symbol makes the command be executed whenever the first element \E\ in the stack is about to be irremediably replaced by a more structured parent element (having \E\ as one of its direct children). It is the parent element which is provided to the ML code. Instead of always referring to the first element of the stack, \N\ consecutive occurrences of \@\ will make the ML code getting as argument the direct parent of the \N\-th element.\ C \ \Positional navigation: referring to any previous parsed sub-tree in the stack\ \ int a = (((0 + 5))) /*@@ highlight */ * 4; int a = (((0 + 5))) /*@& highlight */ * 4; int a = (((0 + 5))) /*@@@@@ highlight */ * 4; int a = (((0 + 5))) /*@&&&& highlight */ * 4; \ text \\&\ behaves as \@\, but instead of always giving the designated direct parent to the ML code, it finds the first parent ancestor making non-trivial changes in the respective grammar rule (a non-trivial change can be for example the registration of the position of the current AST node being built).\ C \ \Positional navigation: moving the comment after a number of C token\ \ int b = 7 / (3) * 50; /*@+++@@ highlight */ long long f (int a) { while (0) { return 0; } } int b = 7 / (3) * 50; \ text \\N\ consecutive occurrences of \+\ will delay the interpretation of the comment, which is ignored at the place it is written. The comment is only really considered after the C parser has treated \N\ more tokens.\ C \ \Closing C comments \*/\ must close anything, even when editing ML code\ \ int a = (((0 //@ (* inline *) \setup \fn _ => fn _ => fn _ => fn context => let in (* */ *) context end\ /*@ \setup \(K o K o K) I\ (* * / *) */ ))); \ C \ \Inline comments with antiquotations\ \ /*@ \setup\(K o K o K) (fn x => K x @{con\ text (**)})\ */ // break of line activated everywhere (also in antiquotations) int a = 0; //\ @ \setup\(K o K o K) (fn x => K x @{term \a \ + b\ (* (**) *\ \ )})\ \ subsection \Erroneous Annotations Treated as Regular C Comments\ C \ \Permissive Types of Antiquotations\ \ int a = 0; /*@ \setup (* Errors: Explicit warning + Explicit markup reporting *) */ /** \setup (* Errors: Turned into tracing report information *) */ /** \setup \fn _ => fn _ => fn _ => I\ (* An example of correct syntax accepted as usual *) */ \ C \ \Permissive Types of Antiquotations\ \ int a = 0; /*@ \setup \fn _ => fn _ => fn _ => I\ \setup (* Parsing error of a single command does not propagate to other commands *) \setup \fn _ => fn _ => fn _ => I\ context */ /** \setup \fn _ => fn _ => fn _ => I\ \setup (* Parsing error of a single command does not propagate to other commands *) \setup \fn _ => fn _ => fn _ => I\ context */ /*@ \setup (* Errors in all commands are all rendered *) \setup (* Errors in all commands are all rendered *) \setup (* Errors in all commands are all rendered *) */ /** \setup (* Errors in all commands makes the whole comment considered as an usual comment *) \setup (* Errors in all commands makes the whole comment considered as an usual comment *) \setup (* Errors in all commands makes the whole comment considered as an usual comment *) */ \ subsection \Bottom-Up vs. Top-Down Evaluation\ ML\ -structure Example_Data = Generic_Data (type T = string list - val empty = [] val extend = I val merge = K empty) +structure Example_Data = Generic_Data +( + type T = string list + val empty = [] + val merge = K empty +) fun add_ex s1 s2 = Example_Data.map (cons s2) #> (fn context => let val () = Output.information (s1 ^ s2) val () = app (fn s => writeln (" Data content: " ^ s)) (Example_Data.get context) in context end) \ setup \Context.theory_map (Example_Data.put [])\ declare[[ML_source_trace]] declare[[C_parser_trace]] C \ \Arbitrary interleaving of effects: \\setup\ vs \\setup\\\ \ int b,c,d/*@@ \setup \fn s => fn x => fn env => @{print_top} s x env #> add_ex "evaluation of " "3_print_top"\ */,e = 0; /*@@ \setup \fn s => fn x => fn env => @{print_top} s x env #> add_ex "evaluation of " "4_print_top"\ */ int b,c,d/*@@ \setup\ \fn s => fn x => fn env => @{print_top} s x env #> add_ex "evaluation of " "6_print_top"\ */,e = 0; /*@@ \setup\ \fn s => fn x => fn env => @{print_top} s x env #> add_ex "evaluation of " "5_print_top"\ */ \ section \Reporting of Positions and Contextual Update of Environment\ text \ To show the content of the parsing environment, the ML antiquotations \print_top'\ and \print_stack'\ will respectively be used instead of \print_top\ and \print_stack\. This example suite allows to explore the bindings represented in the C environment and made accessible in PIDE for hovering. \ subsection \Reporting: \typedef\, \enum\\ (*\struct\*) declare [[ML_source_trace = false]] declare [[C_lexer_trace = false]] C \ \Reporting of Positions\ \ typedef int i, j; /*@@ \setup \@{print_top'}\ @highlight */ //@ +++++@ \setup \@{print_top'}\ +++++@highlight int j = 0; typedef int i, j; j jj1 = 0; j jj = jj1; j j = jj1 + jj; typedef i j; typedef i j; typedef i j; i jj = jj; j j = jj; \ C \ \Nesting type definitions\ \ typedef int j; j a = 0; typedef int k; int main (int c) { j b = 0; typedef int k; typedef k l; k a = c; l a = 0; } k a = a; \ C \ \Reporting \enum\\ \ enum a b; // bound case: undeclared enum a {aaa}; // define case enum a {aaa}; // define case: redefined enum a _; // bound case __thread (f ( enum a, enum a vv)); enum a /* \\ \\<^ML>\C_Grammar_Rule_Wrap_Overloading.function_definition4\\*/ f (enum a a) { } __thread enum a /* \\ \\<^ML>\C_Grammar_Rule_Wrap_Overloading.declaration_specifier2\\*/ f (enum a a) { enum c {ccc}; // define case __thread enum c f (enum c a) { return 0; } enum c /* \\ \\<^ML>\C_Grammar_Rule_Wrap_Overloading.nested_function_definition2\\*/ f (enum c a) { return 0; } return 0; } enum z {zz}; // define case int main (enum z *x) /* \\ \\<^ML>\C_Grammar_Rule_Wrap_Overloading.parameter_type_list2\\*/ { return zz; } int main (enum a *x, ...) /* \\ \\<^ML>\C_Grammar_Rule_Wrap_Overloading.parameter_type_list3\\*/ { return zz; } \ subsection \Continuation Calculus with the C Environment: Presentation in ML\ declare [[C_parser_trace = false]] ML\ val C = tap o C_Module.C val C' = C_Module.C' \ C \ \Nesting C code without propagating the C environment\ \ int a = 0; int b = 7 / (3) * 50 /*@@@@@ \setup \fn _ => fn _ => fn _ => C \int b = a + a + a + a + a + a + a ;\ \ */; \ C \ \Nesting C code and propagating the C environment\ \ int a = 0; int b = 7 / (3) * 50 /*@@@@@ \setup \fn _ => fn _ => fn env => C' env \int b = a + a + a + a + a + a + a ;\ \ */; \ subsection \Continuation Calculus with the C Environment: Presentation with Outer Commands\ ML\ val _ = Theory.setup (C_Inner_Syntax.command0 (fn src => fn context => C' (C_Stack.Data_Lang.get' context |> #2) src context) C_Parse.C_source ("C'", \<^here>, \<^here>, \<^here>)) \ C \ \Nesting C code without propagating the C environment\ \ int f (int a) { int b = 7 / (3) * 50 /*@ C \int b = a + a + a + a + a + a + a;\ */; int c = b + a + a + a + a + a + a; } \ C \ \Nesting C code and propagating the C environment\ \ int f (int a) { int b = 7 / (3) * 50 /*@ C' \int b = a + a + a + a + a + a + a;\ */; int c = b + b + b + b + a + a + a + a + a + a; } \ C \ \Miscellaneous\ \ int f (int a) { int b = 7 / (3) * 50 /*@ C \int b = a + a + a + a + a; //@ C' \int c = b + b + b + b + a;\ \ */; int b = 7 / (3) * 50 /*@ C' \int b = a + a + a + a + a; //@ C' \int c = b + b + b + b + a;\ \ */; int c = b + b + b + b + a + a + a + a + a + a; } \ subsection \Continuation Calculus with the C Environment: Deep-First Nesting vs Breadth-First Folding: Propagation of \<^ML_type>\C_Env.env_lang\\ C \ \Propagation of report environment while manually composing at ML level (with \#>\)\ \ \In \c1 #> c2\, \c1\ and \c2\ should not interfere each other.\ \ //@ ML \fun C_env src _ _ env = C' env src\ int a; int f (int b) { int c = 0; /*@ \setup \fn _ => fn _ => fn env => C' env \int d = a + b + c + d; //@ \setup \C_env \int e = a + b + c + d;\\\ #> C \int d = a + b + c + d; //@ \setup \C_env \int e = a + b + c + d;\\\ #> C' env \int d = a + b + c + d; //@ \setup \C_env \int e = a + b + c + d;\\\ #> C \int d = a + b + c + d; //@ \setup \C_env \int e = a + b + c + d;\\\ \ */ int e = a + b + c + d; }\ C \ \Propagation of directive environment (evaluated before parsing) to any other annotations (evaluated at parsing time)\ \ #undef int #define int(a,b) int #define int int int a; int f (int b) { int c = 0; /*@ \setup \fn _ => fn _ => fn env => C' env \int d = a + b + c + d; //@ \setup \C_env \int e = a + b + c + d;\\\ #> C \int d = a + b + c + d; //@ \setup \C_env \int e = a + b + c + d;\\\ #> C' env \int d = a + b + c + d; //@ \setup \C_env \int e = a + b + c + d;\\\ #> C \int d = a + b + c + d; //@ \setup \C_env \int e = a + b + c + d;\\\ \ */ #undef int int e = a + b + c + d; } \ subsection \Continuation Calculus with the C Environment: Deep-First Nesting vs Breadth-First Folding: Propagation of \<^ML_type>\C_Env.env_tree\\ ML\ structure Data_Out = Generic_Data - (type T = int - val empty = 0 - val extend = I - val merge = K empty) +( + type T = int + val empty = 0 + val merge = K empty +) fun show_env0 make_string f msg context = Output.information ("(" ^ msg ^ ") " ^ make_string (f (Data_Out.get context))) val show_env = tap o show_env0 @{make_string} I \ setup \Context.theory_map (C_Module.Data_Accept.put (fn _ => fn _ => Data_Out.map (fn x => x + 1)))\ C \ \Propagation of Updates\ \ typedef int i, j; int j = 0; typedef int i, j; j jj1 = 0; j jj = jj1; /*@@ \setup \fn _ => fn _ => fn _ => show_env "POSITION 0"\ @\setup \@{print_top'}\ */ typedef int k; /*@@ \setup \fn _ => fn _ => fn env => C' env \k jj = jj; //@@ \setup \@{print_top'}\ k jj = jj + jj1; typedef k l; //@@ \setup \@{print_top'}\\ #> show_env "POSITION 1"\ */ j j = jj1 + jj; //@@ \setup \@{print_top'}\ typedef i j; /*@@ \setup \fn _ => fn _ => fn _ => show_env "POSITION 2"\ */ typedef i j; typedef i j; i jj = jj; j j = jj; \ ML\show_env "POSITION 3" (Context.Theory @{theory})\ setup \Context.theory_map (C_Module.Data_Accept.put (fn _ => fn _ => I))\ subsection \Reporting: Scope of Recursive Functions\ declare [[C_starting_env = last]] C \ \Propagation of Updates\ \ int a = 0; int b = a * a + 0; int jjj = b; int main (void main(int *x,int *y),int *jjj) { return a + jjj + main(); } int main2 () { int main3 () { main2() + main(); } int main () { main2() + main(); } return a + jjj + main3() + main(); } \ C \ int main3 () { main2 (); } \ declare [[C_starting_env = empty]] subsection \Reporting: Extensions to Function Types, Array Types\ C \int f (int z);\ C \int * f (int z);\ C \int (* f) (int z /* \\ \\<^ML>\C_Grammar_Rule_Wrap_Overloading.declarator1\\*/);\ C \typedef int (* f) (int z);\ C \int f (int z) {}\ C \int * f (int z) {return z;}\ C \int ((* f) (int z1, int z2)) {return z1 + z2;}\ C \int (* (* f) (int z1, int z2)) {return z1 + z2;}\ C \typedef int (* f) (int z); f uuu (int b) {return b;};\ C \typedef int (* (* f) (int z, int z)) (int a); f uuu (int b) {return b;};\ C \struct z { int (* f) (int z); int (* (* ff) (int z)) (int a); };\ C \double (* (* f (int a /* \\ \\<^ML>\C_Grammar_Rule_Wrap_Overloading.declarator1\\*/)) (int a, double d)) (char a);\ C \double (* (((* f) []) (int a)) (int b, double c)) (char d) {int a = b + c + d;}\ C \double ((*((f) (int a))) (int a /* \\ \\<^ML>\C_Grammar_Rule_Lib.doFuncParamDeclIdent\\*/, double)) (char c) {int a = 0;}\ C \ \Nesting functions\ \ double (* (* f (int a)) (int a, double)) (char c) { double (* (* f (int a)) (double a, int a)) (char) { return a; } } \ C \ \Old function syntax\ \ f (x) int x; {return x;} \ section \General Isar Commands\ locale zz begin definition "z' = ()" end C \ \Mixing arbitrary commands\ \ int a = 0; int b = a * a + 0; int jjj = b; /*@ @@@ ML \@{lemma \A \ B \ B \ A\ by (ml_tactic \blast_tac ctxt 1\)}\ definition "a' = ()" declare [[ML_source_trace]] lemma (in zz) \A \ B \ B \ A\ by (ml_tactic \blast_tac ctxt 1\) definition (in zz) "z = ()" corollary "zz.z' = ()" apply (unfold zz.z'_def) by blast theorem "True &&& True" by (auto, presburger?) */ \ declare [[ML_source_trace = false]] C \ \Backslash newlines must be supported by \<^ML>\C_Token.syntax'\ (in particular in keywords)\ \ //@ lem\ ma (i\ n z\ z) \ \\ AA \ B\ \\ B \ A\ \ A\ b\ y (ml_t\ actic \\ bla\ st_tac c\ txt\ 0\ 001\) \ section \Starting Parsing Rule\ subsection \Basics\ C \ \Parameterizing starting rule\ \ /*@ declare [[C_starting_rule = "statement"]] C \while (a) {}\ C \a = 2;\ declare [[C_starting_rule = "expression"]] C \2 + 3\ C \a = 2\ C \a[1]\ C \&a\ C \a\ */ \ subsection \Embedding in Inner Terms\ term \\<^C> \ \default behavior of parsing depending on the activated option\ \0\\ term \\<^C>\<^sub>u\<^sub>n\<^sub>i\<^sub>t \ \force the explicit parsing\ \f () {while (a) {}; return 0;} int a = 0;\\ term \\<^C>\<^sub>d\<^sub>e\<^sub>c\<^sub>l \ \force the explicit parsing\ \int a = 0; \\ term \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r \ \force the explicit parsing\ \a\\ term \\<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t \ \force the explicit parsing\ \while (a) {}\\ declare [[C_starting_rule = "translation_unit"]] term \\<^C> \ \default behavior of parsing depending on the current option\ \int a = 0;\\ subsection \User Defined Setup of Syntax\ setup \C_Module.C_Term.map_expression (fn _ => fn _ => fn _ => @{term "10 :: nat"})\ setup \C_Module.C_Term.map_statement (fn _ => fn _ => fn _ => @{term "20 :: nat"})\ value \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\1\ + \<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t\for (;;);\\ setup \ \redefinition\ \C_Module.C_Term.map_expression (fn _ => fn _ => fn _ => @{term "1000 :: nat"})\ value \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\1\ + \<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t\for (;;);\\ setup \C_Module.C_Term.map_default (fn _ => fn _ => fn _ => @{term "True"})\ subsection \Validity of Context for Annotations\ ML \fun fac x = if x = 0 then 1 else x * fac (x - 1)\ ML \ \Execution of annotations in term possible in (the outermost) \<^theory_text>\ML\\ \ \<^term>\ \<^C> \int c = 0; /*@ ML \fac 100\ */\ \ \ definition \ \Execution of annotations in term possible in \<^ML_type>\local_theory\ commands (such as \<^theory_text>\definition\)\ \ term = \<^C> \int c = 0; /*@ ML \fac 100\ */\ \ section \Scopes of Inner and Outer Terms\ ML \ local fun bind scan ((stack1, (to_delay, stack2)), _) = C_Parse.range scan >> (fn (src, range) => C_Env.Parsing ( (stack1, stack2) , ( range , C_Inner_Syntax.bottom_up (fn _ => fn context => ML_Context.exec (tap (fn _ => Syntax.read_term (Context.proof_of context) (Token.inner_syntax_of src))) context) , Symtab.empty , to_delay))) in val _ = Theory.setup ( C_Annotation.command' ("term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r", \<^here>) "" (bind (C_Token.syntax' (Parse.token Parse.cartouche))) #> C_Inner_Syntax.command0 (C_Inner_Toplevel.keep'' o C_Inner_Isar_Cmd.print_term) (C_Token.syntax' (Scan.succeed [] -- Parse.term)) ("term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r", \<^here>, \<^here>, \<^here>)) end \ C \ int z = z; /*@ C \//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ C' \//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\ C \//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ C' \//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\ */\ term(*outer*) \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\ C \ int z = z; /*@ C \//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ C' \//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\ C \//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ C' \//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\ */\ term(*outer*) \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\ declare [[C_starting_env = last]] C \ int z = z; /*@ C \//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ C' \//@ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\ C \//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ C' \//@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\\ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\ */\ term(*outer*) \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\z\\ declare [[C_starting_env = empty]] C \ \Propagation of report environment while manually composing at ML level\ \ int a; int f (int b) { int c = 0; /*@ \setup \fn _ => fn _ => fn env => C' env \int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\\ #> C \int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\\ #> C' env \int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\\ #> C \int d = a + b + c + d; //@ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\\ \ term\<^sub>i\<^sub>n\<^sub>n\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\ term\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r \\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\c\ + \<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r\d\\ */ int e = a + b + c + d; }\ section \Calculation in Directives\ subsection \Annotation Command Classification\ C \ \Lexing category vs. parsing category\ \ int a = 0; // \ \Category 2: only parsing\ //@ \setup \K (K (K I))\ (* evaluation at parsing *) //@@ \setup\ \K (K (K I))\ (* evaluation at parsing *) //@ highlight (* evaluation at parsing *) //@@ highlight\ (* evaluation at parsing *) // \ \Category 3: with lexing\ //@ #setup I (* evaluation at lexing (and directives resolving) *) //@ setup I (* evaluation at parsing *) //@@ setup\ I (* evaluation at parsing *) //@ #ML I (* evaluation at lexing (and directives resolving) *) //@ ML I (* evaluation at parsing *) //@@ ML\ I (* evaluation at parsing *) //@ #C \\ (* evaluation at lexing (and directives resolving) *) //@ C \\ (* evaluation at parsing *) //@@ C\ \\ (* evaluation at parsing *) \ C \ \Scheduling example\ \ //@+++++ ML \writeln "2"\ int a = 0; //@@ ML\ \writeln "3"\ //@ #ML \writeln "1"\ \ C \ \Scheduling example\ \ //* lemma True by simp //* #lemma True #by simp //* #lemma True by simp //* lemma True #by simp \ C \ \Scheduling example\ \ /*@ lemma \1 = one\ \2 = two\ \two + one = three\ by auto #definition [simp]: \three = 3\ #definition [simp]: \two = 2\ #definition [simp]: \one = 1\ */ \ subsection \Generalizing ML Antiquotations with C Directives\ ML \ structure Directive_setup_define = Generic_Data - (type T = int - val empty = 0 - val extend = I - val merge = K empty) +( + type T = int + val empty = 0 + val merge = K empty +) fun setup_define1 pos f = C_Directive.setup_define pos (fn toks => fn (name, (pos1, _)) => tap (fn _ => writeln ("Executing " ^ name ^ Position.here pos1 ^ " (only once)")) #> pair (f toks)) (K I) fun setup_define2 pos = C_Directive.setup_define pos (K o pair) \ C \ \General scheme of C antiquotations\ \ /*@ #setup \ \Overloading \#define\\ \ setup_define2 \<^here> (fn (name, (pos1, _)) => op ` Directive_setup_define.get #>> (case name of "f3" => curry op * 152263 | _ => curry op + 1) #> tap (fn (nb, _) => tracing ("Executing antiquotation " ^ name ^ Position.here pos1 ^ " (number = " ^ Int.toString nb ^ ")")) #> uncurry Directive_setup_define.put) \ */ #define f1 #define f2 int a = 0; #define f3 f1 f2 f1 f3 //@ #setup \ \Resetting \#define\\ \setup_define2 \<^here> (K I)\ f3 #define f3 f3 \ C \ \Dynamic token computing in \#define\\ \ //@ #setup \setup_define1 \<^here> (K [])\ #define f int a = 0; f f f f //@ #setup \setup_define1 \<^here> (fn toks => toks @ toks)\ #define f int b = a; f f //@ #setup \setup_define1 \<^here> I\ #define f int a = 0; f f \ section \Miscellaneous\ C \ \Antiquotations acting on a parsed-subtree\ \ # /**/ include // backslash rendered unescaped f(){0 + 0;} /**/ // val _ : theory => 'a => theory # /* context */ if if elif #include if then else ; # /* zzz */ elif /**/ #else\ #define FOO 00 0 "" (( FOO(FOO(a,b,c)) #endif\ C \ \Header-names in directives\ \ #define F #define G "stdio\h" // expecting an error whenever expanded #define H "stdio_h" // can be used anywhere without errors int f = /*F*/ ""; int g = /*G*/ ""; int h = H ""; #include F \ C \ \Parsing tokens as directives only when detecting space symbols before \#\\ \/* */ \ \ // # /* */ define /**/ \ a a a /*#include <>*/ // must not be considered as a directive \ C \ \Universal character names in identifiers and Isabelle symbols\ \ #include int main () { char * ó\<^url>ò = "ó\<^url>ò"; printf ("%s", ó\<^url>ò); } \ end diff --git a/thys/Isabelle_C/C11-FrontEnd/examples/C2.thy b/thys/Isabelle_C/C11-FrontEnd/examples/C2.thy --- a/thys/Isabelle_C/C11-FrontEnd/examples/C2.thy +++ b/thys/Isabelle_C/C11-FrontEnd/examples/C2.thy @@ -1,502 +1,504 @@ (****************************************************************************** * Isabelle/C * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) chapter \Example: A Simple C Program with Directives and Annotations\ theory C2 imports "../C_Main" begin section \A Simplistic Setup: Parse and Store\ text\The following setup just stores the result of the parsed values in the environment.\ ML\ structure Data_Out = Generic_Data - (type T = (C_Grammar_Rule.start_happy * C_Antiquote.antiq C_Env.stream) list - val empty = [] - val extend = I - val merge = K empty) +( + type T = (C_Grammar_Rule.start_happy * C_Antiquote.antiq C_Env.stream) list + val empty = [] + val merge = K empty +) fun get_module thy = let val context = Context.Theory thy in (Data_Out.get context |> map (apfst (C_Grammar_Rule.start_happy1 #> the)), C_Module.Data_In_Env.get context) end \ setup \Context.theory_map (C_Module.Data_Accept.put (fn ast => fn env_lang => Data_Out.map (cons (ast, #stream_ignored env_lang |> rev))))\ section \Example of a Possible Semantics for \#include\\ subsection \Implementation\ text \ The CPP directive \<^C>\#include _\ is used to import signatures of modules in C. This has the effect that imported identifiers are included in the C environment and, as a consequence, appear as constant symbols and not as free variables in the output. \ text \ The following structure is an extra mechanism to define the effect of \<^C>\#include _\ wrt. to its definition in its environment. \ ML \ structure Directive_include = Generic_Data - (type T = (Input.source * C_Env.markup_ident) list Symtab.table - val empty = Symtab.empty - val extend = I - val merge = K empty) +( + type T = (Input.source * C_Env.markup_ident) list Symtab.table + val empty = Symtab.empty + val merge = K empty +) \ ML \ \\<^theory>\Pure\\ \ local fun return f (env_cond, env) = ([], (env_cond, f env)) val _ = Theory.setup (Context.theory_map (C_Context0.Directives.map (C_Context.directive_update ("include", \<^here>) ( (return o K I) , fn C_Lex.Include (C_Lex.Group2 (toks_bl, _, tok :: _)) => let fun exec file = if exists (fn C_Scan.Left _ => false | C_Scan.Right _ => true) file then K (error ("Unsupported character" ^ Position.here (Position.range_position (C_Lex.pos_of tok, C_Lex.end_pos_of (List.last toks_bl))))) else fn (env_lang, env_tree) => fold (fn (src, data) => fn (env_lang, env_tree) => let val (name, pos) = Input.source_content src in C_Grammar_Rule_Lib.shadowTypedef0'''' name [pos] data env_lang env_tree end) (these (Symtab.lookup (Directive_include.get (#context env_tree)) (String.concat (maps (fn C_Scan.Left s => [s] | _ => []) file)))) (env_lang, env_tree) in case tok of C_Lex.Token (_, (C_Lex.String (_, file), _)) => exec file | C_Lex.Token (_, (C_Lex.File (_, file), _)) => exec file | _ => tap (fn _ => (* not yet implemented *) warning ("Ignored directive" ^ Position.here (Position.range_position ( C_Lex.pos_of tok , C_Lex.end_pos_of (List.last toks_bl))))) end |> K |> K | _ => K (K I))))) in end \ ML \ structure Include = struct fun init name vars = Context.theory_map (Directive_include.map (Symtab.update (name, map (rpair {global = true, params = [], ret = C_Env.Previous_in_stack}) vars))) fun append name vars = Context.theory_map (Directive_include.map (Symtab.map_default (name, []) (rev o fold (cons o rpair {global = true, params = [], ret = C_Env.Previous_in_stack}) vars o rev))) val show = Context.theory_map (Directive_include.map (tap (Symtab.dest #> app (fn (fic, vars) => writeln ("Content of \"" ^ fic ^ "\": " ^ String.concat (map (fn (i, _) => let val (name, pos) = Input.source_content i in name ^ Position.here pos ^ " " end) vars)))))) end \ setup \Include.append "stdio.h" [\printf\, \scanf\]\ subsection \Tests\ C \ //@ setup \Include.append "tmp" [\b\]\ #include "tmp" int a = b; \ C \ int b = 0; //@ setup \Include.init "tmp" [\b\]\ #include "tmp" int a = b; \ C \ int c = 0; //@ setup \Include.append "tmp" [\c\]\ //@ setup \Include.append "tmp" [\c\]\ #include "tmp" int a = b + c; //@ setup \Include.show\ \ section \Working with Pragmas\ C\ #include #include /*sdfsdf */ #define a B #define b(C) #pragma /* just exists syntaxically */ \ text\In the following, we retrieve the C11 AST parsed above. \ ML\ val ((C_Ast.CTranslUnit0 (t,u), v)::R, env) = get_module @{theory}; val u = C_Grammar_Rule_Lib.decode u; C_Ast.CTypeSpec0; \ section \Working with Annotation Commands\ ML \ \\<^theory>\Isabelle_C.C_Command\\ \ \ \setup for a dummy ensures : the "Hello World" of Annotation Commands\ local datatype antiq_hol = Term of string (* term *) val scan_opt_colon = Scan.option (C_Parse.$$$ ":") fun msg cmd_name call_pos cmd_pos = tap (fn _ => tracing ("\Hello World\ reported by \"" ^ cmd_name ^ "\" here" ^ call_pos cmd_pos)) fun command (cmd as (cmd_name, _)) scan0 scan f = C_Annotation.command' cmd "" (fn (_, (cmd_pos, _)) => (scan0 -- (scan >> f) >> (fn _ => C_Env.Never |> msg cmd_name Position.here cmd_pos))) in val _ = Theory.setup ( C_Inner_Syntax.command_no_range (C_Inner_Toplevel.generic_theory oo C_Inner_Isar_Cmd.setup \K (K (K I))\) ("loop", \<^here>, \<^here>) #> command ("ensures", \<^here>) scan_opt_colon C_Parse.term Term #> command ("invariant", \<^here>) scan_opt_colon C_Parse.term Term #> command ("assigns", \<^here>) scan_opt_colon C_Parse.term Term #> command ("requires", \<^here>) scan_opt_colon C_Parse.term Term #> command ("variant", \<^here>) scan_opt_colon C_Parse.term Term) end \ C\ /*@ ensures "result >= x && result >= y" */ int max(int x, int y) { if (x > y) return x; else return y; } \ ML\ val ((C_Ast.CTranslUnit0 (t,u), v)::R, env) = get_module @{theory}; val u = C_Grammar_Rule_Lib.decode u \ section \C Code: Various Examples\ text\This example suite is drawn from Frama-C and used in our GLA - TPs. \ C\ int sqrt(int a) { int i = 0; int tm = 1; int sum = 1; /*@ loop invariant "1 <= sum <= a+tm" loop invariant "(i+1)*(i+1) == sum" loop invariant "tm+(i*i) == sum" loop invariant "1<=tm<=sum" loop assigns "i, tm, sum" loop variant "a-sum" */ while (sum <= a) { i++; tm = tm + 2; sum = sum + tm; } return i; } \ C\ /*@ requires "n >= 0" requires "valid(t+(0..n-1))" ensures "exists integer i; (0<=i result == 0" ensures "(forall integer i; 0<=i t[i] == 0) <==> result == 1" assigns nothing */ int allzeros(int t[], int n) { int k = 0; /*@ loop invariant "0 <= k <= n" loop invariant "forall integer i; 0<=i t[i] == 0" loop assigns k loop variant "n-k" */ while(k < n) { if (t[k]) return 0; k = k + 1; } return 1; } \ C\ /*@ requires "n >= 0" requires "valid(t+(0..n-1))" ensures "(forall integer i; 0<=i t[i] != v) <==> result == -1" ensures "(exists integer i; 0<=i result == v" assigns nothing */ int binarysearch(int t[], int n, int v) { int l = 0; int u = n-1; /*@ loop invariant false */ while (l <= u) { int m = (l + u) / 2; if (t[m] < v) { l = m + 1; } else if (t[m] > v) { u = m - 1; } else return m; } return -1; } \ C\ /*@ requires "n >= 0" requires "valid(t+(0..n-1))" requires "(forall integer i,j; 0<=i<=j t[i] <= t[j])" ensures "exists integer i; (0<=i result == 1" ensures "(forall integer i; 0<=i t[i] != x) <==> result == 0" assigns nothing */ int linearsearch(int x, int t[], int n) { int i = 0; /*@ loop invariant "0<=i<=n" loop invariant "forall integer j; 0<=j (t[j] != x)" loop assigns i loop variant "n-i" */ while (i < n) { if (t[i] < x) { i++; } else { return (t[i] == x); } } return 0; } \ section \C Code: A Sorting Algorithm\ C\ #include int main() { int array[100], n, c, d, position, swap; printf("Enter number of elements\n"); scanf("%d", &n); printf("Enter %d integers\n", n); for (c = 0; c < n; c++) scanf("%d", &array[c]); for (c = 0; c < (n - 1); c++) { position = c; for (d = c + 1; d < n; d++) { if (array[position] > array[d]) position = d; } if (position != c) { swap = array[c]; array[c] = array[position]; array[position] = swap; } } printf("Sorted list in ascending order:\n"); for (c = 0; c < n; c++) printf("%d\n", array[c]); return 0; } \ text\A better example implementation:\ C\ #include #include #define SIZE 10 void swap(int *x,int *y); void selection_sort(int* a, const int n); void display(int a[],int size); void main() { int a[SIZE] = {8,5,2,3,1,6,9,4,0,7}; int i; printf("The array before sorting:\n"); display(a,SIZE); selection_sort(a,SIZE); printf("The array after sorting:\n"); display(a,SIZE); } /* swap two integers */ void swap(int *x,int *y) { int temp; temp = *x; *x = *y; *y = temp; } /* perform selection sort */ void selection_sort(int* a,const int size) { int i, j, min; for (i = 0; i < size - 1; i++) { min = i; for (j = i + 1; j < size; j++) { if (a[j] < a[min]) { min = j; } } swap(&a[i], &a[min]); } } /* display array content */ void display(int a[],const int size) { int i; for(i=0; i text\Accessing the underlying C11-AST's via the ML Interface.\ ML\ local open C_Ast in val _ = CTranslUnit0 val ((CTranslUnit0 (t,u), v)::_, _) = get_module @{theory}; val u = C_Grammar_Rule_Lib.decode u val _ = case u of Left (p1,p2) => writeln (Position.here p1 ^ " " ^ Position.here p2) | Right _ => error "Not expecting that value" val CDeclExt0(x1)::_ = t; val _ = CDecl0 end \ section \C Code: Floats Exist\ C\ int a; float b; int m() {return 0;} \ end \ No newline at end of file diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Command.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Command.thy --- a/thys/Isabelle_C/C11-FrontEnd/src/C_Command.thy +++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Command.thy @@ -1,963 +1,967 @@ (****************************************************************************** * Isabelle/C * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) section \Interface: Inner and Outer Commands\ theory C_Command imports C_Eval keywords "C" :: thy_decl % "ML" and "C_file" :: thy_load % "ML" and "C_export_boot" :: thy_decl % "ML" and "C_export_file" :: thy_decl and "C_prf" :: prf_decl % "proof" (* FIXME % "ML" ?? *) and "C_val" :: diag % "ML" begin subsection \Parsing Entry-Point: Error and Acceptance Cases\ ML \ \\<^file>\~~/src/Pure/Tools/ghc.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/Tools/ghc.ML Author: Makarius Support for GHC: Glasgow Haskell Compiler. *) \ structure C_Serialize = struct (** string literals **) fun print_codepoint c = (case c of 10 => "\\n" | 9 => "\\t" | 11 => "\\v" | 8 => "\\b" | 13 => "\\r" | 12 => "\\f" | 7 => "\\a" | 27 => "\\e" | 92 => "\\\\" | 63 => "\\?" | 39 => "\\'" | 34 => "\\\"" | c => if c >= 32 andalso c < 127 then chr c else error "Not yet implemented"); fun print_symbol sym = (case Symbol.decode sym of Symbol.Char s => print_codepoint (ord s) | Symbol.UTF8 s => UTF8.decode_permissive s |> map print_codepoint |> implode | Symbol.Sym s => "\\092<" ^ s ^ ">" | Symbol.Control s => "\\092<^" ^ s ^ ">" | _ => translate_string (print_codepoint o ord) sym); val print_string = quote o implode o map print_symbol o Symbol.explode; end \ ML \ \\<^file>\~~/src/Pure/Tools/generated_files.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/Tools/generated_files.ML Author: Makarius Generated source files for other languages: with antiquotations, without Isabelle symbols. *) \ structure C_Generated_Files = struct val c_dir = "C"; val c_ext = "c"; val c_make_comment = enclose "/*" "*/"; (** context data **) (* file types *) fun get_file_type ext = if ext = "" then error "Bad file extension" else if c_ext = ext then () else error ("Unknown file type for extension " ^ quote ext); (** Isar commands **) (* generate_file *) fun generate_file (binding, src_content) lthy = let val (path, pos) = Path.dest_binding binding; val () = get_file_type (#2 (Path.split_ext path)) handle ERROR msg => error (msg ^ Position.here pos); val header = c_make_comment " generated by Isabelle "; val content = header ^ "\n" ^ src_content; in lthy |> (Local_Theory.background_theory o Generated_Files.add_files) (binding, content) end; (** concrete file types **) val _ = Theory.setup (Generated_Files.file_type \<^binding>\C\ {ext = c_ext, make_comment = c_make_comment, make_string = C_Serialize.print_string}); end \ ML \ \\<^theory>\Isabelle_C.C_Eval\\ \ structure C_Module = struct structure Data_In_Source = Generic_Data - (type T = Input.source list - val empty = [] - val extend = I - val merge = K empty) +( + type T = Input.source list + val empty = [] + val merge = K empty +) structure Data_In_Env = Generic_Data - (type T = C_Env.env_lang - val empty = C_Env.empty_env_lang - val extend = I - val merge = K empty) +( + type T = C_Env.env_lang + val empty = C_Env.empty_env_lang + val merge = K empty +) structure Data_Accept = Generic_Data - (type T = C_Grammar_Rule.start_happy -> C_Env.env_lang -> Context.generic -> Context.generic - fun empty _ _ = I - val extend = I - val merge = #2) +( + type T = C_Grammar_Rule.start_happy -> C_Env.env_lang -> Context.generic -> Context.generic + fun empty _ _ = I + val merge = #2 +) structure Data_Term = Generic_Data - (type T = (C_Grammar_Rule.start_happy -> C_Env.env_lang -> local_theory -> term) Symtab.table - val empty = Symtab.empty - val extend = I - val merge = #2) +( + type T = (C_Grammar_Rule.start_happy -> C_Env.env_lang -> local_theory -> term) Symtab.table + val empty = Symtab.empty + val merge = #2 +) structure C_Term = struct val key_translation_unit = \translation_unit\ val key_external_declaration = \external_declaration\ val key_statement = \statement\ val key_expression = \expression\ val key_default = \default\ local val source_content = Input.source_content #> #1 in val key0_translation_unit = source_content key_translation_unit val key0_external_declaration = source_content key_external_declaration val key0_statement = source_content key_statement val key0_expression = source_content key_expression val key0_default = source_content key_default end val tok0_translation_unit = (key0_translation_unit, C_Grammar.Tokens.start_translation_unit) val tok0_external_declaration = ( key0_external_declaration , C_Grammar.Tokens.start_external_declaration) val tok0_statement = (key0_statement, C_Grammar.Tokens.start_statement) val tok0_expression = (key0_expression, C_Grammar.Tokens.start_expression) val tok_translation_unit = (key_translation_unit, C_Grammar.Tokens.start_translation_unit) val tok_external_declaration = ( key_external_declaration , C_Grammar.Tokens.start_external_declaration) val tok_statement = (key_statement, C_Grammar.Tokens.start_statement) val tok_expression = (key_expression, C_Grammar.Tokens.start_expression) val tokens = [ tok0_translation_unit , tok0_external_declaration , tok0_statement , tok0_expression ] local fun map_upd0 key v = Context.theory_map (Data_Term.map (Symtab.update (key, v))) fun map_upd key start f = map_upd0 key (f o the o start) in val map_translation_unit = map_upd key0_translation_unit C_Grammar_Rule.start_happy1 val map_external_declaration = map_upd key0_external_declaration C_Grammar_Rule.start_happy2 val map_statement = map_upd key0_statement C_Grammar_Rule.start_happy3 val map_expression = map_upd key0_expression C_Grammar_Rule.start_happy4 val map_default = map_upd0 key0_default end end fun env0 ctxt = case Config.get ctxt C_Options.starting_env of "last" => Data_In_Env.get (Context.Proof ctxt) | "empty" => C_Env.empty_env_lang | s => error ("Unknown option: " ^ s ^ Position.here (Config.pos_of C_Options.starting_env)) val env = env0 o Context.proof_of fun start source context = Input.range_of source |> let val s = Config.get (Context.proof_of context) C_Options.starting_rule in case AList.lookup (op =) C_Term.tokens s of SOME tok => tok | NONE => error ("Unknown option: " ^ s ^ Position.here (Config.pos_of C_Options.starting_rule)) end fun err0 _ _ pos = C_Env.map_error_lines (cons ("Parser: No matching grammar rule" ^ Position.here pos)) val err = pair () oooo err0 fun accept0 f env_lang ast = Data_In_Env.put env_lang #> (fn context => f context ast env_lang (Data_Accept.get context ast env_lang context)) fun accept env_lang (_, (ast, _, _)) = pair () o C_Env.map_context (accept0 (K (K (K I))) env_lang ast) val eval_source = C_Context.eval_source env start err accept fun c_enclose bg en source = C_Lex.@@ ( C_Lex.@@ (C_Lex.read bg, C_Lex.read_source source) , C_Lex.read en); structure C_Term' = struct val err = pair Term.dummy oooo err0 fun accept ctxt start_rule = let val (key, start) = case start_rule of NONE => (C_Term.key_default, start) | SOME (key, start_rule) => (key, fn source => fn _ => start_rule (Input.range_of source)) val (key, pos) = Input.source_content key in ( start , fn env_lang => fn (_, (ast, _, _)) => C_Env.map_context' (accept0 (fn context => pair oo (case Symtab.lookup (Data_Term.get context) key of NONE => tap (fn _ => warning ("Representation function associated to\ \ \"" ^ key ^ "\"" ^ Position.here pos ^ " not found (returning a dummy term)")) (fn _ => fn _ => @{term "()"}) | SOME f => fn ast => fn env_lang => f ast env_lang ctxt)) env_lang ast)) end fun eval_in text context env start_rule = let val (start, accept) = accept (Context.proof_of context) start_rule in C_Context.eval_in (SOME context) env (start text) err accept end fun parse_translation l = l |> map (apsnd (fn start_rule => fn ctxt => fn args => let val msg = (case start_rule of NONE => C_Term.key_default | SOME (key, _) => key) |> Input.source_content |> #1 fun err () = raise TERM (msg, args) in case args of [(c as Const (\<^syntax_const>\_constrain\, _)) $ Free (s, _) $ p] => (case Term_Position.decode_position p of SOME (pos, _) => c $ let val src = uncurry (Input.source false) let val s0 = Symbol_Pos.explode (s, pos) val s = Symbol_Pos.cartouche_content s0 in ( Symbol_Pos.implode s , case s of [] => Position.no_range | (_, pos0) :: _ => Position.range (pos0, s0 |> List.last |> snd)) end in eval_in src (case Context.get_generic_context () of NONE => Context.Proof ctxt | SOME context => Context.mapping I (K ctxt) context) (C_Stack.Data_Lang.get #> (fn NONE => env0 ctxt | SOME (_, env_lang) => env_lang)) start_rule (c_enclose "" "" src) end $ p | NONE => err ()) | _ => err () end)) end fun eval_in text ctxt = C_Context.eval_in ctxt env (start text) err accept fun exec_eval source = Data_In_Source.map (cons source) #> ML_Context.exec (fn () => eval_source source) fun C_prf source = Proof.map_context (Context.proof_map (exec_eval source)) #> Proof.propagate_ml_env fun C_export_boot source context = context |> Config.put_generic ML_Env.ML_environment ML_Env.Isabelle |> Config.put_generic ML_Env.ML_write_global true |> exec_eval source |> Config.restore_generic ML_Env.ML_write_global context |> Config.restore_generic ML_Env.ML_environment context |> Local_Theory.propagate_ml_env fun C source = exec_eval source #> Local_Theory.propagate_ml_env fun C' env_lang src context = context |> C_Env.empty_env_tree |> C_Context.eval_source' env_lang (fn src => start src context) err accept src |> (fn (_, {context, reports_text, error_lines}) => tap (fn _ => case error_lines of [] => () | l => warning (cat_lines (rev l))) (C_Stack.Data_Tree.map (curry C_Stack.Data_Tree_Args.merge (reports_text, [])) context)) fun C_export_file (pos, _) lthy = let val c_sources = Data_In_Source.get (Context.Proof lthy) val binding = Path.binding ( Path.appends [ Path.basic C_Generated_Files.c_dir , Path.basic (string_of_int (length c_sources)) , lthy |> Proof_Context.theory_of |> Context.theory_name |> Path.explode |> Path.ext C_Generated_Files.c_ext ] , pos) in lthy |> C_Generated_Files.generate_file (binding, rev c_sources |> map (Input.source_content #> #1) |> cat_lines) |> tap (Proof_Context.theory_of #> (fn thy => let val file = Generated_Files.get_file thy binding in Generated_Files.export_file thy file; writeln (Export.message thy Path.current); writeln (prefix " " (Generated_Files.print_file file)) end)) end end \ subsection \Definitions of Inner Directive Commands\ subsubsection \Initialization\ ML \ \\<^theory>\Pure\\ \ structure C_Directive = struct local fun directive_update keyword data = C_Context.directive_update keyword (data, K (K (K I))) fun return f (env_cond, env) = ([], (env_cond, f env)) fun directive_update_define pos f_toks f_antiq = directive_update ("define", pos) (return o (fn C_Lex.Define (_, C_Lex.Group1 ([], [tok3]), NONE, C_Lex.Group1 ([], toks)) => let val map_ctxt = case (tok3, toks) of (C_Lex.Token ((pos, _), (C_Lex.Ident, ident)), [C_Lex.Token (_, (C_Lex.Integer (_, C_Lex.Repr_decimal, []), integer))]) => C_Env.map_context (Context.map_theory (Named_Target.theory_map (Specification.definition_cmd (SOME (Binding.make (ident, pos), NONE, NoSyn)) [] [] (Binding.empty_atts, ident ^ " \ " ^ integer) true #> tap (fn ((_, (_, t)), ctxt) => Output.information ("Generating " ^ Pretty.string_of (Syntax.pretty_term ctxt (Thm.prop_of t)) ^ Position.here (Position.range_position ( C_Lex.pos_of tok3 , C_Lex.end_pos_of (List.last toks))))) #> #2))) | _ => I in fn (env_dir, env_tree) => let val name = C_Lex.content_of tok3 val pos = [C_Lex.pos_of tok3] val data = (pos, serial (), (C_Scan.Left (f_toks toks), f_antiq)) in ( Symtab.update (name, data) env_dir , env_tree |> C_Context.markup_directive_define false (C_Ast.Left (data, C_Env_Ext.list_lookup env_dir name)) pos name |> map_ctxt) end end | C_Lex.Define (_, C_Lex.Group1 ([], [tok3]), SOME (C_Lex.Group1 (_ :: toks_bl, _)), _) => tap (fn _ => (* not yet implemented *) warning ("Ignored functional macro directive" ^ Position.here (Position.range_position (C_Lex.pos_of tok3, C_Lex.end_pos_of (List.last toks_bl))))) | _ => I)) in val setup_define = Context.theory_map o C_Context0.Directives.map ooo directive_update_define val _ = Theory.setup (Context.theory_map (C_Context0.Directives.map (directive_update_define \<^here> (K o pair) (K I) #> directive_update ("undef", \<^here>) (return o (fn C_Lex.Undef (C_Lex.Group2 (_, _, [tok])) => (fn (env_dir, env_tree) => let val name = C_Lex.content_of tok val pos1 = [C_Lex.pos_of tok] val data = Symtab.lookup env_dir name in ( (case data of NONE => env_dir | SOME _ => Symtab.delete name env_dir) , C_Context.markup_directive_define true (C_Ast.Right (pos1, data)) pos1 name env_tree) end) | _ => I))))) end end \ subsection \Definitions of Inner Annotation Commands\ subsubsection \Library\ ML \ \\<^file>\~~/src/Pure/Isar/toplevel.ML\\ \ structure C_Inner_Toplevel = struct val theory = Context.map_theory fun local_theory' target f gthy = let val (finish, lthy) = Target_Context.switch_named_cmd target gthy; val lthy' = lthy |> Local_Theory.new_group |> f false |> Local_Theory.reset_group; in finish lthy' end val generic_theory = I fun keep'' f = tap (f o Context.proof_of) end \ ML \ \\<^file>\~~/src/Pure/Isar/isar_cmd.ML\\ \ structure C_Inner_Isar_Cmd = struct (** theory declarations **) (* generic setup *) fun setup0 f_typ f_val src = fn NONE => let val setup = "setup" in C_Context.expression "C_Ast" (Input.range_of src) setup (f_typ "C_Stack.stack_data" "C_Stack.stack_data_elem -> C_Env.env_lang -> Context.generic -> Context.generic") ("fn context => \ \let val (stack, env_lang) = C_Stack.Data_Lang.get' context \ \in " ^ f_val setup "stack" ^ " (stack |> hd) env_lang end context") (ML_Lex.read_source src) end | SOME rule => let val hook = "hook" in C_Context.expression "C_Ast" (Input.range_of src) hook (f_typ "C_Stack.stack_data" (C_Grammar_Rule.type_reduce rule ^ " C_Stack.stack_elem -> C_Env.env_lang -> Context.generic -> Context.generic")) ("fn context => \ \let val (stack, env_lang) = C_Stack.Data_Lang.get' context \ \in " ^ f_val hook "stack" ^ " " ^ "(stack \ \|> hd \ \|> C_Stack.map_svalue0 C_Grammar_Rule.reduce" ^ Int.toString rule ^ ")\ \env_lang \ \end \ \ context") (ML_Lex.read_source src) end val setup = setup0 (fn a => fn b => a ^ " -> " ^ b) (fn a => fn b => a ^ " " ^ b) val setup' = setup0 (K I) K (* print theorems, terms, types etc. *) local fun string_of_term ctxt s = let val t = Syntax.read_term ctxt s; val T = Term.type_of t; val ctxt' = Proof_Context.augment t ctxt; in Pretty.string_of (Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t), Pretty.fbrk, Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' T)]) end; fun print_item string_of (modes, arg) ctxt = Print_Mode.with_modes modes (fn () => writeln (string_of ctxt arg)) (); in val print_term = print_item string_of_term; end; end \ ML \ \\<^file>\~~/src/Pure/Isar/outer_syntax.ML\\ \ structure C_Inner_Syntax = struct val drop1 = fn C_Scan.Left f => C_Scan.Left (K o f) | C_Scan.Right (f, dir) => C_Scan.Right (K o f, dir) val drop2 = fn C_Scan.Left f => C_Scan.Left (K o K o f) | C_Scan.Right (f, dir) => C_Scan.Right (K o K o f, dir) val bottom_up = C_Env.Bottom_up o C_Env.Exec_annotation (**) fun pref_lex name = "#" ^ name val pref_bot = I fun pref_top name = name ^ "\" (**) fun command2' cmd f (pos_bot, pos_top) = let fun cmd' dir = cmd (C_Scan.Right (f, dir)) Keyword.thy_decl in cmd' bottom_up (pref_bot, pos_bot) #> cmd' C_Env.Top_down (pref_top, pos_top) end fun command3' cmd f (pos_lex, pos_bot, pos_top) = cmd (C_Scan.Left f) (pref_lex, pos_lex) #> command2' (K o cmd) f (pos_bot, pos_top) fun command2 cmd f (name, pos_bot, pos_top) = command2' (fn f => fn kind => fn (name_pref, pos) => cmd f kind (name_pref name, pos)) f (pos_bot, pos_top) fun command3 cmd f (name, pos_lex, pos_bot, pos_top) = command3' (fn f => fn (name_pref, pos) => cmd f (name_pref name, pos)) f (pos_lex, pos_bot, pos_top) (**) fun command00 f kind scan name = C_Annotation.command'' kind name "" (case f of C_Scan.Left f => (fn _ => C_Parse.range scan >> (fn (src, range) => C_Env.Lexing (range, f src range))) | C_Scan.Right (f, dir) => fn ((stack1, (to_delay, stack2)), _) => C_Parse.range scan >> (fn (src, range) => C_Env.Parsing ((stack1, stack2), (range, dir (f src range), Symtab.empty, to_delay)))) fun command00_no_range f kind name = C_Annotation.command'' kind name "" (case f of C_Scan.Left f => (fn (_, range) => Scan.succeed () >> K (C_Env.Lexing (range, f range))) | C_Scan.Right (f, dir) => fn ((stack1, (to_delay, stack2)), range) => Scan.succeed () >> K (C_Env.Parsing ((stack1, stack2), (range, dir (f range), Symtab.empty, to_delay)))) (**) fun command' f = command00 (drop1 f) Keyword.thy_decl fun command f scan = command2 (fn f => fn kind => command00 f kind scan) (K o f) fun command_range f = command00_no_range f Keyword.thy_decl val command_range' = command3 (command_range o drop1) fun command_no_range' f = command00_no_range (drop1 f) Keyword.thy_decl fun command_no_range f = command2 command00_no_range (K f) fun command0 f scan = command3 (fn f => command' (drop1 f) scan) f fun local_command' (name, pos_lex, pos_bot, pos_top) scan f = command3' (fn f => fn (name_pref, pos) => command' (drop1 f) (C_Token.syntax' (Parse.opt_target -- scan name_pref)) (name_pref name, pos)) (fn (target, arg) => C_Inner_Toplevel.local_theory' target (f arg)) (pos_lex, pos_bot, pos_top) fun local_command'' spec = local_command' spec o K val command0_no_range = command_no_range' o drop1 fun command0' f kind scan = command3 (fn f => fn (name, pos) => command00 (drop2 f) kind (scan name) (name, pos)) f end \ ML \ \\<^file>\~~/src/Pure/ML/ml_file.ML\\ \ structure C_Inner_File = struct fun command_c ({lines, pos, ...}: Token.file) = C_Module.C (Input.source true (cat_lines lines) (pos, pos)); fun C files gthy = command_c (hd (files (Context.theory_of gthy))) gthy; fun command_ml environment debug files gthy = let val file: Token.file = hd (files (Context.theory_of gthy)); val source = Token.file_source file; val _ = Document_Output.check_comments (Context.proof_of gthy) (Input.source_explode source); val flags: ML_Compiler.flags = {environment = environment, redirect = true, verbose = true, debug = debug, writeln = writeln, warning = warning}; in gthy |> ML_Context.exec (fn () => ML_Context.eval_source flags source) |> Local_Theory.propagate_ml_env end; val ML = command_ml ""; val SML = command_ml ML_Env.SML; end; \ subsubsection \Initialization\ setup \ \\<^theory>\Pure\\ \ C_Thy_Header.add_keywords_minor (maps (fn ((name, pos_lex, pos_bot, pos_top), ty) => [ ((C_Inner_Syntax.pref_lex name, pos_lex), ty) , ((C_Inner_Syntax.pref_bot name, pos_bot), ty) , ((C_Inner_Syntax.pref_top name, pos_top), ty) ]) [ (("apply", \<^here>, \<^here>, \<^here>), ((Keyword.prf_script, []), ["proof"])) , (("by", \<^here>, \<^here>, \<^here>), ((Keyword.qed, []), ["proof"])) , (("done", \<^here>, \<^here>, \<^here>), ((Keyword.qed_script, []), ["proof"])) ]) \ ML \ \\<^theory>\Pure\\ \ local val semi = Scan.option (C_Parse.$$$ ";"); structure C_Isar_Cmd = struct fun ML source = ML_Context.exec (fn () => ML_Context.eval_source (ML_Compiler.verbose true ML_Compiler.flags) source) #> Local_Theory.propagate_ml_env fun theorem schematic ((long, binding, includes, elems, concl), (l_meth, o_meth)) int lthy = (if schematic then Specification.schematic_theorem_cmd else Specification.theorem_cmd) long Thm.theoremK NONE (K I) binding includes elems concl int lthy |> fold (fn m => tap (fn _ => Method.report m) #> Proof.apply m #> Seq.the_result "") l_meth |> (case o_meth of NONE => Proof.global_done_proof | SOME (m1, m2) => tap (fn _ => (Method.report m1; Option.map Method.report m2)) #> Proof.global_terminal_proof (m1, m2)) fun definition (((decl, spec), prems), params) = #2 oo Specification.definition_cmd decl params prems spec fun declare (facts, fixes) = #2 oo Specification.theorems_cmd "" [(Binding.empty_atts, flat facts)] fixes end local val long_keyword = Parse_Spec.includes >> K "" || Parse_Spec.long_statement_keyword; val long_statement = Scan.optional (Parse_Spec.opt_thm_name ":" --| Scan.ahead long_keyword) Binding.empty_atts -- Scan.optional Parse_Spec.includes [] -- Parse_Spec.long_statement >> (fn ((binding, includes), (elems, concl)) => (true, binding, includes, elems, concl)); val short_statement = Parse_Spec.statement -- Parse_Spec.if_statement -- Parse.for_fixes >> (fn ((shows, assumes), fixes) => (false, Binding.empty_atts, [], [Element.Fixes fixes, Element.Assumes assumes], Element.Shows shows)); in fun theorem spec schematic = C_Inner_Syntax.local_command' spec (fn name_pref => (long_statement || short_statement) -- let val apply = Parse.$$$ (name_pref "apply") |-- Method.parse in Scan.repeat1 apply -- (Parse.$$$ (name_pref "done") >> K NONE) || Scan.repeat apply -- (Parse.$$$ (name_pref "by") |-- Method.parse -- Scan.option Method.parse >> SOME) end) (C_Isar_Cmd.theorem schematic) end val opt_modes = Scan.optional (\<^keyword>\(\ |-- Parse.!!! (Scan.repeat1 Parse.name --| \<^keyword>\)\)) []; val _ = Theory.setup ( C_Inner_Syntax.command (C_Inner_Toplevel.generic_theory oo C_Inner_Isar_Cmd.setup) C_Parse.ML_source ("\setup", \<^here>, \<^here>) #> C_Inner_Syntax.command0 (C_Inner_Toplevel.theory o Isar_Cmd.setup) C_Parse.ML_source ("setup", \<^here>, \<^here>, \<^here>) #> C_Inner_Syntax.command0 (C_Inner_Toplevel.generic_theory o C_Isar_Cmd.ML) C_Parse.ML_source ("ML", \<^here>, \<^here>, \<^here>) #> C_Inner_Syntax.command0 (C_Inner_Toplevel.generic_theory o C_Module.C) C_Parse.C_source ("C", \<^here>, \<^here>, \<^here>) #> C_Inner_Syntax.command0' (C_Inner_Toplevel.generic_theory o C_Inner_File.ML NONE) Keyword.thy_load (fn name => C_Resources.parse_files name --| semi) ("ML_file", \<^here>, \<^here>, \<^here>) #> C_Inner_Syntax.command0' (C_Inner_Toplevel.generic_theory o C_Inner_File.C) Keyword.thy_load (fn name => C_Resources.parse_files name --| semi) ("C_file", \<^here>, \<^here>, \<^here>) #> C_Inner_Syntax.command0 (C_Inner_Toplevel.generic_theory o C_Module.C_export_boot) C_Parse.C_source ("C_export_boot", \<^here>, \<^here>, \<^here>) #> C_Inner_Syntax.command_range' (Context.map_theory o Named_Target.theory_map o C_Module.C_export_file) ("C_export_file", \<^here>, \<^here>, \<^here>) #> C_Inner_Syntax.command_no_range (C_Inner_Toplevel.generic_theory oo C_Inner_Isar_Cmd.setup \fn ((_, (_, pos1, pos2)) :: _) => (fn _ => fn _ => tap (fn _ => Position.reports_text [((Position.range (pos1, pos2) |> Position.range_position, Markup.intensify), "")])) | _ => fn _ => fn _ => I\) ("highlight", \<^here>, \<^here>) #> theorem ("theorem", \<^here>, \<^here>, \<^here>) false #> theorem ("lemma", \<^here>, \<^here>, \<^here>) false #> theorem ("corollary", \<^here>, \<^here>, \<^here>) false #> theorem ("proposition", \<^here>, \<^here>, \<^here>) false #> theorem ("schematic_goal", \<^here>, \<^here>, \<^here>) true #> C_Inner_Syntax.local_command'' ("definition", \<^here>, \<^here>, \<^here>) (Scan.option Parse_Spec.constdecl -- (Parse_Spec.opt_thm_name ":" -- Parse.prop) -- Parse_Spec.if_assumes -- Parse.for_fixes) C_Isar_Cmd.definition #> C_Inner_Syntax.local_command'' ("declare", \<^here>, \<^here>, \<^here>) (Parse.and_list1 Parse.thms1 -- Parse.for_fixes) C_Isar_Cmd.declare #> C_Inner_Syntax.command0 (C_Inner_Toplevel.keep'' o C_Inner_Isar_Cmd.print_term) (C_Token.syntax' (opt_modes -- Parse.term)) ("term", \<^here>, \<^here>, \<^here>)) in end \ subsection \Definitions of Outer Classical Commands\ subsubsection \Library\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/Pure.thy Author: Makarius The Pure theory, with definitions of Isar commands and some lemmas. *) ML \ \\<^file>\~~/src/Pure/Isar/parse.ML\\ \ structure C_Outer_Parse = struct val C_source = Parse.input (Parse.group (fn () => "C source") Parse.text) end \ ML \ \\<^file>\~~/src/Pure/Isar/outer_syntax.ML\\ \ structure C_Outer_Syntax = struct val _ = Outer_Syntax.command \<^command_keyword>\C\ "" (C_Outer_Parse.C_source >> (Toplevel.generic_theory o C_Module.C)); end \ ML \ \\<^file>\~~/src/Pure/Isar/isar_cmd.ML\\ \ structure C_Outer_Isar_Cmd = struct (* diagnostic ML evaluation *) structure Diag_State = Proof_Data ( type T = Toplevel.state option; fun init _ = NONE; ); fun C_diag source state = let val opt_ctxt = try Toplevel.generic_theory_of state |> Option.map (Context.proof_of #> Diag_State.put (SOME state)); in Context.setmp_generic_context (Option.map Context.Proof opt_ctxt) (fn () => C_Module.eval_source source) () end; fun diag_state ctxt = (case Diag_State.get ctxt of SOME st => st | NONE => Toplevel.init_toplevel ()); val diag_goal = Proof.goal o Toplevel.proof_of o diag_state; val _ = Theory.setup (ML_Antiquotation.value (Binding.qualify true "Isar" \<^binding>\C_state\) (Scan.succeed "C_Outer_Isar_Cmd.diag_state ML_context") #> ML_Antiquotation.value (Binding.qualify true "Isar" \<^binding>\C_goal\) (Scan.succeed "C_Outer_Isar_Cmd.diag_goal ML_context")); end \ ML \ \\<^file>\~~/src/Pure/ML/ml_file.ML\\ \ structure C_Outer_File = struct fun command_c ({src_path, lines, digest, pos}: Token.file) = let val provide = Resources.provide (src_path, digest); in I #> C_Module.C (Input.source true (cat_lines lines) (pos, pos)) #> Context.mapping provide (Local_Theory.background_theory provide) end; fun C files gthy = command_c (hd (files (Context.theory_of gthy))) gthy; end; \ subsubsection \Initialization\ ML \ \\<^theory>\Pure\\ \ local val semi = Scan.option \<^keyword>\;\; val _ = Outer_Syntax.command \<^command_keyword>\C_file\ "read and evaluate Isabelle/C file" (Resources.parse_files single --| semi >> (Toplevel.generic_theory o C_Outer_File.C)); val _ = Outer_Syntax.command \<^command_keyword>\C_export_boot\ "C text within theory or local theory, and export to bootstrap environment" (C_Outer_Parse.C_source >> (Toplevel.generic_theory o C_Module.C_export_boot)); val _ = Outer_Syntax.command \<^command_keyword>\C_prf\ "C text within proof" (C_Outer_Parse.C_source >> (Toplevel.proof o C_Module.C_prf)); val _ = Outer_Syntax.command \<^command_keyword>\C_val\ "diagnostic C text" (C_Outer_Parse.C_source >> (Toplevel.keep o C_Outer_Isar_Cmd.C_diag)); val _ = Outer_Syntax.local_theory \<^command_keyword>\C_export_file\ "diagnostic C text" (Scan.succeed () >> K (C_Module.C_export_file Position.no_range)); in end\ subsection \Syntax for Pure Term\ syntax "_C_translation_unit" :: \cartouche_position \ string\ ("\<^C>\<^sub>u\<^sub>n\<^sub>i\<^sub>t _") syntax "_C_external_declaration" :: \cartouche_position \ string\ ("\<^C>\<^sub>d\<^sub>e\<^sub>c\<^sub>l _") syntax "_C_expression" :: \cartouche_position \ string\ ("\<^C>\<^sub>e\<^sub>x\<^sub>p\<^sub>r _") syntax "_C_statement" :: \cartouche_position \ string\ ("\<^C>\<^sub>s\<^sub>t\<^sub>m\<^sub>t _") syntax "_C" :: \cartouche_position \ string\ ("\<^C> _") parse_translation \ C_Module.C_Term'.parse_translation [ (\<^syntax_const>\_C_translation_unit\, SOME C_Module.C_Term.tok_translation_unit) , (\<^syntax_const>\_C_external_declaration\, SOME C_Module.C_Term.tok_external_declaration) , (\<^syntax_const>\_C_expression\, SOME C_Module.C_Term.tok_expression) , (\<^syntax_const>\_C_statement\, SOME C_Module.C_Term.tok_statement) , (\<^syntax_const>\_C\, NONE) ] \ end diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Eval.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Eval.thy --- a/thys/Isabelle_C/C11-FrontEnd/src/C_Eval.thy +++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Eval.thy @@ -1,767 +1,766 @@ (****************************************************************************** * Isabelle/C * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) section \Evaluation Scheduling\ theory C_Eval imports C_Parser_Language C_Parser_Annotation begin subsection \Evaluation Engine for the Core Language\ \ \\<^file>\~~/src/Pure/Thy/thy_info.ML\: \<^theory>\Isabelle_C.C_Parser_Language\\ ML \ \\<^theory>\Isabelle_C.C_Environment\\ \ structure C_Stack = struct type 'a stack_elem = (LALR_Table.state, 'a, Position.T) C_Env.stack_elem0 type stack_data = (LALR_Table.state, C_Grammar.Tokens.svalue0, Position.T) C_Env.stack0 type stack_data_elem = (LALR_Table.state, C_Grammar.Tokens.svalue0, Position.T) C_Env.stack_elem0 fun map_svalue0 f (st, (v, pos1, pos2)) = (st, (f v, pos1, pos2)) structure Data_Lang = struct val empty' = ([], C_Env.empty_env_lang) structure Data_Lang = Generic_Data - (type T = (stack_data * C_Env.env_lang) option - val empty = NONE - val extend = I - val merge = K empty) +( + type T = (stack_data * C_Env.env_lang) option + val empty = NONE + val merge = K empty +) open Data_Lang fun get' context = case get context of NONE => empty' | SOME data => data fun setmp data f context = put (get context) (f (put data context)) end structure Data_Tree_Args : GENERIC_DATA_ARGS = struct type T = C_Position.reports_text * C_Env.error_lines val empty = ([], []) - val extend = I fun merge ((l11, l12), (l21, l22)) = (l11 @ l21, l12 @ l22) end structure Data_Tree = Generic_Data (Data_Tree_Args) fun setmp_tree f context = let val x = Data_Tree.get context val context = f (Data_Tree.put Data_Tree_Args.empty context) in (Data_Tree.get context, Data_Tree.put x context) end fun stack_exec0 f {context, reports_text, error_lines} = let val ((reports_text', error_lines'), context) = setmp_tree f context in { context = context , reports_text = append reports_text' reports_text , error_lines = append error_lines' error_lines } end fun stack_exec env_dir data_put = stack_exec0 o Data_Lang.setmp (SOME (apsnd (C_Env.map_env_directives (K env_dir)) data_put)) end \ ML \ \\<^file>\~~/src/Pure/ML/ml_context.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/ML/ml_context.ML Author: Makarius ML context and antiquotations. *) \ structure C_Context0 = struct (* theory data *) type env_direct = bool (* internal result for conditional directives: branch skipping *) * (C_Env.env_directives * C_Env.env_tree) structure Directives = Generic_Data (type T = (Position.T list * serial * ( (* evaluated during lexing phase *) (C_Lex.token_kind_directive -> env_direct -> C_Env.antiq_language list (* nested annotations from the input *) * env_direct (*NOTE: remove the possibility of returning a too modified env?*)) * (* evaluated during parsing phase *) (C_Lex.token_kind_directive -> C_Env.env_propagation_directive))) Symtab.table val empty = Symtab.empty - val extend = I val merge = Symtab.join (K #2)); end \ ML \ \\<^theory>\Isabelle_C.C_Lexer_Language\\ \ structure C_Grammar_Lexer : ARG_LEXER1 = struct structure LALR_Lex_Instance = struct type ('a,'b) token = ('a, 'b) C_Grammar.Tokens.token type pos = Position.T type arg = C_Grammar.Tokens.arg type svalue0 = C_Grammar.Tokens.svalue0 type svalue = arg -> svalue0 * arg type state = C_Grammar.ParserData.LALR_Table.state end type stack = (LALR_Lex_Instance.state, LALR_Lex_Instance.svalue0, LALR_Lex_Instance.pos) C_Env.stack' fun advance_hook stack = (fn f => fn (arg, stack_ml) => f (#stream_hook arg) (arg, stack_ml)) (fn [] => I | l :: ls => I #> fold_rev (fn (_, syms, ml_exec) => let val len = length syms in if len = 0 then I #>> (case ml_exec of (_, C_Env.Bottom_up (C_Env.Exec_annotation exec), env_dir, _) => (fn arg => C_Env.map_env_tree (C_Stack.stack_exec env_dir (stack, #env_lang arg) (exec NONE)) arg) | (_, C_Env.Bottom_up (C_Env.Exec_directive exec), env_dir, _) => C_Env.map_env_lang_tree (curry (exec NONE env_dir)) | ((pos, _), _, _, _) => C_Env_Ext.map_context (fn _ => error ( "Style of evaluation not yet implemented" ^ Position.here pos))) else I ##> let val len = len - 1 in fn stack_ml => stack_ml |> (if length stack_ml <= len then tap (fn _ => warning ("Maximum depth reached (" ^ Int.toString (len - length stack_ml + 1) ^ " in excess)" ^ Position.here (Symbol_Pos.range syms |> Position.range_position))) #> tap (fn _ => warning ("Unevaluated code" ^ Position.here (ml_exec |> #1 |> Position.range_position))) #> I else if length stack_ml - len <= 2 then tap (fn _ => warning ("Unevaluated code\ \ as the hook is pointing to an internal initial value" ^ Position.here (ml_exec |> #1 |> Position.range_position))) #> I else nth_map len (cons ml_exec)) end end) l #>> C_Env.map_stream_hook (K ls)) fun add_stream_hook (syms_shift, syms, ml_exec) = C_Env.map_stream_hook (fn stream_hook => case fold (fn _ => fn (eval1, eval2) => (case eval2 of e2 :: eval2 => (e2, eval2) | [] => ([], [])) |>> (fn e1 => e1 :: eval1)) syms_shift ([], stream_hook) of (eval1, eval2) => fold cons eval1 (case eval2 of e :: es => ((syms_shift, syms, ml_exec) :: e) :: es | [] => [[(syms_shift, syms, ml_exec)]])) fun makeLexer ((stack, stack_ml, stack_pos, stack_tree), arg) = let val (token, arg) = C_Env_Ext.map_stream_lang' (fn (st, []) => (NONE, (st, [])) | (st, x :: xs) => (SOME x, (st, xs))) arg fun return0' f = (arg, stack_ml) |> advance_hook stack |> f |> (fn (arg, stack_ml) => rpair ((stack, stack_ml, stack_pos, stack_tree), arg)) fun return0 x = \ \Warning: \advance_hook\ must not be early evaluated here, as it might generate undesirable markup reporting (in annotation commands).\ \ \Todo: Arrange \advance_hook\ as a pure function, so that the overall could be eta-simplified.\ return0' I x val encoding = fn C_Lex.Encoding_L => true | _ => false open C_Ast fun token_err pos1 pos2 src = C_Grammar_Tokens.token_of_string (C_Grammar.Tokens.error (pos1, pos2)) (ClangCVersion0 (From_string src)) (CChar (From_char_hd "0") false) (CFloat (From_string src)) (CInteger 0 DecRepr (Flags 0)) (CString0 (From_string src, false)) (Ident (From_string src, 0, OnlyPos NoPosition (NoPosition, 0))) src pos1 pos2 src open C_Scan in case token of NONE => return0' (tap (fn (arg, _) => fold (uncurry (fn pos => fold_rev (fn (syms, _, _) => fn () => let val () = error ("Maximum depth reached (" ^ Int.toString (pos + 1) ^ " in excess)" ^ Position.here (Symbol_Pos.range syms |> Position.range_position)) in () end))) (map_index I (#stream_hook arg)) ())) (C_Grammar.Tokens.x25_eof (Position.none, Position.none)) | SOME (Left (antiq_raw, l_antiq)) => makeLexer ( (stack, stack_ml, stack_pos, stack_tree) , (arg, false) |> fold (fn C_Env.Antiq_stack (_, C_Env.Parsing ((syms_shift, syms), ml_exec)) => I #>> add_stream_hook (syms_shift, syms, ml_exec) | C_Env.Antiq_stack (_, C_Env.Never) => I ##> K true | _ => I) l_antiq |> (fn (arg, false) => arg | (arg, true) => C_Env_Ext.map_stream_ignored (cons (Left antiq_raw)) arg)) | SOME (Right (tok as C_Lex.Token (_, (C_Lex.Directive dir, _)))) => makeLexer ( (stack, stack_ml, stack_pos, stack_tree) , arg |> let val context = C_Env_Ext.get_context arg in fold (fn dir_tok => add_stream_hook ( [] , [] , ( Position.no_range , C_Env.Bottom_up (C_Env.Exec_directive (dir |> (case Symtab.lookup (C_Context0.Directives.get context) (C_Lex.content_of dir_tok) of NONE => K (K (K I)) | SOME (_, _, (_, exec)) => exec))) , Symtab.empty , true))) (C_Lex.directive_cmds dir) end |> C_Env_Ext.map_stream_ignored (cons (Right tok))) | SOME (Right (C_Lex.Token ((pos1, pos2), (tok, src)))) => case tok of C_Lex.String (C_Lex.Encoding_file (SOME err), _) => return0' (apfst (C_Env.map_env_tree (C_Env.map_error_lines (cons (err ^ Position.here pos1))))) (token_err pos1 pos2 src) | _ => return0 (case tok of C_Lex.Char (b, [c]) => C_Grammar.Tokens.cchar (CChar (From_char_hd (case c of Left c => c | _ => chr 0)) (encoding b), pos1, pos2) | C_Lex.String (b, s) => C_Grammar.Tokens.cstr (CString0 ( From_string ( implode (map (fn Left s => s | Right _ => chr 0) s)) , encoding b) , pos1 , pos2) | C_Lex.Integer (i, repr, flag) => C_Grammar.Tokens.cint ( CInteger i (case repr of C_Lex.Repr_decimal => DecRepr0 | C_Lex.Repr_hexadecimal => HexRepr0 | C_Lex.Repr_octal => OctalRepr0) (C_Lex.read_bin (fold (fn flag => map (fn (bit, flag0) => ( if flag0 = (case flag of C_Lex.Flag_unsigned => FlagUnsigned0 | C_Lex.Flag_long => FlagLong0 | C_Lex.Flag_long_long => FlagLongLong0 | C_Lex.Flag_imag => FlagImag0) then "1" else bit , flag0))) flag ([FlagUnsigned, FlagLong, FlagLongLong, FlagImag] |> rev |> map (pair "0")) |> map #1) |> Flags) , pos1 , pos2) | C_Lex.Float s => C_Grammar.Tokens.cfloat (CFloat (From_string (implode (map #1 s))), pos1, pos2) | C_Lex.Ident => let val (name, arg) = C_Grammar_Rule_Lib.getNewName arg val ident0 = C_Grammar_Rule_Lib.mkIdent (C_Grammar_Rule_Lib.posOf' false (pos1, pos2)) src name in if C_Grammar_Rule_Lib.isTypeIdent src arg then C_Grammar.Tokens.tyident (ident0, pos1, pos2) else C_Grammar.Tokens.ident (ident0, pos1, pos2) end | _ => token_err pos1 pos2 src) end end \ text \ This is where the instancing of the parser functor (from \<^theory>\Isabelle_C.C_Parser_Language\) with the lexer (from \<^theory>\Isabelle_C.C_Lexer_Language\) actually happens ... \ ML \ \\<^theory>\Isabelle_C.C_Parser_Language\\ \ structure C_Grammar_Parser = LALR_Parser_Join (structure LrParser = LALR_Parser_Eval structure ParserData = C_Grammar.ParserData structure Lex = C_Grammar_Lexer) \ ML \ \\<^file>\~~/src/Pure/ML/ml_compiler.ML\\ \ structure C_Language = struct open C_Env fun exec_tree write msg (Tree ({rule_pos, rule_type}, l_tree)) = case rule_type of Void => write msg rule_pos "VOID" NONE | Shift => write msg rule_pos "SHIFT" NONE | Reduce (rule_static, (rule0, vacuous, rule_antiq)) => write msg rule_pos ("REDUCE " ^ Int.toString rule0 ^ " " ^ (if vacuous then "X" else "O")) (SOME (C_Grammar_Rule.string_reduce rule0 ^ " " ^ C_Grammar_Rule.type_reduce rule0)) #> (case rule_static of SOME rule_static => rule_static #>> SOME | NONE => pair NONE) #-> (fn env_lang => fold (fn (stack0, env_lang0, (_, C_Env.Top_down exec, env_dir, _)) => C_Stack.stack_exec env_dir (stack0, Option.getOpt (env_lang, env_lang0)) (exec (SOME rule0)) | _ => I) rule_antiq) #> fold (exec_tree write (msg ^ " ")) l_tree fun exec_tree' l env_tree = env_tree |> fold (exec_tree let val ctxt = Context.proof_of (#context env_tree) val write = if Config.get ctxt C_Options.parser_trace andalso Context_Position.is_visible ctxt then fn f => tap (tracing o f) else K I in fn msg => fn (p1, p2) => fn s1 => fn s2 => write (fn _ => msg ^ s1 ^ " " ^ Position.here p1 ^ " " ^ Position.here p2 ^ (case s2 of SOME s2 => " " ^ s2 | NONE => "")) end "") l fun uncurry_context f pos = uncurry (fn x => fn arg => map_env_tree' (f pos x (#env_lang arg)) arg) fun eval env_lang start err accept stream_lang = make env_lang stream_lang #> C_Grammar_Parser.makeLexer #> C_Grammar_Parser.parse ( 0 , uncurry_context (fn (next_pos1, next_pos2) => fn (stack, _, _, stack_tree) => fn env_lang => C_Env.map_reports_text (cons ( ( Position.range_position (case hd stack of (_, (_, pos1, pos2)) => (pos1, pos2)) , Markup.bad ()) , "") #> (case rev (tl stack) of _ :: _ :: stack => append (map_filter (fn (pos1, pos2) => if Position.offset_of pos1 = Position.offset_of pos2 then NONE else SOME ((Position.range_position (pos1, pos2), Markup.intensify), "")) ((next_pos1, next_pos2) :: map (fn (_, (_, pos1, pos2)) => (pos1, pos2)) stack)) | _ => I)) #> exec_tree' (rev stack_tree) #> err env_lang stack (Position.range_position (case hd stack_tree of Tree ({rule_pos = (rule_pos1, _), ...}, _) => (rule_pos1, next_pos2)))) , Position.none , start , uncurry_context (fn _ => fn (stack, _, _, stack_tree) => fn env_lang => exec_tree' stack_tree #> accept env_lang (stack |> hd |> C_Stack.map_svalue0 C_Grammar_Rule.reduce0)) , fn (stack, arg) => arg |> map_rule_input (K stack) |> map_rule_output (K empty_rule_output) , fn (rule0, stack0, pre_ml) => fn arg => let val rule_output = #rule_output arg val env_lang = #env_lang arg val (delayed, actual) = if #output_vacuous rule_output then let fun f (_, _, _, to_delay) = to_delay in (map (filter f) pre_ml, map (filter_out f) pre_ml) end else ([], pre_ml) val actual = flat (map rev actual) in ( (delayed, map (fn x => (stack0, env_lang, x)) actual, rule_output) , fold (fn (_, C_Env.Bottom_up (C_Env.Exec_annotation exec), env_dir, _) => C_Env.map_env_tree (C_Stack.stack_exec env_dir (stack0, env_lang) (exec (SOME rule0))) | (_, C_Env.Bottom_up (C_Env.Exec_directive exec), env_dir, _) => C_Env.map_env_lang_tree (curry (exec (SOME rule0) env_dir)) | _ => I) actual arg) end) #> snd #> apsnd #env_tree end \ subsection \Full Evaluation Engine (Core Language with Annotations)\ \ \\<^file>\~~/src/Pure/Thy/thy_info.ML\: \<^theory>\Isabelle_C.C_Parser_Language\, \<^theory>\Isabelle_C.C_Parser_Annotation\\ ML \ \\<^file>\~~/src/Pure/ML/ml_context.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/ML/ml_context.ML Author: Makarius ML context and antiquotations. *) \ structure C_Context = struct fun fun_decl a v s ctxt = let val (b, ctxt') = ML_Context.variant a ctxt; val env = "fun " ^ b ^ " " ^ v ^ " = " ^ s ^ " " ^ v ^ ";\n"; val body = ML_Context.struct_name ctxt ^ "." ^ b; fun decl (_: Proof.context) = (env, body); in (decl, ctxt') end; (* parsing and evaluation *) local fun scan_antiq context syms = let val keywords = C_Thy_Header.get_keywords' (Context.proof_of context) in ( C_Token.read_antiq' keywords (C_Parse.!!! (Scan.trace (C_Annotation.parse_command (Context.theory_of context)) >> (I #>> C_Env.Antiq_stack))) syms , C_Token.read_with_commands'0 keywords syms) end fun print0 s = maps (fn C_Lex.Token (_, (t as C_Lex.Directive d, _)) => (s ^ @{make_string} t) :: print0 (s ^ " ") (C_Lex.token_list_of d) | C_Lex.Token (_, t) => [case t of (C_Lex.Char _, _) => "Text Char" | (C_Lex.String _, _) => "Text String" | _ => let val t' = @{make_string} (#2 t) in if String.size t' <= 2 then @{make_string} (#1 t) else s ^ @{make_string} (#1 t) ^ " " ^ (String.substring (t', 1, String.size t' - 2) |> Markup.markup Markup.intensify) end]) val print = tracing o cat_lines o print0 "" open C_Scan fun markup_directive ty = C_Grammar_Rule_Lib.markup_make (K NONE) (K ()) (K ty) in fun markup_directive_command data = markup_directive "directive command" (fn cons' => fn def => fn C_Ast.Left _ => cons' (Markup.keyword_properties (if def then Markup.free else Markup.keyword1)) | C_Ast.Right (_, msg, f) => tap (fn _ => Output.information msg) #> f #> cons' (Markup.keyword_properties Markup.free)) data fun directive_update (name, pos) f tab = let val pos = [pos] val data = (pos, serial (), f) val _ = Position.reports_text (markup_directive_command (C_Ast.Left (data, C_Env_Ext.list_lookup tab name)) pos name []) in Symtab.update (name, data) tab end fun markup_directive_define in_direct = C_Env.map_reports_text ooo markup_directive "directive define" (fn cons' => fn def => fn err => (if def orelse in_direct then I else cons' Markup.language_antiquotation) #> (case err of C_Ast.Left _ => I | C_Ast.Right (_, msg, f) => tap (fn _ => Output.information msg) #> f) #> (if def then cons' Markup.free else if in_direct then I else cons' Markup.antiquote)) fun eval env start err accept (ants, ants_err) {context, reports_text, error_lines} = let val error_lines = ants_err error_lines fun scan_comment tag pos (antiq as {explicit, body, ...}) cts = let val (res, l_comm) = scan_antiq context body in Left ( tag , antiq , l_comm , if forall (fn Right _ => true | _ => false) res then let val (l_msg, res) = split_list (map_filter (fn Right (msg, l_report, l_tok) => SOME (msg, (l_report, l_tok)) | _ => NONE) res) val (l_report, l_tok) = split_list res in [( C_Env.Antiq_none (C_Lex.Token (pos, ( (C_Lex.Comment o C_Lex.Comment_suspicious o SOME) ( explicit , cat_lines l_msg , if explicit then flat l_report else []) , cts))) , l_tok)] end else map (fn Left x => x | Right (msg, l_report, tok) => (C_Env.Antiq_none (C_Lex.Token ( C_Token.range_of [tok] , ( (C_Lex.Comment o C_Lex.Comment_suspicious o SOME) (explicit, msg, l_report) , C_Token.content_of tok))) , [tok])) res) end val ants = map (fn C_Lex.Token (pos, (C_Lex.Comment (C_Lex.Comment_formal antiq), cts)) => scan_comment C_Env.Comment_language pos antiq cts | tok => Right tok) ants fun map_ants f1 f2 = maps (fn Left x => f1 x | Right tok => f2 tok) val ants_none = map_ants (fn (_, _, _, l) => maps (fn (C_Env.Antiq_none x, _) => [x] | _ => []) l) (K []) ants val _ = Position.reports (maps (fn Left (_, _, _, [(C_Env.Antiq_none _, _)]) => [] | Left (_, {start, stop, range = (pos, _), ...}, _, _) => (case stop of SOME stop => cons (stop, Markup.antiquote) | NONE => I) [(start, Markup.antiquote), (pos, Markup.language_antiquotation)] | _ => []) ants); val _ = Position.reports_text (maps C_Lex.token_report ants_none @ maps (fn Left (_, _, _, [(C_Env.Antiq_none _, _)]) => [] | Left (_, _, l, ls) => maps (fn (C_Env.Antiq_stack (pos, _), _) => pos | _ => []) ls @ maps (maps (C_Token.reports (C_Thy_Header.get_keywords (Context.theory_of context)))) (l :: map #2 ls) | _ => []) ants); val error_lines = C_Lex.check ants_none error_lines; val ((ants, {context, reports_text, error_lines}), env) = C_Env_Ext.map_env_directives' (fn env_dir => let val (ants, (env_dir, env_tree)) = fold_map let fun subst_directive tok (range1 as (pos1, _)) name (env_dir, env_tree) = case Symtab.lookup env_dir name of NONE => (Right (Left tok), (env_dir, env_tree)) | SOME (data as (_, _, (exec_toks, exec_antiq))) => env_tree |> markup_directive_define false (C_Ast.Right ([pos1], SOME data)) [pos1] name |> (case exec_toks of Left exec_toks => C_Env.map_context' (exec_toks (name, range1)) #> apfst (fn toks => (toks, Symtab.update (name, ( #1 data , #2 data , (Right toks, exec_antiq))) env_dir)) | Right toks => pair (toks, env_dir)) ||> C_Env.map_context (exec_antiq (name, range1)) |-> (fn (toks, env_dir) => pair (Right (Right (pos1, map (C_Lex.set_range range1) toks))) o pair env_dir) in fn Left (tag, antiq, toks, l_antiq) => fold_map (fn antiq as (C_Env.Antiq_stack (_, C_Env.Lexing (_, exec)), _) => apsnd (C_Stack.stack_exec0 (exec C_Env.Comment_language)) #> pair antiq | (C_Env.Antiq_stack (rep, C_Env.Parsing (syms, (range, exec, _, skip))), toks) => (fn env as (env_dir, _) => ( ( C_Env.Antiq_stack (rep, C_Env.Parsing (syms, (range, exec, env_dir, skip))) , toks) , env)) | antiq => pair antiq) l_antiq #> apfst (fn l_antiq => Left (tag, antiq, toks, l_antiq)) | Right tok => case tok of C_Lex.Token (_, (C_Lex.Directive dir, _)) => pair false #> fold (fn dir_tok => let val name = C_Lex.content_of dir_tok val pos1 = [C_Lex.pos_of dir_tok] in fn env_tree as (_, (_, {context = context, ...})) => let val data = Symtab.lookup (C_Context0.Directives.get context) name in env_tree |> apsnd (apsnd (C_Env.map_reports_text (markup_directive_command (C_Ast.Right (pos1, data)) pos1 name))) |> (case data of NONE => I | SOME (_, _, (exec, _)) => exec dir #> #2) end end) (C_Lex.directive_cmds dir) #> snd #> tap (fn _ => app (fn C_Lex.Token ( (pos, _) , (C_Lex.Comment (C_Lex.Comment_formal _), _)) => (Position.reports_text [((pos, Markup.ML_comment), "")]; (* not yet implemented *) warning ("Ignored annotation in directive" ^ Position.here pos)) | _ => ()) (C_Lex.token_list_of dir)) #> pair (Right (Left tok)) | C_Lex.Token (pos, (C_Lex.Keyword, cts)) => subst_directive tok pos cts | C_Lex.Token (pos, (C_Lex.Ident, cts)) => subst_directive tok pos cts | _ => pair (Right (Left tok)) end ants ( env_dir , {context = context, reports_text = reports_text, error_lines = error_lines}) in ((ants, env_tree), env_dir) end) env val ants_stack = map_ants (single o Left o (fn (_, a, _, l) => (a, maps (single o #1) l))) (map Right o (fn Left tok => [tok] | Right (_, toks) => toks)) ants val _ = Position.reports_text (maps (fn Right (Left tok) => C_Lex.token_report tok | Right (Right (pos, [])) => [((pos, Markup.intensify), "")] | _ => []) ants); val ctxt = Context.proof_of context val () = if Config.get ctxt C_Options.lexer_trace andalso Context_Position.is_visible ctxt then print (map_filter (fn Right x => SOME x | _ => NONE) ants_stack) else () in C_Language.eval env start err accept ants_stack {context = context, reports_text = reports_text, error_lines = error_lines} end (* derived versions *) fun eval' env start err accept ants = Context.>>> (fn context => C_Env_Ext.context_map' (eval (env context) (start context) err accept ants #> apsnd (tap (Position.reports_text o #reports_text) #> tap (#error_lines #> (fn [] => () | l => error (cat_lines (rev l)))) #> (C_Env.empty_env_tree o #context))) context) end; fun eval_source env start err accept source = eval' env (start source) err accept (C_Lex.read_source source); fun eval_source' env start err accept source = eval env (start source) err accept (C_Lex.read_source source); fun eval_in o_context env start err accept toks = Context.setmp_generic_context o_context (fn () => eval' env start err accept toks) (); fun expression struct_open range name constraint body ants context = context |> ML_Context.exec let val verbose = Config.get (Context.proof_of context) C_Options.ML_verbose in fn () => ML_Context.eval (ML_Compiler.verbose verbose ML_Compiler.flags) (#1 range) (ML_Lex.read ("Context.put_generic_context (SOME (let open " ^ struct_open ^ " val ") @ ML_Lex.read_range range name @ ML_Lex.read (": " ^ constraint ^ " =") @ ants @ ML_Lex.read ("in " ^ body ^ " end (Context.the_generic_context ())));")) end; end \ end diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy --- a/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy +++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy @@ -1,1410 +1,1409 @@ (****************************************************************************** * Isabelle/C * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) section \Annotation Language: Parsing Combinator\ theory C_Lexer_Annotation imports C_Lexer_Language begin ML \ \\<^file>\~~/src/Pure/Isar/keyword.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/Isar/keyword.ML Author: Makarius Isar keyword classification. *) \ structure C_Keyword = struct (** keyword classification **) (* kinds *) val command_kinds = [Keyword.diag, Keyword.document_heading, Keyword.document_body, Keyword.document_raw, Keyword.thy_begin, Keyword.thy_end, Keyword.thy_load, Keyword.thy_decl, Keyword.thy_decl_block, Keyword.thy_defn, Keyword.thy_stmt, Keyword.thy_goal, Keyword.thy_goal_defn, Keyword.thy_goal_stmt, Keyword.qed, Keyword.qed_script, Keyword.qed_block, Keyword.qed_global, Keyword.prf_goal, Keyword.prf_block, Keyword.next_block, Keyword.prf_open, Keyword.prf_close, Keyword.prf_chain, Keyword.prf_decl, Keyword.prf_asm, Keyword.prf_asm_goal, Keyword.prf_script, Keyword.prf_script_goal, Keyword.prf_script_asm_goal]; (* specifications *) type entry = {pos: Position.T, id: serial, kind: string, files: string list, (*extensions of embedded files*) tags: string list}; fun check_spec pos ((kind, files), tags) : entry = if not (member (op =) command_kinds kind) then error ("Unknown annotation syntax keyword kind " ^ quote kind) else if not (null files) andalso kind <> Keyword.thy_load then error ("Illegal specification of files for " ^ quote kind) else {pos = pos, id = serial (), kind = kind, files = files, tags = tags}; (** keyword tables **) (* type keywords *) datatype keywords = Keywords of {minor: Scan.lexicon, major: Scan.lexicon, commands: entry Symtab.table}; fun minor_keywords (Keywords {minor, ...}) = minor; fun major_keywords (Keywords {major, ...}) = major; fun make_keywords (minor, major, commands) = Keywords {minor = minor, major = major, commands = commands}; fun map_keywords f (Keywords {minor, major, commands}) = make_keywords (f (minor, major, commands)); (* build keywords *) val empty_keywords = make_keywords (Scan.empty_lexicon, Scan.empty_lexicon, Symtab.empty); fun empty_keywords' minor = make_keywords (minor, Scan.empty_lexicon, Symtab.empty); fun merge_keywords (Keywords {minor = minor1, major = major1, commands = commands1}, Keywords {minor = minor2, major = major2, commands = commands2}) = make_keywords (Scan.merge_lexicons (minor1, minor2), Scan.merge_lexicons (major1, major2), Symtab.merge (K true) (commands1, commands2)); val add_keywords0 = fold (fn ((name, pos), force_minor, spec as ((kind, _), _)) => map_keywords (fn (minor, major, commands) => let val extend = Scan.extend_lexicon (Symbol.explode name) fun update spec = Symtab.update (name, spec) in if force_minor then (extend minor, major, update (check_spec pos spec) commands) else if kind = "" orelse kind = Keyword.before_command orelse kind = Keyword.quasi_command then (extend minor, major, commands) else (minor, extend major, update (check_spec pos spec) commands) end)); val add_keywords = add_keywords0 o map (fn (cmd, spec) => (cmd, false, spec)) val add_keywords_minor = add_keywords0 o map (fn (cmd, spec) => (cmd, true, spec)) (* keyword status *) fun is_command (Keywords {commands, ...}) = Symtab.defined commands; fun dest_commands (Keywords {commands, ...}) = Symtab.keys commands; (* command keywords *) fun lookup_command (Keywords {commands, ...}) = Symtab.lookup commands; fun command_markup keywords name = lookup_command keywords name |> Option.map (fn {pos, id, ...} => Position.make_entity_markup {def = false} id Markup.command_keywordN (name, pos)); fun command_files keywords name path = (case lookup_command keywords name of NONE => [] | SOME {kind, files, ...} => if kind <> Keyword.thy_load then [] else if null files then [path] else map (fn ext => Path.ext ext path) files); (* command categories *) fun command_category ks = let val tab = Symtab.make_set ks; fun pred keywords name = (case lookup_command keywords name of NONE => false | SOME {kind, ...} => Symtab.defined tab kind); in pred end; val is_theory_end = command_category [Keyword.thy_end]; val is_proof_asm = command_category [Keyword.prf_asm, Keyword.prf_asm_goal]; val is_improper = command_category [ Keyword.qed_script , Keyword.prf_script , Keyword.prf_script_goal , Keyword.prf_script_asm_goal]; end; \ text \ Notes: \<^item> The next structure contains a duplicated copy of the type \<^ML_type>\Token.T\, since it is not possible to set an arbitrary \<^emph>\slot\ value in \<^ML_structure>\Token\. \<^item> Parsing priorities in C and HOL slightly differ, see for instance \<^ML>\Token.explode\. \ ML \ \\<^file>\~~/src/Pure/Isar/token.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/Isar/token.ML Author: Markus Wenzel, TU Muenchen Outer token syntax for Isabelle/Isar. *) \ structure C_Token = struct (** tokens **) (* token kind *) val immediate_kinds' = fn Token.Command => 0 | Token.Keyword => 1 | Token.Ident => 2 | Token.Long_Ident => 3 | Token.Sym_Ident => 4 | Token.Var => 5 | Token.Type_Ident => 6 | Token.Type_Var => 7 | Token.Nat => 8 | Token.Float => 9 | Token.Space => 10 | _ => ~1 val delimited_kind = (fn Token.String => true | Token.Alt_String => true | Token.Verbatim => true | Token.Cartouche => true | Token.Comment _ => true | _ => false); (* datatype token *) (*The value slot assigns an (optional) internal value to a token, usually as a side-effect of special scanner setup (see also args.ML). Note that an assignable ref designates an intermediate state of internalization -- it is NOT meant to persist.*) datatype T = Token of (Symbol_Pos.text * Position.range) * (Token.kind * string) * slot and slot = Slot | Value of value option | Assignable of value option Unsynchronized.ref and value = Source of T list | Literal of bool * Markup.T | Name of Token.name_value * morphism | Typ of typ | Term of term | Fact of string option * thm list | (*optional name for dynamic fact, i.e. fact "variable"*) Attribute of morphism -> attribute | Declaration of declaration | Files of Token.file Exn.result list; type src = T list; (* position *) fun pos_of (Token ((_, (pos, _)), _, _)) = pos; fun end_pos_of (Token ((_, (_, pos)), _, _)) = pos; fun adjust_offsets adjust (Token ((x, range), y, z)) = Token ((x, apply2 (Position.adjust_offsets adjust) range), y, z); (* stopper *) fun mk_eof pos = Token (("", (pos, Position.none)), (Token.EOF, ""), Slot); val eof = mk_eof Position.none; fun is_eof (Token (_, (Token.EOF, _), _)) = true | is_eof _ = false; val not_eof = not o is_eof; val stopper = Scan.stopper (fn [] => eof | toks => mk_eof (end_pos_of (List.last toks))) is_eof; (* kind of token *) fun kind_of (Token (_, (k, _), _)) = k; fun is_kind k (Token (_, (k', _), _)) = k = k'; val is_command = is_kind Token.Command; fun keyword_with pred (Token (_, (Token.Keyword, x), _)) = pred x | keyword_with _ _ = false; val is_command_modifier = keyword_with (fn x => x = "private" orelse x = "qualified"); fun ident_with pred (Token (_, (Token.Ident, x), _)) = pred x | ident_with _ _ = false; fun is_ignored (Token (_, (Token.Space, _), _)) = true | is_ignored (Token (_, (Token.Comment NONE, _), _)) = true | is_ignored _ = false; fun is_proper (Token (_, (Token.Space, _), _)) = false | is_proper (Token (_, (Token.Comment _, _), _)) = false | is_proper _ = true; fun is_comment (Token (_, (Token.Comment _, _), _)) = true | is_comment _ = false; fun is_informal_comment (Token (_, (Token.Comment NONE, _), _)) = true | is_informal_comment _ = false; fun is_formal_comment (Token (_, (Token.Comment (SOME _), _), _)) = true | is_formal_comment _ = false; fun is_document_marker (Token (_, (Token.Comment (SOME Comment.Marker), _), _)) = true | is_document_marker _ = false; fun is_begin_ignore (Token (_, (Token.Comment NONE, "<"), _)) = true | is_begin_ignore _ = false; fun is_end_ignore (Token (_, (Token.Comment NONE, ">"), _)) = true | is_end_ignore _ = false; fun is_error (Token (_, (Token.Error _, _), _)) = true | is_error _ = false; fun is_error' (Token (_, (Token.Error msg, _), _)) = SOME msg | is_error' _ = NONE; fun content_of (Token (_, (_, x), _)) = x; fun content_of' (Token (_, (_, _), Value (SOME (Source l)))) = map (fn Token ((_, (pos, _)), (_, x), _) => (x, pos)) l | content_of' _ = []; val is_stack1 = fn Token (_, (Token.Sym_Ident, _), Value (SOME (Source l))) => forall (fn tok => content_of tok = "+") l | _ => false; val is_stack2 = fn Token (_, (Token.Sym_Ident, _), Value (SOME (Source l))) => forall (fn tok => content_of tok = "@") l | _ => false; val is_stack3 = fn Token (_, (Token.Sym_Ident, _), Value (SOME (Source l))) => forall (fn tok => content_of tok = "&") l | _ => false; (* blanks and newlines -- space tokens obey lines *) fun is_space (Token (_, (Space, _), _)) = true | is_space _ = false; fun is_blank (Token (_, (Space, x), _)) = not (String.isSuffix "\n" x) | is_blank _ = false; fun is_newline (Token (_, (Space, x), _)) = String.isSuffix "\n" x | is_newline _ = false; (* range of tokens *) fun range_of (toks as tok :: _) = let val pos' = end_pos_of (List.last toks) in Position.range (pos_of tok, pos') end | range_of [] = Position.no_range; val core_range_of = drop_prefix is_ignored #> drop_suffix is_ignored #> range_of; (* token content *) fun content_of (Token (_, (_, x), _)) = x; fun source_of (Token ((source, _), _, _)) = source; fun input_of (Token ((source, range), (kind, _), _)) = Input.source (delimited_kind kind) source range; fun inner_syntax_of tok = let val x = content_of tok in if YXML.detect x then x else Syntax.implode_input (input_of tok) end; (* markup reports *) local val token_kind_markup = fn Token.Var => (Markup.var, "") | Token.Type_Ident => (Markup.tfree, "") | Token.Type_Var => (Markup.tvar, "") | Token.String => (Markup.string, "") | Token.Alt_String => (Markup.alt_string, "") | Token.Verbatim => (Markup.verbatim, "") | Token.Cartouche => (Markup.cartouche, "") | Token.Comment _ => (Markup.ML_comment, "") | Token.Error msg => (Markup.bad (), msg) | _ => (Markup.empty, ""); fun keyword_reports tok = map (fn markup => ((pos_of tok, markup), "")); fun command_markups keywords x = if C_Keyword.is_theory_end keywords x then [Markup.keyword2 |> Markup.keyword_properties] else (if C_Keyword.is_proof_asm keywords x then [Markup.keyword3] else if C_Keyword.is_improper keywords x then [Markup.keyword1, Markup.improper] else [Markup.keyword1]) |> map Markup.command_properties; fun keyword_markup (important, keyword) x = if important orelse Symbol.is_ascii_identifier x then keyword else Markup.delimiter; fun command_minor_markups keywords x = if C_Keyword.is_theory_end keywords x then [Markup.keyword2 |> Markup.keyword_properties] else (if C_Keyword.is_proof_asm keywords x then [Markup.keyword3] else if C_Keyword.is_improper keywords x then [Markup.keyword1, Markup.improper] else if C_Keyword.is_command keywords x then [Markup.keyword1] else [keyword_markup (false, Markup.keyword2 |> Markup.keyword_properties) x]); in fun completion_report tok = if is_kind Token.Keyword tok then map (fn m => ((pos_of tok, m), "")) (Completion.suppress_abbrevs (content_of tok)) else []; fun reports keywords tok = if is_command tok then keyword_reports tok (command_markups keywords (content_of tok)) else if is_stack1 tok orelse is_stack2 tok orelse is_stack3 tok then keyword_reports tok [Markup.keyword2 |> Markup.keyword_properties] else if is_kind Token.Keyword tok then keyword_reports tok (command_minor_markups keywords (content_of tok)) else let val pos = pos_of tok; val (m, text) = token_kind_markup (kind_of tok); val deleted = Symbol_Pos.explode_deleted (source_of tok, pos); in ((pos, m), text) :: map (fn p => ((p, Markup.delete), "")) deleted end; fun markups keywords = map (#2 o #1) o reports keywords; end; (* unparse *) fun unparse' (Token ((source0, _), (kind, x), _)) = let val source = \ \ We are computing a reverse function of \<^ML>\Symbol_Pos.implode_range\ taking into account consecutive \<^ML>\Symbol.DEL\ symbols potentially appearing at the beginning, or at the end of the string. As remark, \<^ML>\Symbol_Pos.explode\ will remove any potentially consecutive \<^ML>\Symbol.DEL\ symbols. This is why it is not used here.\ case Symbol.explode source0 of x :: xs => if x = Symbol.DEL then case rev xs of x' :: xs => if x' = Symbol.DEL then implode (rev xs) else source0 | _ => source0 else source0 | _ => source0 in case kind of Token.String => Symbol_Pos.quote_string_qq source | Token.Alt_String => Symbol_Pos.quote_string_bq source | Token.Verbatim => enclose "{*" "*}" source | Token.Cartouche => cartouche source | Token.Comment NONE => enclose "(*" "*)" source | Token.EOF => "" | _ => x end; fun text_of tok = let val k = Token.str_of_kind (kind_of tok); val ms = markups C_Keyword.empty_keywords tok; val s = unparse' tok; in if s = "" then (k, "") else if size s < 40 andalso not (exists_string (fn c => c = "\n") s) then (k ^ " " ^ Markup.markups ms s, "") else (k, Markup.markups ms s) end; (** associated values **) (* inlined file content *) fun file_source (file: Token.file) = let val text = cat_lines (#lines file); val end_pos = Position.symbol_explode text (#pos file); in Input.source true text (Position.range (#pos file, end_pos)) end; fun get_files (Token (_, _, Value (SOME (Files files)))) = files | get_files _ = []; fun put_files [] tok = tok | put_files files (Token (x, y, Slot)) = Token (x, y, Value (SOME (Files files))) | put_files _ tok = raise Fail ("Cannot put inlined files here" ^ Position.here (pos_of tok)); (* access values *) (* reports of value *) (* name value *) (* maxidx *) (* fact values *) (* transform *) (* static binding *) (*1st stage: initialize assignable slots*) fun init_assignable tok = (case tok of Token (x, y, Slot) => Token (x, y, Assignable (Unsynchronized.ref NONE)) | Token (_, _, Value _) => tok | Token (_, _, Assignable r) => (r := NONE; tok)); (*2nd stage: assign values as side-effect of scanning*) fun assign v tok = (case tok of Token (x, y, Slot) => Token (x, y, Value v) | Token (_, _, Value _) => tok | Token (_, _, Assignable r) => (r := v; tok)); fun evaluate mk eval arg = let val x = eval arg in (assign (SOME (mk x)) arg; x) end; (*3rd stage: static closure of final values*) fun closure (Token (x, y, Assignable (Unsynchronized.ref v))) = Token (x, y, Value v) | closure tok = tok; (* pretty *) (* src *) (** scanners **) open Basic_Symbol_Pos; val err_prefix = "Annotation lexical error: "; fun !!! msg = Symbol_Pos.!!! (fn () => err_prefix ^ msg); (* scan stack *) fun scan_stack is_stack = Scan.optional (Scan.one is_stack >> content_of') [] (* scan symbolic idents *) val scan_symid = Scan.many1 (Symbol.is_symbolic_char o Symbol_Pos.symbol) || Scan.one (Symbol.is_symbolic o Symbol_Pos.symbol) >> single; fun is_symid str = (case try Symbol.explode str of SOME [s] => Symbol.is_symbolic s orelse Symbol.is_symbolic_char s | SOME ss => forall Symbol.is_symbolic_char ss | _ => false); fun ident_or_symbolic "begin" = false | ident_or_symbolic ":" = true | ident_or_symbolic "::" = true | ident_or_symbolic s = Symbol_Pos.is_identifier s orelse is_symid s; (* scan verbatim text *) val scan_verb = $$$ "*" --| Scan.ahead (~$$ "}") || Scan.one (fn (s, _) => s <> "*" andalso Symbol.not_eof s) >> single; val scan_verbatim = Scan.ahead ($$ "{" -- $$ "*") |-- !!! "unclosed verbatim text" ((Symbol_Pos.scan_pos --| $$ "{" --| $$ "*") -- (Scan.repeats scan_verb -- ($$ "*" |-- $$ "}" |-- Symbol_Pos.scan_pos))); val recover_verbatim = $$$ "{" @@@ $$$ "*" @@@ Scan.repeats scan_verb; (* scan cartouche *) val scan_cartouche = Symbol_Pos.scan_pos -- ((Symbol_Pos.scan_cartouche err_prefix >> Symbol_Pos.cartouche_content) -- Symbol_Pos.scan_pos); (* scan space *) fun space_symbol (s, _) = Symbol.is_blank s andalso s <> "\n"; val scan_space = Scan.many1 space_symbol @@@ Scan.optional ($$$ "\n") [] || Scan.many space_symbol @@@ $$$ "\n"; (* scan comment *) val scan_comment = Symbol_Pos.scan_pos -- (Symbol_Pos.scan_comment_body err_prefix -- Symbol_Pos.scan_pos); (** token sources **) local fun token_leq ((_, syms1), (_, syms2)) = length syms1 <= length syms2; fun token k ss = Token ((Symbol_Pos.implode ss, Symbol_Pos.range ss), (k, Symbol_Pos.content ss), Slot); fun token' (mk_value, k) ss = if mk_value then Token ( (Symbol_Pos.implode ss, Symbol_Pos.range ss) , (k, Symbol_Pos.content ss) , Value (SOME (Source (map (fn (s, pos) => Token (("", (pos, Position.none)), (k, s), Slot)) ss)))) else token k ss; fun token_t k = token' (true, k) fun token_range k (pos1, (ss, pos2)) = Token (Symbol_Pos.implode_range (pos1, pos2) ss, (k, Symbol_Pos.content ss), Slot); fun scan_token keywords = !!! "bad input" (Symbol_Pos.scan_string_qq err_prefix >> token_range Token.String || Symbol_Pos.scan_string_bq err_prefix >> token_range Token.Alt_String || scan_verbatim >> token_range Token.Verbatim || scan_cartouche >> token_range Token.Cartouche || scan_comment >> token_range (Token.Comment NONE) || Comment.scan_outer >> (fn (k, ss) => token (Token.Comment (SOME k)) ss) || scan_space >> token Token.Space || Scan.repeats1 ($$$ "+") >> token_t Token.Sym_Ident || Scan.repeats1 ($$$ "@") >> token_t Token.Sym_Ident || Scan.repeats1 ($$$ "&") >> token_t Token.Sym_Ident || (Scan.max token_leq (Scan.max token_leq (Scan.literal (C_Keyword.major_keywords keywords) >> pair Token.Command) (Scan.literal (C_Keyword.minor_keywords keywords) >> pair Token.Keyword)) (Lexicon.scan_longid >> pair Token.Long_Ident || Scan.max token_leq (C_Lex.scan_ident >> pair Token.Ident) (Lexicon.scan_id >> pair Token.Ident) || Lexicon.scan_var >> pair Token.Var || Lexicon.scan_tid >> pair Token.Type_Ident || Lexicon.scan_tvar >> pair Token.Type_Var || Symbol_Pos.scan_float >> pair Token.Float || Symbol_Pos.scan_nat >> pair Token.Nat || scan_symid >> pair Token.Sym_Ident)) >> uncurry (token' o pair false)); fun recover msg = (Symbol_Pos.recover_string_qq || Symbol_Pos.recover_string_bq || recover_verbatim || Symbol_Pos.recover_cartouche || Symbol_Pos.recover_comment || Scan.one (Symbol.not_eof o Symbol_Pos.symbol) >> single) >> (single o token (Token.Error msg)); in fun make_source keywords {strict} = let val scan_strict = Scan.bulk (scan_token keywords); val scan = if strict then scan_strict else Scan.recover scan_strict recover; in Source.source Symbol_Pos.stopper scan end; end; (* explode *) fun tokenize keywords strict syms = Source.of_list syms |> make_source keywords strict |> Source.exhaust; fun explode keywords pos text = Symbol_Pos.explode (text, pos) |> tokenize keywords {strict = false}; fun explode0 keywords = explode keywords Position.none; (* print name in parsable form *) (* make *) (** parsers **) type 'a parser = T list -> 'a * T list; type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list); (* read body -- e.g. antiquotation source *) fun read_with_commands'0 keywords syms = Source.of_list syms |> make_source keywords {strict = false} |> Source.filter (not o is_proper) |> Source.exhaust fun read_with_commands' keywords scan syms = Source.of_list syms |> make_source keywords {strict = false} |> Source.filter is_proper |> Source.source stopper (Scan.recover (Scan.bulk scan) (fn msg => Scan.one (not o is_eof) >> (fn tok => [C_Scan.Right let val msg = case is_error' tok of SOME msg0 => msg0 ^ " (" ^ msg ^ ")" | NONE => msg in ( msg , [((pos_of tok, Markup.bad ()), msg)] , tok) end]))) |> Source.exhaust; fun read_antiq' keywords scan = read_with_commands' keywords (scan >> C_Scan.Left); (* wrapped syntax *) local fun make src pos = Token.make src pos |> #1 fun make_default text pos = make ((~1, 0), text) pos fun explode keywords pos text = case Token.explode keywords pos text of [tok] => tok | _ => make_default text pos in fun syntax' f = I #> map (fn tok0 as Token ((source, (pos1, pos2)), (kind, x), _) => if is_stack1 tok0 orelse is_stack2 tok0 orelse is_stack3 tok0 then make_default source pos1 else if is_eof tok0 then Token.eof else if delimited_kind kind then explode Keyword.empty_keywords pos1 (unparse' tok0) else let val tok1 = explode ((case kind of Token.Keyword => Keyword.add_keywords [((x, Position.none), Keyword.no_spec)] | Token.Command => Keyword.add_keywords [( (x, Position.none), (Keyword.thy_decl, []))] | _ => I) Keyword.empty_keywords) pos1 source in if Token.kind_of tok1 = kind then tok1 else make ( ( immediate_kinds' kind , case Position.distance_of (pos1, pos2) of NONE => 0 | SOME i => i) , source) pos1 end) #> f #> apsnd (map (fn tok => Token ( (Token.source_of tok, Token.range_of [tok]) , (Token.kind_of tok, Token.content_of tok) , Slot))) end end; type 'a c_parser = 'a C_Token.parser; type 'a c_context_parser = 'a C_Token.context_parser; \ ML \ \\<^file>\~~/src/Pure/Isar/parse.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/Isar/parse.ML Author: Markus Wenzel, TU Muenchen Generic parsers for Isabelle/Isar outer syntax. *) \ signature C_PARSE = sig type T type src = T list type 'a parser = T list -> 'a * T list type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list) (**) val C_source: Input.source parser val star: string parser (**) val group: (unit -> string) -> (T list -> 'a) -> T list -> 'a val !!! : (T list -> 'a) -> T list -> 'a val !!!! : (T list -> 'a) -> T list -> 'a val not_eof: T parser val token: 'a parser -> T parser val range: 'a parser -> ('a * Position.range) parser val position: 'a parser -> ('a * Position.T) parser val input: 'a parser -> Input.source parser val inner_syntax: 'a parser -> string parser val command: string parser val keyword: string parser val short_ident: string parser val long_ident: string parser val sym_ident: string parser val dots: string parser val minus: string parser val term_var: string parser val type_ident: string parser val type_var: string parser val number: string parser val float_number: string parser val string: string parser val string_position: (string * Position.T) parser val alt_string: string parser val verbatim: string parser val cartouche: string parser val eof: string parser val command_name: string -> string parser val keyword_with: (string -> bool) -> string parser val keyword_markup: bool * Markup.T -> string -> string parser val keyword_improper: string -> string parser val $$$ : string -> string parser val reserved: string -> string parser val underscore: string parser val maybe: 'a parser -> 'a option parser val maybe_position: ('a * Position.T) parser -> ('a option * Position.T) parser val opt_keyword: string -> bool parser val opt_bang: bool parser val begin: string parser val opt_begin: bool parser val nat: int parser val int: int parser val real: real parser val enum_positions: string -> 'a parser -> ('a list * Position.T list) parser val enum1_positions: string -> 'a parser -> ('a list * Position.T list) parser val enum: string -> 'a parser -> 'a list parser val enum1: string -> 'a parser -> 'a list parser val and_list: 'a parser -> 'a list parser val and_list1: 'a parser -> 'a list parser val enum': string -> 'a context_parser -> 'a list context_parser val enum1': string -> 'a context_parser -> 'a list context_parser val and_list': 'a context_parser -> 'a list context_parser val and_list1': 'a context_parser -> 'a list context_parser val list: 'a parser -> 'a list parser val list1: 'a parser -> 'a list parser val name: string parser val name_range: (string * Position.range) parser val name_position: (string * Position.T) parser val binding: binding parser val embedded: string parser val embedded_input: Input.source parser val embedded_position: (string * Position.T) parser val text: string parser val path: string parser val path_binding: (string * Position.T) parser val session_name: (string * Position.T) parser val theory_name: (string * Position.T) parser val liberal_name: string parser val parname: string parser val parbinding: binding parser val class: string parser val sort: string parser val type_const: string parser val arity: (string * string list * string) parser val multi_arity: (string list * string list * string) parser val type_args: string list parser val type_args_constrained: (string * string option) list parser val typ: string parser val mixfix: mixfix parser val mixfix': mixfix parser val opt_mixfix: mixfix parser val opt_mixfix': mixfix parser val syntax_mode: Syntax.mode parser val where_: string parser val const_decl: (string * string * mixfix) parser val const_binding: (binding * string * mixfix) parser val params: (binding * string option * mixfix) list parser val vars: (binding * string option * mixfix) list parser val for_fixes: (binding * string option * mixfix) list parser val ML_source: Input.source parser val document_source: Input.source parser val document_marker: Input.source parser val const: string parser val term: string parser val prop: string parser val literal_fact: string parser val propp: (string * string list) parser val termp: (string * string list) parser val private: Position.T parser val qualified: Position.T parser val target: (string * Position.T) parser val opt_target: (string * Position.T) option parser val args: T list parser val args1: (string -> bool) -> T list parser val attribs: src list parser val opt_attribs: src list parser val thm_sel: Facts.interval list parser val thm: (Facts.ref * src list) parser val thms1: (Facts.ref * src list) list parser val options: ((string * Position.T) * (string * Position.T)) list parser end; structure C_Parse: C_PARSE = struct type T = C_Token.T type src = T list type 'a parser = T list -> 'a * T list type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list) structure Token = struct open Token open C_Token end (** error handling **) (* group atomic parsers (no cuts!) *) fun group s scan = scan || Scan.fail_with (fn [] => (fn () => s () ^ " expected,\nbut end-of-input was found") | tok :: _ => (fn () => (case Token.text_of tok of (txt, "") => s () ^ " expected,\nbut " ^ txt ^ Position.here (Token.pos_of tok) ^ " was found" | (txt1, txt2) => s () ^ " expected,\nbut " ^ txt1 ^ Position.here (Token.pos_of tok) ^ " was found:\n" ^ txt2))); (* cut *) fun cut kind scan = let fun get_pos [] = " (end-of-input)" | get_pos (tok :: _) = Position.here (Token.pos_of tok); fun err (toks, NONE) = (fn () => kind ^ get_pos toks) | err (toks, SOME msg) = (fn () => let val s = msg () in if String.isPrefix kind s then s else kind ^ get_pos toks ^ ": " ^ s end); in Scan.!! err scan end; fun !!! scan = cut "Annotation syntax error" scan; fun !!!! scan = cut "Corrupted annotation syntax in presentation" scan; (** basic parsers **) (* tokens *) fun RESET_VALUE atom = (*required for all primitive parsers*) Scan.ahead (Scan.one (K true)) -- atom >> (fn (arg, x) => (Token.assign NONE arg; x)); val not_eof = RESET_VALUE (Scan.one Token.not_eof); fun token atom = Scan.ahead not_eof --| atom; fun range scan = (Scan.ahead not_eof >> (Token.range_of o single)) -- scan >> Library.swap; fun position scan = (Scan.ahead not_eof >> Token.pos_of) -- scan >> Library.swap; fun input atom = Scan.ahead atom |-- not_eof >> Token.input_of; fun inner_syntax atom = Scan.ahead atom |-- not_eof >> Token.inner_syntax_of; fun kind k = group (fn () => Token.str_of_kind k) (RESET_VALUE (Scan.one (Token.is_kind k) >> Token.content_of)); val command = kind Token.Command; val keyword = kind Token.Keyword; val short_ident = kind Token.Ident; val long_ident = kind Token.Long_Ident; val sym_ident = kind Token.Sym_Ident; val term_var = kind Token.Var; val type_ident = kind Token.Type_Ident; val type_var = kind Token.Type_Var; val number = kind Token.Nat; val float_number = kind Token.Float; val string = kind Token.String; val alt_string = kind Token.Alt_String; val verbatim = kind Token.Verbatim; val cartouche = kind Token.Cartouche; val eof = kind Token.EOF; fun command_name x = group (fn () => Token.str_of_kind Token.Command ^ " " ^ quote x) (RESET_VALUE (Scan.one (fn tok => Token.is_command tok andalso Token.content_of tok = x))) >> Token.content_of; fun keyword_with pred = RESET_VALUE (Scan.one (Token.keyword_with pred) >> Token.content_of); fun keyword_markup markup x = group (fn () => Token.str_of_kind Token.Keyword ^ " " ^ quote x) (Scan.ahead not_eof -- keyword_with (fn y => x = y)) >> (fn (tok, x) => (Token.assign (SOME (Token.Literal markup)) tok; x)); val keyword_improper = keyword_markup (true, Markup.improper); val $$$ = keyword_markup (false, Markup.quasi_keyword); fun reserved x = group (fn () => "reserved identifier " ^ quote x) (RESET_VALUE (Scan.one (Token.ident_with (fn y => x = y)) >> Token.content_of)); val dots = sym_ident :-- (fn "\" => Scan.succeed () | _ => Scan.fail) >> #1; val minus = sym_ident :-- (fn "-" => Scan.succeed () | _ => Scan.fail) >> #1; val underscore = sym_ident :-- (fn "_" => Scan.succeed () | _ => Scan.fail) >> #1; fun maybe scan = underscore >> K NONE || scan >> SOME; fun maybe_position scan = position (underscore >> K NONE) || scan >> apfst SOME; val nat = number >> (#1 o Library.read_int o Symbol.explode); val int = Scan.optional (minus >> K ~1) 1 -- nat >> op *; val real = float_number >> Value.parse_real || int >> Real.fromInt; fun opt_keyword s = Scan.optional ($$$ "(" |-- !!! (($$$ s >> K true) --| $$$ ")")) false; val opt_bang = Scan.optional ($$$ "!" >> K true) false; val begin = $$$ "begin"; val opt_begin = Scan.optional (begin >> K true) false; (* enumerations *) fun enum1_positions sep scan = scan -- Scan.repeat (position ($$$ sep) -- !!! scan) >> (fn (x, ys) => (x :: map #2 ys, map (#2 o #1) ys)); fun enum_positions sep scan = enum1_positions sep scan || Scan.succeed ([], []); fun enum1 sep scan = scan ::: Scan.repeat ($$$ sep |-- !!! scan); fun enum sep scan = enum1 sep scan || Scan.succeed []; fun enum1' sep scan = scan ::: Scan.repeat (Scan.lift ($$$ sep) |-- scan); fun enum' sep scan = enum1' sep scan || Scan.succeed []; fun and_list1 scan = enum1 "and" scan; fun and_list scan = enum "and" scan; fun and_list1' scan = enum1' "and" scan; fun and_list' scan = enum' "and" scan; fun list1 scan = enum1 "," scan; fun list scan = enum "," scan; (* names and embedded content *) val name = group (fn () => "name") (short_ident || long_ident || sym_ident || number || string); val name_range = input name >> Input.source_content_range; val name_position = input name >> Input.source_content; val string_position = input string >> Input.source_content; val binding = name_position >> Binding.make; val embedded = group (fn () => "embedded content") (cartouche || string || short_ident || long_ident || sym_ident || term_var || type_ident || type_var || number); val embedded_input = input embedded; val embedded_position = embedded_input >> Input.source_content; val text = group (fn () => "text") (embedded || verbatim); val path = group (fn () => "file name/path specification") embedded; val path_binding = group (fn () => "path binding (strict file name)") (position embedded); val session_name = group (fn () => "session name") name_position; val theory_name = group (fn () => "theory name") name_position; val liberal_name = keyword_with Token.ident_or_symbolic || name; val parname = Scan.optional ($$$ "(" |-- name --| $$$ ")") ""; val parbinding = Scan.optional ($$$ "(" |-- binding --| $$$ ")") Binding.empty; (* type classes *) val class = group (fn () => "type class") (inner_syntax embedded); val sort = group (fn () => "sort") (inner_syntax embedded); val type_const = group (fn () => "type constructor") (inner_syntax embedded); val arity = type_const -- ($$$ "::" |-- !!! (Scan.optional ($$$ "(" |-- !!! (list1 sort --| $$$ ")")) [] -- sort)) >> Scan.triple2; val multi_arity = and_list1 type_const -- ($$$ "::" |-- !!! (Scan.optional ($$$ "(" |-- !!! (list1 sort --| $$$ ")")) [] -- sort)) >> Scan.triple2; (* types *) val typ = group (fn () => "type") (inner_syntax embedded); fun type_arguments arg = arg >> single || $$$ "(" |-- !!! (list1 arg --| $$$ ")") || Scan.succeed []; val type_args = type_arguments type_ident; val type_args_constrained = type_arguments (type_ident -- Scan.option ($$$ "::" |-- !!! sort)); (* mixfix annotations *) local val mfix = input (string || cartouche); val mixfix_ = mfix -- !!! (Scan.optional ($$$ "[" |-- !!! (list nat --| $$$ "]")) [] -- Scan.optional nat 1000) >> (fn (sy, (ps, p)) => fn range => Mixfix (sy, ps, p, range)); val structure_ = $$$ "structure" >> K Structure; val binder_ = $$$ "binder" |-- !!! (mfix -- ($$$ "[" |-- nat --| $$$ "]" -- nat || nat >> (fn n => (n, n)))) >> (fn (sy, (p, q)) => fn range => Binder (sy, p, q, range)); val infixl_ = $$$ "infixl" |-- !!! (mfix -- nat >> (fn (sy, p) => fn range => Infixl (sy, p, range))); val infixr_ = $$$ "infixr" |-- !!! (mfix -- nat >> (fn (sy, p) => fn range => Infixr (sy, p, range))); val infix_ = $$$ "infix" |-- !!! (mfix -- nat >> (fn (sy, p) => fn range => Infix (sy, p, range))); val mixfix_body = mixfix_ || structure_ || binder_ || infixl_ || infixr_ || infix_; fun annotation guard body = Scan.trace ($$$ "(" |-- guard (body --| $$$ ")")) >> (fn (mx, toks) => mx (Token.range_of toks)); fun opt_annotation guard body = Scan.optional (annotation guard body) NoSyn; in val mixfix = annotation !!! mixfix_body; val mixfix' = annotation I mixfix_body; val opt_mixfix = opt_annotation !!! mixfix_body; val opt_mixfix' = opt_annotation I mixfix_body; end; (* syntax mode *) val syntax_mode_spec = ($$$ "output" >> K ("", false)) || name -- Scan.optional ($$$ "output" >> K false) true; val syntax_mode = Scan.optional ($$$ "(" |-- !!! (syntax_mode_spec --| $$$ ")")) Syntax.mode_default; (* fixes *) val where_ = $$$ "where"; val const_decl = name -- ($$$ "::" |-- !!! typ) -- opt_mixfix >> Scan.triple1; val const_binding = binding -- ($$$ "::" |-- !!! typ) -- opt_mixfix >> Scan.triple1; val param_mixfix = binding -- Scan.option ($$$ "::" |-- typ) -- mixfix' >> (single o Scan.triple1); val params = (binding -- Scan.repeat binding) -- Scan.option ($$$ "::" |-- !!! (Scan.ahead typ -- embedded)) >> (fn ((x, ys), T) => (x, Option.map #1 T, NoSyn) :: map (fn y => (y, Option.map #2 T, NoSyn)) ys); val vars = and_list1 (param_mixfix || params) >> flat; val for_fixes = Scan.optional ($$$ "for" |-- !!! vars) []; (* embedded source text *) val ML_source = input (group (fn () => "ML source") text); val document_source = input (group (fn () => "document source") text); val document_marker = group (fn () => "document marker") (RESET_VALUE (Scan.one Token.is_document_marker >> Token.input_of)); (* terms *) val const = group (fn () => "constant") (inner_syntax embedded); val term = group (fn () => "term") (inner_syntax embedded); val prop = group (fn () => "proposition") (inner_syntax embedded); val literal_fact = inner_syntax (group (fn () => "literal fact") (alt_string || cartouche)); (* patterns *) val is_terms = Scan.repeat1 ($$$ "is" |-- term); val is_props = Scan.repeat1 ($$$ "is" |-- prop); val propp = prop -- Scan.optional ($$$ "(" |-- !!! (is_props --| $$$ ")")) []; val termp = term -- Scan.optional ($$$ "(" |-- !!! (is_terms --| $$$ ")")) []; (* target information *) val private = position ($$$ "private") >> #2; val qualified = position ($$$ "qualified") >> #2; val target = ($$$ "(" -- $$$ "in") |-- !!! (name_position --| $$$ ")"); val opt_target = Scan.option target; (* arguments within outer syntax *) local val argument_kinds = [Token.Ident, Token.Long_Ident, Token.Sym_Ident, Token.Var, Token.Type_Ident, Token.Type_Var, Token.Nat, Token.Float, Token.String, Token.Alt_String, Token.Cartouche, Token.Verbatim]; fun arguments is_symid = let fun argument blk = group (fn () => "argument") (Scan.one (fn tok => let val kind = Token.kind_of tok in member (op =) argument_kinds kind orelse Token.keyword_with is_symid tok orelse (blk andalso Token.keyword_with (fn s => s = ",") tok) end)); fun args blk x = Scan.optional (args1 blk) [] x and args1 blk x = (Scan.repeats1 (Scan.repeat1 (argument blk) || argsp "(" ")" || argsp "[" "]")) x and argsp l r x = (token ($$$ l) ::: !!! (args true @@@ (token ($$$ r) >> single))) x; in (args, args1) end; in val args = #1 (arguments Token.ident_or_symbolic) false; fun args1 is_symid = #2 (arguments is_symid) false; end; (* attributes *) val attrib = token liberal_name ::: !!! args; val attribs = $$$ "[" |-- list attrib --| $$$ "]"; val opt_attribs = Scan.optional attribs []; (* theorem references *) val thm_sel = $$$ "(" |-- list1 (nat --| minus -- nat >> Facts.FromTo || nat --| minus >> Facts.From || nat >> Facts.Single) --| $$$ ")"; val thm = $$$ "[" |-- attribs --| $$$ "]" >> pair (Facts.named "") || (literal_fact >> Facts.Fact || name_position -- Scan.option thm_sel >> Facts.Named) -- opt_attribs; val thms1 = Scan.repeat1 thm; (* options *) val option_name = group (fn () => "option name") name_position; val option_value = group (fn () => "option value") ((token real || token name) >> Token.content_of); val option = option_name :-- (fn (_, pos) => Scan.optional ($$$ "=" |-- !!! (position option_value)) ("true", pos)); val options = $$$ "[" |-- list1 option --| $$$ "]"; (** C basic parsers **) (* embedded source text *) val C_source = input (group (fn () => "C source") text); (* AutoCorres (MODIFIES) *) val star = sym_ident :-- (fn "*" => Scan.succeed () | _ => Scan.fail) >> #1; end; structure C_Parse_Native: C_PARSE = struct open Token open Parse (** C basic parsers **) (* embedded source text *) val C_source = input (group (fn () => "C source") text); (* AutoCorres (MODIFIES) *) val star = sym_ident :-- (fn "*" => Scan.succeed () | _ => Scan.fail) >> #1; end; \ ML \ \\<^file>\~~/src/Pure/Thy/thy_header.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/Thy/thy_header.ML Author: Makarius Static theory header information. *) \ structure C_Thy_Header = struct val bootstrap_keywords = C_Keyword.empty_keywords' (Keyword.minor_keywords (Thy_Header.get_keywords @{theory})) (* theory data *) structure Data = Theory_Data ( type T = C_Keyword.keywords; val empty = bootstrap_keywords; - val extend = I; val merge = C_Keyword.merge_keywords; ); val add_keywords = Data.map o C_Keyword.add_keywords; val add_keywords_minor = Data.map o C_Keyword.add_keywords_minor; val get_keywords = Data.get; val get_keywords' = get_keywords o Proof_Context.theory_of; end \ end diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Annotation.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Annotation.thy --- a/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Annotation.thy +++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Annotation.thy @@ -1,252 +1,251 @@ (****************************************************************************** * Isabelle/C * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) section \Annotation Language: Command Parser Registration\ theory C_Parser_Annotation imports C_Lexer_Annotation C_Environment begin ML \ \\<^file>\~~/src/Pure/Isar/outer_syntax.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/Isar/outer_syntax.ML Author: Markus Wenzel, TU Muenchen Isabelle/Isar outer syntax. *) \ structure C_Annotation = struct (** outer syntax **) (* errors *) fun err_command msg name ps = error (msg ^ quote (Markup.markup Markup.keyword1 name) ^ Position.here_list ps); fun err_dup_command name ps = err_command "Duplicate annotation syntax command " name ps; (* command parsers *) datatype command_parser = Parser of (Symbol_Pos.T list * (bool * Symbol_Pos.T list)) * Position.range -> C_Env.eval_time c_parser; datatype command = Command of {comment: string, command_parser: command_parser, pos: Position.T, id: serial}; fun eq_command (Command {id = id1, ...}, Command {id = id2, ...}) = id1 = id2; fun new_command comment command_parser pos = Command {comment = comment, command_parser = command_parser, pos = pos, id = serial ()}; fun command_pos (Command {pos, ...}) = pos; fun command_markup def (name, Command {pos, id, ...}) = Position.make_entity_markup def id Markup.commandN (name, pos); (* theory data *) structure Data = Theory_Data ( type T = command Symtab.table; val empty = Symtab.empty; - val extend = I; fun merge data : T = data |> Symtab.join (fn name => fn (cmd1, cmd2) => if eq_command (cmd1, cmd2) then raise Symtab.SAME else err_dup_command name [command_pos cmd1, command_pos cmd2]); ); val get_commands = Data.get; val dest_commands = get_commands #> Symtab.dest #> sort_by #1; val lookup_commands = Symtab.lookup o get_commands; (* maintain commands *) fun add_command name cmd thy = let val _ = C_Keyword.is_command (C_Thy_Header.get_keywords thy) name orelse err_command "Undeclared outer syntax command " name [command_pos cmd]; val _ = (case lookup_commands thy name of NONE => () | SOME cmd' => err_dup_command name [command_pos cmd, command_pos cmd']); val _ = Context_Position.report_generic (Context.the_generic_context ()) (command_pos cmd) (command_markup {def = true} (name, cmd)); in Data.map (Symtab.update (name, cmd)) thy end; fun delete_command (name, pos) thy = let val _ = C_Keyword.is_command (C_Thy_Header.get_keywords thy) name orelse err_command "Undeclared outer syntax command " name [pos]; in Data.map (Symtab.delete name) thy end; (* implicit theory setup *) type command_keyword = string * Position.T; fun raw_command0 kind (name, pos) comment command_parser = C_Thy_Header.add_keywords [((name, pos), ((kind, []), [name]))] #> add_command name (new_command comment command_parser pos); fun raw_command (name, pos) comment command_parser = let val setup = add_command name (new_command comment command_parser pos) in Context.>> (Context.mapping setup (Local_Theory.background_theory setup)) end; fun command (name, pos) comment parse = raw_command (name, pos) comment (Parser parse); fun command'' kind (name, pos) comment parse = raw_command0 kind (name, pos) comment (Parser parse); val command' = command'' Keyword.thy_decl; (** toplevel parsing **) (* parse spans *) (* parse commands *) local fun scan_stack' f b = Scan.one f >> (pair b o C_Token.content_of') in val before_command = C_Token.scan_stack C_Token.is_stack1 -- Scan.optional ( scan_stack' C_Token.is_stack2 false || scan_stack' C_Token.is_stack3 true) (pair false []) end fun parse_command thy = Scan.ahead (before_command |-- C_Parse.position C_Parse.command) :|-- (fn (name, pos) => let val command_tags = before_command -- C_Parse.range C_Parse.command >> (fn (cmd, (_, range)) => (cmd, range)); in case lookup_commands thy name of SOME (cmd as Command {command_parser = Parser parse, ...}) => C_Parse.!!! (command_tags :|-- parse) >> pair [((pos, command_markup {def = false} (name, cmd)), "")] | NONE => Scan.fail_with (fn _ => fn _ => let val msg = "undefined command "; in msg ^ quote (Markup.markup Markup.keyword1 name) end) end) (* check commands *) fun command_reports thy tok = if C_Token.is_command tok then let val name = C_Token.content_of tok in (case lookup_commands thy name of NONE => [] | SOME cmd => [((C_Token.pos_of tok, command_markup {def = false} (name, cmd)), "")]) end else []; fun check_command ctxt (name, pos) = let val thy = Proof_Context.theory_of ctxt; val keywords = C_Thy_Header.get_keywords thy; in if C_Keyword.is_command keywords name then let val markup = C_Token.explode0 keywords name |> maps (command_reports thy) |> map (#2 o #1); val _ = Context_Position.reports ctxt (map (pair pos) markup); in name end else let val completion_report = Completion.make_report (name, pos) (fn completed => C_Keyword.dest_commands keywords |> filter completed |> sort_strings |> map (fn a => (a, (Markup.commandN, a)))); in error ("Bad command " ^ quote name ^ Position.here pos ^ completion_report) end end; end \ ML \ \\<^file>\~~/src/Pure/PIDE/resources.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay *) (* Title: Pure/PIDE/resources.ML Author: Makarius Resources for theories and auxiliary files. *) \ structure C_Resources = struct (* load files *) fun parse_files cmd = Scan.ahead C_Parse.not_eof -- C_Parse.path >> (fn (tok, name) => fn thy => (case C_Token.get_files tok of [] => let val keywords = C_Thy_Header.get_keywords thy; val master_dir = Resources.master_directory thy; val pos = C_Token.pos_of tok; val delimited = Input.is_delimited (C_Token.input_of tok); val src_paths = C_Keyword.command_files keywords cmd (Path.explode name); in map (Command.read_file master_dir pos delimited) src_paths end | files => map Exn.release files)); end; \ end diff --git a/thys/Isabelle_Meta_Model/isabelle_home/src/Tools/Code/Isabelle_code_target.thy b/thys/Isabelle_Meta_Model/isabelle_home/src/Tools/Code/Isabelle_code_target.thy --- a/thys/Isabelle_Meta_Model/isabelle_home/src/Tools/Code/Isabelle_code_target.thy +++ b/thys/Isabelle_Meta_Model/isabelle_home/src/Tools/Code/Isabelle_code_target.thy @@ -1,213 +1,214 @@ (****************************************************************************** * ISABELLE COPYRIGHT NOTICE, LICENCE AND DISCLAIMER. * * Copyright (c) 1986-2018 Contributors (in the changeset history) * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) chapter\Part ...\ theory Isabelle_code_target imports Main keywords "attach" and "lazy_code_printing" "apply_code_printing" "apply_code_printing_reflect" :: thy_decl begin subsection\beginning (lazy code printing)\ ML\ structure Isabelle_Code_Target = struct (* Title: Tools/Code/code_target.ML Author: Florian Haftmann, TU Muenchen Generic infrastructure for target language data. *) open Basic_Code_Symbol; open Basic_Code_Thingol; (** checking and parsing of symbols **) val parse_classrel_ident = Parse.class --| @{keyword "<"} -- Parse.class; val parse_inst_ident = Parse.name --| @{keyword "::"} -- Parse.class; (** serializations and serializer **) (* serialization: abstract nonsense to cover different destinies for generated code *) (* serializers: functions producing serializations *) (** theory data **) (** serializer usage **) (* montage *) (* code generation *) fun prep_destination s = ({physical = true}, (Path.explode s, Position.none)); fun export_code_cmd all_public raw_cs seris thy = let val ctxt = Proof_Context.init_global thy; val cs = Code_Thingol.read_const_exprs ctxt raw_cs; in thy |> Named_Target.theory_map (Code_Target.export_code all_public cs ((map o apfst o apsnd o Option.map) prep_destination seris)) end; (** serializer configuration **) (* reserved symbol names *) (* checking of syntax *) (* custom symbol names *) (* custom printings *) (* concrete syntax *) (** Isar setup **) fun parse_single_symbol_pragma parse_keyword parse_isa parse_target = parse_keyword |-- Parse.!!! (parse_isa --| (@{keyword "\"} || @{keyword "=>"}) -- Parse.and_list1 (@{keyword "("} |-- (Parse.name --| @{keyword ")"} -- Scan.option parse_target))); fun parse_symbol_pragma parse_const parse_tyco parse_class parse_classrel parse_inst parse_module = parse_single_symbol_pragma @{keyword "constant"} Parse.term parse_const >> Constant || parse_single_symbol_pragma @{keyword "type_constructor"} Parse.type_const parse_tyco >> Type_Constructor || parse_single_symbol_pragma @{keyword "type_class"} Parse.class parse_class >> Type_Class || parse_single_symbol_pragma @{keyword "class_relation"} parse_classrel_ident parse_classrel >> Class_Relation || parse_single_symbol_pragma @{keyword "class_instance"} parse_inst_ident parse_inst >> Class_Instance || parse_single_symbol_pragma @{keyword "code_module"} Parse.name parse_module >> Code_Symbol.Module; fun parse_symbol_pragmas parse_const parse_tyco parse_class parse_classrel parse_inst parse_module = Parse.enum1 "|" (Parse.group (fn () => "code symbol pragma") (parse_symbol_pragma parse_const parse_tyco parse_class parse_classrel parse_inst parse_module)); end \ ML\ structure Code_printing = struct datatype code_printing = Code_printing of (string * (bstring * Code_Printer.raw_const_syntax option) list, string * (bstring * Code_Printer.tyco_syntax option) list, string * (bstring * string option) list, (string * string) * (bstring * unit option) list, (xstring * string) * (bstring * unit option) list, bstring * (bstring * (string * Code_Symbol.T list) option) list) Code_Symbol.attr list structure Data_code = Theory_Data - (type T = code_printing list Symtab.table - val empty = Symtab.empty - val extend = I - val merge = Symtab.merge (K true)) +( + type T = code_printing list Symtab.table + val empty = Symtab.empty + val merge = Symtab.merge (K true) +) val code_empty = "" val () = Outer_Syntax.command @{command_keyword lazy_code_printing} "declare dedicated printing for code symbols" (Isabelle_Code_Target.parse_symbol_pragmas (Code_Printer.parse_const_syntax) (Code_Printer.parse_tyco_syntax) Parse.string (Parse.minus >> K ()) (Parse.minus >> K ()) (Parse.text -- Scan.optional (@{keyword "attach"} |-- Scan.repeat1 Parse.term >> map Code_Symbol.Constant) []) >> (fn code => Toplevel.theory (Data_code.map (Symtab.map_default (code_empty, []) (fn l => Code_printing code :: l))))) fun apply_code_printing thy = (case Symtab.lookup (Data_code.get thy) code_empty of SOME l => rev l | _ => []) |> (fn l => fold (fn Code_printing l => fold Code_Target.set_printings l) l thy) val () = Outer_Syntax.command @{command_keyword apply_code_printing} "apply dedicated printing for code symbols" (Parse.$$$ "(" -- Parse.$$$ ")" >> K (Toplevel.theory apply_code_printing)) fun reflect_ml source thy = case ML_Context.exec (fn () => ML_Context.eval_source (ML_Compiler.verbose false ML_Compiler.flags) source) (Context.Theory thy) of Context.Theory thy => thy fun apply_code_printing_reflect thy = (case Symtab.lookup (Data_code.get thy) code_empty of SOME l => rev l | _ => []) |> (fn l => fold (fn Code_printing l => fold (fn Code_Symbol.Module (_, l) => fold (fn ("SML", SOME (txt, _)) => reflect_ml (Input.source false txt (Position.none, Position.none)) | _ => I) l | _ => I) l) l thy) val () = Outer_Syntax.command @{command_keyword apply_code_printing_reflect} "apply dedicated printing for code symbols" (Parse.ML_source >> (fn src => Toplevel.theory (apply_code_printing_reflect o reflect_ml src))) end \ end diff --git a/thys/Isabelle_Meta_Model/toy_example/embedding/Generator_dynamic_sequential.thy b/thys/Isabelle_Meta_Model/toy_example/embedding/Generator_dynamic_sequential.thy --- a/thys/Isabelle_Meta_Model/toy_example/embedding/Generator_dynamic_sequential.thy +++ b/thys/Isabelle_Meta_Model/toy_example/embedding/Generator_dynamic_sequential.thy @@ -1,1718 +1,1719 @@ (****************************************************************************** * Citadelle * * Copyright (c) 2011-2018 Université Paris-Saclay, Univ. Paris-Sud, France * 2013-2017 IRT SystemX, France * 2011-2015 Achim D. Brucker, Germany * 2016-2018 The University of Sheffield, UK * 2016-2017 Nanyang Technological University, Singapore * 2017-2018 Virginia Tech, USA * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) section\Dynamic Meta Embedding with Reflection\ theory Generator_dynamic_sequential imports Printer "../../isabelle_home/src/HOL/Isabelle_Main2" (*<*) keywords (* Toy language *) "Between" "Attributes" "Operations" "Constraints" "Role" "Ordered" "Subsets" "Union" "Redefines" "Derived" "Qualifier" "Existential" "Inv" "Pre" "Post" "self" "Nonunique" "Sequence_" (* Isabelle syntax *) "output_directory" "THEORY" "IMPORTS" "SECTION" "SORRY" "no_dirty" "deep" "shallow" "syntax_print" "skip_export" "generation_semantics" "flush_all" (* Isabelle semantics (parameterizing the semantics of Toy language) *) "design" "analysis" "oid_start" and (* Toy language *) "Enum" "Abstract_class" "Class" "Association" "Composition" "Aggregation" "Abstract_associationclass" "Associationclass" "Context" "End" "Instance" "BaseType" "State" "PrePost" (* Isabelle syntax *) "generation_syntax" :: thy_decl (*>*) begin text\In the ``dynamic'' solution: the exportation is automatically handled inside Isabelle/jEdit. Inputs are provided using the syntax of the Toy Language, and in output we basically have two options: \begin{itemize} \item The first is to generate an Isabelle file for inspection or debugging. The generated file can interactively be loaded in Isabelle/jEdit, or saved to the hard disk. This mode is called the ``deep exportation'' mode or shortly the ``deep'' mode. The aim is to maximally automate the process one is manually performing in @{file \Generator_static.thy\}. \item On the other hand, it is also possible to directly execute in Isabelle/jEdit the generated file from the random access memory. This mode corresponds to the ``shallow reflection'' mode or shortly ``shallow'' mode. \end{itemize} In both modes, the reflection is necessary since the main part used by both was defined at Isabelle side. As a consequence, experimentations in ``deep'' and ``shallow'' are performed without leaving the editing session, in the same as the one the meta-compiler is actually running.\ apply_code_printing_reflect \ val stdout_file = Unsynchronized.ref "" \ text\This variable is not used in this theory (only in @{file \Generator_static.thy\}), but needed for well typechecking the reflected SML code.\ code_reflect' open META functions (* executing the compiler as monadic combinators for deep and shallow *) fold_thy_deep fold_thy_shallow (* printing the HOL AST to (shallow Isabelle) string *) write_file (* manipulating the compiling environment *) compiler_env_config_reset_all compiler_env_config_update oidInit D_output_header_thy_update map2_ctxt_term check_export_code (* printing the TOY AST to (deep Isabelle) string *) isabelle_apply isabelle_of_compiler_env_config subsection\Interface Between the Reflected and the Native\ ML\ val To_string0 = META.meta_of_logic \ ML\ structure From = struct val string = META.SS_base o META.ST val binding = string o Binding.name_of (*fun term ctxt s = string (XML.content_of (YXML.parse_body (Syntax.string_of_term ctxt s)))*) val internal_oid = META.Oid o Code_Numeral.natural_of_integer val option = Option.map val list = List.map fun pair f1 f2 (x, y) = (f1 x, f2 y) fun pair3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) structure Pure = struct val indexname = pair string Code_Numeral.natural_of_integer val class = string val sort = list class fun typ e = (fn Type (s, l) => (META.Type o pair string (list typ)) (s, l) | TFree (s, s0) => (META.TFree o pair string sort) (s, s0) | TVar (i, s0) => (META.TVar o pair indexname sort) (i, s0) ) e fun term e = (fn Const (s, t) => (META.Const o pair string typ) (s, t) | Free (s, t) => (META.Free o pair string typ) (s, t) | Var (i, t) => (META.Var o pair indexname typ) (i, t) | Bound i => (META.Bound o Code_Numeral.natural_of_integer) i | Abs (s, ty, t) => (META.Abs o pair3 string typ term) (s, ty, t) | op $ (term1, term2) => (META.App o pair term term) (term1, term2) ) e end fun toy_ctxt_term thy expr = META.T_pure (Pure.term (Syntax.read_term (Proof_Context.init_global thy) expr)) end \ ML\fun List_mapi f = META.mapi (f o Code_Numeral.integer_of_natural)\ ML\ structure Ty' = struct fun check l_oid l = let val Mp = META.map_prod val Me = String.explode val Mi = String.implode val Ml = map in META.check_export_code (writeln o Mi) (warning o Mi) (fn s => writeln (Markup.markup (Markup.bad ()) (Mi s))) (error o To_string0) (Ml (Mp I Me) l_oid) ((META.SS_base o META.ST) l) end end \ subsection\Binding of the Reflected API to the Native API\ ML\ structure META_overload = struct val of_semi__typ = META.of_semi_typ To_string0 val of_semi__term = META.of_semi_terma To_string0 val of_semi__term' = META.of_semi_term To_string0 val fold = fold end \ ML\ structure Bind_Isabelle = struct fun To_binding s = Binding.make (s, Position.none) val To_sbinding = To_binding o To_string0 fun semi__method_simp g f = Method.Basic (fn ctxt => SIMPLE_METHOD (g (asm_full_simp_tac (f ctxt)))) val semi__method_simp_one = semi__method_simp (fn f => f 1) val semi__method_simp_all = semi__method_simp (CHANGED_PROP o PARALLEL_ALLGOALS) datatype semi__thm' = Thms_single' of thm | Thms_mult' of thm list fun semi__thm_attribute ctxt = let open META open META_overload val S = fn Thms_single' t => t val M = fn Thms_mult' t => t in fn Thm_thm s => Thms_single' (Proof_Context.get_thm ctxt (To_string0 s)) | Thm_thms s => Thms_mult' (Proof_Context.get_thms ctxt (To_string0 s)) | Thm_THEN (e1, e2) => (case (semi__thm_attribute ctxt e1, semi__thm_attribute ctxt e2) of (Thms_single' e1, Thms_single' e2) => Thms_single' (e1 RSN (1, e2)) | (Thms_mult' e1, Thms_mult' e2) => Thms_mult' (e1 RLN (1, e2))) | Thm_simplified (e1, e2) => Thms_single' (asm_full_simplify (clear_simpset ctxt addsimps [S (semi__thm_attribute ctxt e2)]) (S (semi__thm_attribute ctxt e1))) | Thm_OF (e1, e2) => Thms_single' ([S (semi__thm_attribute ctxt e2)] MRS (S (semi__thm_attribute ctxt e1))) | Thm_where (nth, l) => Thms_single' (Rule_Insts.where_rule ctxt (List.map (fn (var, expr) => (((To_string0 var, 0), Position.none), of_semi__term expr)) l) [] (S (semi__thm_attribute ctxt nth))) | Thm_symmetric e1 => let val e2 = S (semi__thm_attribute ctxt (Thm_thm (From.string "sym"))) in case semi__thm_attribute ctxt e1 of Thms_single' e1 => Thms_single' (e1 RSN (1, e2)) | Thms_mult' e1 => Thms_mult' (e1 RLN (1, [e2])) end | Thm_of (nth, l) => Thms_single' (Rule_Insts.of_rule ctxt (List.map (SOME o of_semi__term) l, []) [] (S (semi__thm_attribute ctxt nth))) end fun semi__thm_attribute_single ctxt s = case (semi__thm_attribute ctxt s) of Thms_single' t => t fun semi__thm_mult ctxt = let fun f thy = case (semi__thm_attribute ctxt thy) of Thms_mult' t => t | Thms_single' t => [t] in fn META.Thms_single thy => f thy | META.Thms_mult thy => f thy end fun semi__thm_mult_l ctxt l = List.concat (map (semi__thm_mult ctxt) l) fun semi__method_simp_only l ctxt = clear_simpset ctxt addsimps (semi__thm_mult_l ctxt l) fun semi__method_simp_add_del_split (l_add, l_del, l_split) ctxt = fold Splitter.add_split (semi__thm_mult_l ctxt l_split) (ctxt addsimps (semi__thm_mult_l ctxt l_add) delsimps (semi__thm_mult_l ctxt l_del)) fun semi__method expr = let open META open Method open META_overload in case expr of Method_rule o_s => Basic (fn ctxt => METHOD (HEADGOAL o Classical.rule_tac ctxt (case o_s of NONE => [] | SOME s => [semi__thm_attribute_single ctxt s]))) | Method_drule s => Basic (fn ctxt => drule ctxt 0 [semi__thm_attribute_single ctxt s]) | Method_erule s => Basic (fn ctxt => erule ctxt 0 [semi__thm_attribute_single ctxt s]) | Method_elim s => Basic (fn ctxt => elim ctxt [semi__thm_attribute_single ctxt s]) | Method_intro l => Basic (fn ctxt => intro ctxt (map (semi__thm_attribute_single ctxt) l)) | Method_subst (asm, l, s) => Basic (fn ctxt => SIMPLE_METHOD' ((if asm then EqSubst.eqsubst_asm_tac else EqSubst.eqsubst_tac) ctxt (map (fn s => case Int.fromString (To_string0 s) of SOME i => i) l) [semi__thm_attribute_single ctxt s])) | Method_insert l => Basic (fn ctxt => insert (semi__thm_mult_l ctxt l)) | Method_plus t => Combinator ( no_combinator_info , Repeat1 , [Combinator (no_combinator_info, Then, List.map semi__method t)]) | Method_option t => Combinator ( no_combinator_info , Try , [Combinator (no_combinator_info, Then, List.map semi__method t)]) | Method_or t => Combinator (no_combinator_info, Orelse, List.map semi__method t) | Method_one (Method_simp_only l) => semi__method_simp_one (semi__method_simp_only l) | Method_one (Method_simp_add_del_split l) => semi__method_simp_one (semi__method_simp_add_del_split l) | Method_all (Method_simp_only l) => semi__method_simp_all (semi__method_simp_only l) | Method_all (Method_simp_add_del_split l) => semi__method_simp_all (semi__method_simp_add_del_split l) | Method_auto_simp_add_split (l_simp, l_split) => Basic (fn ctxt => SIMPLE_METHOD (auto_tac (fold (fn (f, l) => fold f l) [(Simplifier.add_simp, semi__thm_mult_l ctxt l_simp) ,(Splitter.add_split, List.map (Proof_Context.get_thm ctxt o To_string0) l_split)] ctxt))) | Method_rename_tac l => Basic (K (SIMPLE_METHOD' (Tactic.rename_tac (List.map To_string0 l)))) | Method_case_tac e => Basic (fn ctxt => SIMPLE_METHOD' (Induct_Tacs.case_tac ctxt (of_semi__term e) [] NONE)) | Method_blast n => Basic (case n of NONE => SIMPLE_METHOD' o blast_tac | SOME lim => fn ctxt => SIMPLE_METHOD' (depth_tac ctxt (Code_Numeral.integer_of_natural lim))) | Method_clarify => Basic (fn ctxt => (SIMPLE_METHOD' (fn i => CHANGED_PROP (clarify_tac ctxt i)))) | Method_metis (l_opt, l) => Basic (fn ctxt => (METHOD oo Metis_Tactic.metis_method) ( (if l_opt = [] then NONE else SOME (map To_string0 l_opt), NONE) , map (semi__thm_attribute_single ctxt) l) ctxt) end fun then_tactic l = let open Method in (Combinator (no_combinator_info, Then, map semi__method l), (Position.none, Position.none)) end fun local_terminal_proof o_by = let open META in case o_by of Command_done => Proof.local_done_proof | Command_sorry => Proof.local_skip_proof true | Command_by l_apply => Proof.local_terminal_proof (then_tactic l_apply, NONE) end fun global_terminal_proof o_by = let open META in case o_by of Command_done => Proof.global_done_proof | Command_sorry => Proof.global_skip_proof true | Command_by l_apply => Proof.global_terminal_proof (then_tactic l_apply, NONE) end fun proof_show_gen f (thes, thes_when) st = st |> Proof.proof (SOME ( Method.Source [Token.make_string ("-", Position.none)] , (Position.none, Position.none))) |> Seq.the_result "" |> f |> Proof.show_cmd (thes_when = []) NONE (K I) [] (if thes_when = [] then [] else [(Binding.empty_atts, map (fn t => (t, [])) thes_when)]) [(Binding.empty_atts, [(thes, [])])] true |> snd val semi__command_state = let open META_overload in fn META.Command_apply_end l => (fn st => st |> Proof.apply_end (then_tactic l) |> Seq.the_result "") end val semi__command_proof = let open META_overload val thesis = "?thesis" fun proof_show f = proof_show_gen f (thesis, []) in fn META.Command_apply l => (fn st => st |> Proof.apply (then_tactic l) |> Seq.the_result "") | META.Command_using l => (fn st => let val ctxt = Proof.context_of st in Proof.using [map (fn s => ([ s], [])) (semi__thm_mult_l ctxt l)] st end) | META.Command_unfolding l => (fn st => let val ctxt = Proof.context_of st in Proof.unfolding [map (fn s => ([s], [])) (semi__thm_mult_l ctxt l)] st end) | META.Command_let (e1, e2) => proof_show (Proof.let_bind_cmd [([of_semi__term e1], of_semi__term e2)]) | META.Command_have (n, b, e, e_pr) => proof_show (fn st => st |> Proof.have_cmd true NONE (K I) [] [] [( (To_sbinding n, if b then [[Token.make_string ("simp", Position.none)]] else []) , [(of_semi__term e, [])])] true |> snd |> local_terminal_proof e_pr) | META.Command_fix_let (l, l_let, o_exp, _) => proof_show_gen ( fold (fn (e1, e2) => Proof.let_bind_cmd [([of_semi__term e1], of_semi__term e2)]) l_let o Proof.fix_cmd (List.map (fn i => (To_sbinding i, NONE, NoSyn)) l)) ( case o_exp of NONE => thesis | SOME (l_spec, _) => (String.concatWith (" \ ") (List.map of_semi__term l_spec)) , case o_exp of NONE => [] | SOME (_, l_when) => List.map of_semi__term l_when) end fun semi__theory in_theory in_local = let open META open META_overload in (*let val f = *)fn Theory_datatype (Datatype (n, l)) => in_local (BNF_FP_Def_Sugar.co_datatype_cmd BNF_Util.Least_FP BNF_LFP.construct_lfp (Ctr_Sugar.default_ctr_options_cmd, [( ( ( (([], To_sbinding n), NoSyn) , List.map (fn (n, l) => ( ( (To_binding "", To_sbinding n) , List.map (fn s => (To_binding "", of_semi__typ s)) l) , NoSyn)) l) , (To_binding "", To_binding "", To_binding "")) , [])])) | Theory_type_synonym (Type_synonym (n, v, l)) => in_theory (fn thy => let val s_bind = To_sbinding n in (snd o Typedecl.abbrev_global (s_bind, map To_string0 v, NoSyn) (Isabelle_Typedecl.abbrev_cmd0 (SOME s_bind) thy (of_semi__typ l))) thy end) | Theory_type_notation (Type_notation (n, e)) => in_local (Local_Theory.type_notation_cmd true ("", true) [(To_string0 n, Mixfix (Input.string (To_string0 e), [], 1000, Position.no_range))]) | Theory_instantiation (Instantiation (n, n_def, expr)) => in_theory (fn thy => let val name = To_string0 n val tycos = [ let val Term.Type (s, _) = (Isabelle_Typedecl.abbrev_cmd0 NONE thy name) in s end ] in thy |> Class.instantiation (tycos, [], Syntax.read_sort (Proof_Context.init_global thy) "object") |> fold_map (fn _ => fn thy => let val ((_, (_, ty)), thy) = Specification.definition_cmd NONE [] [] ((To_binding (To_string0 n_def ^ "_" ^ name ^ "_def"), []) , of_semi__term expr) false thy in (ty, thy) end) tycos |-> Class.prove_instantiation_exit_result (map o Morphism.thm) (fn ctxt => fn thms => Class.intro_classes_tac ctxt [] THEN ALLGOALS (Proof_Context.fact_tac ctxt thms)) |-> K I end) | Theory_overloading (Overloading (n_c, e_c, n, e)) => in_theory (fn thy => thy |> Overloading.overloading_cmd [(To_string0 n_c, of_semi__term e_c, true)] |> snd o Specification.definition_cmd NONE [] [] ((To_sbinding n, []), of_semi__term e) false |> Local_Theory.exit_global) | Theory_consts (Consts (n, ty, symb)) => in_theory (Sign.add_consts_cmd [( To_sbinding n , of_semi__typ ty , Mixfix (Input.string ("(_) " ^ To_string0 symb), [], 1000, Position.no_range))]) | Theory_definition def => in_local let val (def, e) = case def of Definition e => (NONE, e) | Definition_where1 (name, (abbrev, prio), e) => (SOME ( To_sbinding name , NONE , Mixfix (Input.string ("(1" ^ of_semi__term abbrev ^ ")"), [], Code_Numeral.integer_of_natural prio, Position.no_range)), e) | Definition_where2 (name, abbrev, e) => (SOME ( To_sbinding name , NONE , Mixfix (Input.string ("(" ^ of_semi__term abbrev ^ ")"), [], 1000, Position.no_range)), e) in (snd o Specification.definition_cmd def [] [] (Binding.empty_atts, of_semi__term e) false) end | Theory_lemmas (Lemmas_simp_thm (simp, s, l)) => in_local (fn lthy => (snd o Specification.theorems Thm.theoremK [((To_sbinding s, List.map (fn s => Attrib.check_src lthy [Token.make_string (s, Position.none)]) (if simp then ["simp", "code_unfold"] else [])), List.map (fn x => ([semi__thm_attribute_single lthy x], [])) l)] [] false) lthy) | Theory_lemmas (Lemmas_simp_thms (s, l)) => in_local (fn lthy => (snd o Specification.theorems Thm.theoremK [((To_sbinding s, List.map (fn s => Attrib.check_src lthy [Token.make_string (s, Position.none)]) ["simp", "code_unfold"]), List.map (fn x => (Proof_Context.get_thms lthy (To_string0 x), [])) l)] [] false) lthy) | Theory_lemma (Lemma (n, l_spec, l_apply, o_by)) => in_local (fn lthy => Specification.theorem_cmd true Thm.theoremK NONE (K I) Binding.empty_atts [] [] (Element.Shows [((To_sbinding n, []) ,[((String.concatWith (" \ ") (List.map of_semi__term l_spec)), [])])]) false lthy |> fold (semi__command_proof o META.Command_apply) l_apply |> global_terminal_proof o_by) | Theory_lemma (Lemma_assumes (n, l_spec, concl, l_apply, o_by)) => in_local (fn lthy => lthy |> Specification.theorem_cmd true Thm.theoremK NONE (K I) (To_sbinding n, []) [] (List.map (fn (n, (b, e)) => Element.Assumes [( ( To_sbinding n , if b then [[Token.make_string ("simp", Position.none)]] else []) , [(of_semi__term e, [])])]) l_spec) (Element.Shows [(Binding.empty_atts, [(of_semi__term concl, [])])]) false |> fold semi__command_proof l_apply |> (case map_filter (fn META.Command_let _ => SOME [] | META.Command_have _ => SOME [] | META.Command_fix_let (_, _, _, l) => SOME l | _ => NONE) (rev l_apply) of [] => global_terminal_proof o_by | _ :: l => let val arg = (NONE, true) in fn st => st |> local_terminal_proof o_by |> fold (fn l => fold semi__command_state l o Proof.local_qed arg) l |> Proof.global_qed arg end)) | Theory_axiomatization (Axiomatization (n, e)) => in_theory (#2 o Specification.axiomatization_cmd [] [] [] [((To_sbinding n, []), of_semi__term e)]) | Theory_section _ => in_theory I | Theory_text _ => in_theory I | Theory_ML (SML ml) => in_theory (Code_printing.reflect_ml (Input.source false (of_semi__term' ml) (Position.none, Position.none))) | Theory_setup (Setup ml) => in_theory (Isar_Cmd.setup (Input.source false (of_semi__term' ml) (Position.none, Position.none))) | Theory_thm (Thm thm) => in_local (fn lthy => let val () = writeln (Pretty.string_of (Proof_Context.pretty_fact lthy ("", List.map (semi__thm_attribute_single lthy) thm))) in lthy end) | Theory_interpretation (Interpretation (n, loc_n, loc_param, o_by)) => in_local (fn lthy => lthy |> Interpretation.interpretation_cmd ( [ ( (To_string0 loc_n, Position.none) , ( (To_string0 n, true) , (if loc_param = [] then Expression.Named [] else Expression.Positional (map (SOME o of_semi__term) loc_param), [])))] , []) |> global_terminal_proof o_by) (*in fn t => fn thy => f t thy handle ERROR s => (warning s; thy) end*) end end structure Bind_META = struct open Bind_Isabelle fun all_meta aux ret = let open META open META_overload in fn META_semi_theories thy => ret o (case thy of Theories_one thy => semi__theory I Named_Target.theory_map thy | Theories_locale (data, l) => fn thy => thy |> ( Expression.add_locale_cmd (To_sbinding (META.holThyLocale_name data)) Binding.empty [] ([], []) (List.concat (map (fn (fixes, assumes) => List.concat [ map (fn (e,ty) => Element.Fixes [( To_binding (of_semi__term e) , SOME (of_semi__typ ty) , NoSyn)]) fixes , case assumes of NONE => [] | SOME (n, e) => [Element.Assumes [( (To_sbinding n, []) , [(of_semi__term e, [])])]]]) (META.holThyLocale_header data))) #> snd) |> fold (fold (semi__theory Local_Theory.background_theory (fn f => Local_Theory.new_group #> f #> Local_Theory.reset_group #> (fn lthy => #1 (Target_Context.switch_named_cmd NONE (Context.Proof lthy)) lthy |> Context.the_proof)))) l |> Local_Theory.exit_global) | META_boot_generation_syntax _ => ret o I | META_boot_setup_env _ => ret o I | META_all_meta_embedding meta => fn thy => aux (map2_ctxt_term (fn T_pure x => T_pure x | e => let fun aux e = case e of T_to_be_parsed (s, _) => SOME let val t = Syntax.read_term (Proof_Context.init_global thy) (To_string0 s) in (t, Term.add_frees t []) end | T_lambda (a, e) => Option.map (fn (e, l_free) => let val a = To_string0 a val (t, l_free) = case List.partition (fn (x, _) => x = a) l_free of ([], l_free) => (Term.TFree ("'a", ["HOL.type"]), l_free) | ([(_, t)], l_free) => (t, l_free) in (lambda (Term.Free (a, t)) e, l_free) end) (aux e) | _ => NONE in case aux e of NONE => error "nested pure expression not expected" | SOME (e, _) => META.T_pure (From.Pure.term e) end) meta) thy end end \ (*<*) subsection\Directives of Compilation for Target Languages\ ML\ structure Deep0 = struct fun apply_hs_code_identifiers ml_module thy = let fun mod_hs (fic, ml_module) = Code_Symbol.Module (fic, [("Haskell", SOME ml_module)]) in fold (Code_Target.set_identifiers o mod_hs) (map (fn x => (Context.theory_name x, ml_module)) (* list of .hs files that will be merged together in "ml_module" *) ( thy :: (* we over-approximate the set of compiler files *) Context.ancestors_of thy)) thy end val default_key = "" structure Export_code_env = struct structure Isabelle = struct val function = "write_file" val argument_main = "main" end structure Haskell = struct val function = "Function" val argument = "Argument" val main = "Main" structure Filename = struct fun hs_function ext = function ^ "." ^ ext fun hs_argument ext = argument ^ "." ^ ext fun hs_main ext = main ^ "." ^ ext end end structure OCaml = struct val make = "write" structure Filename = struct fun function ext = "function." ^ ext fun argument ext = "argument." ^ ext fun main_fic ext = "main." ^ ext fun makefile ext = make ^ "." ^ ext end end structure Scala = struct structure Filename = struct fun function ext = "Function." ^ ext fun argument ext = "Argument." ^ ext end end structure SML = struct val main = "Run" structure Filename = struct fun function ext = "Function." ^ ext fun argument ext = "Argument." ^ ext fun stdout ext = "Stdout." ^ ext fun main_fic ext = main ^ "." ^ ext end end datatype file_input = File | Directory end fun compile l cmd = let val (l, rc) = fold (fn cmd => (fn (l, 0) => let val res = Isabelle_System.bash_process (Bash.script cmd) in ((Process_Result.out res, Process_Result.err res) :: l, Process_Result.rc res) end | x => x)) l ([], 0) val l = rev l in if rc = 0 then (l, Isabelle_System.bash_output cmd) else let val () = fold (fn (out, err) => K (warning err; writeln out)) l () in error "Compilation failed" end end val check = fold (fn (cmd, msg) => fn () => let val (out, rc) = Isabelle_System.bash_output cmd in if rc = 0 then () else ( writeln out ; error msg) end) val compiler = let open Export_code_env in [ let val ml_ext = "hs" in ( "Haskell", ml_ext, Directory, Haskell.Filename.hs_function , check [("ghc --version", "ghc is not installed (required for compiling a Haskell project)")] , (fn mk_fic => fn ml_module => fn mk_free => fn thy => File.write (mk_fic ("Main." ^ ml_ext)) (String.concatWith "; " [ "import qualified Unsafe.Coerce" , "import qualified " ^ Haskell.function , "import qualified " ^ Haskell.argument , "main :: IO ()" , "main = " ^ Haskell.function ^ "." ^ Isabelle.function ^ " (Unsafe.Coerce.unsafeCoerce " ^ Haskell.argument ^ "." ^ mk_free (Proof_Context.init_global thy) Isabelle.argument_main ([]: (string * string) list) ^ ")"])) , fn tmp_export_code => fn tmp_file => compile [ "mv " ^ tmp_file ^ "/" ^ Haskell.Filename.hs_argument ml_ext ^ " " ^ Path.implode tmp_export_code , "cd " ^ Path.implode tmp_export_code ^ " && ghc -outputdir _build " ^ Haskell.Filename.hs_main ml_ext ] (Path.implode (Path.append tmp_export_code (Path.make [Haskell.main])))) end , let val ml_ext = "ml" in ( "OCaml", ml_ext, File, OCaml.Filename.function , check [("ocp-build -version", "ocp-build is not installed (required for compiling an OCaml project)") ,("ocamlopt -version", "ocamlopt is not installed (required for compiling an OCaml project)")] , fn mk_fic => fn ml_module => fn mk_free => fn thy => let val () = File.write (mk_fic (OCaml.Filename.makefile "ocp")) (String.concat [ "comp += \"-g\" link += \"-g\" " , "begin generated = true begin library \"nums\" end end " , "begin program \"", OCaml.make, "\" sort = true files = [ \"", OCaml.Filename.function ml_ext , "\" \"", OCaml.Filename.argument ml_ext , "\" \"", OCaml.Filename.main_fic ml_ext , "\" ]" , "requires = [\"nums\"] " , "end" ]) in File.write (mk_fic (OCaml.Filename.main_fic ml_ext)) ("let _ = Function." ^ ml_module ^ "." ^ Isabelle.function ^ " (Obj.magic (Argument." ^ ml_module ^ "." ^ mk_free (Proof_Context.init_global thy) Isabelle.argument_main ([]: (string * string) list) ^ "))") end , fn tmp_export_code => fn tmp_file => compile [ "mv " ^ tmp_file ^ " " ^ Path.implode (Path.append tmp_export_code (Path.make [OCaml.Filename.argument ml_ext])) , "cd " ^ Path.implode tmp_export_code ^ " && ocp-build -init -scan -no-bytecode 2>&1" ] (Path.implode (Path.append tmp_export_code (Path.make [ "_obuild" , OCaml.make , OCaml.make ^ ".asm"])))) end , let val ml_ext = "scala" val ml_module = Unsynchronized.ref ("", "") in ( "Scala", ml_ext, File, Scala.Filename.function , check [("scala -e 0", "scala is not installed (required for compiling a Scala project)")] , (fn _ => fn ml_mod => fn mk_free => fn thy => ml_module := (ml_mod, mk_free (Proof_Context.init_global thy) Isabelle.argument_main ([]: (string * string) list))) , fn tmp_export_code => fn tmp_file => let val l = File.read_lines (Path.explode tmp_file) val (ml_module, ml_main) = Unsynchronized.! ml_module val () = File.write_list (Path.append tmp_export_code (Path.make [Scala.Filename.argument ml_ext])) (List.map (fn s => s ^ "\n") ("object " ^ ml_module ^ " { def main (__ : Array [String]) = " ^ ml_module ^ "." ^ Isabelle.function ^ " (" ^ ml_module ^ "." ^ ml_main ^ ")" :: l @ ["}"])) in compile [] ("scala -nowarn " ^ Path.implode (Path.append tmp_export_code (Path.make [Scala.Filename.argument ml_ext]))) end) end , let val ml_ext_thy = "thy" val ml_ext_ml = "ML" in ( "SML", ml_ext_ml, File, SML.Filename.function , check [ let val isa = "isabelle" in ( Path.implode (Path.expand (Path.append (Path.variable "ISABELLE_HOME") (Path.make ["bin", isa]))) ^ " version" , isa ^ " is not installed (required for compiling a SML project)") end ] , fn mk_fic => fn ml_module => fn mk_free => fn thy => let val esc_star = "*" fun ml l = List.concat [ [ "ML{" ^ esc_star ] , map (fn s => s ^ ";") l , [ esc_star ^ "}"] ] val () = let val fic = mk_fic (SML.Filename.function ml_ext_ml) in (* replace ("\\" ^ "<") by ("\\\060") in 'fic' *) File.write_list fic (map (fn s => (if s = "" then "" else String.concatWith "\\" (map (fn s => let val l = String.size s in if l > 0 andalso String.sub (s,0) = #"<" then "\\060" ^ String.substring (s, 1, String.size s - 1) else s end) (String.fields (fn c => c = #"\\") s))) ^ "\n") (File.read_lines fic)) end in File.write_list (mk_fic (SML.Filename.main_fic ml_ext_thy)) (map (fn s => s ^ "\n") (List.concat [ [ "theory " ^ SML.main , "imports Main" , "begin" , "declare [[ML_print_depth = 500]]" (* any large number so that @{make_string} displays all the expression *) ] , ml [ "val stdout_file = Unsynchronized.ref (File.read (Path.make [\"" ^ SML.Filename.stdout ml_ext_ml ^ "\"]))" , "use \"" ^ SML.Filename.argument ml_ext_ml ^ "\"" ] , ml let val arg = "argument" in [ "val " ^ arg ^ " = XML.content_of (YXML.parse_body (@{make_string} (" ^ ml_module ^ "." ^ mk_free (Proof_Context.init_global thy) Isabelle.argument_main ([]: (string * string) list) ^ ")))" , "use \"" ^ SML.Filename.function ml_ext_ml ^ "\"" , "ML_Context.eval_source (ML_Compiler.verbose false ML_Compiler.flags) (Input.source false (\"let open " ^ ml_module ^ " in " ^ Isabelle.function ^ " (\" ^ " ^ arg ^ " ^ \") end\") (Position.none, Position.none) )" ] end , [ "end" ]])) end , fn tmp_export_code => fn tmp_file => let val stdout_file = Isabelle_System.create_tmp_path "stdout_file" "thy" val () = File.write (Path.append tmp_export_code (Path.make [SML.Filename.stdout ml_ext_ml])) (Path.implode (Path.expand stdout_file)) val (l, (_, exit_st)) = compile [ "mv " ^ tmp_file ^ " " ^ Path.implode (Path.append tmp_export_code (Path.make [SML.Filename.argument ml_ext_ml])) , "cd " ^ Path.implode tmp_export_code ^ " && echo 'use_thy \"" ^ SML.main ^ "\";' | " ^ Path.implode (Path.expand (Path.append (Path.variable "ISABELLE_HOME") (Path.make ["bin", "isabelle"]))) ^ " console" ] "true" val stdout = case try File.read stdout_file of SOME s => let val () = File.rm stdout_file in s end | NONE => "" in (l, (stdout, if List.exists (fn (err, _) => List.exists (fn "*** Error" => true | _ => false) (String.tokens (fn #"\n" => true | _ => false) err)) l then let val () = fold (fn (out, err) => K (warning err; writeln out)) l () in 1 end else exit_st)) end) end ] end structure Find = struct fun ext ml_compiler = case List.find (fn (ml_compiler0, _, _, _, _, _, _) => ml_compiler0 = ml_compiler) compiler of SOME (_, ext, _, _, _, _, _) => ext fun export_mode ml_compiler = case List.find (fn (ml_compiler0, _, _, _, _, _, _) => ml_compiler0 = ml_compiler) compiler of SOME (_, _, mode, _, _, _, _) => mode fun function ml_compiler = case List.find (fn (ml_compiler0, _, _, _, _, _, _) => ml_compiler0 = ml_compiler) compiler of SOME (_, _, _, f, _, _, _) => f fun check_compil ml_compiler = case List.find (fn (ml_compiler0, _, _, _, _, _, _) => ml_compiler0 = ml_compiler) compiler of SOME (_, _, _, _, build, _, _) => build fun init ml_compiler = case List.find (fn (ml_compiler0, _, _, _, _, _, _) => ml_compiler0 = ml_compiler) compiler of SOME (_, _, _, _, _, build, _) => build fun build ml_compiler = case List.find (fn (ml_compiler0, _, _, _, _, _, _) => ml_compiler0 = ml_compiler) compiler of SOME (_, _, _, _, _, _, build) => build end end \ ML\ structure Deep = struct fun absolute_path filename thy = Path.implode (Path.append (Resources.master_directory thy) (Path.explode filename)) fun export_code_tmp_file seris g = fold (fn ((ml_compiler, ml_module), export_arg) => fn f => fn g => f (fn accu => let val tmp_name = Context.theory_name @{theory} in (if Deep0.Find.export_mode ml_compiler = Deep0.Export_code_env.Directory then Isabelle_System.with_tmp_dir tmp_name else Isabelle_System.with_tmp_file tmp_name (Deep0.Find.ext ml_compiler)) (fn filename => g (((((ml_compiler, ml_module), Path.implode filename), export_arg) :: accu))) end)) seris (fn f => f []) (g o rev) fun mk_path_export_code tmp_export_code ml_compiler i = Path.append tmp_export_code (Path.make [ml_compiler ^ Int.toString i]) fun export_code_cmd' seris tmp_export_code f_err filename_thy raw_cs thy = export_code_tmp_file seris (fn seris => let val mem_scala = List.exists (fn ((("Scala", _), _), _) => true | _ => false) seris val thy' (* FIXME unused *) = Isabelle_Code_Target.export_code_cmd false (if mem_scala then Deep0.Export_code_env.Isabelle.function :: raw_cs else raw_cs) ((map o apfst o apsnd) SOME seris) (let val v = Deep0.apply_hs_code_identifiers Deep0.Export_code_env.Haskell.argument thy in if mem_scala then Code_printing.apply_code_printing v else v end) in List_mapi (fn i => fn seri => case seri of (((ml_compiler, _), filename), _) => let val (l, (out, err)) = Deep0.Find.build ml_compiler (mk_path_export_code tmp_export_code ml_compiler i) filename val _ = f_err seri err in (l, out) end) seris end) fun mk_term ctxt s = fst (Scan.pass (Context.Proof ctxt) Args.term (Token.explode0 (Thy_Header.get_keywords' ctxt) s)) fun mk_free ctxt s l = let val t_s = mk_term ctxt s in if Term.is_Free t_s then s else let val l = (s, "") :: l in mk_free ctxt (fst (hd (Term.variant_frees t_s l))) l end end val list_all_eq = fn x0 :: xs => List.all (fn x1 => x0 = x1) xs end \ subsection\Saving the History of Meta Commands\ ML\ fun p_gen f g = f "[" "]" g (*|| f "{" "}" g*) || f "(" ")" g fun paren f = p_gen (fn s1 => fn s2 => fn f => Parse.$$$ s1 |-- f --| Parse.$$$ s2) f fun parse_l f = Parse.$$$ "[" |-- Parse.!!! (Parse.list f --| Parse.$$$ "]") fun parse_l' f = Parse.$$$ "[" |-- Parse.list f --| Parse.$$$ "]" fun parse_l1' f = Parse.$$$ "[" |-- Parse.list1 f --| Parse.$$$ "]" fun annot_ty f = Parse.$$$ "(" |-- f --| Parse.$$$ "::" -- Parse.binding --| Parse.$$$ ")" \ ML\ structure Generation_mode = struct datatype internal_deep = Internal_deep of (string * (string list (* imports *) * string (* import optional (bootstrap) *))) option * ((bstring (* compiler *) * bstring (* main module *) ) * Token.T list) list (* seri_args *) * bstring option (* filename_thy *) * Path.T (* tmp dir export_code *) * bool (* true: skip preview of code exportation *) datatype 'a generation_mode = Gen_deep of unit META.compiler_env_config_ext * internal_deep | Gen_shallow of unit META.compiler_env_config_ext * 'a (* theory init *) | Gen_syntax_print of int option structure Data_gen = Theory_Data - (type T = theory generation_mode list Symtab.table - val empty = Symtab.empty - val extend = I - val merge = Symtab.merge (K true)) +( + type T = theory generation_mode list Symtab.table + val empty = Symtab.empty + val merge = Symtab.merge (K true) +) val code_expr_argsP = Scan.optional (@{keyword "("} |-- Parse.args --| @{keyword ")"}) [] val parse_scheme = @{keyword "design"} >> K META.Gen_only_design || @{keyword "analysis"} >> K META.Gen_only_analysis val parse_sorry_mode = Scan.optional ( @{keyword "SORRY"} >> K (SOME META.Gen_sorry) || @{keyword "no_dirty"} >> K (SOME META.Gen_no_dirty)) NONE val parse_deep = Scan.optional (@{keyword "skip_export"} >> K true) false -- Scan.optional (((Parse.$$$ "(" -- @{keyword "THEORY"}) |-- Parse.name -- ((Parse.$$$ ")" -- Parse.$$$ "(" -- @{keyword "IMPORTS"}) |-- parse_l' Parse.name -- Parse.name) --| Parse.$$$ ")") >> SOME) NONE -- Scan.optional (@{keyword "SECTION"} >> K true) false -- parse_sorry_mode -- (* code_expr_inP *) parse_l1' (@{keyword "in"} |-- (Parse.name -- Scan.optional (@{keyword "module_name"} |-- Parse.name) "" -- code_expr_argsP)) -- Scan.optional ((Parse.$$$ "(" -- @{keyword "output_directory"}) |-- Parse.name --| Parse.$$$ ")" >> SOME) NONE val parse_semantics = let val z = 0 in Scan.optional (paren (@{keyword "generation_semantics"} |-- paren (parse_scheme -- Scan.optional ((Parse.$$$ "," -- @{keyword "oid_start"}) |-- Parse.nat) z))) (META.Gen_default, z) end val mode = let fun mk_env output_disable_thy output_header_thy oid_start design_analysis sorry_mode dirty = META.compiler_env_config_empty output_disable_thy (From.option (From.pair From.string (From.pair (From.list From.string) From.string)) output_header_thy) (META.oidInit (From.internal_oid oid_start)) design_analysis (sorry_mode, dirty) in @{keyword "deep"} |-- parse_semantics -- parse_deep >> (fn ( (design_analysis, oid_start) , ( ((((skip_exportation, output_header_thy), output_disable_thy), sorry_mode), seri_args) , filename_thy)) => fn ctxt => Gen_deep ( mk_env (not output_disable_thy) output_header_thy oid_start design_analysis sorry_mode (Config.get ctxt quick_and_dirty) , Internal_deep ( output_header_thy , seri_args , filename_thy , Isabelle_System.create_tmp_path "deep_export_code" "" , skip_exportation))) || @{keyword "shallow"} |-- parse_semantics -- parse_sorry_mode >> (fn ((design_analysis, oid_start), sorry_mode) => fn ctxt => Gen_shallow ( mk_env true NONE oid_start design_analysis sorry_mode (Config.get ctxt quick_and_dirty) , ())) || (@{keyword "syntax_print"} |-- Scan.optional (Parse.number >> SOME) NONE) >> (fn n => K (Gen_syntax_print (case n of NONE => NONE | SOME n => Int.fromString n))) end fun f_command l_mode = Toplevel.theory (fn thy => let val (l_mode, thy) = META.mapM (fn Gen_shallow (env, ()) => let val thy0 = thy in fn thy => (Gen_shallow (env, thy0), thy) end | Gen_syntax_print n => (fn thy => (Gen_syntax_print n, thy)) | Gen_deep (env, Internal_deep ( output_header_thy , seri_args , filename_thy , tmp_export_code , skip_exportation)) => fn thy => let val _ = warning ("After closing Isabelle/jEdit, we may still need to remove this directory (by hand): " ^ Path.implode (Path.expand tmp_export_code)) val seri_args' = List_mapi (fn i => fn ((ml_compiler, ml_module), export_arg) => let val tmp_export_code = Deep.mk_path_export_code tmp_export_code ml_compiler i fun mk_fic s = Path.append tmp_export_code (Path.make [s]) val () = Deep0.Find.check_compil ml_compiler () val _ = Isabelle_System.make_directory tmp_export_code in ((( (ml_compiler, ml_module) , Path.implode (if Deep0.Find.export_mode ml_compiler = Deep0.Export_code_env.Directory then tmp_export_code else mk_fic (Deep0.Find.function ml_compiler (Deep0.Find.ext ml_compiler)))) , export_arg), mk_fic) end) seri_args val thy' (* FIXME unused *) = Isabelle_Code_Target.export_code_cmd (List.exists (fn (((("SML", _), _), _), _) => true | _ => false) seri_args') [Deep0.Export_code_env.Isabelle.function] (List.map ((apfst o apsnd) SOME o fst) seri_args') (Code_printing.apply_code_printing (Deep0.apply_hs_code_identifiers Deep0.Export_code_env.Haskell.function thy)) val () = fold (fn ((((ml_compiler, ml_module), _), _), mk_fic) => fn _ => Deep0.Find.init ml_compiler mk_fic ml_module Deep.mk_free thy) seri_args' () in (Gen_deep (env, Internal_deep ( output_header_thy , seri_args , filename_thy , tmp_export_code , skip_exportation)), thy) end) let val ctxt = Proof_Context.init_global thy in map (fn f => f ctxt) l_mode end thy in Data_gen.map (Symtab.map_default (Deep0.default_key, l_mode) (fn _ => l_mode)) thy end) fun update_compiler_config f = Data_gen.map (Symtab.map_entry Deep0.default_key (fn l_mode => map (fn Gen_deep (env, d) => Gen_deep (META.compiler_env_config_update f env, d) | Gen_shallow (env, thy) => Gen_shallow (META.compiler_env_config_update f env, thy) | Gen_syntax_print n => Gen_syntax_print n) l_mode)) end \ subsection\Factoring All Meta Commands Together\ setup\ML_Antiquotation.inline @{binding mk_string} (Scan.succeed "(fn ctxt => fn x => ML_Pretty.string_of_polyml (ML_system_pretty (x, FixedInt.fromInt (Config.get ctxt (ML_Print_Depth.print_depth)))))") \ ML\ fun exec_deep (env, output_header_thy, seri_args, filename_thy, tmp_export_code, l_obj) thy0 = let open Generation_mode in let val of_arg = META.isabelle_of_compiler_env_config META.isabelle_apply I in let fun def s = Named_Target.theory_map (snd o Specification.definition_cmd NONE [] [] (Binding.empty_atts, s) false) in let val name_main = Deep.mk_free (Proof_Context.init_global thy0) Deep0.Export_code_env.Isabelle.argument_main [] in thy0 |> def (String.concatWith " " ( "(" (* polymorphism weakening needed by export_code *) ^ name_main ^ " :: (_ \ abr_string option) compiler_env_config_scheme)" :: "=" :: To_string0 (of_arg (META.compiler_env_config_more_map (fn () => (l_obj, From.option From.string (Option.map (fn filename_thy => Deep.absolute_path filename_thy thy0) filename_thy))) env)) :: [])) |> Deep.export_code_cmd' seri_args tmp_export_code (fn (((_, _), msg), _) => fn err => if err <> 0 then error msg else ()) filename_thy [name_main] |> (fn l => let val (l_warn, l) = (map fst l, map snd l) in if Deep.list_all_eq l then (List.concat l_warn, hd l) else error "There is an extracted language which does not produce a similar Isabelle content as the others" end) |> (fn (l_warn, s) => let val () = writeln (case (output_header_thy, filename_thy) of (SOME _, SOME _) => s | _ => String.concat (map ( (fn s => s ^ "\n") o Active.sendback_markup_command o trim_line) (String.tokens (fn c => c = #"\t") s))) in fold (fn (out, err) => K ( writeln (Markup.markup Markup.keyword2 err) ; case trim_line out of "" => () | out => writeln (Markup.markup Markup.keyword1 out))) l_warn () end) end end end end fun outer_syntax_command0 mk_string cmd_spec cmd_descr parser get_all_meta_embed = let open Generation_mode in Outer_Syntax.command cmd_spec cmd_descr (parser >> (fn name => Toplevel.theory (fn thy => let val (env, thy) = META.mapM let val get_all_meta_embed = get_all_meta_embed name in fn Gen_syntax_print n => (fn thy => let val _ = writeln (mk_string (Proof_Context.init_global (case n of NONE => thy | SOME n => Config.put_global ML_Print_Depth.print_depth n thy)) name) in (Gen_syntax_print n, thy) end) | Gen_deep (env, Internal_deep ( output_header_thy , seri_args , filename_thy , tmp_export_code , skip_exportation)) => (fn thy0 => let val l_obj = get_all_meta_embed thy0 in thy0 |> (if skip_exportation then K () else exec_deep ( META.d_output_header_thy_update (fn _ => NONE) env , output_header_thy , seri_args , NONE , tmp_export_code , l_obj)) |> K (Gen_deep ( META.fold_thy_deep l_obj env , Internal_deep ( output_header_thy , seri_args , filename_thy , tmp_export_code , skip_exportation)), thy0) end) | Gen_shallow (env, thy0) => fn thy => let fun aux (env, thy) x = META.fold_thy_shallow (fn f => f () handle ERROR e => ( warning "Shallow Backtracking: (true) Isabelle declarations occurring among the META-simulated ones are ignored (if any)" (* TODO automatically determine if there is such Isabelle declarations, for raising earlier a specific error message *) ; error e)) (fn _ => fn _ => thy0) (fn l => fn (env, thy) => Bind_META.all_meta (fn x => fn thy => aux (env, thy) [x]) (pair env) l thy) x (env, thy) val (env, thy) = aux (env, thy) (get_all_meta_embed thy) in (Gen_shallow (env, thy0), thy) end end (case Symtab.lookup (Data_gen.get thy) Deep0.default_key of SOME l => l | _ => [Gen_syntax_print NONE]) thy in Data_gen.map (Symtab.update (Deep0.default_key, env)) thy end))) end fun outer_syntax_command mk_string cmd_spec cmd_descr parser get_all_meta_embed = outer_syntax_command0 mk_string cmd_spec cmd_descr parser (fn a => fn thy => [get_all_meta_embed a thy]) \ subsection\Parameterizing the Semantics of Embedded Languages\ ML\ val () = let open Generation_mode in Outer_Syntax.command @{command_keyword generation_syntax} "set the generating list" (( mode >> (fn x => SOME [x]) || parse_l' mode >> SOME || @{keyword "deep"} -- @{keyword "flush_all"} >> K NONE) >> (fn SOME x => f_command x | NONE => Toplevel.theory (fn thy => let val l = case Symtab.lookup (Data_gen.get thy) Deep0.default_key of SOME l => l | _ => [] val l = List.concat (List.map (fn Gen_deep x => [x] | _ => []) l) val _ = case l of [] => warning "Nothing to perform." | _ => () val thy = fold (fn (env, Internal_deep (output_header_thy, seri_args, filename_thy, tmp_export_code, _)) => fn thy0 => thy0 |> let val (env, l_exec) = META.compiler_env_config_reset_all env in exec_deep (env, output_header_thy, seri_args, filename_thy, tmp_export_code, l_exec) end |> K thy0) l thy in thy end))) end \ subsection\Common Parser for Toy\ ML\ structure TOY_parse = struct datatype ('a, 'b) use_context = TOY_context_invariant of 'a | TOY_context_pre_post of 'b fun optional f = Scan.optional (f >> SOME) NONE val colon = Parse.$$$ ":" fun repeat2 scan = scan ::: Scan.repeat1 scan fun xml_unescape s = (XML.content_of (YXML.parse_body s), Position.none) |> Symbol_Pos.explode |> Symbol_Pos.implode |> From.string fun outer_syntax_command2 mk_string cmd_spec cmd_descr parser v_true v_false get_all_meta_embed = outer_syntax_command mk_string cmd_spec cmd_descr (optional (paren @{keyword "shallow"}) -- parser) (fn (is_shallow, use) => fn thy => get_all_meta_embed (if is_shallow = NONE then ( fn s => META.T_to_be_parsed ( From.string s , xml_unescape s) , v_true) else (From.toy_ctxt_term thy, v_false)) use) (* *) val ident_dot_dot = let val f = Parse.sym_ident >> (fn "\" => "\" | _ => Scan.fail "Syntax error") in f -- f end val ident_star = Parse.sym_ident (* "*" *) (* *) val unlimited_natural = ident_star >> (fn "*" => META.Mult_star | "\" => META.Mult_infinity | _ => Scan.fail "Syntax error") || Parse.number >> (fn s => META.Mult_nat (case Int.fromString s of SOME i => Code_Numeral.natural_of_integer i | NONE => Scan.fail "Syntax error")) val term_base = Parse.number >> (META.ToyDefInteger o From.string) || Parse.float_number >> (META.ToyDefReal o (From.pair From.string From.string o (fn s => case String.tokens (fn #"." => true | _ => false) s of [l1,l2] => (l1,l2) | _ => Scan.fail "Syntax error"))) || Parse.string >> (META.ToyDefString o From.string) val multiplicity = parse_l' (unlimited_natural -- optional (ident_dot_dot |-- unlimited_natural)) fun toy_term x = ( term_base >> META.ShallB_term || Parse.binding >> (META.ShallB_str o From.binding) || @{keyword "self"} |-- Parse.nat >> (fn n => META.ShallB_self (From.internal_oid n)) || paren (Parse.list toy_term) >> (* untyped, corresponds to Set, Sequence or Pair *) (* WARNING for Set: we are describing a finite set *) META.ShallB_list) x val name_object = optional (Parse.list1 Parse.binding --| colon) -- Parse.binding val type_object_weak = let val name_object = Parse.binding >> (fn s => (NONE, s)) in name_object -- Scan.repeat (Parse.$$$ "<" |-- Parse.list1 name_object) >> let val f = fn (_, s) => META.ToyTyCore_pre (From.binding s) in fn (s, l) => META.ToyTyObj (f s, map (map f) l) end end val type_object = name_object -- Scan.repeat (Parse.$$$ "<" |-- Parse.list1 name_object) >> let val f = fn (_, s) => META.ToyTyCore_pre (From.binding s) in fn (s, l) => META.ToyTyObj (f s, map (map f) l) end val category = multiplicity -- optional (@{keyword "Role"} |-- Parse.binding) -- Scan.repeat ( @{keyword "Ordered"} >> K META.Ordered0 || @{keyword "Subsets"} |-- Parse.binding >> K META.Subsets0 || @{keyword "Union"} >> K META.Union0 || @{keyword "Redefines"} |-- Parse.binding >> K META.Redefines0 || @{keyword "Derived"} -- Parse.$$$ "=" |-- Parse.term >> K META.Derived0 || @{keyword "Qualifier"} |-- Parse.term >> K META.Qualifier0 || @{keyword "Nonunique"} >> K META.Nonunique0 || @{keyword "Sequence_"} >> K META.Sequence) >> (fn ((l_mult, role), l) => META.Toy_multiplicity_ext (l_mult, From.option From.binding role, l, ())) val type_base = Parse.reserved "Void" >> K META.ToyTy_base_void || Parse.reserved "Boolean" >> K META.ToyTy_base_boolean || Parse.reserved "Integer" >> K META.ToyTy_base_integer || Parse.reserved "UnlimitedNatural" >> K META.ToyTy_base_unlimitednatural || Parse.reserved "Real" >> K META.ToyTy_base_real || Parse.reserved "String" >> K META.ToyTy_base_string fun use_type_gen type_object v = ((* collection *) Parse.reserved "Set" |-- use_type >> (fn l => META.ToyTy_collection (META.Toy_multiplicity_ext ([], NONE, [META.Set], ()), l)) || Parse.reserved "Sequence" |-- use_type >> (fn l => META.ToyTy_collection (META.Toy_multiplicity_ext ([], NONE, [META.Sequence], ()), l)) || category -- use_type >> META.ToyTy_collection (* pair *) || Parse.reserved "Pair" |-- ( use_type -- use_type || Parse.$$$ "(" |-- use_type --| Parse.$$$ "," -- use_type --| Parse.$$$ ")") >> META.ToyTy_pair (* base *) || type_base (* raw HOL *) || Parse.sym_ident (* "\" *) |-- Parse.typ --| Parse.sym_ident (* "\" *) >> (META.ToyTy_raw o xml_unescape) (* object type *) || type_object >> META.ToyTy_object || ((Parse.$$$ "(" |-- Parse.list ( (Parse.binding --| colon >> (From.option From.binding o SOME)) -- ( Parse.$$$ "(" |-- use_type --| Parse.$$$ ")" || use_type_gen type_object_weak) >> META.ToyTy_binding ) --| Parse.$$$ ")" >> (fn ty_arg => case rev ty_arg of [] => META.ToyTy_base_void | ty_arg => fold (fn x => fn acc => META.ToyTy_pair (x, acc)) (tl ty_arg) (hd ty_arg))) -- optional (colon |-- use_type)) >> (fn (ty_arg, ty_out) => case ty_out of NONE => ty_arg | SOME ty_out => META.ToyTy_arrow (ty_arg, ty_out)) || (Parse.$$$ "(" |-- use_type --| Parse.$$$ ")" >> (fn s => META.ToyTy_binding (NONE, s)))) v and use_type x = use_type_gen type_object x val use_prop = (optional (optional (Parse.binding >> From.binding) --| Parse.$$$ ":") >> (fn NONE => NONE | SOME x => x)) -- Parse.term --| optional (Parse.$$$ ";") >> (fn (n, e) => fn from_expr => META.ToyProp_ctxt (n, from_expr e)) (* *) val association_end = type_object -- category --| optional (Parse.$$$ ";") val association = optional @{keyword "Between"} |-- Scan.optional (repeat2 association_end) [] val invariant = optional @{keyword "Constraints"} |-- Scan.optional (@{keyword "Existential"} >> K true) false --| @{keyword "Inv"} -- use_prop structure Outer_syntax_Association = struct fun make ass_ty l = META.Toy_association_ext (ass_ty, META.ToyAssRel l, ()) end (* *) val context = Scan.repeat (( optional (@{keyword "Operations"} || Parse.$$$ "::") |-- Parse.binding -- use_type --| optional (Parse.$$$ "=" |-- Parse.term || Parse.term) -- Scan.repeat ( (@{keyword "Pre"} || @{keyword "Post"}) -- use_prop >> TOY_context_pre_post || invariant >> TOY_context_invariant) --| optional (Parse.$$$ ";")) >> (fn ((name_fun, ty), expr) => fn from_expr => META.Ctxt_pp (META.Toy_ctxt_pre_post_ext ( From.binding name_fun , ty , From.list (fn TOY_context_pre_post (pp, expr) => META.T_pp (if pp = "Pre" then META.ToyCtxtPre else META.ToyCtxtPost, expr from_expr) | TOY_context_invariant (b, expr) => META.T_invariant (META.T_inv (b, expr from_expr))) expr , ()))) || invariant >> (fn (b, expr) => fn from_expr => META.Ctxt_inv (META.T_inv (b, expr from_expr)))) val class = optional @{keyword "Attributes"} |-- Scan.repeat (Parse.binding --| colon -- use_type --| optional (Parse.$$$ ";")) -- context datatype use_classDefinition = TOY_class | TOY_class_abstract datatype ('a, 'b) use_classDefinition_content = TOY_class_content of 'a | TOY_class_synonym of 'b structure Outer_syntax_Class = struct fun make from_expr abstract ty_object attribute oper = META.Toy_class_raw_ext ( ty_object , From.list (From.pair From.binding I) attribute , From.list (fn f => f from_expr) oper , abstract , ()) end (* *) val term_object = parse_l ( optional ( Parse.$$$ "(" |-- Parse.binding --| Parse.$$$ "," -- Parse.binding --| Parse.$$$ ")" --| (Parse.sym_ident >> (fn "|=" => Scan.succeed | _ => Scan.fail ""))) -- Parse.binding -- ( Parse.$$$ "=" |-- toy_term)) val list_attr' = term_object >> (fn res => (res, [] : binding list)) fun object_cast e = ( annot_ty term_object -- Scan.repeat ( (Parse.sym_ident >> (fn "->" => Scan.succeed | "\" => Scan.succeed | "\" => Scan.succeed | _ => Scan.fail "")) |-- ( Parse.reserved "toyAsType" |-- Parse.$$$ "(" |-- Parse.binding --| Parse.$$$ ")" || Parse.binding)) >> (fn ((res, x), l) => (res, rev (x :: l)))) e val object_cast' = object_cast >> (fn (res, l) => (res, rev l)) fun get_toyinst l _ = META.ToyInstance (map (fn ((name,typ), (l_attr, is_cast)) => let val f = map (fn ((pre_post, attr), data) => ( From.option (From.pair From.binding From.binding) pre_post , ( From.binding attr , data))) val l_attr = fold (fn b => fn acc => META.ToyAttrCast (From.binding b, acc, [])) is_cast (META.ToyAttrNoCast (f l_attr)) in META.Toy_instance_single_ext (From.option From.binding name, From.option From.binding typ, l_attr, ()) end) l) val parse_instance = (Parse.binding >> SOME) -- optional (@{keyword "::"} |-- Parse.binding) --| @{keyword "="} -- (list_attr' || object_cast') (* *) datatype state_content = ST_l_attr of (((binding * binding) option * binding) * META.toy_data_shallow) list * binding list | ST_binding of binding val state_parse = parse_l' ( object_cast >> ST_l_attr || Parse.binding >> ST_binding) fun mk_state thy = map (fn ST_l_attr l => META.ToyDefCoreAdd (case get_toyinst (map (fn (l_i, l_ty) => ((NONE, SOME (hd l_ty)), (l_i, rev (tl l_ty)))) [l]) thy of META.ToyInstance [x] => x) | ST_binding b => META.ToyDefCoreBinding (From.binding b)) (* *) datatype state_pp_content = ST_PP_l_attr of state_content list | ST_PP_binding of binding val state_pp_parse = state_parse >> ST_PP_l_attr || Parse.binding >> ST_PP_binding fun mk_pp_state thy = fn ST_PP_l_attr l => META.ToyDefPPCoreAdd (mk_state thy l) | ST_PP_binding s => META.ToyDefPPCoreBinding (From.binding s) end \ subsection\Setup of Meta Commands for Toy: Enum\ ML\ val () = outer_syntax_command @{mk_string} @{command_keyword Enum} "" (Parse.binding -- parse_l1' Parse.binding) (fn (n1, n2) => K (META.META_enum (META.ToyEnum (From.binding n1, From.list From.binding n2)))) \ subsection\Setup of Meta Commands for Toy: (abstract) Class\ ML\ local open TOY_parse fun mk_classDefinition abstract cmd_spec = outer_syntax_command2 @{mk_string} cmd_spec "Class generation" ( Parse.binding --| Parse.$$$ "=" -- TOY_parse.type_base >> TOY_class_synonym || type_object -- class >> TOY_class_content) (curry META.META_class_raw META.Floor1) (curry META.META_class_raw META.Floor2) (fn (from_expr, META_class_raw) => fn TOY_class_content (ty_object, (attribute, oper)) => META_class_raw (Outer_syntax_Class.make from_expr (abstract = TOY_class_abstract) ty_object attribute oper) | TOY_class_synonym (n1, n2) => META.META_class_synonym (META.ToyClassSynonym (From.binding n1, n2))) in val () = mk_classDefinition TOY_class @{command_keyword Class} val () = mk_classDefinition TOY_class_abstract @{command_keyword Abstract_class} end \ subsection\Setup of Meta Commands for Toy: Association, Composition, Aggregation\ ML\ local open TOY_parse fun mk_associationDefinition ass_ty cmd_spec = outer_syntax_command @{mk_string} cmd_spec "" ( repeat2 association_end || optional Parse.binding |-- association) (fn l => fn _ => META.META_association (Outer_syntax_Association.make ass_ty l)) in val () = mk_associationDefinition META.ToyAssTy_association @{command_keyword Association} val () = mk_associationDefinition META.ToyAssTy_composition @{command_keyword Composition} val () = mk_associationDefinition META.ToyAssTy_aggregation @{command_keyword Aggregation} end \ subsection\Setup of Meta Commands for Toy: (abstract) Associationclass\ ML\ local open TOY_parse datatype use_associationClassDefinition = TOY_associationclass | TOY_associationclass_abstract fun mk_associationClassDefinition abstract cmd_spec = outer_syntax_command2 @{mk_string} cmd_spec "" ( type_object -- association -- class -- optional (Parse.reserved "aggregation" || Parse.reserved "composition")) (curry META.META_ass_class META.Floor1) (curry META.META_ass_class META.Floor2) (fn (from_expr, META_ass_class) => fn (((ty_object, l_ass), (attribute, oper)), assty) => META_ass_class (META.ToyAssClass ( Outer_syntax_Association.make (case assty of SOME "aggregation" => META.ToyAssTy_aggregation | SOME "composition" => META.ToyAssTy_composition | _ => META.ToyAssTy_association) l_ass , Outer_syntax_Class.make from_expr (abstract = TOY_associationclass_abstract) ty_object attribute oper))) in val () = mk_associationClassDefinition TOY_associationclass @{command_keyword Associationclass} val () = mk_associationClassDefinition TOY_associationclass_abstract @{command_keyword Abstract_associationclass} end \ subsection\Setup of Meta Commands for Toy: Context\ ML\ local open TOY_parse in val () = outer_syntax_command2 @{mk_string} @{command_keyword Context} "" (optional (Parse.list1 Parse.binding --| colon) -- Parse.binding -- context) (curry META.META_ctxt META.Floor1) (curry META.META_ctxt META.Floor2) (fn (from_expr, META_ctxt) => (fn ((l_param, name), l) => META_ctxt (META.Toy_ctxt_ext ( case l_param of NONE => [] | SOME l => From.list From.binding l , META.ToyTyObj (META.ToyTyCore_pre (From.binding name), []) , From.list (fn f => f from_expr) l , ())))) end \ subsection\Setup of Meta Commands for Toy: End\ ML\ val () = outer_syntax_command0 @{mk_string} @{command_keyword End} "Class generation" (Scan.optional ( Parse.$$$ "[" -- Parse.reserved "forced" -- Parse.$$$ "]" >> K true || Parse.$$$ "!" >> K true) false) (fn b => fn _ => if b then [META.META_flush_all META.ToyFlushAll] else []) \ subsection\Setup of Meta Commands for Toy: BaseType, Instance, State\ ML\ val () = outer_syntax_command @{mk_string} @{command_keyword BaseType} "" (parse_l' TOY_parse.term_base) (K o META.META_def_base_l o META.ToyDefBase) local open TOY_parse in val () = outer_syntax_command @{mk_string} @{command_keyword Instance} "" (Scan.optional (parse_instance -- Scan.repeat (optional @{keyword "and"} |-- parse_instance) >> (fn (x, xs) => x :: xs)) []) (META.META_instance oo get_toyinst) val () = outer_syntax_command @{mk_string} @{command_keyword State} "" (TOY_parse.optional (paren @{keyword "shallow"}) -- Parse.binding --| @{keyword "="} -- state_parse) (fn ((is_shallow, name), l) => fn thy => META.META_def_state ( if is_shallow = NONE then META.Floor1 else META.Floor2 , META.ToyDefSt (From.binding name, mk_state thy l))) end \ subsection\Setup of Meta Commands for Toy: PrePost\ ML\ local open TOY_parse in val () = outer_syntax_command @{mk_string} @{command_keyword PrePost} "" (TOY_parse.optional (paren @{keyword "shallow"}) -- TOY_parse.optional (Parse.binding --| @{keyword "="}) -- state_pp_parse -- TOY_parse.optional state_pp_parse) (fn (((is_shallow, n), s_pre), s_post) => fn thy => META.META_def_pre_post ( if is_shallow = NONE then META.Floor1 else META.Floor2 , META.ToyDefPP ( From.option From.binding n , mk_pp_state thy s_pre , From.option (mk_pp_state thy) s_post))) end (*val _ = print_depth 100*) \ (*>*) end diff --git a/thys/Lazy_Case/lazy_case.ML b/thys/Lazy_Case/lazy_case.ML --- a/thys/Lazy_Case/lazy_case.ML +++ b/thys/Lazy_Case/lazy_case.ML @@ -1,193 +1,192 @@ signature LAZY_CASE = sig val lazify: Ctr_Sugar.ctr_sugar -> local_theory -> local_theory val lazify_typ: typ -> local_theory -> local_theory val lazify_cmd: string -> local_theory -> local_theory val lazy_case_plugin: string val setup: theory -> theory end structure Lazy_Case : LAZY_CASE = struct structure Data = Generic_Data ( type T = Symtab.set val empty = Symtab.empty - val extend = I val merge = Symtab.merge op = ) fun init [] = error "empty list" | init [_] = [] | init (x :: xs) = x :: init xs fun lazify {T, casex, ctrs, case_thms, case_cong, ...} lthy = let val is_fun = can dest_funT val typ_name = fst (dest_Type T) val len = length ctrs val idxs = 0 upto len - 1 val (name, typ) = dest_Const casex ||> Logic.unvarifyT_global val (typs, _) = strip_type typ val exists = Symtab.defined (Data.get (Context.Proof lthy)) typ_name val warn = Pretty.separate "" [Syntax.pretty_typ lthy T, Pretty.str "already lazified"] |> Pretty.block val _ = if exists then warning (Pretty.string_of warn) else () in (* for records, casex is the dummy pattern *) if Term.is_dummy_pattern casex orelse forall is_fun (init typs) orelse exists then lthy else let val arg_typs = init typs fun apply_to_unit typ idx = if is_fun typ then (typ, Bound idx) else (@{typ unit} --> typ, Bound idx $ @{term "()"}) val (arg_typs', args) = split_list (map2 apply_to_unit arg_typs (rev idxs)) val def = list_comb (Const (name, typ), args) |> fold_rev Term.abs (map (pair "c") arg_typs') val binding = Binding.name "case_lazy" val ((term, thm), (lthy', lthy)) = (snd o Local_Theory.begin_nested) lthy |> Proof_Context.concealed |> Local_Theory.map_background_naming (Name_Space.mandatory_path typ_name) |> Local_Theory.define ((binding, NoSyn), ((Thm.def_binding binding, []), def)) |>> apsnd snd ||> `Local_Theory.end_nested val phi = Proof_Context.export_morphism lthy lthy' val thm' = Morphism.thm phi thm val term' = Logic.unvarify_global (Morphism.term phi term) fun defs_tac ctxt idx = Local_Defs.unfold_tac ctxt [thm', nth case_thms idx] THEN HEADGOAL (resolve_tac ctxt @{thms refl}) val frees = fastype_of term' |> strip_type |> fst |> init val frees_f = Name.invent_names Name.context "f0" frees val frees_g = Name.invent_names Name.context "g0" frees val fs = map Free frees_f val gs = map Free frees_g fun mk_def_goal ctr idx = let val (name, len) = dest_Const ctr ||> strip_type ||> fst ||> length val frees = Name.invent Name.context "p0" len val args = map (Free o rpair dummyT) frees val ctr_val = list_comb (Const (name, dummyT), args) val lhs = list_comb (term', fs) $ ctr_val val rhs = if len = 0 then nth fs idx $ @{term "()"} else list_comb (nth fs idx, args) in (frees, HOLogic.mk_Trueprop (Syntax.check_term lthy' (HOLogic.mk_eq (lhs, rhs)))) end fun prove_defs (frees', goal) idx = Goal.prove_future lthy' (map fst frees_f @ frees') [] goal (fn {context, ...} => defs_tac context idx) val def_thms = map2 prove_defs (map2 mk_def_goal ctrs idxs) idxs val frees = Name.invent_names Name.context "q0" arg_typs val unfold_goal = let val lhs = list_comb (Const (name, typ), map Free frees) fun mk_abs (name, typ) = if is_fun typ then Free (name, typ) else Abs ("u", @{typ unit}, Free (name, typ)) val rhs = list_comb (Const (fst (dest_Const term'), dummyT), map mk_abs frees) in HOLogic.mk_Trueprop (Syntax.check_term lthy' (HOLogic.mk_eq (lhs, rhs))) end fun unfold_tac ctxt = Local_Defs.unfold_tac ctxt [thm'] THEN HEADGOAL (resolve_tac ctxt @{thms refl}) val unfold_thm = Goal.prove_future lthy' (map fst frees) [] unfold_goal (fn {context, ...} => unfold_tac context) fun mk_cong_prem t ctr (f, g) = let (* FIXME get rid of dummyT here *) fun mk_all t = Logic.all_const dummyT $ Abs ("", dummyT, t) val len = dest_Const ctr |> snd |> strip_type |> fst |> length val args = map Bound (len - 1 downto 0) val ctr_val = list_comb (Logic.unvarify_global ctr, args) val args' = if len = 0 then [Bound 0] else args val lhs = list_comb (f, args') val rhs = list_comb (g, args') val concl = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) val prem = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, ctr_val)) in fold (K mk_all) args' (Logic.mk_implies (prem, concl)) end val cong_goal = let val t1 = Free ("t1", Logic.unvarifyT_global T) val t2 = Free ("t2", Logic.unvarifyT_global T) val prems = HOLogic.mk_Trueprop (HOLogic.mk_eq (t1, t2)) :: map2 (mk_cong_prem t2) ctrs (fs ~~ gs) val lhs = list_comb (term', fs) $ t1 val rhs = list_comb (term', gs) $ t2 val concl = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) in Logic.list_implies (prems, concl) |> Syntax.check_term lthy' end fun cong_tac ctxt = Local_Defs.unfold_tac ctxt [thm'] THEN HEADGOAL (eresolve_tac ctxt [case_cong]) THEN ALLGOALS (ctxt |> Subgoal.FOCUS (fn {context = ctxt, prems, ...} => HEADGOAL (resolve_tac ctxt prems THEN' resolve_tac ctxt prems))) val cong_thm = Goal.prove_future lthy' ("t1" :: "t2" :: map fst frees_f @ map fst frees_g) [] cong_goal (fn {context, ...} => cong_tac context) val upd = Data.map (Symtab.update_new (typ_name, ())) in lthy' |> Local_Theory.note ((Binding.empty, @{attributes [code]}), def_thms) |> snd |> Local_Theory.note ((Binding.empty, @{attributes [code_unfold]}), [unfold_thm]) |> snd |> Local_Theory.note ((Binding.empty, @{attributes [fundef_cong]}), [cong_thm]) |> snd |> Local_Theory.declaration {syntax = false, pervasive = true} (K upd) end end fun lazify_typ typ lthy = lazify (the (Ctr_Sugar.ctr_sugar_of lthy (fst (dest_Type typ)))) lthy fun lazify_cmd s lthy = lazify_typ (Proof_Context.read_type_name {proper = true, strict = false} lthy s) lthy val lazy_case_plugin = Plugin_Name.declare_setup @{binding lazy_case} (** setup **) val _ = Outer_Syntax.local_theory @{command_keyword "lazify"} "defines a lazy case constant and sets up the code generator" (Scan.repeat1 Args.embedded_inner_syntax >> fold lazify_cmd) val setup = Ctr_Sugar.ctr_sugar_interpretation lazy_case_plugin (lazify_typ o #T) end \ No newline at end of file diff --git a/thys/Monad_Memo_DP/transform/Transform_Data.ML b/thys/Monad_Memo_DP/transform/Transform_Data.ML --- a/thys/Monad_Memo_DP/transform/Transform_Data.ML +++ b/thys/Monad_Memo_DP/transform/Transform_Data.ML @@ -1,167 +1,165 @@ signature TRANSFORM_DATA = sig type dp_info = { old_head: term, new_head': term, new_headT: term, old_defs: thm list, new_defT: thm, new_def': thm list } type cmd_info = { scope: binding, head: term, locale: string option, dp_info: dp_info option } val get_dp_info: string -> Proof.context -> term -> dp_info option val get_last_cmd_info: Proof.context -> cmd_info val commit_dp_info: string -> dp_info -> local_theory -> local_theory val add_tmp_cmd_info: binding * term * string option -> local_theory -> local_theory val get_or_last_cmd_info: Proof.context -> (string * term) option -> cmd_info end structure Transform_Data : TRANSFORM_DATA = struct type dp_info = { old_head: term, new_head': term, new_headT: term, old_defs: thm list, new_defT: thm, new_def': thm list } type cmd_info = { scope: binding, head: term, locale: string option, dp_info: dp_info option } fun map_cmd_info f0 f1 f2 f3 {scope, head, locale, dp_info} = {scope = f0 scope, head = f1 head, locale = f2 locale, dp_info = f3 dp_info} fun map_cmd_dp_info f = map_cmd_info I I I f structure Data = Generic_Data ( type T = { monadified_terms: (string * cmd_info Item_Net.T) list, last_cmd_info: cmd_info option } val empty = { monadified_terms = ["state", "heap"] ~~ replicate 2 (Item_Net.init (op aconv o apply2 #head) (single o #head)), last_cmd_info = NONE } - val extend = I - fun merge ( {monadified_terms = m0, ...}, {monadified_terms = m1, ...} ) = let val keys0 = map fst m0 val keys1 = map fst m1 val _ = @{assert} (keys0 = keys1) val vals = map Item_Net.merge (map snd m0 ~~ map snd m1) val ms = keys0 ~~ vals in {monadified_terms = ms, last_cmd_info = NONE} end ) fun transform_dp_info phi {old_head, new_head', new_headT, old_defs, new_defT, new_def'} = { old_head = Morphism.term phi old_head, new_head' = Morphism.term phi new_head', new_headT = Morphism.term phi new_headT, old_defs = Morphism.fact phi old_defs, new_def' = Morphism.fact phi new_def', new_defT = Morphism.thm phi new_defT } fun get_monadified_terms_generic monad_name context = Data.get context |> #monadified_terms |> (fn l => AList.lookup op= l monad_name) |> the fun get_monadified_terms monad_name ctxt = get_monadified_terms_generic monad_name (Context.Proof ctxt) fun map_data f0 f1 = Data.map (fn {monadified_terms, last_cmd_info} => {monadified_terms = f0 monadified_terms, last_cmd_info = f1 last_cmd_info}) fun map_monadified_terms f = map_data f I fun map_last_cmd_info f = map_data I f fun put_monadified_terms_generic monad_name new_terms context = context |> map_monadified_terms (AList.update op= (monad_name, new_terms)) fun map_monadified_terms_generic monad_name f context = context |> map_monadified_terms (AList.map_entry op= monad_name f) fun put_last_cmd_info cmd_info_opt context = map_last_cmd_info (K cmd_info_opt) context fun get_cmd_info monad_name ctxt tm = get_monadified_terms monad_name ctxt |> (fn net => Item_Net.retrieve net tm) fun get_dp_info monad_name ctxt tm = get_cmd_info monad_name ctxt tm |> (fn result => case result of {dp_info = SOME dp_info', ...} :: _ => SOME dp_info' | _ => NONE) fun get_last_cmd_info_generic context = Data.get context |> #last_cmd_info |> the fun get_last_cmd_info ctxt = get_last_cmd_info_generic (Context.Proof ctxt) fun commit_dp_info monad_name dp_info = Local_Theory.declaration {pervasive = false, syntax = false} (fn phi => fn context => let val old_cmd_info = get_last_cmd_info_generic context val new_dp_info = transform_dp_info phi dp_info val new_cmd_info = old_cmd_info |> map_cmd_dp_info (K (SOME new_dp_info)) in context |> map_monadified_terms_generic monad_name (Item_Net.update new_cmd_info) |> put_last_cmd_info (SOME new_cmd_info) end) fun add_tmp_cmd_info (scope, head, locale_opt) = Local_Theory.declaration {pervasive = false, syntax = false} (fn phi => fn context => let val new_cmd_info = { scope = Morphism.binding phi scope, head = Morphism.term phi head, locale = locale_opt, dp_info = NONE } in context |> put_last_cmd_info (SOME new_cmd_info) end ) fun get_or_last_cmd_info ctxt monad_name_tm_opt = case monad_name_tm_opt of NONE => get_last_cmd_info ctxt | SOME (monad_name, tm) => get_cmd_info monad_name ctxt tm |> the_single end diff --git a/thys/Monad_Normalisation/monad_rules.ML b/thys/Monad_Normalisation/monad_rules.ML --- a/thys/Monad_Normalisation/monad_rules.ML +++ b/thys/Monad_Normalisation/monad_rules.ML @@ -1,245 +1,244 @@ (* Title: monad_rules.ML Author: Manuel Eberl, TU München Author: Joshua Schneider, ETH Zurich Author: Andreas Lochbihler, ETH Zurich Monad laws and distributivity of bind over control operators (if, case_x ...). *) signature MONAD_RULES = sig type info = { bind_assoc: thm option, bind_commute: thm option, return_bind: thm option, bind_return: thm option } val get_monad: Proof.context -> string -> info option val get_monad_rules: Context.generic -> thm list val get_distrib_rule: Proof.context -> string -> thm option val get_distrib_rules: Context.generic -> thm list end; structure Monad_Rules : MONAD_RULES = struct fun same_const (Const (c,_), Const (c',_)) = (c = c') | same_const _ = false; fun analyze_bind_assoc thm = let val (lhs, rhs) = Thm.prop_of thm |> HOLogic.dest_Trueprop |> HOLogic.dest_eq in case (lhs, rhs) of (c1 $ (c2 $ Var x $ Var y) $ Var z, c3 $ Var x' $ Abs (_, _, c4 $ (Var y' $ Bound 0) $ Var z')) => if forall same_const ([c1,c2,c3] ~~ [c2,c3,c4]) andalso forall (op =) ([x,y,z] ~~ [x',y',z']) then c1 else raise THM ("analyze_bind_assoc", 1, [thm]) | _ => raise THM ("analyze_bind_assoc", 1, [thm]) end; fun analyze_return_bind thm = let val (lhs, rhs) = Thm.prop_of thm |> HOLogic.dest_Trueprop |> HOLogic.dest_eq in case (lhs, rhs) of (Const (c_bind,T) $ _ $ Var x, Var x' $ Var _) => if x = x' then Const (c_bind, T) else raise THM ("analyze_return_bind", 1, [thm]) | _ => raise THM ("analyze_return_bind", 1, [thm]) end; fun analyze_bind_return thm = let val (lhs, rhs) = Thm.prop_of thm |> HOLogic.dest_Trueprop |> HOLogic.dest_eq in case (lhs, rhs) of (Const (c_bind,T) $ Var x $ ret, Var x') => if x = x' then (Const (c_bind, T), ret) else raise THM ("analyze_bind_return", 1, [thm]) | _ => raise THM ("analyze_bind_return", 1, [thm]) end; fun analyze_bind_commute thm = let val (lhs,rhs) = Thm.prop_of thm |> HOLogic.dest_Trueprop |> HOLogic.dest_eq in case (lhs,rhs) of (c1 $ Var x $ Abs (_,_, c2 $ Var y $ (Var z $ Bound 0)), c3 $ Var y' $ Abs (_,_, c4 $ Var x' $ Abs (_, _, Var z' $ Bound 0 $ Bound 1))) => if forall same_const ([c1,c2,c3] ~~ [c2,c3,c4]) andalso forall op= ([x,y,z] ~~ [x',y',z']) then c1 else raise THM ("analyze_bind_commute", 1, [thm]) | _ => raise THM ("analyze_bind_commute", 1, [thm]) end; fun analyze_bind_distrib thm = let val (lhs, rhs) = Thm.prop_of thm |> HOLogic.dest_Trueprop |> HOLogic.dest_eq in case lhs of Var _ $ Var x $ Abs (_, _, y) => if member (op =) (Term.add_vars y []) x then raise THM ("analyze_bind_distrib", 1, [thm]) else let val (c, c') = apply2 head_of (y, rhs) in if same_const (c, c') then c else raise THM ("analyze_bind_distrib", 1, [thm]) end | _ => raise THM ("analyze_bind_distrib", 1, [thm]) end; type info = { bind_assoc: thm option, bind_commute: thm option, return_bind: thm option, bind_return: thm option }; fun make_info bind_assoc bind_commute return_bind bind_return = {bind_assoc = bind_assoc, bind_commute = bind_commute, return_bind = return_bind, bind_return = bind_return}; val empty_info = make_info NONE NONE NONE NONE; fun map_info f1 f2 f3 f4 {bind_assoc, bind_commute, return_bind, bind_return} = {bind_assoc = f1 bind_assoc, bind_commute = f2 bind_commute, return_bind = f3 return_bind, bind_return = f4 bind_return}; fun map_info_thms f = let val g = Option.map f in map_info g g g g end; fun merge_info (i1, i2) = if pointer_eq (i1, i2) then raise Symtab.SAME else let val {bind_assoc = ba1, bind_commute = bc1, return_bind = rb1, bind_return = br1} = i1; val {bind_assoc = ba2, bind_commute = bc2, return_bind = rb2, bind_return = br2} = i2; val ba = merge_options (ba1, ba2); val bc = merge_options (bc1, bc2); val rb = merge_options (rb1, rb2); val br = merge_options (br1, br2); in make_info ba bc rb br end; fun pretty_info ctxt bindc {bind_assoc, bind_commute, return_bind, bind_return} = let fun pretty_law (_, NONE) = NONE | pretty_law (name, SOME thm) = SOME (Pretty.block [Pretty.str name, Pretty.brk 1, Thm.pretty_thm ctxt thm]) val list = [("return-bind:", return_bind), ("bind-return:", bind_return), ("bind-assoc:", bind_assoc), ("bind-commute:", bind_commute)] in map_filter pretty_law list |> cons (Syntax.pretty_term (Config.put Adhoc_Overloading.show_variants true ctxt) (Const (bindc, dummyT))) |> Pretty.fbreaks |> Pretty.block end structure Data = Generic_Data( type T = { monads: info Symtab.table, distribs: thm Symtab.table }; val empty = {monads = Symtab.empty, distribs = Symtab.empty}; - val extend = I; fun merge ({monads = m1, distribs = d1}, {monads = m2, distribs = d2}) = {monads = Symtab.join (K merge_info) (m1, m2), distribs = Symtab.merge (K true) (d1, d2)}; ); fun map_data f1 f2 {monads, distribs} = {monads = f1 monads, distribs = f2 distribs}; fun get_monad_rules context = let fun add_simps {bind_assoc, return_bind, bind_return, ...} = map_filter I [bind_assoc, return_bind, bind_return]; val {monads, ...} = Data.get context; in Symtab.fold (fn (_, info) => append (add_simps info)) monads [] end; fun get_monad ctxt bindc = let val {monads, ...} = Data.get (Context.Proof ctxt); in Option.map (map_info_thms (Thm.transfer' ctxt)) (Symtab.lookup monads bindc) end; fun get_distrib_rule ctxt controlc = let val {distribs, ...} = Data.get (Context.Proof ctxt); in Option.map (Thm.transfer' ctxt) (Symtab.lookup distribs controlc) end; fun get_distrib_rules context = let val {distribs, ...} = Data.get context in Symtab.dest distribs |> map snd end; fun add_monad_rule thm context = let fun add_rule (analyze, map_info') = let val (bindc, _) = dest_Const (analyze thm) in map_data (Symtab.map_default (bindc, empty_info) map_info') I end; fun put_thm _ = SOME thm; val add_rule' = case get_first (try add_rule) [(analyze_bind_assoc, map_info put_thm I I I), (analyze_bind_commute, map_info I put_thm I I), (analyze_return_bind, map_info I I put_thm I), (analyze_bind_return #> fst, map_info I I I put_thm)] of SOME f => f | NONE => error "Bad monad rule"; in Data.map add_rule' context end; fun add_distrib_rule thm context = let val (controlc, _) = dest_Const (analyze_bind_distrib thm) handle THM _ => error "Bad distributivity rule"; in Data.map (map_data I (Symtab.update (controlc, thm))) context end; fun pretty_monad_rules ctxt = let val info = Data.get (Context.Proof ctxt) val monads = #monads info |> Symtab.dest |> map (uncurry (pretty_info ctxt)) |> Pretty.big_list "Monad laws" fun pretty_distrib (name, thm) = Pretty.block [ Syntax.pretty_term ctxt (Const (name, dummyT)), Pretty.str ": ", Pretty.brk 0, Thm.pretty_thm ctxt thm] val distribs = #distribs info |> Symtab.dest |> map pretty_distrib |> Pretty.big_list "Distributivity laws" in Pretty.blk (0, [monads, Pretty.fbrk, Pretty.fbrk, distribs]) end val add_monad_rules_simp = Context.map_proof (fn ctxt => ctxt addsimps (get_monad_rules (Context.Proof ctxt))) val _ = Theory.setup (Attrib.setup @{binding monad_rule} (Scan.succeed (Thm.declaration_attribute add_monad_rule)) "declaration of monad rule" #> Attrib.setup @{binding monad_distrib} (Scan.succeed (Thm.declaration_attribute add_distrib_rule)) "declaration of distributive rule for monadic bind" #> Attrib.setup @{binding monad_rule_internal} (Scan.succeed (Thm.declaration_attribute (K add_monad_rules_simp))) "dynamic declaration of monad rules as [simp]" #> Global_Theory.add_thms_dynamic (@{binding monad_rule}, get_monad_rules) #> Global_Theory.add_thms_dynamic (@{binding monad_distrib}, get_distrib_rules)); val _ = Outer_Syntax.command @{command_keyword print_monad_rules} "print monad rules" (Scan.succeed (Toplevel.keep (Pretty.writeln o pretty_monad_rules o Toplevel.context_of))); end; diff --git a/thys/Nominal2/nominal_dt_data.ML b/thys/Nominal2/nominal_dt_data.ML --- a/thys/Nominal2/nominal_dt_data.ML +++ b/thys/Nominal2/nominal_dt_data.ML @@ -1,149 +1,150 @@ (* Author: Christian Urban data about nominal datatypes *) signature NOMINAL_DT_DATA = sig (* info of raw binding functions *) type bn_info = term * int * (int * term option) list list (* binding modes and binding clauses *) datatype bmode = Lst | Res | Set datatype bclause = BC of bmode * (term option * int) list * int list type info = {inject : thm list, distinct : thm list, strong_inducts : thm list, strong_exhaust : thm list} val get_all_info: Proof.context -> (string * info) list val get_info: Proof.context -> string -> info option val the_info: Proof.context -> string -> info val register_info: (string * info) -> Context.generic -> Context.generic val mk_infos: string list -> thm list -> thm list -> thm list -> thm list -> (string * info) list datatype user_data = UserData of {dts : Old_Datatype.spec list, cn_names : string list, cn_tys : (string * string) list, bn_funs : (binding * typ * mixfix) list, bn_eqs : (Attrib.binding * term) list, bclauses : bclause list list list} datatype raw_dt_info = RawDtInfo of {raw_dt_names : string list, raw_fp_sugars : BNF_FP_Def_Sugar.fp_sugar list, raw_dts : Old_Datatype.spec list, raw_tys : typ list, raw_ty_args : (string * sort) list, raw_cns_info : cns_info list, raw_all_cns : term list list, raw_inject_thms : thm list, raw_distinct_thms : thm list, raw_induct_thm : thm, raw_induct_thms : thm list, raw_exhaust_thms : thm list, raw_size_trms : term list, raw_size_thms : thm list} datatype alpha_result = AlphaResult of {alpha_names : string list, alpha_trms : term list, alpha_tys : typ list, alpha_bn_names : string list, alpha_bn_trms : term list, alpha_bn_tys : typ list, alpha_intros : thm list, alpha_cases : thm list, alpha_raw_induct : thm} end structure Nominal_Dt_Data: NOMINAL_DT_DATA = struct (* term - is constant of the bn-function int - is datatype number over which the bn-function is defined int * term option - is number of the corresponding argument with possibly recursive call with bn-function term *) type bn_info = term * int * (int * term option) list list datatype bmode = Lst | Res | Set datatype bclause = BC of bmode * (term option * int) list * int list (* information generated by nominal_datatype *) type info = {inject : thm list, distinct : thm list, strong_inducts : thm list, strong_exhaust : thm list} structure NominalData = Generic_Data - (type T = info Symtab.table +( + type T = info Symtab.table val empty = Symtab.empty - val extend = I - val merge = Symtab.merge (K true)) + val merge = Symtab.merge (K true) +) val get_all_info = Symtab.dest o NominalData.get o Context.Proof val get_info = Symtab.lookup o NominalData.get o Context.Proof val register_info = NominalData.map o Symtab.update fun the_info thy name = (case get_info thy name of SOME info => info | NONE => error ("Unknown nominal datatype " ^ quote name)) fun mk_infos ty_names inject distinct strong_inducts strong_exhaust = let fun aux ty_name = (ty_name, {inject = inject, distinct = distinct, strong_inducts = strong_inducts, strong_exhaust = strong_exhaust }) in map aux ty_names end datatype user_data = UserData of {dts : Old_Datatype.spec list, cn_names : string list, cn_tys : (string * string) list, bn_funs : (binding * typ * mixfix) list, bn_eqs : (Attrib.binding * term) list, bclauses : bclause list list list} datatype raw_dt_info = RawDtInfo of {raw_dt_names : string list, raw_fp_sugars : BNF_FP_Def_Sugar.fp_sugar list, raw_dts : Old_Datatype.spec list, raw_tys : typ list, raw_ty_args : (string * sort) list, raw_cns_info : cns_info list, raw_all_cns : term list list, raw_inject_thms : thm list, raw_distinct_thms : thm list, raw_induct_thm : thm, raw_induct_thms : thm list, raw_exhaust_thms : thm list, raw_size_trms : term list, raw_size_thms : thm list} datatype alpha_result = AlphaResult of {alpha_names : string list, alpha_trms : term list, alpha_tys : typ list, alpha_bn_names : string list, alpha_bn_trms : term list, alpha_bn_tys : typ list, alpha_intros : thm list, alpha_cases : thm list, alpha_raw_induct : thm} end diff --git a/thys/Nominal2/nominal_function_common.ML b/thys/Nominal2/nominal_function_common.ML --- a/thys/Nominal2/nominal_function_common.ML +++ b/thys/Nominal2/nominal_function_common.ML @@ -1,163 +1,162 @@ (* Nominal Function Common Author: Christian Urban heavily based on the code of Alexander Krauss (code forked on 5 June 2011) Redefinition of config datatype *) signature NOMINAL_FUNCTION_DATA = sig type nominal_info = {is_partial : bool, defname : string, (* contains no logical entities: invariant under morphisms: *) add_simps : (binding -> binding) -> string -> (binding -> binding) -> Token.src list -> thm list -> local_theory -> thm list * local_theory, case_names : string list, fs : term list, R : term, psimps: thm list, pinducts: thm list, simps : thm list option, inducts : thm list option, termination: thm, eqvts: thm list} end structure Nominal_Function_Common = struct type nominal_info = {is_partial : bool, defname : string, (* contains no logical entities: invariant under morphisms: *) add_simps : (binding -> binding) -> string -> (binding -> binding) -> Token.src list -> thm list -> local_theory -> thm list * local_theory, case_names : string list, fs : term list, R : term, psimps: thm list, pinducts: thm list, simps : thm list option, inducts : thm list option, termination: thm, eqvts: thm list} fun morph_function_data ({add_simps, case_names, fs, R, psimps, pinducts, simps, inducts, termination, defname, is_partial, eqvts} : nominal_info) phi = let val term = Morphism.term phi val thm = Morphism.thm phi val fact = Morphism.fact phi val name = Binding.name_of o Morphism.binding phi o Binding.name in { add_simps = add_simps, case_names = case_names, fs = map term fs, R = term R, psimps = fact psimps, pinducts = fact pinducts, simps = Option.map fact simps, inducts = Option.map fact inducts, termination = thm termination, defname = name defname, is_partial=is_partial, eqvts = fact eqvts } end structure NominalFunctionData = Generic_Data ( type T = (term * nominal_info) Item_Net.T; val empty : T = Item_Net.init (op aconv o apply2 fst) (single o fst); - val extend = I; fun merge tabs : T = Item_Net.merge tabs; ) val get_function = NominalFunctionData.get o Context.Proof; fun lift_morphism ctxt f = let fun term t = Thm.term_of (Drule.cterm_rule f (Thm.cterm_of ctxt t)) in Morphism.morphism "lift_morphism" {binding = [], typ = [Logic.type_map term], term = [term], fact = [map f]} end fun import_function_data t ctxt = let val ct = Thm.cterm_of ctxt t val inst_morph = lift_morphism ctxt o Thm.instantiate fun match (trm, data) = SOME (morph_function_data data (inst_morph (Thm.match (Thm.cterm_of ctxt trm, ct)))) handle Pattern.MATCH => NONE in get_first match (Item_Net.retrieve (get_function ctxt) t) end fun import_last_function ctxt = case Item_Net.content (get_function ctxt) of [] => NONE | (t, data) :: _ => let val ([t'], ctxt') = Variable.import_terms true [t] ctxt in import_function_data t' ctxt' end val all_function_data = Item_Net.content o get_function fun add_function_data (data : nominal_info as {fs, termination, ...}) = NominalFunctionData.map (fold (fn f => Item_Net.update (f, data)) fs) #> Function_Common.store_termination_rule termination (* Configuration management *) datatype nominal_function_opt = Sequential | Default of string | DomIntros | No_Partials | Invariant of string datatype nominal_function_config = NominalFunctionConfig of {sequential: bool, default: string option, domintros: bool, partials: bool, inv: string option} fun apply_opt Sequential (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=true, default=default, domintros=domintros, partials=partials, inv=inv} | apply_opt (Default d) (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=sequential, default=SOME d, domintros=domintros, partials=partials, inv=inv} | apply_opt DomIntros (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=sequential, default=default, domintros=true, partials=partials, inv=inv} | apply_opt No_Partials (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=sequential, default=default, domintros=domintros, partials=false, inv=inv} | apply_opt (Invariant s) (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=sequential, default=default, domintros=domintros, partials=partials, inv = SOME s} val nominal_default_config = NominalFunctionConfig { sequential=false, default=NONE, domintros=false, partials=true, inv=NONE} datatype nominal_function_result = NominalFunctionResult of {fs: term list, G: term, R: term, psimps : thm list, simple_pinducts : thm list, cases : thm, termination : thm, domintros : thm list option, eqvts : thm list} end diff --git a/thys/Nominal2/nominal_thmdecls.ML b/thys/Nominal2/nominal_thmdecls.ML --- a/thys/Nominal2/nominal_thmdecls.ML +++ b/thys/Nominal2/nominal_thmdecls.ML @@ -1,328 +1,330 @@ (* Title: nominal_thmdecls.ML Author: Christian Urban Author: Tjark Weber Infrastructure for the lemma collections "eqvts", "eqvts_raw". Provides the attributes [eqvt] and [eqvt_raw], and the theorem lists "eqvts" and "eqvts_raw". The [eqvt] attribute expects a theorem of the form ?p \ (c ?x1 ?x2 ...) = c (?p \ ?x1) (?p \ ?x2) ... (1) or, if c is a relation with arity >= 1, of the form c ?x1 ?x2 ... ==> c (?p \ ?x1) (?p \ ?x2) ... (2) [eqvt] will store this theorem in the form (1) or, if c is a relation with arity >= 1, in the form c (?p \ ?x1) (?p \ ?x2) ... = c ?x1 ?x2 ... (3) in "eqvts". (The orientation of (3) was chosen because Isabelle's simplifier uses equations from left to right.) [eqvt] will also derive and store the theorem ?p \ c == c (4) in "eqvts_raw". (1)-(4) are all logically equivalent. We consider (1) and (2) to be more end-user friendly, i.e., slightly more natural to understand and prove, while (3) and (4) make the rewriting system for equivariance more predictable and less prone to looping in Isabelle. The [eqvt_raw] attribute expects a theorem of the form (4), and merely stores it in "eqvts_raw". [eqvt_raw] is provided because certain equivariance theorems would lead to looping when used for simplification in the form (1): notably, equivariance of permute (infix \), i.e., ?p \ (?q \ ?x) = (?p \ ?q) \ (?p \ ?x). To support binders such as All/Ex/Ball/Bex etc., which are typically applied to abstractions, argument terms ?xi (as well as permuted arguments ?p \ ?xi) in (1)-(3) need not be eta- contracted, i.e., they may be of the form "%z. ?xi z" or "%z. (?p \ ?x) z", respectively. For convenience, argument terms ?xi (as well as permuted arguments ?p \ ?xi) in (1)-(3) may actually be tuples, e.g., "(?xi, ?xj)" or "(?p \ ?xi, ?p \ ?xj)", respectively. In (1)-(4), "c" is either a (global) constant or a locally fixed parameter, e.g., of a locale or type class. *) signature NOMINAL_THMDECLS = sig val eqvt_add: attribute val eqvt_del: attribute val eqvt_raw_add: attribute val eqvt_raw_del: attribute val get_eqvts_thms: Proof.context -> thm list val get_eqvts_raw_thms: Proof.context -> thm list val eqvt_transform: Proof.context -> thm -> thm val is_eqvt: Proof.context -> term -> bool end; structure Nominal_ThmDecls: NOMINAL_THMDECLS = struct structure EqvtData = Generic_Data -( type T = thm Item_Net.T; +( + type T = thm Item_Net.T; val empty = Thm.item_net; - val extend = I; - val merge = Item_Net.merge); + val merge = Item_Net.merge +); (* EqvtRawData is implemented with a Termtab (rather than an Item_Net) so that we can efficiently decide whether a given constant has a corresponding equivariance theorem stored, cf. the function is_eqvt. *) structure EqvtRawData = Generic_Data -( type T = thm Termtab.table; +( + type T = thm Termtab.table; val empty = Termtab.empty; - val extend = I; - val merge = Termtab.merge (K true)); + val merge = Termtab.merge (K true) +); val eqvts = Item_Net.content o EqvtData.get val eqvts_raw = map snd o Termtab.dest o EqvtRawData.get val _ = Theory.setup (Global_Theory.add_thms_dynamic (@{binding "eqvts"}, eqvts) #> Global_Theory.add_thms_dynamic (@{binding "eqvts_raw"}, eqvts_raw)) val get_eqvts_thms = eqvts o Context.Proof val get_eqvts_raw_thms = eqvts_raw o Context.Proof (** raw equivariance lemmas **) (* Returns true iff an equivariance lemma exists in "eqvts_raw" for a given term. *) val is_eqvt = Termtab.defined o EqvtRawData.get o Context.Proof (* Returns c if thm is of the form (4), raises an error otherwise. *) fun key_of_raw_thm context thm = let fun error_msg () = error ("Theorem must be of the form \"?p \ c \ c\", with c a constant or fixed parameter:\n" ^ Syntax.string_of_term (Context.proof_of context) (Thm.prop_of thm)) in case Thm.prop_of thm of \<^Const_>\Pure.eq _ for \<^Const_>\permute _ for p c\ c'\ => if is_Var p andalso is_fixed (Context.proof_of context) c andalso c aconv c' then c else error_msg () | _ => error_msg () end fun add_raw_thm thm context = let val c = key_of_raw_thm context thm in if Termtab.defined (EqvtRawData.get context) c then warning ("Replacing existing raw equivariance theorem for \"" ^ Syntax.string_of_term (Context.proof_of context) c ^ "\".") else (); EqvtRawData.map (Termtab.update (c, thm)) context end fun del_raw_thm thm context = let val c = key_of_raw_thm context thm in if Termtab.defined (EqvtRawData.get context) c then EqvtRawData.map (Termtab.delete c) context else ( warning ("Cannot delete non-existing raw equivariance theorem for \"" ^ Syntax.string_of_term (Context.proof_of context) c ^ "\"."); context ) end (** adding/deleting lemmas to/from "eqvts" **) fun add_thm thm context = ( if Item_Net.member (EqvtData.get context) thm then warning ("Theorem already declared as equivariant:\n" ^ Syntax.string_of_term (Context.proof_of context) (Thm.prop_of thm)) else (); EqvtData.map (Item_Net.update thm) context ) fun del_thm thm context = ( if Item_Net.member (EqvtData.get context) thm then EqvtData.map (Item_Net.remove thm) context else ( warning ("Cannot delete non-existing equivariance theorem:\n" ^ Syntax.string_of_term (Context.proof_of context) (Thm.prop_of thm)); context ) ) (** transformation of equivariance lemmas **) (* Transforms a theorem of the form (1) into the form (4). *) local fun tac ctxt thm = let val ss_thms = @{thms "permute_minus_cancel" "permute_prod.simps" "split_paired_all"} in REPEAT o FIRST' [CHANGED o simp_tac (put_simpset HOL_basic_ss ctxt addsimps ss_thms), resolve_tac ctxt [thm RS @{thm trans}], resolve_tac ctxt @{thms trans[OF "permute_fun_def"]} THEN' resolve_tac ctxt @{thms ext}] end in fun thm_4_of_1 ctxt thm = let val (p, c) = thm |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst |> dest_perm ||> fst o (fixed_nonfixed_args ctxt) val goal = HOLogic.mk_Trueprop (HOLogic.mk_eq (mk_perm p c, c)) val ([goal', p'], ctxt') = Variable.import_terms false [goal, p] ctxt in Goal.prove ctxt [] [] goal' (fn {context = goal_ctxt, ...} => tac goal_ctxt thm 1) |> singleton (Proof_Context.export ctxt' ctxt) |> (fn th => th RS @{thm "eq_reflection"}) |> zero_var_indexes end handle TERM _ => raise THM ("thm_4_of_1", 0, [thm]) end (* local *) (* Transforms a theorem of the form (2) into the form (1). *) local fun tac ctxt thm thm' = let val ss_thms = @{thms "permute_minus_cancel"(2)} in EVERY' [resolve_tac ctxt @{thms iffI}, dresolve_tac ctxt @{thms permute_boolE}, resolve_tac ctxt [thm], assume_tac ctxt, resolve_tac ctxt @{thms permute_boolI}, dresolve_tac ctxt [thm'], full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps ss_thms)] end in fun thm_1_of_2 ctxt thm = let val (prem, concl) = thm |> Thm.prop_of |> Logic.dest_implies |> apply2 HOLogic.dest_Trueprop (* since argument terms "?p \ ?x1" may actually be eta-expanded or tuples, we need the following function to find ?p *) fun find_perm \<^Const_>\permute _ for \p as Var _\ _\ = p | find_perm \<^Const_>\Pair _ _ for x _\ = find_perm x | find_perm (Abs (_, _, body)) = find_perm body | find_perm _ = raise THM ("thm_3_of_2", 0, [thm]) val p = concl |> dest_comb |> snd |> find_perm val goal = HOLogic.mk_Trueprop (HOLogic.mk_eq (mk_perm p prem, concl)) val ([goal', p'], ctxt') = Variable.import_terms false [goal, p] ctxt val thm' = infer_instantiate ctxt' [(#1 (dest_Var p), Thm.cterm_of ctxt' (mk_minus p'))] thm in Goal.prove ctxt' [] [] goal' (fn {context = goal_ctxt, ...} => tac goal_ctxt thm thm' 1) |> singleton (Proof_Context.export ctxt' ctxt) end handle TERM _ => raise THM ("thm_1_of_2", 0, [thm]) end (* local *) (* Transforms a theorem of the form (1) into the form (3). *) fun thm_3_of_1 _ thm = (thm RS (@{thm "permute_bool_def"} RS @{thm "sym"} RS @{thm "trans"}) RS @{thm "sym"}) |> zero_var_indexes local val msg = cat_lines ["Equivariance theorem must be of the form", " ?p \ (c ?x1 ?x2 ...) = c (?p \ ?x1) (?p \ ?x2) ...", "or, if c is a relation with arity >= 1, of the form", " c ?x1 ?x2 ... ==> c (?p \ ?x1) (?p \ ?x2) ..."] in (* Transforms a theorem of the form (1) or (2) into the form (4). *) fun eqvt_transform ctxt thm = (case Thm.prop_of thm of \<^Const_>\Trueprop for _\ => thm_4_of_1 ctxt thm | \<^Const_>\Pure.imp for _ _\ => thm_4_of_1 ctxt (thm_1_of_2 ctxt thm) | _ => error msg) handle THM _ => error msg (* Transforms a theorem of the form (1) into theorems of the form (1) (or, if c is a relation with arity >= 1, of the form (3)) and (4); transforms a theorem of the form (2) into theorems of the form (3) and (4). *) fun eqvt_and_raw_transform ctxt thm = (case Thm.prop_of thm of \<^Const_>\Trueprop for \<^Const_>\HOL.eq _ for _ c_args\\ => let val th' = if fastype_of c_args = @{typ "bool"} andalso (not o null) (snd (fixed_nonfixed_args ctxt c_args)) then thm_3_of_1 ctxt thm else thm in (th', thm_4_of_1 ctxt thm) end | \<^Const_>\Pure.imp for _ _\ => let val th1 = thm_1_of_2 ctxt thm in (thm_3_of_1 ctxt th1, thm_4_of_1 ctxt th1) end | _ => error msg) handle THM _ => error msg end (* local *) (** attributes **) val eqvt_raw_add = Thm.declaration_attribute add_raw_thm val eqvt_raw_del = Thm.declaration_attribute del_raw_thm fun eqvt_add_or_del eqvt_fn raw_fn = Thm.declaration_attribute (fn thm => fn context => let val (eqvt, raw) = eqvt_and_raw_transform (Context.proof_of context) thm in context |> eqvt_fn eqvt |> raw_fn raw end) val eqvt_add = eqvt_add_or_del add_thm add_raw_thm val eqvt_del = eqvt_add_or_del del_thm del_raw_thm val _ = Theory.setup (Attrib.setup @{binding "eqvt"} (Attrib.add_del eqvt_add eqvt_del) "Declaration of equivariance lemmas - they will automatically be brought into the form ?p \ c \ c" #> Attrib.setup @{binding "eqvt_raw"} (Attrib.add_del eqvt_raw_add eqvt_raw_del) "Declaration of raw equivariance lemmas - no transformation is performed") end; diff --git a/thys/Partial_Function_MR/partial_function_mr.ML b/thys/Partial_Function_MR/partial_function_mr.ML --- a/thys/Partial_Function_MR/partial_function_mr.ML +++ b/thys/Partial_Function_MR/partial_function_mr.ML @@ -1,339 +1,338 @@ (* Author: Rene Thiemann, License: LGPL *) signature PARTIAL_FUNCTION_MR = sig val init: string -> (* make monad_map: monad term * funs * monad as typ * monad bs typ * a->b typs -> map_monad funs monad term *) (term * term list * typ * typ * typ list -> term) -> (* make monad type: fixed and flexible types *) (typ list * typ list -> typ) -> (* destruct monad type: fixed and flexible types *) (typ -> typ list * typ list) -> (* monad_map_compose thm: mapM f (mapM g x) = mapM (f o g) x *) thm list -> (* monad_map_ident thm: mapM (% y. y) x = x *) thm list -> declaration val add_partial_function_mr: string -> (binding * typ option * mixfix) list -> Specification.multi_specs -> local_theory -> thm list * local_theory val add_partial_function_mr_cmd: string -> (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> local_theory -> thm list * local_theory end; structure Partial_Function_MR: PARTIAL_FUNCTION_MR = struct val partial_function_mr_trace = Attrib.setup_config_bool @{binding partial_function_mr_trace} (K false); fun trace ctxt msg = if Config.get ctxt partial_function_mr_trace then tracing msg else () datatype setup_data = Setup_Data of {mk_monad_map: term * term list * typ * typ * typ list -> term, mk_monadT: typ list * typ list -> typ, dest_monadT: typ -> typ list * typ list, monad_map_comp: thm list, monad_map_id: thm list}; (* the following code has been copied from partial_function.ML *) structure Modes = Generic_Data ( type T = setup_data Symtab.table; val empty = Symtab.empty; - val extend = I; fun merge data = Symtab.merge (K true) data; ) val known_modes = Symtab.keys o Modes.get o Context.Proof; val lookup_mode = Symtab.lookup o Modes.get o Context.Proof; fun curry_const (A, B, C) = Const (@{const_name Product_Type.curry}, [HOLogic.mk_prodT (A, B) --> C, A, B] ---> C); fun mk_curry f = case fastype_of f of Type ("fun", [Type (_, [S, T]), U]) => curry_const (S, T, U) $ f | T => raise TYPE ("mk_curry", [T], [f]); fun curry_n arity = funpow (arity - 1) mk_curry; fun uncurry_n arity = funpow (arity - 1) HOLogic.mk_case_prod; (* end copy of partial_function.ML *) fun init mode mk_monad_map mk_monadT dest_monadT monad_map_comp monad_map_id phi = let val thm = Morphism.thm phi; (* TODO: are there morphisms required on mk_monad_map???, ... *) val data' = Setup_Data {mk_monad_map=mk_monad_map, mk_monadT=mk_monadT, dest_monadT=dest_monadT, monad_map_comp=map thm monad_map_comp,monad_map_id=map thm monad_map_id}; in Modes.map (Symtab.update (mode, data')) end fun mk_sumT (T1,T2) = Type (@{type_name sum}, [T1,T2]) fun mk_choiceT [ty] = ty | mk_choiceT (ty :: more) = mk_sumT (ty,mk_choiceT more) | mk_choiceT _ = error "mk_choiceT []" fun mk_choice_resT mk_monadT dest_monadT mTs = let val (commonTs,argTs) = map dest_monadT mTs |> split_list |> apfst hd; val n = length (hd argTs); val new = map (fn i => mk_choiceT (map (fn xs => nth xs i) argTs)) (0 upto (n - 1)) in mk_monadT (commonTs,new) end; fun mk_inj [_] t _ = t | mk_inj (ty :: more) t n = let val moreT = mk_choiceT more; val allT = mk_sumT (ty,moreT) in if n = 0 then Const (@{const_name Inl}, ty --> allT) $ t else Const (@{const_name Inr}, moreT --> allT) $ mk_inj more t (n-1) end | mk_inj _ _ _ = error "mk_inj [] _ _" fun mk_proj [_] t _ = t | mk_proj (ty :: more) t n = let val moreT = mk_choiceT more; val allT = mk_sumT (ty,moreT) in if n = 0 then Const (@{const_name Sum_Type.projl}, allT --> ty) $ t else mk_proj more (Const (@{const_name Sum_Type.projr}, allT --> moreT) $ t) (n-1) end | mk_proj _ _ _ = error "mk_proj [] _ _" fun get_head ctxt (_,(_,eqn)) = let val ((_, plain_eqn), _) = Variable.focus NONE eqn ctxt; val lhs = HOLogic.dest_eq (HOLogic.dest_Trueprop plain_eqn) |> #1; val head = strip_comb lhs |> #1; in head end; fun get_infos lthy heads (fix,(_,eqn)) = let val ((_, plain_eqn), _) = Variable.focus NONE eqn lthy; val ((f_binding, fT), mixfix) = fix; val fname = Binding.name_of f_binding; val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop plain_eqn); val (_, args) = strip_comb lhs; val F = fold_rev lambda (heads @ args) rhs; val arity = length args; val (aTs, bTs) = chop arity (binder_types fT); val tupleT = foldl1 HOLogic.mk_prodT aTs; val fT_uc = tupleT :: bTs ---> body_type fT; val (inT,resT) = dest_funT fT_uc; val f_uc = Free (fname, fT_uc); val f_cuc = curry_n arity f_uc in (fname, f_cuc, f_uc, inT, resT, ((f_binding,mixfix),fT), F, arity, args) end; fun fresh_var ctxt name = Name.variant name (Variable.names_of ctxt) |> #1 (* partial_function_mr definition *) fun gen_add_partial_function_mr prep mode fixes_raw eqns_raw lthy = let val setup_data = the (lookup_mode lthy mode) handle Option.Option => error (cat_lines ["Unknown mode " ^ quote mode ^ ".", "Known modes are " ^ commas_quote (known_modes lthy) ^ "."]); val Setup_Data {mk_monad_map, mk_monadT, dest_monadT, monad_map_comp, monad_map_id} = setup_data; val _ = if length eqns_raw < 2 then error "require at least two function definitions" else (); val ((fixes, eq_abinding_eqns), _) = prep fixes_raw eqns_raw lthy; val _ = if length eqns_raw = length fixes then () else error "# of eqns does not match # of constants"; val fix_eq_abinding_eqns = fixes ~~ eq_abinding_eqns; val heads = map (get_head lthy) fix_eq_abinding_eqns; val fnames = map (Binding.name_of o #1 o #1) fixes val fnames' = map (#1 o Term.dest_Free) heads val f_f = fnames ~~ fnames' val _ = case find_first (fn (f,g) => not (f = g)) f_f of NONE => () | SOME _ => error ("list of function symbols does not match list of equations:\n" ^ @{make_string} fnames ^ "\nvs\n" ^ @{make_string} fnames') val all = map (get_infos lthy heads) fix_eq_abinding_eqns val f_cucs = map #2 all val f_ucs = map #3 all val inTs = map #4 all val resTs = map #5 all val bindings_types = map #6 all val Fs = map #7 all val arities = map #8 all val all_args = map #9 all val glob_inT = mk_choiceT inTs val glob_resT = mk_choice_resT mk_monadT dest_monadT resTs val inj = mk_inj inTs val glob_fname = fresh_var lthy (foldl1 (fn (a,b) => a ^ "_" ^ b) (fnames @ [serial_string ()])) val glob_constT = glob_inT --> glob_resT; val glob_const = Free (glob_fname, glob_constT) val nums = 0 upto (length all - 1) fun mk_res_inj_proj n = let val resT = nth resTs n val glob_Targs = dest_monadT glob_resT |> #2 val res_Targs = dest_monadT resT |> #2 val m = length res_Targs fun inj_proj m = let val resTs_m = map (fn resT => nth (dest_monadT resT |> #2) m) resTs val resT_arg = nth resTs_m n val globT_arg = nth glob_Targs m val x = Free ("x",resT_arg) val y = Free ("x",globT_arg) val inj = lambda x (mk_inj resTs_m x n) val proj = lambda y (mk_proj resTs_m y n) in ((inj, resT_arg --> globT_arg), (proj, globT_arg --> resT_arg)) end; val (inj,proj) = map inj_proj (0 upto (m - 1)) |> split_list val (t_to_ss_inj,t_to_sTs_inj) = split_list inj; val (t_to_ss_proj,t_to_sTs_proj) = split_list proj; in (fn mt => mk_monad_map (mt, t_to_ss_inj, resT, glob_resT, t_to_sTs_inj), fn mt => mk_monad_map (mt, t_to_ss_proj, glob_resT, resT, t_to_sTs_proj)) end; val (res_inj, res_proj) = map mk_res_inj_proj nums |> split_list fun mk_global_fun n = let val fname = nth fnames n val inT = nth inTs n val xs = Free (fresh_var lthy ("x_" ^ fname), inT) val inj_xs = inj xs n val glob_inj_xs = glob_const $ inj_xs val glob_inj_xs_map = nth res_proj n glob_inj_xs val res = lambda xs glob_inj_xs_map in (xs,res) end val (xss,global_funs) = map mk_global_fun nums |> split_list fun mk_cases n = let val xs = nth xss n val F = nth Fs n; val arity = nth arities n; val F_uc = fold_rev lambda f_ucs (uncurry_n arity (list_comb (F, f_cucs))); val F_uc_inst = Term.betapplys (F_uc,global_funs) val res = lambda xs (nth res_inj n (F_uc_inst $ xs)) in res end; val all_cases = map mk_cases nums; fun combine_cases [cs] [_] = cs | combine_cases (cs :: more) (inT :: moreTy) = let val moreT = mk_choiceT moreTy val sumT = mk_sumT (inT, moreT) val case_const = Const (@{const_name case_sum}, (inT --> glob_resT) --> (moreT --> glob_resT) --> sumT --> glob_resT) in case_const $ cs $ combine_cases more moreTy end | combine_cases _ _ = error "combine_cases with incompatible argument lists"; val glob_x_name = fresh_var lthy ("x_" ^ glob_fname) val glob_x = Free (glob_x_name,glob_inT) val rhs = combine_cases all_cases inTs $ glob_x; val lhs = glob_const $ glob_x val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs)) val glob_binding = Binding.name (glob_fname) |> Binding.concealed val glob_attrib_binding = Binding.empty_atts val _ = trace lthy "invoking partial_function on global function" val priv_lthy = lthy |> Proof_Context.private_scope (Binding.new_scope()) val ((glob_const, glob_simp_thm),priv_lthy') = priv_lthy |> Partial_Function.add_partial_function mode [(glob_binding,SOME glob_constT,NoSyn)] (glob_attrib_binding,eq) val glob_lthy = priv_lthy' |> Proof_Context.restore_naming lthy val _ = trace lthy "deriving simp rules for separate functions from global function" fun define_f n (fs, fdefs,rhss,lthy) = let val ((fbinding,mixfix),_) = nth bindings_types n val fname = nth fnames n val inT = nth inTs n; val arity = nth arities n; val x = Free (fresh_var lthy ("x_" ^ fname), inT) val inj_argsProd = inj x n val call = glob_const $ inj_argsProd val post = nth res_proj n call val rhs = curry_n arity (lambda x post) val ((f, (_, f_def)),lthy') = Local_Theory.define_internal ((fbinding,mixfix), (Binding.empty_atts, rhs)) lthy in (f :: fs, f_def :: fdefs,rhs :: rhss,lthy') end val (fs,fdefs,f_rhss,local_lthy) = fold_rev define_f nums ([],[],[],glob_lthy) val glob_simp_thm' = let fun mk_case_new n = let val F = nth Fs n val arity = nth arities n val Finst = uncurry_n arity (Term.betapplys (F,fs)) val xs = nth xss n val res = lambda xs (nth res_inj n (Finst $ xs)) in res end; val new_cases = map mk_case_new nums; val rhs = combine_cases new_cases inTs $ glob_x; val lhs = glob_const $ glob_x val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs)) in Goal.prove local_lthy [glob_x_name] [] eq (fn {prems = _, context = ctxt} => Thm.instantiate' [] [SOME (Thm.cterm_of ctxt glob_x)] glob_simp_thm |> (fn simp_thm => unfold_tac ctxt [simp_thm] THEN unfold_tac ctxt fdefs)) end fun mk_simp_thm n = let val args = nth all_args n val arg_names = map (dest_Free #> fst) args val f = nth fs n val F = nth Fs n val fdef = nth fdefs n val lhs = list_comb (f,args); val mhs = Term.betapplys (nth f_rhss n, args) val rhs = list_comb (list_comb (F,fs), args); val eq1 = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,mhs)) val eq2 = HOLogic.mk_Trueprop (HOLogic.mk_eq (mhs,rhs)) val simp_thm1 = Goal.prove local_lthy arg_names [] eq1 (fn {prems = _, context = ctxt} => unfold_tac ctxt [fdef]) val simp_thm2 = Goal.prove local_lthy arg_names [] eq2 (fn {prems = _, context = ctxt} => unfold_tac ctxt [glob_simp_thm'] THEN unfold_tac ctxt @{thms sum.simps curry_def split} THEN unfold_tac ctxt (@{thm o_def} :: monad_map_comp) THEN unfold_tac ctxt (monad_map_id @ @{thms sum.sel})) in @{thm trans} OF [simp_thm1,simp_thm2] end val simp_thms = map mk_simp_thm nums fun register n lthy = let val simp_thm = nth simp_thms n val eq_abinding = nth eq_abinding_eqns n |> fst val fname = nth fnames n val f = nth fs n in lthy |> Local_Theory.note (eq_abinding, [simp_thm]) |-> (fn (_, simps) => Spec_Rules.add Binding.empty Spec_Rules.equational_recdef [f] simps #> Local_Theory.note ((Binding.qualify true fname (Binding.name "simps"), @{attributes [code]}), simps) #>> snd #>> hd) end in fold (fn i => fn (simps, lthy) => case register i lthy of (simp, lthy') => (simps @ [simp], lthy')) nums ([], local_lthy) end; val add_partial_function_mr = gen_add_partial_function_mr Specification.check_multi_specs; val add_partial_function_mr_cmd = gen_add_partial_function_mr Specification.read_multi_specs; val mode = @{keyword "("} |-- Parse.name --| @{keyword ")"}; val _ = Outer_Syntax.local_theory @{command_keyword partial_function_mr} "define mutually recursive partial functions" (mode -- Parse_Spec.specification >> (fn (mode, (fixes, specs)) => add_partial_function_mr_cmd mode fixes specs #> #2)); end diff --git a/thys/Planarity_Certificates/l4v/lib/wp/WP-method.ML b/thys/Planarity_Certificates/l4v/lib/wp/WP-method.ML --- a/thys/Planarity_Certificates/l4v/lib/wp/WP-method.ML +++ b/thys/Planarity_Certificates/l4v/lib/wp/WP-method.ML @@ -1,355 +1,353 @@ (* * Copyright 2014, NICTA * * This software may be distributed and modified according to the terms of * the BSD 2-Clause license. Note that NO WARRANTY is provided. * See "LICENSE_BSD2.txt" for details. * * @TAG(NICTA_BSD) *) signature WP = sig type wp_rules = {trips: thm list * (theory -> term -> term), rules: (int * thm) Net.net * int * (int * thm) list, splits: thm list, combs: thm list, unsafe_rules: thm list}; val debug_get: Proof.context -> wp_rules; val derived_rule: thm -> thm -> thm list; val get_combined_rules': thm list -> thm -> thm list; val get_combined_rules: thm list -> thm list -> thm list; val get_rules: Proof.context -> thm list -> wp_rules; val apply_rules_tac_n: bool -> Proof.context -> thm list -> thm list Unsynchronized.ref -> int -> tactic; val apply_rules_tac: bool -> Proof.context -> thm list -> thm list Unsynchronized.ref -> tactic; val apply_rules_args: bool -> (Proof.context -> Method.method) context_parser; val apply_once_tac: bool -> Proof.context -> thm list -> thm list Unsynchronized.ref -> tactic; val apply_once_args: bool -> (Proof.context -> Method.method) context_parser; val setup: theory -> theory; val warn_unused: bool Config.T val wp_add: Thm.attribute; val wp_del: Thm.attribute; val splits_add: Thm.attribute; val splits_del: Thm.attribute; val combs_add: Thm.attribute; val combs_del: Thm.attribute; val wp_unsafe_add: Thm.attribute; val wp_unsafe_del: Thm.attribute; end; structure WeakestPre = struct type wp_rules = {trips: thm list * (theory -> term -> term), rules: (int * thm) Net.net * int * (int * thm) list, splits: thm list, combs: thm list, unsafe_rules: thm list}; fun accum_last_occurence' [] _ = ([], Termtab.empty) | accum_last_occurence' ((t, v) :: ts) tt1 = let val tm = Thm.prop_of t; val tt2 = Termtab.insert_list (K false) (tm, v) tt1; val (ts', tt3) = accum_last_occurence' ts tt2; in case Termtab.lookup tt3 tm of NONE => ((t, Termtab.lookup_list tt2 tm) :: ts', Termtab.update (tm, ()) tt3) | SOME _ => (ts', tt3) end; fun accum_last_occurence ts = fst (accum_last_occurence' ts Termtab.empty); fun flat_last_occurence ts = map fst (accum_last_occurence (map (fn v => (v, ())) ts)); fun dest_rules (trips, _, others) = rev (order_list (Net.entries trips @ others)); fun get_key trip_conv t = let val t' = Thm.concl_of t |> trip_conv (Thm.theory_of_thm t) |> Envir.beta_eta_contract; in case t' of \<^Const_>\Trueprop for \\<^Const_>\triple_judgement _ _ for _ f _\\\ => SOME f | _ => NONE end; fun add_rule_inner trip_conv t (trips, n, others) = ( case get_key trip_conv t of SOME k => (Net.insert_term (K false) (k, (n, t)) trips, n + 1, others) | _ => (trips, n + 1, (n, t) :: others) ); fun del_rule_inner trip_conv t (trips, n, others) = case get_key trip_conv t of SOME k => (Net.delete_term_safe (Thm.eq_thm_prop o apply2 snd) (k, (n, t)) trips, n, others) | _ => (trips, n, remove (Thm.eq_thm_prop o apply2 snd) (n, t) others) val no_rules = (Net.empty, 0, []); fun mk_rules trip_conv rules = fold_rev (add_rule_inner trip_conv) rules no_rules; fun mk_trip_conv trips thy = Pattern.rewrite_term thy (map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) trips) [] fun rules_merge (wp_rules, wp_rules') = let val trips = Thm.merge_thms (fst (#trips wp_rules), fst (#trips wp_rules')); val trip_conv = mk_trip_conv trips val rules = flat_last_occurence (dest_rules (#rules wp_rules) @ dest_rules (#rules wp_rules')); in {trips = (trips, trip_conv), rules = mk_rules trip_conv rules, splits = Thm.merge_thms (#splits wp_rules, #splits wp_rules'), combs = Thm.merge_thms (#combs wp_rules, #combs wp_rules'), unsafe_rules = Thm.merge_thms (#unsafe_rules wp_rules, #unsafe_rules wp_rules')} end structure WPData = Generic_Data -(struct - type T = wp_rules; - val empty = {trips = ([], K I), rules = no_rules, - splits = [], combs = [], unsafe_rules = []}; - val extend = I; - - val merge = rules_merge; -end); +( + type T = wp_rules; + val empty = {trips = ([], K I), rules = no_rules, + splits = [], combs = [], unsafe_rules = []}; + val merge = rules_merge; +); fun derived_rule rule combinator = [rule RSN (1, combinator)] handle THM _ => []; fun get_combined_rules' combs' rule = rule :: (List.concat (map (derived_rule rule) combs')); fun get_combined_rules rules' combs' = List.concat (map (get_combined_rules' combs') rules'); fun add_rule rule rs = {trips = #trips rs, rules = add_rule_inner (snd (#trips rs)) rule (#rules rs), splits = #splits rs, combs = #combs rs, unsafe_rules = #unsafe_rules rs}; fun del_rule rule rs = {trips = #trips rs, rules = del_rule_inner (snd (#trips rs)) rule (#rules rs), splits = #splits rs, combs = #combs rs, unsafe_rules = #unsafe_rules rs}; fun add_trip rule (rs : wp_rules) = let val trips = Thm.add_thm rule (fst (#trips rs)); val trip_conv = mk_trip_conv trips in {trips = (trips, trip_conv), rules = mk_rules trip_conv (dest_rules (#rules rs)), splits = #splits rs, combs = #combs rs, unsafe_rules = #unsafe_rules rs} end; fun del_trip rule (rs : wp_rules) = let val trips = Thm.del_thm rule (fst (#trips rs)); val trip_conv = mk_trip_conv trips in {trips = (trips, trip_conv), rules = mk_rules trip_conv (dest_rules (#rules rs)), splits = #splits rs, combs = #combs rs, unsafe_rules = #unsafe_rules rs} end; fun add_split rule (rs : wp_rules) = {trips = #trips rs, rules = #rules rs, splits = Thm.add_thm rule (#splits rs), combs = #combs rs, unsafe_rules = #unsafe_rules rs}; fun add_comb rule (rs : wp_rules) = {trips = #trips rs, rules = #rules rs, splits = #splits rs, combs = Thm.add_thm rule (#combs rs), unsafe_rules = #unsafe_rules rs}; fun del_split rule rs = {trips = #trips rs, rules = #rules rs, splits = Thm.del_thm rule (#splits rs), combs = #combs rs, unsafe_rules = #unsafe_rules rs}; fun del_comb rule rs = {trips = #trips rs, rules = #rules rs, splits = #splits rs, combs = Thm.del_thm rule (#combs rs), unsafe_rules = #unsafe_rules rs}; fun add_unsafe_rule rule rs = {trips = #trips rs, rules = #rules rs, splits = #splits rs, combs = #combs rs, unsafe_rules = Thm.add_thm rule (#unsafe_rules rs)}; fun del_unsafe_rule rule rs = {trips = #trips rs, rules = #rules rs, splits = #splits rs, combs = #combs rs, unsafe_rules = Thm.del_thm rule (#unsafe_rules rs)}; fun gen_att m = Thm.declaration_attribute (fn thm => fn context => WPData.map (m thm) context); val wp_add = gen_att add_rule; val wp_del = gen_att del_rule; val trip_add = gen_att add_trip; val trip_del = gen_att del_trip; val splits_add = gen_att add_split; val splits_del = gen_att del_split; val combs_add = gen_att add_comb; val combs_del = gen_att del_comb; val wp_unsafe_add = gen_att add_unsafe_rule; val wp_unsafe_del = gen_att del_unsafe_rule; val setup = Attrib.setup @{binding "wp"} (Attrib.add_del wp_add wp_del) "monadic weakest precondition rules" #> Attrib.setup @{binding "wp_trip"} (Attrib.add_del trip_add trip_del) "monadic triple conversion rules" #> Attrib.setup @{binding "wp_split"} (Attrib.add_del splits_add splits_del) "monadic split rules" #> Attrib.setup @{binding "wp_comb"} (Attrib.add_del combs_add combs_del) "monadic combination rules" #> Attrib.setup @{binding "wp_unsafe"} (Attrib.add_del wp_unsafe_add wp_unsafe_del) "unsafe monadic weakest precondition rules" fun debug_get ctxt = WPData.get (Context.Proof ctxt); fun get_rules ctxt extras = fold_rev add_rule extras (debug_get ctxt); fun append_used_rule rule used_rules = used_rules := !used_rules @ [rule] fun add_extra_rule rule extra_rules = extra_rules := !extra_rules @ [rule] fun resolve_ruleset_tac ctxt rs used_rules_ref n t = let fun append_rule rule thm = Seq.map (fn thm => (append_used_rule rule used_rules_ref; thm)) thm; fun rtac th = resolve_tac ctxt [th] in case Thm.cprem_of t n |> Thm.term_of |> snd (#trips rs) (Thm.theory_of_thm t) |> Envir.beta_eta_contract |> Logic.strip_assums_concl handle THM _ => \<^Const>\True\ of \<^Const_>\Trueprop for \<^Const_>\triple_judgement _ _ for _ f _\\ => let val ts = Net.unify_term (#1 (#rules rs)) f |> order_list |> rev; val combapps = Seq.maps (fn combapp => Seq.map (fn combapp' => (combapp, combapp')) (rtac combapp n t)) (Seq.of_list (#combs rs)) |> Seq.list_of |> Seq.of_list; fun per_rule_tac t = (fn thm => append_rule t (rtac t n thm)) ORELSE (fn _ => Seq.maps (fn combapp => append_rule t (append_rule (#1 combapp) (rtac t n (#2 combapp)))) combapps); in FIRST (map per_rule_tac ts) ORELSE FIRST (map (fn split => fn thm => append_rule split (rtac split n thm)) (#splits rs)) end t | _ => FIRST (map (fn rule => fn thm => append_rule rule (rtac rule n thm)) (map snd (#3 (#rules rs)) @ #splits rs)) t end; fun pretty_rule ctxt rule = Pretty.big_list (Thm.get_name_hint rule) [Thm.pretty_thm ctxt rule] |> Pretty.string_of; fun trace_used_thms false _ _ = Seq.empty | trace_used_thms true used_rules ctxt = let val used_thms = !used_rules in map (fn rule => tracing (pretty_rule ctxt rule)) used_thms |> Seq.of_list end; val warn_unused = Attrib.setup_config_bool @{binding wp_warn_unused} (K false); fun warn_unused_thms ctxt thms extra_rules used_rules = if Config.get ctxt warn_unused then let val used_thms = map (fn rule => Thm.get_name_hint rule) (!used_rules) val unused_thms = map Thm.get_name_hint (!extra_rules @ thms) |> subtract (op =) used_thms in if not (null unused_thms) then "Unused theorems: " ^ commas_quote unused_thms |> warning else () end else () fun warn_unsafe_thms unsafe_thms n ctxt t = let val used_rules = Unsynchronized.ref [] : thm list Unsynchronized.ref; val useful_unsafe_thms = filter (fn rule => (is_some o SINGLE ( resolve_ruleset_tac ctxt (get_rules ctxt [rule]) used_rules n)) t) unsafe_thms val unsafe_thm_names = map (fn rule => Thm.get_name_hint rule) useful_unsafe_thms in if not (null unsafe_thm_names) then "Unsafe theorems that could be used: " ^ commas_quote unsafe_thm_names |> warning else () end; fun apply_rules_tac_n trace ctxt extras extras_ref n = let val rules = get_rules ctxt extras; val used_rules = Unsynchronized.ref [] : thm list Unsynchronized.ref in (fn t => Seq.map (fn thm => (warn_unused_thms ctxt extras extras_ref used_rules; trace_used_thms trace used_rules ctxt; thm)) (CHANGED (REPEAT_DETERM (resolve_ruleset_tac ctxt rules used_rules n)) t)) THEN_ELSE (fn t => (warn_unsafe_thms (#unsafe_rules rules) n ctxt t; all_tac t), fn t => (warn_unsafe_thms (#unsafe_rules rules) n ctxt t; no_tac t)) end; fun apply_rules_tac trace ctxt extras extras_ref = apply_rules_tac_n trace ctxt extras extras_ref 1; fun apply_once_tac trace ctxt extras extras_ref t = let val used_rules = Unsynchronized.ref [] : thm list Unsynchronized.ref; in Seq.map (fn thm => (warn_unused_thms ctxt extras extras_ref used_rules; trace_used_thms trace used_rules ctxt; thm)) (resolve_ruleset_tac ctxt (get_rules ctxt extras) used_rules 1 t) end fun clear_rules ({combs, rules=_, trips, splits, unsafe_rules}) = {combs=combs, rules=no_rules, trips=trips, splits=splits, unsafe_rules=unsafe_rules} fun wp_modifiers extras_ref = [Args.add -- Args.colon >> K (I, fn att => (add_extra_rule (#2 att) extras_ref; wp_add att)), Args.del -- Args.colon >> K (I, wp_del), Args.$$$ "comb" -- Args.colon >> K (I, fn att => (add_extra_rule (#2 att) extras_ref; combs_add att)), Args.$$$ "comb" -- Args.add -- Args.colon >> K (I, fn att => (add_extra_rule (#2 att) extras_ref; combs_add att)), Args.$$$ "comb" -- Args.del -- Args.colon >> K (I, combs_del), Args.$$$ "only" -- Args.colon >> K (Context.proof_map (WPData.map clear_rules), fn att => (add_extra_rule (#2 att) extras_ref; wp_add att))]; fun has_colon xs = exists (Token.keyword_with (curry (op =) ":")) xs; fun if_colon scan1 scan2 xs = if has_colon (snd xs) then scan1 xs else scan2 xs; (* FIXME: It would be nice if we could just use Method.sections, but to maintain compatability we require that the order of thms in each section is reversed. *) fun thms ss = Scan.repeat (Scan.unless (Scan.lift (Scan.first ss)) Attrib.multi_thm) >> flat; fun app (f, att) ths context = fold_map (Thm.apply_attribute att) ths (Context.map_proof f context); fun section ss = Scan.depend (fn context => (Scan.first ss -- Scan.pass context (thms ss)) :|-- (fn (m, ths) => Scan.succeed (swap (app m (rev ths) context)))); fun sections ss = Scan.repeat (section ss); fun apply_rules_args trace xs = let val extras_ref = Unsynchronized.ref [] : thm list Unsynchronized.ref; in if_colon (sections (wp_modifiers extras_ref) >> K (fn ctxt => SIMPLE_METHOD (apply_rules_tac trace ctxt [] extras_ref))) (Attrib.thms >> curry (fn (extras, ctxt) => Method.SIMPLE_METHOD ( apply_rules_tac trace ctxt extras extras_ref ) )) end xs; fun apply_once_args trace xs = let val extras_ref = Unsynchronized.ref [] : thm list Unsynchronized.ref; in if_colon (sections (wp_modifiers extras_ref) >> K (fn ctxt => SIMPLE_METHOD (apply_once_tac trace ctxt [] extras_ref))) (Attrib.thms >> curry (fn (extras, ctxt) => Method.SIMPLE_METHOD ( apply_once_tac trace ctxt extras extras_ref ) )) end xs; end; structure WeakestPreInst : WP = WeakestPre; diff --git a/thys/Pratt_Certificate/pratt.ML b/thys/Pratt_Certificate/pratt.ML --- a/thys/Pratt_Certificate/pratt.ML +++ b/thys/Pratt_Certificate/pratt.ML @@ -1,508 +1,507 @@ (* File: pratt.ML Author: Manuel Eberl, TU München Various functions around Pratt certificates to prove primality of numbers. *) signature PRATT = sig type prime_thm_cache = (int * thm) list type tac_config = {cache : prime_thm_cache, verbose : bool, code : bool} datatype cert = Pratt_Node of int * int * cert list exception INVALID_CERT of cert val get_cert_number : cert -> int val mk_cert : int -> cert option val check_cert : cert -> bool val replay_cert : prime_thm_cache -> cert -> Proof.context -> thm * prime_thm_cache val replay_cert_code : cert -> Proof.context -> thm val prove_prime : prime_thm_cache -> int -> Proof.context -> thm option * prime_thm_cache val certT : typ val termify_cert : cert -> term val untermify_cert : term -> cert val pretty_cert : cert -> Pretty.T val read_cert : Input.source -> cert val cert_cartouche : cert parser val tac_config_parser : tac_config parser val tac : tac_config -> cert option -> Proof.context -> int -> tactic val setup_valid_cert_code_conv : (Proof.context -> conv) -> Context.generic -> Context.generic end structure Pratt : PRATT = struct fun mod_exp _ 0 m = if m = 1 then 0 else 1 | mod_exp b e m = case Integer.div_mod e 2 of (e', 0) => mod_exp ((b * b) mod m) e' m | (e', _) => (b * mod_exp ((b * b) mod m) e' m) mod m local fun calc_primes mode ps i n = if n = 0 then ps else if exists (fn p => i mod p = 0) ps then let val i = i + 1 and n = if mode then n else n - 1 in calc_primes mode ps i n end else let val ps = ps @ [i] and i = i + 1 and n = n - 1 in calc_primes mode ps i n end; in fun primes_up_to n = if n < 2 then [] else calc_primes false [2] 3 (n - 2); end; val small_primes = primes_up_to 100 fun factorise n = let val init = (small_primes, 101, false) fun get_divisor (p :: _, _, _) = p | get_divisor ([], k, _) = k fun next (_ :: ps, k, b) = (ps, k, b) | next ([], k, b) = ([], k + (if b then 4 else 2), not b) fun divide_out d n = let fun divide (n, acc) = if n mod d = 0 then divide (n div d, acc + 1) else (n, acc) in divide (n, 0) end fun factor st n acc = let val d = get_divisor st in if n <= 1 then rev acc else if d * d > n then rev ((n, 1) :: acc) else case divide_out d n of (n', k) => factor (next st) n' (if k = 0 then acc else (d, k) :: acc) end in factor init n [] end type prime_thm_cache = (int * thm) list datatype cert = Pratt_Node of int * int * cert list exception INVALID_CERT of cert fun get_cert_number (Pratt_Node (n, _, _)) = n fun mk_cert n = let exception PRATT fun cert n cache = if AList.defined op= cache n then cache else let fun find p lb ub = if ub < lb then NONE else if p lb then SOME lb else find p (lb+1) ub val ps = map fst (factorise (n - 1)) fun suitable' a p = mod_exp a ((n - 1) div p) n <> 1 fun suitable a = mod_exp a (n - 1) n = 1 andalso forall (suitable' a) ps val a = case find suitable 1 n of NONE => raise PRATT | SOME a => a val cache = fold cert ps cache val proofs = map (the o AList.lookup op= cache) ps in (n, Pratt_Node (n, a, proofs)) :: cache end in AList.lookup op= (cert n []) n handle PRATT => NONE end fun prove_list_all ctxt property thms = let val thm = Drule.infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt property)] @{thm list.pred_inject(1)} fun prove acc [] = acc | prove acc (thm :: thms) = prove (@{thm list_all_ConsI} OF [thm, acc]) thms in prove thm (rev thms) end fun check_prime_factors_subset 0 _ = false | check_prime_factors_subset n [] = n = 1 | check_prime_factors_subset n (p :: ps) = if n mod p = 0 then check_prime_factors_subset (n div p) (p :: ps) else check_prime_factors_subset n ps fun check_cert' (Pratt_Node (n, a, ts)) = let val ps = map get_cert_number ts in check_prime_factors_subset (n - 1) ps andalso forall (fn p => mod_exp a ((n - 1) div p) n <> 1) ps andalso mod_exp a (n - 1) n = 1 end fun check_cert (Pratt_Node (n, a, ts)) = check_cert' (Pratt_Node (n, a, ts)) andalso forall check_cert ts fun replay_cert cache cert ctxt = let val mk_nat = HOLogic.mk_number @{typ "Nat.nat"} val mk_eq_thm = Thm.cterm_of ctxt #> Thm.reflexive fun replay (Pratt_Node (n, a, ts)) cache = case AList.lookup op= cache n of SOME thm => (thm, cache) | NONE => let val _ = if check_cert' cert then () else raise INVALID_CERT cert val (prime_thms, cache) = fold_map replay ts cache val (n', a') = apply2 mk_nat (n, a) val prime_thm = prove_list_all ctxt @{term "prime :: nat \ bool"} prime_thms val thm = (@{thm lehmers_theorem'} OF [prime_thm, mk_eq_thm a', mk_eq_thm n']) fun mk_thm () = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop (@{term "prime :: nat \ bool"} $ mk_nat n)) (fn {context = ctxt, ...} => HEADGOAL (resolve_tac ctxt [thm]) THEN ALLGOALS (TRY o REPEAT_ALL_NEW (resolve_tac ctxt @{thms list_all_ConsI list.pred_inject(1)})) THEN PARALLEL_ALLGOALS (Simplifier.simp_tac ctxt)) in case try mk_thm () of NONE => raise THM ("replay_cert", 0, [thm]) | SOME thm => (thm, (n, thm) :: cache) end in replay cert cache end fun prove_prime cache n ctxt = case mk_cert n of NONE => (NONE, cache) | SOME cert => case replay_cert cache cert ctxt of (thm, cache) => (SOME thm, cache) (* datatype token *) datatype token_kind = Nat of int | Comma | Open_Brace | Close_Brace | Space | EOF datatype token = Token of token_kind * Position.T fun pos_of (Token (_, pos)) = pos fun is_space (Token (Space, _)) = true | is_space _ = false fun is_eof (Token (EOF, _)) = true | is_eof _ = false fun mk_eof pos = Token (EOF, pos) fun token_kind_name (Nat _) = "natural number" | token_kind_name Comma = "comma" | token_kind_name Open_Brace = "opening curly brace" | token_kind_name Close_Brace = "closing curly brace" | token_kind_name Space = "whitespace" | token_kind_name EOF = "end of input" val stopper = Scan.stopper (fn [] => mk_eof Position.none | toks => mk_eof (pos_of (List.last toks))) is_eof (* tokenize *) local fun space_symbol ((s, _): Symbol_Pos.T) = Symbol.is_blank s andalso s <> "\n" val scan_space = Scan.many1 space_symbol @@@ Scan.optional (Symbol_Pos.$$$ "\n") [] || Scan.many space_symbol @@@ Symbol_Pos.$$$ "\n" fun token kind (ss: Symbol_Pos.T list) = Token (kind, Position.range_position (Symbol_Pos.range ss)) val scan_token = Symbol_Pos.scan_nat >> (fn ss => let val kind = Nat (#1 (Library.read_int (map #1 ss))) val pos = Position.range_position (Symbol_Pos.range ss) in Token (kind, pos) end) || Symbol_Pos.$$$ "," >> token Comma || Symbol_Pos.$$$ "{" >> token Open_Brace || Symbol_Pos.$$$ "}" >> token Close_Brace || scan_space >> token Space val scan_all_tokens = Scan.repeat scan_token --| Symbol_Pos.!!! (fn () => "Lexical error") (Scan.ahead (Scan.one Symbol_Pos.is_eof)) in val tokenize = #1 o Scan.error (Scan.finite Symbol_Pos.stopper scan_all_tokens) o Input.source_explode end; (* parse *) local type 'a parser = token list -> 'a * token list fun err_msg expected toks () = let fun found [] = "end of input" | found (Token (kind, _) :: _) = token_kind_name kind in expected ^ " expected, but " ^ found toks ^ " was found" end fun !!! (scan: 'a parser) = let fun get_pos [] = " (end-of-input)" | get_pos (tok :: _) = Position.here (pos_of tok) fun err (toks, msg) () = "Syntax error" ^ get_pos toks ^ (case msg of NONE => "" | SOME m => ": " ^ m ()) in Scan.!! err scan end; fun one kind = Scan.some (fn Token (kind', _) => if kind = kind' then SOME () else NONE) || Scan.fail_with (err_msg (token_kind_name kind)) val nat = Scan.some (fn Token (Nat n, _) => SOME n | _ => NONE) || Scan.fail_with (err_msg "natural number") val comma = one Comma val open_brace = one Open_Brace val close_brace = one Close_Brace fun enum1 scan = scan ::: Scan.repeat (comma |-- scan) fun enum scan = enum1 scan || Scan.succeed [] fun list scan = !!! open_brace |-- enum scan --| !!! close_brace fun parse toks = ((open_brace |-- !!! (nat --| !!! comma -- !!! nat --| !!! comma -- list parse --| !!! close_brace)) >> (fn ((a, b), c) => Pratt_Node (a, b, c)) || !!! nat >> (fn a => Pratt_Node (a, 1, [])) || Scan.fail_with (err_msg "opening curly brace or natural number")) toks in fun read_cert input = let val toks = filter_out is_space (tokenize input) in #1 (Scan.error (Scan.finite stopper (parse --| !!! (Scan.ahead (one EOF)))) toks) end end val cert_cartouche = Args.cartouche_input >> read_cert val certT = @{typ "Pratt_Certificate.pratt_tree"} local val mk_nat = HOLogic.mk_number @{typ nat} val dest_nat = snd o HOLogic.dest_number in fun termify_cert (Pratt_Node (n, a, ts)) = @{term Pratt_Node} $ HOLogic.mk_tuple [mk_nat n, mk_nat a, HOLogic.mk_list certT (map termify_cert ts)] fun untermify_cert (@{term Pratt_Node} $ t) = ( case HOLogic.strip_tuple t of [n, a, ts] => Pratt_Node (dest_nat n, dest_nat a, map untermify_cert (HOLogic.dest_list ts)) | _ => raise TERM ("untermify_cert", [@{term Pratt_Node} $ t])) | untermify_cert t = raise TERM ("untermify_cert", [t]) end structure Data = Generic_Data ( type T = (Proof.context -> conv) option val empty : T = NONE - val extend = I fun merge (_, conv) = conv ) fun setup_valid_cert_code_conv conv ctxt = Data.put (SOME conv) ctxt fun has_code_conv ctxt = case Data.get (Context.Proof ctxt) of SOME _ => true | _ => false fun valid_cert_code_conv ctxt = case Data.get (Context.Proof ctxt) of SOME conv => conv ctxt | NONE => (fn ct => raise CTERM ("valid_cert_code_conv", [ct])) fun replay_cert_code cert ctxt = let val goal = Thm.cterm_of ctxt (HOLogic.mk_Trueprop (@{term valid_pratt_tree} $ termify_cert cert)) in @{thm valid_pratt_tree_imp_prime'} OF [valid_cert_code_conv ctxt goal] end handle TERM _ => raise INVALID_CERT cert | CTERM _ => raise INVALID_CERT cert | THM _ => raise INVALID_CERT cert local val pretty_int = Pretty.str o string_of_int in fun pretty_cert (Pratt_Node (2, _, _)) = pretty_int 2 | pretty_cert (Pratt_Node (n, a, ts)) = Pretty.list "{" "}" [pretty_int n, pretty_int a, Pretty.enum "," "{" "}" (map pretty_cert ts)] end type tac_config = {cache : prime_thm_cache, verbose : bool, code : bool} exception NO_CODE local fun cert_err config cert = let val _ = if #verbose config then Pretty.chunks [Pretty.str "Invalid Pratt certificate:", Pretty.indent 2 (pretty_cert cert)] |> Pretty.string_of |> warning else () in no_tac end in fun tac config cert ctxt i = let val cmd = Pretty.block ([Pretty.str "pratt"] @ (if #code config then [Pretty.str " (", Pretty.keyword1 "code", Pretty.str ")"] else [])) fun print_cert cert = [Pretty.keyword1 "by", Pretty.brk 1, Pretty.str "(", cmd, Pretty.str " ", Pretty.blk (2, [Pretty.cartouche (pretty_cert cert)]), Pretty.str ")"] |> Pretty.blk o pair 4 |> Pretty.string_of |> Active.sendback_markup_command |> prefix "To repeat this proof with a pre-computed certificate, use:\n" |> Output.information fun not_prime_err n = let val _ = if #verbose config then warning ("Not a prime number: " ^ Int.toString n) else () in NONE end fun certify p = case cert of SOME cert => SOME cert | NONE => let val p' = p |> HOLogic.dest_Trueprop |> dest_comb |> snd |> HOLogic.dest_number |> snd in case mk_cert p' of SOME cert => let val _ = if #verbose config then print_cert cert else () in SOME cert end | NONE => not_prime_err p' end val replay = if #code config then if has_code_conv ctxt then replay_cert_code else let val _ = if #verbose config then warning ("Code for Pratt certificates was not set up yet. " ^ "Load the theory Pratt_Certificate_Code to do this.") else () in raise NO_CODE end else fst oo replay_cert (#cache config) in Subgoal.FOCUS_PARAMS (fn {concl, ...} => case certify (Thm.term_of concl) of NONE => no_tac | SOME cert => HEADGOAL (resolve_tac ctxt [replay cert ctxt]) ) ctxt i end handle INVALID_CERT cert => cert_err config cert | NO_CODE => no_tac end val default_config = {verbose = true, code = false, cache = []} local val silent : (tac_config -> tac_config) parser = Args.$$$ "silent" >> (K (fn {code, cache, ...} => {verbose = false, code = code, cache = cache})) val code : (tac_config -> tac_config) parser = Args.$$$ "code" >> (K (fn {verbose, cache, ...} => {verbose = verbose, code = true, cache = cache})) val option = silent || code val options = Scan.optional (Args.parens (Parse.list option) >> (fn fs => fold (fn f => fn g => f o g) fs I)) I in val tac_config_parser = options >> (fn f => f default_config) end end diff --git a/thys/Proof_Strategy_Language/Isar_Interface.ML b/thys/Proof_Strategy_Language/Isar_Interface.ML --- a/thys/Proof_Strategy_Language/Isar_Interface.ML +++ b/thys/Proof_Strategy_Language/Isar_Interface.ML @@ -1,170 +1,169 @@ (* Title: Isar_Interface.ML Author: Yutaka Nagashima, Data61, CSIRO This file provides the Isar-level interface of PSL. One can activate the interfaces by calling the function, "PSL_Interface.activate_isar_interface ()". *) (*** PSL_INTERFACE: One can define new strategies only through the Isar interface. ***) signature PSL_INTERFACE = sig val activate_isar_interface : unit -> unit; (* "strategy" and "try_hard_strategy" have to be exposed, * so that Mirabelle can use it without exposing "lookup". *) type strategy; val try_hard_strategy : Proof.context -> strategy option; val try_parallel_strategy : Proof.context -> strategy option; end; (*** PSL_Interface: One can define new strategies only through the Isar interface. ***) structure PSL_Interface : PSL_INTERFACE = struct structure Mp = Monadic_Prover; structure Pc = Parser_Combinator; type strategy = Mp.str; structure Data = Generic_Data ( type T = strategy Symtab.table; val empty = Symtab.empty : T; - val extend = I; val merge = Symtab.merge (K true); ); fun lookup ctxt = (Symtab.lookup o Data.get) (Context.Proof ctxt); fun update k v = Data.map (Symtab.update_new (k, v)); structure Lookup : LOOKUP = struct fun get_str ctxt name = let val some_str = lookup ctxt name : Mp.str option; val strategy = Utils.the' (name ^ "?\nDid you really define such a strategy?\n" ^ "Also, you should not forget that PThenOne and PThenAll take *exactly* two sub-strategies!") some_str : Mp.str; in strategy end; end; structure PSL_Parser = mk_PSL_Parser(Lookup); fun put_strategy (name:string, str:strategy) = update name str |> Context.theory_map |> Local_Theory.background_theory; fun tokens_to_string tokens = tokens |> map Token.unparse |> String.concatWith " "; fun string_parser_to_token_parser (symbols_parser:'a Pc.parser) = (fn (tokens:Token.T list) => tokens |> tokens_to_string |> Symbol.explode |> symbols_parser |> Seq.hd (*This function assumes that the string_parser consumes the entire string.*) |> apsnd (K ([]))) : 'a Token.parser; fun parse_strategy_def_tokens ctxt = string_parser_to_token_parser (PSL_Parser.strategy_parser ctxt) : (string * Mp.str) Token.parser; val parse_and_put_strategy_def : (local_theory -> local_theory) Token.parser = fn tokens => let fun get_token_parser ctxt = parse_strategy_def_tokens ctxt : (string * Mp.str) Token.parser; fun get_token_p_result ctxt = get_token_parser ctxt tokens |> fst : string * Mp.str; fun put_str_in_lthy (lthy:local_theory) = put_strategy (get_token_p_result lthy) lthy; in (put_str_in_lthy, []) end; fun get_monad_tactic (strategy:strategy) (proof_state:Proof.state) = let val core_tac = Mp.desugar strategy; val interpret = Mp.interpret; fun hard_timeout_in (sec:real) = Timeout.apply (seconds sec); in hard_timeout_in 60000.0 (interpret (Mp.eval_prim, Mp.eval_para, Mp.eval_strategic, Mp.m_equal, Mp.iddfc, (5,20)) core_tac) proof_state end : Proof.state Mp.monad; type trans_trans = Toplevel.transition -> Toplevel.transition; val strategy_invocation_parser = PSL_Parser.invocation_parser : string Pc.parser; local infix >>=; val op >>= = Parser_Combinator.>>=; in fun invocation_parser_to_trans_trans_parser (inv_p : string Pc.parser) (get_trans_trans : string -> trans_trans) = string_parser_to_token_parser (inv_p >>= (Pc.result o get_trans_trans)) : trans_trans Token.parser; end; fun get_trans_trans (strategy_name:string) = (((Toplevel.keep_proof:(Toplevel.state -> unit) -> trans_trans) (fn top => let type log = Dynamic_Utils.log; val lmap = Seq.map; val context = Toplevel.context_of top : Proof.context; val some_strategy = lookup context strategy_name; val strategy = Utils.the' (strategy_name ^ "? You haven't defined such a strategy!") some_strategy; val tactic = get_monad_tactic strategy : Proof.state Mp.stttac; val proof_state = Toplevel.proof_of top; val results' = tactic proof_state : Proof.state Mp.monad; val results = results' [] : (log * Proof.state) Seq.seq; val logs = lmap fst results : log Seq.seq; val applies = lmap Dynamic_Utils.mk_apply_script logs; val print = writeln (case Seq.pull applies of NONE => error "empty sequence. no proof found." | SOME _ => Seq.hd applies); in print end) ):trans_trans); fun activate_isar_interface _ = let val _ = Outer_Syntax.local_theory @{command_keyword strategy} "PSL strategy definition" parse_and_put_strategy_def; val _ = Outer_Syntax.command @{command_keyword find_proof} "find_proof tries to find a proof based on high level strategies provided in advance.." (invocation_parser_to_trans_trans_parser strategy_invocation_parser get_trans_trans); val _ = Outer_Syntax.command @{command_keyword try_hard} "try_hard to find efficient proof-scripts." (Scan.succeed (get_trans_trans "Try_Hard")) val _ = Outer_Syntax.command @{command_keyword try_hard_one} "try_hard to find efficient proof-scripts." (Scan.succeed (get_trans_trans "Try_Hard_One")) val _ = Outer_Syntax.command @{command_keyword try_hard_all} "try_hard to find efficient proof-scripts." (Scan.succeed (get_trans_trans "Try_Hard_All")) val _ = Outer_Syntax.command @{command_keyword try_parallel} "try_hard to find efficient proof-scripts." (Scan.succeed (get_trans_trans "Try_Parallel")) in () end; fun try_hard_strategy (ctxt:Proof.context) = lookup ctxt "Try_Hard"; fun try_parallel_strategy (ctxt:Proof.context) = lookup ctxt "Try_Parallel"; end; (*** activate the Isar interface of PSL. ***) PSL_Interface.activate_isar_interface (); \ No newline at end of file diff --git a/thys/Randomised_Social_Choice/Automation/Preference_Profile_Cmd.thy b/thys/Randomised_Social_Choice/Automation/Preference_Profile_Cmd.thy --- a/thys/Randomised_Social_Choice/Automation/Preference_Profile_Cmd.thy +++ b/thys/Randomised_Social_Choice/Automation/Preference_Profile_Cmd.thy @@ -1,386 +1,385 @@ (* Title: Preference_Profiles_Cmd.thy Author: Manuel Eberl, TU München Provides the preference_profile command that defines preference profiles, proves well-formedness, and provides some useful lemmas for them. *) section \Automatic definition of Preference Profiles\ theory Preference_Profile_Cmd imports Complex_Main "../Elections" keywords "preference_profile" :: thy_goal begin ML_file \preference_profiles.ML\ context election begin lemma preferred_alts_prefs_from_table: assumes "prefs_from_table_wf agents alts xs" "i \ set (map fst xs)" shows "preferred_alts (prefs_from_table xs i) x = of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x" proof - interpret pref_profile_wf agents alts "prefs_from_table xs" by (intro pref_profile_from_tableI assms) from assms have [simp]: "i \ agents" by (auto simp: prefs_from_table_wf_def) have "of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x = Collect (of_weak_ranking (the (map_of xs i)) x)" by (rule eval_Collect_of_weak_ranking [symmetric]) also from assms(2) have "the (map_of xs i) \ set (map snd xs)" by (cases "map_of xs i") (force simp: map_of_eq_None_iff dest: map_of_SomeD)+ from prefs_from_table_wfD(5)[OF assms(1) this] have "Collect (of_weak_ranking (the (map_of xs i)) x) = {y\alts. of_weak_ranking (the (map_of xs i)) x y}" by safe (force elim!: of_weak_ranking.cases) also from assms have "of_weak_ranking (the (map_of xs i)) = prefs_from_table xs i" by (subst prefs_from_table_map_of[OF assms(1)]) (auto simp: prefs_from_table_wf_def) finally show ?thesis by (simp add: of_weak_ranking_Collect_ge_def preferred_alts_altdef) qed lemma favorites_prefs_from_table: assumes wf: "prefs_from_table_wf agents alts xs" and i: "i \ agents" shows "favorites (prefs_from_table xs) i = hd (the (map_of xs i))" proof (cases "map_of xs i") case None with assms show ?thesis by (auto simp: map_of_eq_None_iff prefs_from_table_wf_def) next case (Some y) with assms have "is_finite_weak_ranking y" "y \ []" by (auto simp: prefs_from_table_wf_def) with Some show ?thesis unfolding favorites_def using assms by (simp add: prefs_from_table_def is_finite_weak_ranking_def Max_wrt_of_weak_ranking prefs_from_table_wfD) qed lemma has_unique_favorites_prefs_from_table: assumes wf: "prefs_from_table_wf agents alts xs" shows "has_unique_favorites (prefs_from_table xs) = list_all (\z. is_singleton (hd (snd z))) xs" proof - interpret pref_profile_wf agents alts "prefs_from_table xs" by (intro pref_profile_from_tableI assms) from wf have "agents = set (map fst xs)" "distinct (map fst xs)" by (auto simp: prefs_from_table_wf_def) thus ?thesis unfolding has_unique_favorites_altdef using assms by (auto simp: favorites_prefs_from_table list_all_iff) qed end subsection \Automatic definition of preference profiles from tables\ function favorites_prefs_from_table where "i = j \ favorites_prefs_from_table ((j,x)#xs) i = hd x" | "i \ j \ favorites_prefs_from_table ((j,x)#xs) i = favorites_prefs_from_table xs i" | "favorites_prefs_from_table [] i = {}" by (metis list.exhaust old.prod.exhaust) auto termination by lexicographic_order lemma (in election) eval_favorites_prefs_from_table: assumes "prefs_from_table_wf agents alts xs" shows "favorites_prefs_from_table xs i = favorites (prefs_from_table xs) i" proof (cases "i \ agents") assume i: "i \ agents" with assms have "favorites (prefs_from_table xs) i = hd (the (map_of xs i))" by (simp add: favorites_prefs_from_table) also from assms i have "i \ set (map fst xs)" by (auto simp: prefs_from_table_wf_def) hence "hd (the (map_of xs i)) = favorites_prefs_from_table xs i" by (induction xs i rule: favorites_prefs_from_table.induct) simp_all finally show ?thesis .. next assume i: "i \ agents" with assms have i': "i \ set (map fst xs)" by (simp add: prefs_from_table_wf_def) hence "map_of xs i = None" by (simp add: map_of_eq_None_iff) hence "prefs_from_table xs i = (\_ _. False)" by (intro ext) (auto simp: prefs_from_table_def) hence "favorites (prefs_from_table xs) i = {}" by (simp add: favorites_def Max_wrt_altdef) also from i' have "\ = favorites_prefs_from_table xs i" by (induction xs i rule: favorites_prefs_from_table.induct) simp_all finally show ?thesis .. qed function weak_ranking_prefs_from_table where "i \ j \ weak_ranking_prefs_from_table ((i,x)#xs) j = weak_ranking_prefs_from_table xs j" | "i = j \ weak_ranking_prefs_from_table ((i,x)#xs) j = x" | "weak_ranking_prefs_from_table [] j = []" by (metis list.exhaust old.prod.exhaust) auto termination by lexicographic_order lemma eval_weak_ranking_prefs_from_table: assumes "prefs_from_table_wf agents alts xs" shows "weak_ranking_prefs_from_table xs i = weak_ranking (prefs_from_table xs i)" proof (cases "i \ agents") assume i: "i \ agents" with assms have "weak_ranking (prefs_from_table xs i) = the (map_of xs i)" by (auto simp: prefs_from_table_def prefs_from_table_wf_def weak_ranking_of_weak_ranking split: option.splits) also from assms i have "i \ set (map fst xs)" by (auto simp: prefs_from_table_wf_def) hence "the (map_of xs i) = weak_ranking_prefs_from_table xs i" by (induction xs i rule: weak_ranking_prefs_from_table.induct) simp_all finally show ?thesis .. next assume i: "i \ agents" with assms have i': "i \ set (map fst xs)" by (simp add: prefs_from_table_wf_def) hence "map_of xs i = None" by (simp add: map_of_eq_None_iff) hence "prefs_from_table xs i = (\_ _. False)" by (intro ext) (auto simp: prefs_from_table_def) hence "weak_ranking (prefs_from_table xs i) = []" by simp also from i' have "\ = weak_ranking_prefs_from_table xs i" by (induction xs i rule: weak_ranking_prefs_from_table.induct) simp_all finally show ?thesis .. qed lemma eval_prefs_from_table_aux: assumes "R \ prefs_from_table xs" "prefs_from_table_wf agents alts xs" shows "R i a b \ prefs_from_table xs i a b" "a \[R i] b \ prefs_from_table xs i a b \ \prefs_from_table xs i b a" "anonymous_profile R = mset (map snd xs)" "election agents alts \ i \ set (map fst xs) \ preferred_alts (R i) x = of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x" "election agents alts \ i \ set (map fst xs) \ favorites R i = favorites_prefs_from_table xs i" "election agents alts \ i \ set (map fst xs) \ weak_ranking (R i) = weak_ranking_prefs_from_table xs i" "election agents alts \ i \ set (map fst xs) \ favorite R i = the_elem (favorites_prefs_from_table xs i)" "election agents alts \ has_unique_favorites R \ list_all (\z. is_singleton (hd (snd z))) xs" using assms prefs_from_table_wfD[OF assms(2)] by (simp_all add: strongly_preferred_def favorite_def anonymise_prefs_from_table election.preferred_alts_prefs_from_table election.eval_favorites_prefs_from_table election.has_unique_favorites_prefs_from_table eval_weak_ranking_prefs_from_table) lemma pref_profile_from_tableI': assumes "R1 \ prefs_from_table xss" "prefs_from_table_wf agents alts xss" shows "pref_profile_wf agents alts R1" using assms by (simp add: pref_profile_from_tableI) ML \ signature PREFERENCE_PROFILES_CMD = sig type info val preference_profile : (term * term) * ((binding * (term * term list list) list) list) -> Proof.context -> Proof.state val preference_profile_cmd : (string * string) * ((binding * (string * string list list) list) list) -> Proof.context -> Proof.state val get_info : term -> Proof.context -> info val add_info : term -> info -> Context.generic -> Context.generic val transform_info : info -> morphism -> info end structure Preference_Profiles_Cmd : PREFERENCE_PROFILES_CMD = struct open Preference_Profiles type info = { term : term, def_thm : thm, wf_thm : thm, wf_raw_thm : thm, binding : binding, raw : (term * term list list) list, eval_thms : thm list } fun transform_info ({term = t, binding, def_thm, wf_thm, wf_raw_thm, raw, eval_thms} : info) phi = let val thm = Morphism.thm phi val fact = Morphism.fact phi val term = Morphism.term phi val bdg = Morphism.binding phi in { term = term t, binding = bdg binding, def_thm = thm def_thm, wf_thm = thm wf_thm, wf_raw_thm = thm wf_raw_thm, raw = map (fn (a, bss) => (term a, map (map term) bss)) raw, eval_thms = fact eval_thms } end structure Data = Generic_Data ( type T = (term * info) Item_Net.T val empty = Item_Net.init (op aconv o apply2 fst) (single o fst) - val extend = I val merge = Item_Net.merge ); fun get_info term lthy = Item_Net.retrieve (Data.get (Context.Proof lthy)) term |> the_single |> snd fun add_info term info lthy = Data.map (Item_Net.update (term, info)) lthy fun add_infos infos lthy = Data.map (fold Item_Net.update infos) lthy fun preference_profile_aux agents alts (binding, args) lthy = let val dest_Type' = Term.dest_Type #> snd #> hd val (agentT, altT) = apply2 (dest_Type' o fastype_of) (agents, alts) val alt_setT = HOLogic.mk_setT altT fun define t = Local_Theory.define ((binding, NoSyn), ((Binding.suffix_name "_def" binding, @{attributes [code]}), t)) lthy val ty = HOLogic.mk_prodT (agentT, HOLogic.listT (HOLogic.mk_setT altT)) val args' = args |> map (fn x => x ||> map (HOLogic.mk_set altT) ||> HOLogic.mk_list alt_setT) val t_raw = args' |> map HOLogic.mk_prod |> HOLogic.mk_list ty val t = Const (@{const_name prefs_from_table}, HOLogic.listT ty --> pref_profileT agentT altT) $ t_raw val ((prefs, prefs_def), lthy) = define t val prefs_from_table_wf_const = Const (@{const_name prefs_from_table_wf}, HOLogic.mk_setT agentT --> HOLogic.mk_setT altT --> HOLogic.listT (HOLogic.mk_prodT (agentT, HOLogic.listT (HOLogic.mk_setT altT))) --> HOLogic.boolT) val wf_prop = (prefs_from_table_wf_const $ agents $ alts $ t_raw) |> HOLogic.mk_Trueprop in ((prefs, wf_prop, prefs_def), lthy) end fun fold_accum f xs s = let fun fold_accum_aux _ [] s acc = (rev acc, s) | fold_accum_aux f (x::xs) s acc = case f x s of (y, s') => fold_accum_aux f xs s' (y::acc) in fold_accum_aux f xs s [] end fun preference_profile ((agents, alts), args) lthy = let fun qualify pref suff = Binding.qualify true (Binding.name_of pref) (Binding.name suff) val (results, lthy) = fold_accum (preference_profile_aux agents alts) args lthy val prefs_terms = map #1 results val wf_props = map #2 results val defs = map (snd o #3) results val raws = map snd args val bindings = map fst args fun tac lthy = let val lthy' = put_simpset HOL_ss lthy addsimps @{thms list.set Union_insert Un_insert_left insert_not_empty Int_empty_left Int_empty_right insert_commute Un_empty_left Un_empty_right insert_absorb2 Union_empty is_weak_ranking_Cons is_weak_ranking_Nil finite_insert finite.emptyI Set.singleton_iff Set.empty_iff Set.ball_simps} in Local_Defs.unfold_tac lthy defs THEN ALLGOALS (resolve_tac lthy [@{thm prefs_from_table_wfI}]) THEN Local_Defs.unfold_tac lthy @{thms is_finite_weak_ranking_def list.set insert_iff empty_iff simp_thms list.map snd_conv fst_conv} THEN ALLGOALS (TRY o REPEAT_ALL_NEW (eresolve_tac lthy @{thms disjE})) THEN ALLGOALS (TRY o Hypsubst.hyp_subst_tac lthy) THEN ALLGOALS (Simplifier.asm_full_simp_tac lthy') THEN ALLGOALS (TRY o REPEAT_ALL_NEW (resolve_tac lthy @{thms conjI})) THEN distinct_subgoals_tac end fun after_qed [wf_thms_raw] lthy = let fun prep_thms attrs suffix (thms : thm list) binding = (((qualify binding suffix, attrs), [(thms,[])])) fun prep_thmss simp suffix thmss = map2 (prep_thms simp suffix) thmss bindings fun notes thmss suffix attrs lthy = Local_Theory.notes (prep_thmss attrs suffix thmss) lthy |> snd fun note thms suffix attrs lthy = notes (map single thms) suffix attrs lthy val eval_thmss = map2 (fn def => fn wf => map (fn thm => thm OF [def, wf]) @{thms eval_prefs_from_table_aux}) defs wf_thms_raw val wf_thms = map2 (fn def => fn wf => @{thm pref_profile_from_tableI'} OF [def, wf]) defs wf_thms_raw val mk_infos = let fun aux acc (bdg::bdgs) (t::ts) (r::raws) (def::def_thms) (wf::wf_thms) (wf_raw::wf_raw_thms) (evals::eval_thmss) = aux ((t, {binding = bdg, term = t, raw = r, def_thm = def, wf_thm = wf, wf_raw_thm = wf_raw, eval_thms = evals}) :: acc) bdgs ts raws def_thms wf_thms wf_raw_thms eval_thmss | aux acc [] _ _ _ _ _ _ = (acc : (term * info) list) | aux _ _ _ _ _ _ _ _ = raise Match in aux [] end val infos = mk_infos bindings prefs_terms raws defs wf_thms wf_thms_raw eval_thmss in lthy |> note wf_thms_raw "wf_raw" [] |> note wf_thms "wf" @{attributes [simp]} |> notes eval_thmss "eval" [] |> Local_Theory.declaration {syntax = false, pervasive = false} (fn m => add_infos (map (fn (t,i) => (Morphism.term m t, transform_info i m)) infos)) end | after_qed _ _ = raise Match in Proof.theorem NONE after_qed [map (fn prop => (prop, [])) wf_props] lthy |> Proof.refine_singleton (Method.Basic (SIMPLE_METHOD o tac)) end fun preference_profile_cmd ((agents, alts), argss) lthy = let val read = Syntax.read_term lthy fun read' ty t = Syntax.parse_term lthy t |> Type.constraint ty |> Syntax.check_term lthy val agents' = read agents val alts' = read alts val agentT = agents' |> fastype_of |> dest_Type |> snd |> hd val altT = alts' |> fastype_of |> dest_Type |> snd |> hd fun read_pref_elem ts = map (read' altT) ts fun read_prefs prefs = map read_pref_elem prefs fun prep (binding, args) = (binding, map (fn (agent, prefs) => (read' agentT agent, read_prefs prefs)) args) in preference_profile ((agents', alts'), map prep argss) lthy end val parse_prefs = let val parse_pref_elem = (Args.bracks (Parse.list1 Parse.term)) || Parse.term >> single in Parse.list1 parse_pref_elem end val parse_pref_profile = Parse.binding --| Args.$$$ "=" -- Scan.repeat1 (Parse.term --| Args.colon -- parse_prefs) val _ = Outer_Syntax.local_theory_to_proof @{command_keyword preference_profile} "construct preference profiles from a table" (Args.$$$ "agents" |-- Args.colon |-- Parse.term --| Args.$$$ "alts" --| Args.colon -- Parse.term --| Args.$$$ "where" -- Parse.and_list1 parse_pref_profile >> preference_profile_cmd); end \ end diff --git a/thys/Refine_Imperative_HOL/Lib/Named_Theorems_Rev.thy b/thys/Refine_Imperative_HOL/Lib/Named_Theorems_Rev.thy --- a/thys/Refine_Imperative_HOL/Lib/Named_Theorems_Rev.thy +++ b/thys/Refine_Imperative_HOL/Lib/Named_Theorems_Rev.thy @@ -1,109 +1,108 @@ theory Named_Theorems_Rev imports Main keywords "named_theorems_rev" :: thy_decl begin ML \ signature NAMED_THEOREMS_REV = sig val member: Proof.context -> string -> thm -> bool val get: Proof.context -> string -> thm list val add_thm: string -> thm -> Context.generic -> Context.generic val del_thm: string -> thm -> Context.generic -> Context.generic val add: string -> attribute val del: string -> attribute val check: Proof.context -> string * Position.T -> string val declare: binding -> string -> local_theory -> string * local_theory end; structure Named_Theorems_Rev: NAMED_THEOREMS_REV = struct (* context data *) structure Data = Generic_Data ( type T = thm Item_Net.T Symtab.table; val empty: T = Symtab.empty; - val extend = I; val merge : T * T -> T = Symtab.join (K Item_Net.merge); ); fun new_entry name = Data.map (fn data => if Symtab.defined data name then error ("Duplicate declaration of named theorems: " ^ quote name) else Symtab.update (name, Thm.item_net) data); fun undeclared name = "Undeclared named theorems " ^ quote name; fun the_entry context name = (case Symtab.lookup (Data.get context) name of NONE => error (undeclared name) | SOME entry => entry); fun map_entry name f context = (the_entry context name; Data.map (Symtab.map_entry name f) context); (* maintain content *) fun member ctxt = Item_Net.member o the_entry (Context.Proof ctxt); fun content context = Item_Net.content o the_entry context; val get = content o Context.Proof; fun add_thm name = map_entry name o Item_Net.update; fun del_thm name = map_entry name o Item_Net.remove; val add = Thm.declaration_attribute o add_thm; val del = Thm.declaration_attribute o del_thm; (* check *) fun check ctxt (xname, pos) = let val context = Context.Proof ctxt; val fact_ref = Facts.Named ((xname, Position.none), NONE); fun err () = error (undeclared xname ^ Position.here pos); in (case try (Proof_Context.get_fact_generic context) fact_ref of SOME (SOME name, _) => if can (the_entry context) name then name else err () | _ => err ()) end; (* declaration *) fun declare binding descr lthy = let val name = Local_Theory.full_name lthy binding; val description = "declaration of " ^ (if descr = "" then Binding.name_of binding ^ " rules" else descr); val lthy' = lthy |> Local_Theory.background_theory (Context.theory_map (new_entry name)) |> Local_Theory.map_contexts (K (Context.proof_map (new_entry name))) |> Local_Theory.add_thms_dynamic (binding, fn context => content context name) |> Attrib.local_setup binding (Attrib.add_del (add name) (del name)) description in (name, lthy') end; val _ = Outer_Syntax.local_theory @{command_keyword named_theorems_rev} "declare named collection of theorems" (Parse.and_list1 (Parse.binding -- Scan.optional Parse.text "") >> fold (fn (b, descr) => snd o declare b descr)); (* ML antiquotation *) val _ = Theory.setup (ML_Antiquotation.inline @{binding named_theorems_rev} (Args.context -- Scan.lift Args.name_position >> (fn (ctxt, name) => ML_Syntax.print_string (check ctxt name)))); end; \ end diff --git a/thys/Refine_Monadic/Generic/RefineG_Transfer.thy b/thys/Refine_Monadic/Generic/RefineG_Transfer.thy --- a/thys/Refine_Monadic/Generic/RefineG_Transfer.thy +++ b/thys/Refine_Monadic/Generic/RefineG_Transfer.thy @@ -1,290 +1,290 @@ section \Transfer between Domains\ theory RefineG_Transfer imports "../Refine_Misc" begin text \Currently, this theory is specialized to transfers that include no data refinement. \ definition "REFINEG_TRANSFER_POST_SIMP x y \ x=y" definition [simp]: "REFINEG_TRANSFER_ALIGN x y == True" lemma REFINEG_TRANSFER_ALIGNI: "REFINEG_TRANSFER_ALIGN x y" by simp lemma START_REFINEG_TRANSFER: assumes "REFINEG_TRANSFER_ALIGN d c" assumes "c\a" assumes "REFINEG_TRANSFER_POST_SIMP c d" shows "d\a" using assms by (simp add: REFINEG_TRANSFER_POST_SIMP_def) lemma STOP_REFINEG_TRANSFER: "REFINEG_TRANSFER_POST_SIMP c c" unfolding REFINEG_TRANSFER_POST_SIMP_def .. ML \ structure RefineG_Transfer = struct - structure Post_Processors = Theory_Data ( + structure Post_Processors = Theory_Data + ( type T = (Proof.context -> tactic') Symtab.table val empty = Symtab.empty - val extend = I val merge = Symtab.join (K snd) ) fun add_post_processor name tac = Post_Processors.map (Symtab.update_new (name,tac)) fun delete_post_processor name = Post_Processors.map (Symtab.delete name) val get_post_processors = Post_Processors.get #> Symtab.dest fun post_process_tac ctxt = let val tacs = get_post_processors (Proof_Context.theory_of ctxt) |> map (fn (_,tac) => tac ctxt) val tac = REPEAT_DETERM' (CHANGED o EVERY' (map (fn t => TRY o t) tacs)) in tac end - structure Post_Simp = Generic_Data ( - type T = simpset - val empty = HOL_basic_ss - val extend = I - val merge = Raw_Simplifier.merge_ss + structure Post_Simp = Generic_Data + ( + type T = simpset + val empty = HOL_basic_ss + val merge = Raw_Simplifier.merge_ss ) fun post_simps_op f a context = let val ctxt = Context.proof_of context fun do_it ss = simpset_of (f (put_simpset ss ctxt, a)) in Post_Simp.map do_it context end val add_post_simps = post_simps_op (op addsimps) val del_post_simps = post_simps_op (op delsimps) fun get_post_ss ctxt = let val ss = Post_Simp.get (Context.Proof ctxt) val ctxt = put_simpset ss ctxt in ctxt end structure post_subst = Named_Thms ( val name = @{binding refine_transfer_post_subst} val description = "Refinement Framework: " ^ "Transfer postprocessing substitutions" ); fun post_subst_tac ctxt = let val s_thms = post_subst.get ctxt fun dis_tac goal_ctxt = ALLGOALS (Tagged_Solver.solve_tac goal_ctxt) val cnv = Cond_Rewr_Conv.cond_rewrs_conv dis_tac s_thms val ts_conv = Conv.top_sweep_conv cnv ctxt val ss = get_post_ss ctxt in REPEAT o CHANGED o (Simplifier.simp_tac ss THEN' CONVERSION ts_conv) end structure transfer = Named_Thms ( val name = @{binding refine_transfer} val description = "Refinement Framework: " ^ "Transfer rules" ); fun transfer_tac thms ctxt i st = let val thms = thms @ transfer.get ctxt; val ss = put_simpset HOL_basic_ss ctxt addsimps @{thms nested_case_prod_simp} in REPEAT_DETERM1 ( COND (has_fewer_prems (Thm.nprems_of st)) no_tac ( FIRST [ Method.assm_tac ctxt i, resolve_tac ctxt thms i, Tagged_Solver.solve_tac ctxt i, CHANGED_PROP (simp_tac ss i)] )) st end (* Adjust right term to have same structure as left one *) fun align_tac ctxt = IF_EXGOAL (fn i => fn st => case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop (REFINEG_TRANSFER_ALIGN ?c _)"} => let val c = Thm.cterm_of ctxt c val cT = Thm.ctyp_of_cterm c val rl = @{thm REFINEG_TRANSFER_ALIGNI} |> Thm.incr_indexes (Thm.maxidx_of st + 1) |> Thm.instantiate' [NONE,SOME cT] [NONE,SOME c] (*val _ = tracing (@{make_string} rl)*) in resolve_tac ctxt [rl] i st end | _ => Seq.empty ) fun post_transfer_tac thms ctxt = let open Autoref_Tacticals in resolve_tac ctxt @{thms START_REFINEG_TRANSFER} THEN' align_tac ctxt THEN' IF_SOLVED (transfer_tac thms ctxt) (post_process_tac ctxt THEN' resolve_tac ctxt @{thms STOP_REFINEG_TRANSFER}) (K all_tac) end fun get_post_simp_rules context = Context.proof_of context |> get_post_ss |> simpset_of |> Raw_Simplifier.dest_ss |> #simps |> map snd local val add_ps = Thm.declaration_attribute (add_post_simps o single) val del_ps = Thm.declaration_attribute (del_post_simps o single) in val setup = I #> add_post_processor "RefineG_Transfer.post_subst" post_subst_tac #> post_subst.setup #> transfer.setup #> Attrib.setup @{binding refine_transfer_post_simp} (Attrib.add_del add_ps del_ps) ("declaration of transfer post simplification rules") #> Global_Theory.add_thms_dynamic ( @{binding refine_transfer_post_simps}, get_post_simp_rules) end end \ setup \RefineG_Transfer.setup\ method_setup refine_transfer = \Scan.lift (Args.mode "post") -- Attrib.thms >> (fn (post,thms) => fn ctxt => SIMPLE_METHOD' ( if post then RefineG_Transfer.post_transfer_tac thms ctxt else RefineG_Transfer.transfer_tac thms ctxt)) \ "Invoke transfer rules" locale transfer = fixes \ :: "'c \ 'a::complete_lattice" begin text \ In the following, we define some transfer lemmas for general HOL - constructs. \ lemma transfer_if[refine_transfer]: assumes "b \ \ s1 \ S1" assumes "\b \ \ s2 \ S2" shows "\ (if b then s1 else s2) \ (if b then S1 else S2)" using assms by auto lemma transfer_prod[refine_transfer]: assumes "\a b. \ (f a b) \ F a b" shows "\ (case_prod f x) \ (case_prod F x)" using assms by (auto split: prod.split) lemma transfer_Let[refine_transfer]: assumes "\x. \ (f x) \ F x" shows "\ (Let x f) \ Let x F" using assms by auto lemma transfer_option[refine_transfer]: assumes "\ fa \ Fa" assumes "\x. \ (fb x) \ Fb x" shows "\ (case_option fa fb x) \ case_option Fa Fb x" using assms by (auto split: option.split) lemma transfer_sum[refine_transfer]: assumes "\l. \ (fl l) \ Fl l" assumes "\r. \ (fr r) \ Fr r" shows "\ (case_sum fl fr x) \ (case_sum Fl Fr x)" using assms by (auto split: sum.split) lemma transfer_list[refine_transfer]: assumes "\ fn \ Fn" assumes "\x xs. \ (fc x xs) \ Fc x xs" shows "\ (case_list fn fc l) \ case_list Fn Fc l" using assms by (auto split: list.split) lemma transfer_rec_list[refine_transfer]: assumes FN: "\s. \ (fn s) \ fn' s" assumes FC: "\x l rec rec' s. \ \s. \ (rec s) \ (rec' s) \ \ \ (fc x l rec s) \ fc' x l rec' s" shows "\ (rec_list fn fc l s) \ rec_list fn' fc' l s" apply (induct l arbitrary: s) apply (simp add: FN) apply (simp add: FC) done lemma transfer_rec_nat[refine_transfer]: assumes FN: "\s. \ (fn s) \ fn' s" assumes FC: "\n rec rec' s. \ \s. \ (rec s) \ rec' s \ \ \ (fs n rec s) \ fs' n rec' s" shows "\ (rec_nat fn fs n s) \ rec_nat fn' fs' n s" apply (induct n arbitrary: s) apply (simp add: FN) apply (simp add: FC) done end text \Transfer into complete lattice structure\ locale ordered_transfer = transfer + constrains \ :: "'c::complete_lattice \ 'a::complete_lattice" text \Transfer into complete lattice structure with distributive transfer function.\ locale dist_transfer = ordered_transfer + constrains \ :: "'c::complete_lattice \ 'a::complete_lattice" assumes \_dist: "\A. is_chain A \ \ (Sup A) = Sup (\`A)" begin lemma \_mono[simp, intro!]: "mono \" apply rule apply (subgoal_tac "is_chain {x,y}") apply (drule \_dist) apply (auto simp: le_iff_sup) [] apply (rule chainI) apply auto done lemma \_strict[simp]: "\ bot = bot" using \_dist[of "{}"] by simp end text \Transfer into ccpo\ locale ccpo_transfer = transfer \ for \ :: "'c::ccpo \ 'a::complete_lattice" text \Transfer into ccpo with distributive transfer function.\ locale dist_ccpo_transfer = ccpo_transfer \ for \ :: "'c::ccpo \ 'a::complete_lattice" + assumes \_dist: "\A. is_chain A \ \ (Sup A) = Sup (\`A)" begin lemma \_mono[simp, intro!]: "mono \" proof fix x y :: 'c assume LE: "x\y" hence C[simp, intro!]: "is_chain {x,y}" by (auto intro: chainI) from LE have "\ x \ sup (\ x) (\ y)" by simp also have "\ = Sup (\`{x,y})" by simp also have "\ = \ (Sup {x,y})" by (rule \_dist[symmetric]) simp also have "Sup {x,y} = y" apply (rule antisym) apply (rule ccpo_Sup_least[OF C]) using LE apply auto [] apply (rule ccpo_Sup_upper[OF C]) by auto finally show "\ x \ \ y" . qed lemma \_strict[simp]: "\ (Sup {}) = bot" using \_dist[of "{}"] by simp end end diff --git a/thys/Refine_Monadic/Refine_Automation.thy b/thys/Refine_Monadic/Refine_Automation.thy --- a/thys/Refine_Monadic/Refine_Automation.thy +++ b/thys/Refine_Monadic/Refine_Automation.thy @@ -1,555 +1,555 @@ section "More Automation" theory Refine_Automation imports Refine_Basic Refine_Transfer keywords "concrete_definition" :: thy_decl and "prepare_code_thms" :: thy_decl and "uses" begin text \ This theory provides a tool for extracting definitions from terms, and for generating code equations for recursion combinators. \ ML \ signature REFINE_AUTOMATION = sig type extraction = { pattern: term, (* Pattern to be defined as own constant *) gen_thm: thm, (* Code eq generator: [| c==rhs; ... |] ==> c == ... *) gen_tac: local_theory -> tactic' (* Solves remaining premises of gen_thm *) } val extract_as_def: (string * typ) list -> string -> term -> local_theory -> ((term * thm) * local_theory) val extract_recursion_eqs: extraction list -> string -> thm -> local_theory -> local_theory val add_extraction: string -> extraction -> theory -> theory val prepare_code_thms_cmd: string list -> thm -> local_theory -> local_theory val define_concrete_fun: extraction list option -> binding -> Token.src list -> indexname list -> thm -> cterm list -> local_theory -> (thm * thm) * local_theory val mk_qualified: string -> bstring -> binding val prepare_cd_pattern: Proof.context -> cterm -> cterm val add_cd_pattern: cterm -> Context.generic -> Context.generic val del_cd_pattern: cterm -> Context.generic -> Context.generic val get_cd_patterns: Proof.context -> cterm list val add_vc_rec_thm: thm -> Context.generic -> Context.generic val del_vc_rec_thm: thm -> Context.generic -> Context.generic val get_vc_rec_thms: Proof.context -> thm list val add_vc_solve_thm: thm -> Context.generic -> Context.generic val del_vc_solve_thm: thm -> Context.generic -> Context.generic val get_vc_solve_thms: Proof.context -> thm list val vc_solve_tac: Proof.context -> bool -> tactic' val vc_solve_modifiers: Method.modifier parser list val setup: theory -> theory end structure Refine_Automation :REFINE_AUTOMATION = struct type extraction = { pattern: term, (* Pattern to be defined as own constant *) gen_thm: thm, (* Code eq generator: [| c==rhs; ... |] ==> c == ... *) gen_tac: local_theory -> tactic' (* Solves remaining premises of gen_thm *) } - structure extractions = Generic_Data ( + structure extractions = Generic_Data + ( type T = extraction list Symtab.table val empty = Symtab.empty - val extend = I val merge = Symtab.merge_list ((op =) o apply2 #pattern) ) fun add_extraction name ex = Context.theory_map (extractions.map ( Symtab.update_list ((op =) o apply2 #pattern) (name,ex))) (* Define new constant name for subterm t in context bnd. Returns replacement for t using the new constant and definition theorem. *) fun extract_as_def bnd name t lthy = let val loose = rev (loose_bnos t); val rnames = #1 (Variable.names_of lthy |> fold_map (Name.variant o #1) bnd); val rfrees = map (fn (name,(_,typ)) => Free (name,typ)) (rnames ~~ bnd); val t' = subst_bounds (rfrees,t); val params = map Bound (rev loose); val param_vars = (Library.foldl (fn (l,i) => nth rfrees i :: l) ([],loose)); val param_types = map fastype_of param_vars; val def_t = Logic.mk_equals (list_comb (Free (name,param_types ---> fastype_of t'),param_vars),t'); val ((lhs_t,(_,def_thm)),lthy) = Specification.definition NONE [] [] (Binding.empty_atts,def_t) lthy; (*val _ = tracing "xxxx";*) val app_t = list_comb (lhs_t, params); in ((app_t,def_thm),lthy) end; fun mk_qualified basename q = Binding.qualify true basename (Binding.name q); fun extract_recursion_eqs exs basename orig_def_thm lthy = let val thy = Proof_Context.theory_of lthy val pat_net : extraction Item_Net.T = Item_Net.init ((op =) o apply2 #pattern) (fn {pattern, ...} => [pattern]) |> fold Item_Net.update exs local fun tr env t ctx = let (* Recurse for subterms *) val (t,ctx) = case t of t1$t2 => let val (t1,ctx) = tr env t1 ctx val (t2,ctx) = tr env t2 ctx in (t1$t2,ctx) end | Abs (x,T,t) => let val (t',ctx) = tr ((x,T)::env) t ctx in (Abs (x,T,t'),ctx) end | _ => (t,ctx) (* Check if we match a pattern *) val ex = Item_Net.retrieve_matching pat_net t |> get_first (fn ex => case try (Pattern.first_order_match thy (#pattern ex,t)) (Vartab.empty,Vartab.empty) of NONE => NONE | SOME _ => SOME ex ) in case ex of NONE => (t,ctx) | SOME ex => let (* Extract as new constant *) val (idx,defs,lthy) = ctx val name = (basename ^ "_" ^ string_of_int idx) val ((t,def_thm),lthy) = extract_as_def env name t lthy val ctx = (idx+1,(def_thm,ex)::defs,lthy) in (t,ctx) end end in fun transform t lthy = let val (t,(_,defs,lthy)) = tr [] t (0,[],lthy) in ((t,defs),lthy) end end (* Import theorem and extract RHS *) val ((_,orig_def_thm'),lthy) = yield_singleton2 (Variable.import true) orig_def_thm lthy; val (lhs,rhs) = orig_def_thm' |> Thm.prop_of |> Logic.dest_equals; (* Transform RHS, generating new constants *) val ((rhs',defs),lthy) = transform rhs lthy; val def_thms = map #1 defs (* Register definitions of generated constants *) val (_,lthy) = Local_Theory.note ((mk_qualified basename "defs",[]),def_thms) lthy; (* Obtain new def_thm *) val def_unfold_ss = put_simpset HOL_basic_ss lthy addsimps (orig_def_thm::def_thms) val new_def_thm = Goal.prove_internal lthy [] (Logic.mk_equals (lhs,rhs') |> Thm.cterm_of lthy) (K (simp_tac def_unfold_ss 1)) (* Obtain new theorem by folding with defs of generated constants *) (* TODO: Maybe cleaner to generate eq-thm and prove by "unfold, refl" *) (*val new_def_thm = Library.foldr (fn (dt,t) => Local_Defs.fold lthy [dt] t) (def_thms,orig_def_thm');*) (* Prepare code equations *) fun mk_code_thm lthy (def_thm,{gen_thm, gen_tac, ...}) = let val ((_,def_thm),lthy') = yield_singleton2 (Variable.import true) def_thm lthy; val thm = def_thm RS gen_thm; val tac = SOLVED' (gen_tac lthy') ORELSE' (simp_tac def_unfold_ss THEN' gen_tac lthy') val thm = the (SINGLE (ALLGOALS tac) thm); val thm = singleton (Variable.export lthy' lthy) thm; in thm end; val code_thms = map (mk_code_thm lthy) defs; val _ = if forall Thm.no_prems code_thms then () else warning "Unresolved premises in code theorems" val (_,lthy) = Local_Theory.note ((mk_qualified basename "code",@{attributes [code]}),new_def_thm::code_thms) lthy; in lthy end; fun prepare_code_thms_cmd names thm lthy = let fun name_of (Const (n,_)) = n | name_of (Free (n,_)) = n | name_of _ = raise (THM ("No definitional theorem",0,[thm])); val (lhs,_) = thm |> Thm.prop_of |> Logic.dest_equals; val basename = lhs |> strip_comb |> #1 |> name_of |> Long_Name.base_name; val exs_tab = extractions.get (Context.Proof lthy) fun get_exs name = case Symtab.lookup exs_tab name of NONE => error ("No such extraction mode: " ^ name) | SOME exs => exs val exs = case names of [] => Symtab.dest_list exs_tab |> map #2 | _ => map get_exs names |> flat val _ = case exs of [] => error "No extraction patterns selected" | _ => () val lthy = extract_recursion_eqs exs basename thm lthy in lthy end; fun extract_concrete_fun _ [] concl = raise TERM ("Conclusion does not match any extraction pattern",[concl]) | extract_concrete_fun thy (pat::pats) concl = ( case Refine_Util.fo_matchp thy pat concl of NONE => extract_concrete_fun thy pats concl | SOME [t] => t | SOME (t::_) => ( warning ("concrete_definition: Pattern has multiple holes, taking " ^ "first one: " ^ @{make_string} pat ); t) | _ => (warning ("concrete_definition: Ignoring invalid pattern " ^ @{make_string} pat); extract_concrete_fun thy pats concl) ) (* Define concrete function from refinement lemma *) fun define_concrete_fun gen_code fun_name attribs_raw param_names thm pats (orig_lthy:local_theory) = let val lthy = orig_lthy; val (((_,inst),thm'),lthy) = yield_singleton2 (Variable.import true) thm lthy; val concl = thm' |> Thm.concl_of (*val ((typ_subst,term_subst),lthy) = Variable.import_inst true [concl] lthy; val concl = Term_Subst.instantiate (typ_subst,term_subst) concl; *) val term_subst = build (inst |> Vars.fold (cons o apsnd Thm.term_of)) val param_terms = map (fn name => case AList.lookup (fn (n,v) => n = #1 v) term_subst name of NONE => raise TERM ("No such variable: " ^Term.string_of_vname name,[concl]) | SOME t => t ) param_names; val f_term = extract_concrete_fun (Proof_Context.theory_of lthy) pats concl; val lhs_type = map Term.fastype_of param_terms ---> Term.fastype_of f_term; val lhs_term = list_comb ((Free (Binding.name_of fun_name,lhs_type)),param_terms); val def_term = Logic.mk_equals (lhs_term,f_term) |> fold Logic.all param_terms; val attribs = map (Attrib.check_src lthy) attribs_raw; val ((_,(_,def_thm)),lthy) = Specification.definition (SOME (fun_name,NONE,Mixfix.NoSyn)) [] [] ((Binding.empty,attribs),def_term) lthy; val folded_thm = Local_Defs.fold lthy [def_thm] thm'; val (_,lthy) = Local_Theory.note ((mk_qualified (Binding.name_of fun_name) "refine",[]),[folded_thm]) lthy; val lthy = case gen_code of NONE => lthy | SOME modes => extract_recursion_eqs modes (Binding.name_of fun_name) def_thm lthy in ((def_thm,folded_thm),lthy) end; val cd_pat_eq = apply2 (Thm.term_of #> Refine_Util.anorm_term) #> (op aconv) - structure cd_patterns = Generic_Data ( + structure cd_patterns = Generic_Data + ( type T = cterm list val empty = [] - val extend = I val merge = merge cd_pat_eq ) fun prepare_cd_pattern ctxt pat = case Thm.term_of pat |> fastype_of of @{typ bool} => Thm.term_of pat |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt | _ => pat fun add_cd_pattern pat context = cd_patterns.map (insert cd_pat_eq (prepare_cd_pattern (Context.proof_of context) pat)) context fun del_cd_pattern pat context = cd_patterns.map (remove cd_pat_eq (prepare_cd_pattern (Context.proof_of context) pat)) context val get_cd_patterns = cd_patterns.get o Context.Proof structure rec_thms = Named_Thms ( val name = @{binding vcs_rec} val description = "VC-Solver: Recursive intro rules" ) structure solve_thms = Named_Thms ( val name = @{binding vcs_solve} val description = "VC-Solver: Solve rules" ) val add_vc_rec_thm = rec_thms.add_thm val del_vc_rec_thm = rec_thms.del_thm val get_vc_rec_thms = rec_thms.get val add_vc_solve_thm = solve_thms.add_thm val del_vc_solve_thm = solve_thms.del_thm val get_vc_solve_thms = solve_thms.get val rec_modifiers = [ Args.$$$ "rec" -- Scan.option Args.add -- Args.colon >> K (Method.modifier rec_thms.add \<^here>), Args.$$$ "rec" -- Scan.option Args.del -- Args.colon >> K (Method.modifier rec_thms.del \<^here>) ]; val solve_modifiers = [ Args.$$$ "solve" -- Scan.option Args.add -- Args.colon >> K (Method.modifier solve_thms.add \<^here>), Args.$$$ "solve" -- Scan.option Args.del -- Args.colon >> K (Method.modifier solve_thms.del \<^here>) ]; val vc_solve_modifiers = clasimp_modifiers @ rec_modifiers @ solve_modifiers; fun vc_solve_tac ctxt no_pre = let val rthms = rec_thms.get ctxt val sthms = solve_thms.get ctxt val pre_tac = if no_pre then K all_tac else clarsimp_tac ctxt val tac = SELECT_GOAL (auto_tac ctxt) in TRY o pre_tac THEN_ALL_NEW_FWD (TRY o REPEAT_ALL_NEW_FWD (resolve_tac ctxt rthms)) THEN_ALL_NEW_FWD (TRY o SOLVED' (resolve_tac ctxt sthms THEN_ALL_NEW_FWD tac)) end val setup = I #> rec_thms.setup #> solve_thms.setup end; \ setup Refine_Automation.setup setup \ let fun parse_cpat cxt = let val (t, (context, tks)) = Scan.lift Args.embedded_inner_syntax cxt val ctxt = Context.proof_of context val t = Proof_Context.read_term_pattern ctxt t in (Thm.cterm_of ctxt t, (context, tks)) end fun do_p f = Scan.repeat1 parse_cpat >> (fn pats => Thm.declaration_attribute (K (fold f pats))) in Attrib.setup @{binding "cd_patterns"} ( Scan.lift Args.add |-- do_p Refine_Automation.add_cd_pattern || Scan.lift Args.del |-- do_p Refine_Automation.del_cd_pattern || do_p Refine_Automation.add_cd_pattern ) "Add/delete concrete_definition pattern" end \ (* Command setup *) (* TODO: Folding of .refine-lemma seems not to work, if the function has parameters on which it does not depend *) ML \Outer_Syntax.local_theory @{command_keyword concrete_definition} "Define function from refinement theorem" (Parse.binding -- Parse.opt_attribs -- Scan.optional (@{keyword "for"} |-- Scan.repeat1 Args.var) [] --| @{keyword "uses"} -- Parse.thm -- Scan.optional (@{keyword "is"} |-- Scan.repeat1 Args.embedded_inner_syntax) [] >> (fn ((((name,attribs),params),raw_thm),pats) => fn lthy => let val thm = case Attrib.eval_thms lthy [raw_thm] of [thm] => thm | _ => error "Expecting exactly one theorem"; val pats = case pats of [] => Refine_Automation.get_cd_patterns lthy | l => map (Proof_Context.read_term_pattern lthy #> Thm.cterm_of lthy #> Refine_Automation.prepare_cd_pattern lthy) l in Refine_Automation.define_concrete_fun NONE name attribs params thm pats lthy |> snd end)) \ text \ Command: \concrete_definition name [attribs] for params uses thm is patterns\ where \attribs\, \for\, and \is\-parts are optional. Declares a new constant \name\ by matching the theorem \thm\ against a pattern. If the \for\ clause is given, it lists variables in the theorem, and thus determines the order of parameters of the defined constant. Otherwise, parameters will be in order of occurrence. If the \is\ clause is given, it lists patterns. The conclusion of the theorem will be matched against each of these patterns. For the first matching pattern, the constant will be declared to be the term that matches the first non-dummy variable of the pattern. If no \is\-clause is specified, the default patterns will be tried. Attribute: \cd_patterns pats\. Declaration attribute. Declares default patterns for the \concrete_definition\ command. \ declare [[ cd_patterns "(?f,_)\_"]] declare [[ cd_patterns "RETURN ?f \ _" "nres_of ?f \ _"]] declare [[ cd_patterns "(RETURN ?f,_)\_" "(nres_of ?f,_)\_"]] declare [[ cd_patterns "_ = ?f" "_ == ?f" ]] ML \ let val modes = (Scan.optional (@{keyword "("} |-- Parse.list1 Parse.name --| @{keyword ")"}) []) in Outer_Syntax.local_theory @{command_keyword prepare_code_thms} "Refinement framework: Prepare theorems for code generation" (modes -- Parse.thms1 >> (fn (modes,raw_thms) => fn lthy => let val thms = Attrib.eval_thms lthy raw_thms in fold (Refine_Automation.prepare_code_thms_cmd modes) thms lthy end) ) end \ text \ Command: \prepare_code_thms (modes) thm\ where the \(mode)\-part is optional. Set up code-equations for recursions in constant defined by \thm\. The optional \modes\ is a comma-separated list of extraction modes. \ lemma gen_code_thm_RECT: fixes x assumes D: "f \ RECT B" assumes M: "trimono B" shows "f x \ B f x" unfolding D apply (subst RECT_unfold) by (rule M) lemma gen_code_thm_REC: fixes x assumes D: "f \ REC B" assumes M: "trimono B" shows "f x \ B f x" unfolding D apply (subst REC_unfold) by (rule M) setup \ Refine_Automation.add_extraction "nres" { pattern = Logic.varify_global @{term "REC x"}, gen_thm = @{thm gen_code_thm_REC}, gen_tac = Refine_Mono_Prover.mono_tac } #> Refine_Automation.add_extraction "nres" { pattern = Logic.varify_global @{term "RECT x"}, gen_thm = @{thm gen_code_thm_RECT}, gen_tac = Refine_Mono_Prover.mono_tac } \ text \ Method \vc_solve (no_pre) clasimp_modifiers rec (add/del): ... solve (add/del): ...\ Named theorems \vcs_rec\ and \vcs_solve\. This method is specialized to solve verification conditions. It first clarsimps all goals, then it tries to apply a set of safe introduction rules (\vcs_rec\, \rec add\). Finally, it applies introduction rules (\vcs_solve\, \solve add\) and tries to discharge all emerging subgoals by auto. If this does not succeed, it backtracks over the application of the solve-rule. \ method_setup vc_solve = \Scan.lift (Args.mode "nopre") --| Method.sections Refine_Automation.vc_solve_modifiers >> (fn (nopre) => fn ctxt => SIMPLE_METHOD ( CHANGED (ALLGOALS (Refine_Automation.vc_solve_tac ctxt nopre)) ))\ "Try to solve verification conditions" end diff --git a/thys/Show/show_generator.ML b/thys/Show/show_generator.ML --- a/thys/Show/show_generator.ML +++ b/thys/Show/show_generator.ML @@ -1,445 +1,446 @@ (* Title: Show Author: Christian Sternagel Author: René Thiemann Maintainer: Christian Sternagel Maintainer: René Thiemann Generate/register show functions for arbitrary types. Precedence is used to determine parenthesization of subexpressions. In the automatically generated functions 0 means "no parentheses" and 1 means "parenthesize". *) signature SHOW_GENERATOR = sig (*generate show functions for the given datatype*) val generate_showsp : string -> local_theory -> local_theory val register_foreign_partial_and_full_showsp : string -> (*type name*) int -> (*default precedence for type parameters*) term -> (*partial show function*) term -> (*show function*) thm option -> (*definition of show function via partial show function*) term -> (*map function*) thm option -> (*compositionality theorem of map function*) bool list -> (*indicate which positions of type parameters are used*) thm -> (*show law intro rule*) local_theory -> local_theory (*for type constants (i.e., nullary type constructors) partial and full show functions coincide and no other information is necessary.*) val register_foreign_showsp : typ -> term -> thm -> local_theory -> local_theory (*automatically derive a "show" class instance for the given datatype*) val show_instance : string -> theory -> theory end structure Show_Generator : SHOW_GENERATOR = struct open Generator_Aux val mk_prec = HOLogic.mk_number @{typ nat} val prec0 = mk_prec 0 val prec1 = mk_prec 1 val showS = @{sort "show"} val showsT = @{typ "shows"} fun showspT T = @{typ nat} --> T --> showsT val showsify_typ = map_atyps (K showsT) val showsify = map_types showsify_typ fun show_law_const T = \<^Const>\show_law T\ fun shows_prec_const T = \<^Const>\shows_prec T\ fun shows_list_const T = \<^Const>\shows_list T\ fun showsp_list_const T = \<^Const>\showsp_list T\ val dest_showspT = binder_types #> tl #> hd type info = {prec : int, pshowsp : term, showsp : term, show_def : thm option, map : term, map_comp : thm option, used_positions : bool list, show_law_intro : thm} structure Data = Generic_Data - (type T = info Symtab.table - val empty = Symtab.empty - val extend = I - val merge = Symtab.merge (fn (info1, info2) => #pshowsp info1 = #pshowsp info2)) +( + type T = info Symtab.table + val empty = Symtab.empty + val merge = Symtab.merge (fn (info1, info2) => #pshowsp info1 = #pshowsp info2) +) fun add_info tyco info = Data.map (Symtab.update_new (tyco, info)) val get_info = Context.Proof #> Data.get #> Symtab.lookup fun the_info ctxt tyco = (case get_info ctxt tyco of SOME info => info | NONE => error ("no show function available for type " ^ quote tyco)) fun declare_info tyco p pshow show show_def m m_comp used_pos law_thm = Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => add_info tyco {prec = p, pshowsp = Morphism.term phi pshow, showsp = Morphism.term phi show, show_def = Option.map (Morphism.thm phi) show_def, map = Morphism.term phi m, map_comp = Option.map (Morphism.thm phi) m_comp, used_positions = used_pos, show_law_intro = Morphism.thm phi law_thm}) val register_foreign_partial_and_full_showsp = declare_info fun register_foreign_showsp T show = let val tyco = (case T of Type (tyco, []) => tyco | _ => error "expected type constant") in register_foreign_partial_and_full_showsp tyco 0 show show NONE (HOLogic.id_const T) NONE [] end fun shows_string c = \<^Const>\shows_string for \HOLogic.mk_string (Long_Name.base_name c)\\ fun mk_shows_parens _ [t] = t | mk_shows_parens p ts = Library.foldl1 HOLogic.mk_comp (\<^Const>\shows_pl for p\ :: separate \<^Const>\shows_space\ ts @ [\<^Const>\shows_pr for p\]) fun simp_only_tac ctxt ths = CHANGED o full_simp_tac (clear_simpset (put_simpset HOL_basic_ss ctxt) addsimps ths) fun generate_showsp tyco lthy = let val (tycos, Ts) = mutual_recursive_types tyco lthy val _ = map (fn tyco => "generating show function for type " ^ quote tyco) tycos |> cat_lines |> writeln val maps = Bnf_Access.map_terms lthy tycos val map_simps = Bnf_Access.map_simps lthy tycos val map_comps = Bnf_Access.map_comps lthy tycos val (tfrees, used_tfrees) = type_parameters (hd Ts) lthy val used_positions = map (member (op =) used_tfrees o TFree) tfrees val ss = map (subT "show") used_tfrees val show_Ts = map showspT used_tfrees val arg_shows = map Free (ss ~~ show_Ts) val dep_tycos = fold (add_used_tycos lthy) tycos [] fun mk_pshowsp (tyco, T) = ("pshowsp_" ^ Long_Name.base_name tyco, showspT T |> showsify_typ) fun default_show T = absdummy T (mk_id @{typ string}) fun constr_terms lthy = Bnf_Access.constr_terms lthy #> map (apsnd (fst o strip_type) o dest_Const) (* primrec definitions of partial show functions *) fun generate_pshow_eqs lthy (tyco, T) = let val constrs = constr_terms lthy tyco |> map (fn (c, Ts) => let val Ts' = map showsify_typ Ts in (Const (c, Ts' ---> T) |> showsify, Ts') end) fun shows_arg (x, T) = let val m = Generator_Aux.create_map default_show (fn (tyco, T) => fn p => Free (mk_pshowsp (tyco, T)) $ p) prec1 (equal @{typ "shows"}) (#used_positions oo the_info) (#map oo the_info) (curry (op $) o #pshowsp oo the_info) tycos (mk_prec o #prec oo the_info) T lthy val pshow = Generator_Aux.create_partial prec1 (equal @{typ "shows"}) (#used_positions oo the_info) (#map oo the_info) (curry (op $) o #pshowsp oo the_info) tycos (mk_prec o #prec oo the_info) T lthy in pshow $ (m $ Free (x, T)) |> infer_type lthy end fun generate_eq lthy (c, arg_Ts) = let val (p, xs) = Name.variant "p" (Variable.names_of lthy) |>> Free o rpair @{typ nat} ||> (fn ctxt => Name.invent_names ctxt "x" arg_Ts) val lhs = Free (mk_pshowsp (tyco, T)) $ p $ list_comb (c, map Free xs) val rhs = shows_string (dest_Const c |> fst) :: map shows_arg xs |> mk_shows_parens p in HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) end in map (generate_eq lthy) constrs end val eqs = map (generate_pshow_eqs lthy) (tycos ~~ Ts) |> flat val bindings = tycos ~~ Ts |> map mk_pshowsp |> map (fn (name, T) => (Binding.name name, T |> showsify_typ |> SOME, NoSyn)) val ((pshows, pshow_simps), lthy) = lthy |> Local_Theory.begin_nested |> snd |> BNF_LFP_Rec_Sugar.primrec false [] bindings (map (fn t => ((Binding.empty_atts, t), [], [])) eqs) |> Local_Theory.end_nested_result (fn phi => fn (pshows, _, pshow_simps) => (map (Morphism.term phi) pshows, map (Morphism.fact phi) pshow_simps)) (* definitions of show functions via partial show functions and map *) fun generate_show_defs tyco lthy = let val ss = map (subT "show") used_tfrees val arg_Ts = map showspT used_tfrees val arg_shows = map Free (ss ~~ arg_Ts) val p = Name.invent (Variable.names_of lthy) "p" 1 |> the_single |> Free o rpair @{typ nat} val (pshow, m) = AList.lookup (op =) (tycos ~~ (pshows ~~ maps)) tyco |> the val ts = tfrees |> map TFree |> map (fn T => AList.lookup (op =) (used_tfrees ~~ map (fn x => x $ prec1) arg_shows) T |> the_default (default_show T)) val args = arg_shows @ [p] val rhs = HOLogic.mk_comp (pshow $ p, list_comb (m, ts)) |> infer_type lthy val abs_def = fold_rev lambda args rhs val name = "showsp_" ^ Long_Name.base_name tyco val ((showsp, (_, prethm)), lthy) = Local_Theory.define ((Binding.name name, NoSyn), (Binding.empty_atts, abs_def)) lthy val eq = Logic.mk_equals (list_comb (showsp, args), rhs) val thm = Goal.prove_future lthy (map (fst o dest_Free) args) [] eq (K (unfold_tac lthy [prethm])) in Local_Theory.note ((Binding.name (name ^ "_def"), []), [thm]) lthy |>> the_single o snd |>> `(K showsp) end val ((shows, show_defs), lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_show_defs tycos |>> split_list |> Local_Theory.end_nested_result (fn phi => fn (shows, show_defs) => (map (Morphism.term phi) shows, map (Morphism.thm phi) show_defs)) (* alternative simp-rules for show functions *) fun generate_show_simps (tyco, T) lthy = let val constrs = constr_terms lthy tyco |> map (apsnd (map freeify_tvars)) |> map (fn (c, Ts) => (Const (c, Ts ---> T), Ts)) fun shows_arg (x, T) = let fun create_show (T as TFree _) = AList.lookup (op =) (used_tfrees ~~ arg_shows) T |> the | create_show (Type (tyco, Ts)) = (case AList.lookup (op =) (tycos ~~ shows) tyco of SOME show_const => list_comb (show_const, arg_shows) | NONE => let val {showsp = s, used_positions = up, ...} = the_info lthy tyco val ts = (up ~~ Ts) |> map_filter (fn (b, T) => if b then SOME (create_show T) else NONE) in list_comb (s, ts) end) | create_show T = error ("unexpected schematic variable " ^ quote (Syntax.string_of_typ lthy T)) val show = create_show T |> infer_type lthy in show $ prec1 $ Free (x, T) end fun generate_eq_thm lthy (c, arg_Ts) = let val (p, xs) = Name.variant "p" (Variable.names_of lthy) |>> Free o rpair @{typ nat} ||> (fn ctxt => Name.invent_names ctxt "x" arg_Ts) val show_const = AList.lookup (op =) (tycos ~~ shows) tyco |> the val lhs = list_comb (show_const, arg_shows) $ p $ list_comb (c, map Free xs) val rhs = shows_string (dest_Const c |> fst) :: map shows_arg xs |> mk_shows_parens p val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy val dep_show_defs = map_filter (#show_def o the_info lthy) dep_tycos val dep_map_comps = map_filter (#map_comp o the_info lthy) dep_tycos val thm = Goal.prove_future lthy (fst (dest_Free p) :: map fst xs @ ss) [] eq (fn {context = ctxt, ...} => unfold_tac ctxt (@{thms id_def o_def} @ flat pshow_simps @ dep_map_comps @ show_defs @ dep_show_defs @ flat map_simps)) in thm end val thms = map (generate_eq_thm lthy) constrs val name = "showsp_" ^ Long_Name.base_name tyco in lthy |> Local_Theory.note ((Binding.name (name ^ "_simps"), @{attributes [simp, code]}), thms) |> apfst snd end val (show_simps, lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_show_simps (tycos ~~ Ts) |> Local_Theory.end_nested_result (fn phi => map (Morphism.fact phi)) (* show law theorems *) val induct_thms = Bnf_Access.induct_thms lthy tycos val set_simps = Bnf_Access.set_simps lthy tycos val sets = Bnf_Access.set_terms lthy tycos fun generate_show_law_thms (tyco, x) = let val sets = AList.lookup (op =) (tycos ~~ sets) tyco |> the val used_sets = map (the o AList.lookup (op =) (map TFree tfrees ~~ sets)) used_tfrees fun mk_prem ((show, set), T) = let (*val y = singleton (Name.variant_list [fst x]) "y" |> Free o rpair T*) val y = Free (subT "x" T, T) val lhs = HOLogic.mk_mem (y, set $ Free x) |> HOLogic.mk_Trueprop val rhs = show_law_const T $ show $ y |> HOLogic.mk_Trueprop in Logic.all y (Logic.mk_implies (lhs, rhs)) end val prems = map mk_prem (arg_shows ~~ used_sets ~~ used_tfrees) val (show_const, T) = AList.lookup (op =) (tycos ~~ (shows ~~ Ts)) tyco |> the val concl = show_law_const T $ list_comb (show_const, arg_shows) $ Free x |> HOLogic.mk_Trueprop in Logic.list_implies (prems, concl) |> infer_type lthy end val xs = Name.invent_names (Variable.names_of lthy) "x" Ts val show_law_prethms = map generate_show_law_thms (tycos ~~ xs) val rec_info = (the_info lthy, #used_positions, tycos) val split_IHs = split_IHs rec_info val recursor_tac = std_recursor_tac rec_info used_tfrees #show_law_intro fun show_law_tac ctxt xs = let val constr_Ts = tycos |> map (#ctrXs_Tss o #fp_ctr_sugar o the o BNF_FP_Def_Sugar.fp_sugar_of ctxt) val ind_case_to_idxs = let fun number n (i, j) ((_ :: xs) :: ys) = (n, (i, j)) :: number (n + 1) (i, j + 1) (xs :: ys) | number n (i, _) ([] :: ys) = number n (i + 1, 0) ys | number _ _ [] = [] in AList.lookup (op =) (number 0 (0, 0) constr_Ts) #> the end fun instantiate_IHs IHs assms = map (fn IH => OF_option IH (replicate (Thm.nprems_of IH - length assms) NONE @ map SOME assms)) IHs fun induct_tac ctxt f = (DETERM o Induction.induction_tac ctxt false (map (fn x => [SOME (NONE, (x, false))]) xs) [] [] (SOME induct_thms) []) THEN_ALL_NEW (fn st => Subgoal.SUBPROOF (fn {context = ctxt, prems, params, ...} => f ctxt (st - 1) prems params) ctxt st) (*do not use full "show_law_simps" here, since otherwise too many subgoals might be solved (so that the number of subgoals does no longer match the number of IHs)*) val show_law_simps_less = @{thms shows_string_append shows_pl_append shows_pr_append shows_space_append} fun o_append_intro_tac ctxt f = HEADGOAL ( K (Method.try_intros_tac ctxt @{thms o_append} []) THEN_ALL_NEW K (unfold_tac ctxt show_law_simps_less) THEN_ALL_NEW (fn i => Subgoal.SUBPROOF (fn {context = ctxt', ...} => f (i - 1) ctxt') ctxt i)) fun solve_tac ctxt case_num prems params = let val (i, _) = ind_case_to_idxs case_num (*(constructor number, argument number)*) val k = length prems - length used_tfrees val (IHs, assms) = chop k prems in resolve_tac ctxt @{thms show_lawI} 1 THEN Subgoal.FOCUS (fn {context = ctxt, ...} => let val assms = map (Local_Defs.unfold ctxt (nth set_simps i)) assms val Ts = map (fastype_of o Thm.term_of o snd) params val IHs = instantiate_IHs IHs assms |> split_IHs Ts in unfold_tac ctxt (nth show_simps i) THEN o_append_intro_tac ctxt (fn i => fn ctxt' => resolve_tac ctxt' @{thms show_lawD} 1 THEN recursor_tac assms (nth Ts i) (nth IHs i) ctxt') end) ctxt 1 end in induct_tac ctxt solve_tac end val show_law_thms = prove_multi_future lthy (map fst xs @ ss) [] show_law_prethms (fn {context = ctxt, ...} => HEADGOAL (show_law_tac ctxt (map Free xs))) val (show_law_thms, lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map (fn (tyco, thm) => Local_Theory.note ((Binding.name ("show_law_" ^ Long_Name.base_name tyco), @{attributes [show_law_intros]}), [thm]) #> apfst (the_single o snd)) (tycos ~~ show_law_thms) |> Local_Theory.end_nested_result Morphism.fact in lthy |> fold (fn ((((((tyco, pshow), show), show_def), m), m_comp), law_thm) => declare_info tyco 1 pshow show (SOME show_def) m (SOME m_comp) used_positions law_thm) (tycos ~~ pshows ~~ shows ~~ show_defs ~~ maps ~~ map_comps ~~ show_law_thms) end fun ensure_info tyco lthy = (case get_info lthy tyco of SOME _ => lthy | NONE => generate_showsp tyco lthy) (* proving show instances *) fun dest_showsp showsp = dest_Const showsp ||> ( binder_types #> chop_prefix (fn T => T <> @{typ nat}) #>> map (freeify_tvars o dest_showspT) ##> map (dest_TFree o freeify_tvars) o snd o dest_Type o hd o tl) fun show_instance tyco thy = let val _ = Sorts.has_instance (Sign.classes_of thy) tyco showS andalso error ("type " ^ quote tyco ^ " is already an instance of class \"show\"") val _ = writeln ("deriving \"show\" instance for type " ^ quote tyco) val thy = Named_Target.theory_map (ensure_info tyco) thy val lthy = Named_Target.theory_init thy val {showsp, ...} = the_info lthy tyco val (showspN, (used_tfrees, tfrees)) = dest_showsp showsp val tfrees' = tfrees |> map (fn (x, S) => if member (op =) used_tfrees (TFree (x, S)) then (x, showS) else (x, S)) val used_tfrees' = map (dest_TFree #> fst #> rpair showS #> TFree) used_tfrees val T = Type (tyco, map TFree tfrees') val arg_Ts = map showspT used_tfrees' val showsp' = Const (showspN, arg_Ts ---> showspT T) val shows_prec_def = Logic.mk_equals (shows_prec_const T, list_comb (showsp', map shows_prec_const used_tfrees')) val shows_list_def = Logic.mk_equals (shows_list_const T, showsp_list_const T $ shows_prec_const T $ prec0) val name = Long_Name.base_name tyco val ((shows_prec_thm, shows_list_thm), lthy) = Class.instantiation ([tyco], tfrees', showS) thy |> Generator_Aux.define_overloaded_generic ((Binding.name ("shows_prec_" ^ name ^ "_def"), @{attributes [code]}), shows_prec_def) ||>> Generator_Aux.define_overloaded_generic ((Binding.name ("shows_list_" ^ name ^ "_def"), @{attributes [code]}), shows_list_def) in Class.prove_instantiation_exit (fn ctxt => let val show_law_intros = Named_Theorems.get ctxt @{named_theorems "show_law_intros"} val show_law_simps = Named_Theorems.get ctxt @{named_theorems "show_law_simps"} val show_append_tac = resolve_tac ctxt @{thms show_lawD} THEN' REPEAT_ALL_NEW (resolve_tac ctxt show_law_intros) THEN_ALL_NEW ( resolve_tac ctxt @{thms show_lawI} THEN' simp_only_tac ctxt show_law_simps) in Class.intro_classes_tac ctxt [] THEN unfold_tac ctxt [shows_prec_thm, shows_list_thm] THEN REPEAT1 (HEADGOAL show_append_tac) end) lthy end val _ = Theory.setup (Derive_Manager.register_derive "show" "generate show instance" (K o show_instance)) end diff --git a/thys/Simpl/hoare.ML b/thys/Simpl/hoare.ML --- a/thys/Simpl/hoare.ML +++ b/thys/Simpl/hoare.ML @@ -1,3408 +1,3403 @@ (* Title: hoare.ML Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2007 Norbert Schirmer This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) signature HOARE = sig datatype hoareMode = Partial | Total val gen_proc_rec: Proof.context -> hoareMode -> int -> thm datatype state_kind = Record | Function datatype par_kind = In | Out val deco: string val proc_deco: string val par_deco: string -> string val chopsfx: string -> string -> string val is_state_var: string -> bool val extern: Proof.context -> string -> string val remdeco: Proof.context -> string -> string val remdeco': string -> string val undeco: Proof.context -> term -> term val varname: string -> string val resuffix: string -> string -> string -> string type proc_info = {params: ((par_kind * string) list), recursive: bool, state_kind: state_kind} type hoare_tac = (bool -> int -> tactic) -> Proof.context -> hoareMode -> int -> tactic type hoare_data = {proc_info: proc_info Symtab.table, active_procs: string list list, default_state_kind: state_kind, generate_guard: (stamp * (Proof.context -> term -> term option)), wp_tacs: (string * hoare_tac) list, hoare_tacs: (string * hoare_tac) list, vcg_simps: thm list} val get_data: Proof.context -> hoare_data val get_params: string -> Proof.context -> (par_kind * string) list option val get_default_state_kind: Proof.context -> state_kind val get_state_kind: string -> Proof.context -> state_kind option val clique_name: string list -> string val install_generate_guard: (Proof.context -> term -> term option) -> Context.generic -> Context.generic val generate_guard: Proof.context -> term -> term option val BasicSimpTac: Proof.context -> state_kind -> bool -> thm list -> (int -> tactic) -> int -> tactic val hoare: (Proof.context -> Proof.method) context_parser val hoare_raw: (Proof.context -> Proof.method) context_parser val vcg: (Proof.context -> Proof.method) context_parser val vcg_step: (Proof.context -> Proof.method) context_parser val hoare_rule: (Proof.context -> Proof.method) context_parser val add_foldcongsimps: thm list -> theory -> theory val get_foldcong_ss : theory -> simpset val add_foldcongs : thm list -> theory -> theory val modeqN : string val modexN : string val implementationN : string val specL : string val vcg_tac : string -> string -> string list -> Proof.context -> int -> tactic val hoare_rule_tac : Proof.context -> thm list -> int -> tactic datatype 'a bodykind = BodyTyp of 'a | BodyTerm of 'a val proc_specs : (bstring * string) list parser val add_params : morphism -> string -> (par_kind * string) list -> Context.generic -> Context.generic val set_default_state_kind : state_kind -> Context.generic -> Context.generic val add_state_kind : morphism -> string -> state_kind -> Context.generic -> Context.generic val add_recursive : morphism -> string -> Context.generic -> Context.generic end; structure Hoare: HOARE = struct (* Misc *) val record_vanish = Attrib.setup_config_bool @{binding hoare_record_vanish} (K true); val use_generalise = Attrib.setup_config_bool @{binding hoare_use_generalise} (K false); val sort_variables = Attrib.setup_config_bool @{binding hoare_sort_variables} (K true); val use_cond_inv_modifies = Attrib.setup_config_bool @{binding hoare_use_cond_inv_modifies} (K true); val hoare_trace = Attrib.setup_config_bool @{binding hoare_trace} (K false); val body_def_sfx = "_body"; val programN = "\"; val hoare_ctxtL = "hoare"; val specL = "_spec"; val procL = "_proc"; val bodyP = "_impl"; val modifysfx = "_modifies"; val modexN = "Hoare.mex"; val modeqN = "Hoare.meq"; val KNF = @{const_name StateFun.K_statefun}; (* Some abstract syntax operations *) val Trueprop = HOLogic.mk_Trueprop; infix 0 ===; val (op ===) = Trueprop o HOLogic.mk_eq; fun is_empty_set (Const (@{const_name Orderings.bot}, _)) = true | is_empty_set _ = false; fun mk_Int Ts A B = let val T = fastype_of1 (Ts, A) in Const (@{const_name Lattices.inf}, T --> T --> T) $ A $ B end; fun mk_Un T (A, B) = Const (@{const_name Lattices.sup}, T --> T --> T) $ A $ B; fun dest_Un (Const (@{const_name Lattices.sup}, _) $ t1 $ t2) = dest_Un t1 @ dest_Un t2 | dest_Un t = [t] fun mk_UN' dT rT t = let val dTs = HOLogic.mk_setT dT; val rTs = HOLogic.mk_setT rT; in Const (@{const_name Complete_Lattices.Sup}, rTs --> rT) $ (Const (@{const_name image}, (dT --> rT) --> dTs --> rTs) $ t $ Const (@{const_name Orderings.top}, dTs)) end; fun mk_UN ((x, T), P) = mk_UN' T (fastype_of P) (absfree (x, T) P); fun dest_UN (Const (@{const_name Complete_Lattices.Sup}, _) $ (Const (@{const_name Set.image}, _) $ Abs (x, T, t) $ Const (@{const_name Orderings.top}, _))) = let val (vars, body) = dest_UN t in ((x, T) :: vars, body) end | dest_UN t = ([], t); fun tap_UN (Const (@{const_name Complete_Lattices.Sup}, _) $ (Const (@{const_name Set.image}, _) $ t $ Const (@{const_name Orderings.top}, _))) = SOME t | tap_UN _ = NONE; (* Fetching the rules *) datatype hoareMode = Partial | Total fun get_rule p t Partial = p | get_rule p t Total = t val Guard = get_rule @{thm HoarePartial.Guard} @{thm HoareTotal.Guard}; val GuardStrip = get_rule @{thm HoarePartial.GuardStrip} @{thm HoareTotal.GuardStrip}; val GuaranteeAsGuard = get_rule @{thm HoarePartial.GuaranteeAsGuard} @{thm HoareTotal.GuaranteeAsGuard}; val Guarantee = get_rule @{thm HoarePartial.Guarantee} @{thm HoareTotal.Guarantee}; val GuaranteeStrip = get_rule @{thm HoarePartial.GuaranteeStrip} @{thm HoareTotal.GuaranteeStrip}; val GuardsNil = get_rule @{thm HoarePartial.GuardsNil} @{thm HoareTotal.GuardsNil}; val GuardsCons = get_rule @{thm HoarePartial.GuardsCons} @{thm HoareTotal.GuardsCons}; val GuardsConsGuaranteeStrip = get_rule @{thm HoarePartial.GuardsConsGuaranteeStrip} @{thm HoareTotal.GuardsConsGuaranteeStrip}; val Skip = get_rule @{thm HoarePartial.Skip} @{thm HoareTotal.Skip}; val Basic = get_rule @{thm HoarePartial.Basic} @{thm HoareTotal.Basic}; val BasicCond = get_rule @{thm HoarePartial.BasicCond} @{thm HoareTotal.BasicCond}; val Spec = get_rule @{thm HoarePartial.Spec} @{thm HoareTotal.Spec}; val SpecIf = get_rule @{thm HoarePartial.SpecIf} @{thm HoareTotal.SpecIf}; val Throw = get_rule @{thm HoarePartial.Throw} @{thm HoareTotal.Throw}; val Raise = get_rule @{thm HoarePartial.raise} @{thm HoareTotal.raise}; val Catch = get_rule @{thm HoarePartial.Catch} @{thm HoareTotal.Catch}; val CondCatch = get_rule @{thm HoarePartial.condCatch} @{thm HoareTotal.condCatch}; val CatchSwap = get_rule @{thm HoarePartial.CatchSwap} @{thm HoareTotal.CatchSwap}; val CondCatchSwap = get_rule @{thm HoarePartial.condCatchSwap} @{thm HoareTotal.condCatchSwap}; val Seq = get_rule @{thm HoarePartial.Seq} @{thm HoareTotal.Seq}; val SeqSwap = get_rule @{thm HoarePartial.SeqSwap} @{thm HoareTotal.SeqSwap}; val BSeq = get_rule @{thm HoarePartial.BSeq} @{thm HoareTotal.BSeq}; val Cond = get_rule @{thm HoarePartial.Cond} @{thm HoareTotal.Cond}; val CondInv'Partial = @{thm HoarePartial.CondInv'}; val CondInv'Total = @{thm HoareTotal.CondInv'}; val CondInv' = get_rule CondInv'Partial CondInv'Total; val SwitchNil = get_rule @{thm HoarePartial.switchNil} @{thm HoareTotal.switchNil}; val SwitchCons = get_rule @{thm HoarePartial.switchCons} @{thm HoareTotal.switchCons}; val CondSwap = get_rule @{thm HoarePartial.CondSwap} @{thm HoareTotal.CondSwap}; val While = get_rule @{thm HoarePartial.While} @{thm HoareTotal.While}; val WhileAnnoG = get_rule @{thm HoarePartial.WhileAnnoG} @{thm HoareTotal.WhileAnnoG}; val WhileAnnoFix = get_rule @{thm HoarePartial.WhileAnnoFix'} @{thm HoareTotal.WhileAnnoFix'}; val WhileAnnoGFix = get_rule @{thm HoarePartial.WhileAnnoGFix} @{thm HoareTotal.WhileAnnoGFix}; val BindR = get_rule @{thm HoarePartial.Bind} @{thm HoareTotal.Bind}; val Block = get_rule @{thm HoarePartial.Block} @{thm HoareTotal.Block}; val BlockSwap = get_rule @{thm HoarePartial.BlockSwap} @{thm HoareTotal.BlockSwap}; val Proc = get_rule @{thm HoarePartial.ProcSpec} @{thm HoareTotal.ProcSpec}; val ProcNoAbr = get_rule @{thm HoarePartial.ProcSpecNoAbrupt} @{thm HoareTotal.ProcSpecNoAbrupt}; val ProcBody = get_rule @{thm HoarePartial.ProcBody} @{thm HoareTotal.ProcBody}; val CallBody = get_rule @{thm HoarePartial.CallBody} @{thm HoareTotal.CallBody}; val FCall = get_rule @{thm HoarePartial.FCall} @{thm HoareTotal.FCall}; val ProcRecSpecs = get_rule @{thm HoarePartial.ProcRecSpecs} @{thm HoareTotal.ProcRecSpecs}; val ProcModifyReturnSameFaults = get_rule @{thm HoarePartial.ProcModifyReturnSameFaults} @{thm HoareTotal.ProcModifyReturnSameFaults}; val ProcModifyReturn = get_rule @{thm HoarePartial.ProcModifyReturn} @{thm HoareTotal.ProcModifyReturn}; val ProcModifyReturnNoAbr = get_rule @{thm HoarePartial.ProcModifyReturnNoAbr} @{thm HoareTotal.ProcModifyReturnNoAbr}; val ProcModifyReturnNoAbrSameFaultsPartial = @{thm HoarePartial.ProcModifyReturnNoAbrSameFaults}; val ProcModifyReturnNoAbrSameFaultsTotal = @{thm HoareTotal.ProcModifyReturnNoAbrSameFaults}; val ProcModifyReturnNoAbrSameFaults = get_rule ProcModifyReturnNoAbrSameFaultsPartial ProcModifyReturnNoAbrSameFaultsTotal; val TrivPost = get_rule @{thm HoarePartial.TrivPost} @{thm HoareTotal.TrivPost}; val TrivPostNoAbr = get_rule @{thm HoarePartial.TrivPostNoAbr} @{thm HoareTotal.TrivPostNoAbr}; val DynProcProcPar = get_rule @{thm HoarePartial.DynProcProcPar} @{thm HoareTotal.DynProcProcPar}; val DynProcProcParNoAbr = get_rule @{thm HoarePartial.DynProcProcParNoAbrupt} @{thm HoareTotal.DynProcProcParNoAbrupt}; val ProcProcParModifyReturn = get_rule @{thm HoarePartial.ProcProcParModifyReturn} @{thm HoareTotal.ProcProcParModifyReturn}; val ProcProcParModifyReturnSameFaultsPartial = @{thm HoarePartial.ProcProcParModifyReturnSameFaults}; val ProcProcParModifyReturnSameFaultsTotal = @{thm HoareTotal.ProcProcParModifyReturnSameFaults}; val ProcProcParModifyReturnSameFaults = get_rule ProcProcParModifyReturnSameFaultsPartial ProcProcParModifyReturnSameFaultsTotal; val ProcProcParModifyReturnNoAbr = get_rule @{thm HoarePartial.ProcProcParModifyReturnNoAbr} @{thm HoareTotal.ProcProcParModifyReturnNoAbr}; val ProcProcParModifyReturnNoAbrSameFaultsPartial = @{thm HoarePartial.ProcProcParModifyReturnNoAbrSameFaults}; val ProcProcParModifyReturnNoAbrSameFaultsTotal = @{thm HoareTotal.ProcProcParModifyReturnNoAbrSameFaults}; val ProcProcParModifyReturnNoAbrSameFaults = get_rule ProcProcParModifyReturnNoAbrSameFaultsPartial ProcProcParModifyReturnNoAbrSameFaultsTotal; val DynCom = get_rule @{thm HoarePartial.DynComConseq} @{thm HoareTotal.DynComConseq}; val AugmentContext = get_rule @{thm HoarePartial.augment_context'} @{thm HoareTotal.augment_context'}; val AugmentEmptyFaults = get_rule @{thm HoarePartial.augment_emptyFaults} @{thm HoareTotal.augment_emptyFaults}; val AsmUN = get_rule @{thm HoarePartial.AsmUN} @{thm HoareTotal.AsmUN}; val SpecAnno = get_rule @{thm HoarePartial.SpecAnno'} @{thm HoareTotal.SpecAnno'}; val SpecAnnoNoAbrupt = get_rule @{thm HoarePartial.SpecAnnoNoAbrupt} @{thm HoareTotal.SpecAnnoNoAbrupt}; val LemAnno = get_rule @{thm HoarePartial.LemAnno} @{thm HoareTotal.LemAnno}; val LemAnnoNoAbrupt = get_rule @{thm HoarePartial.LemAnnoNoAbrupt} @{thm HoareTotal.LemAnnoNoAbrupt}; val singleton_conv_sym = @{thm Set.singleton_conv2} RS sym; val anno_defs = [@{thm Language.whileAnno_def},@{thm Language.whileAnnoG_def},@{thm Language.specAnno_def}, @{thm Language.whileAnnoGFix_def},@{thm Language.whileAnnoFix_def},@{thm Language.lem_def}]; val strip_simps = @{thm Language.strip_simp} :: @{thm Option.option.map(2)} :: @{thms Language.strip_guards_simps}; val normalize_simps = [@{thm Language.while_def}, @{thm Language.bseq_def}, @{thm List.append_Nil}, @{thm List.append_Cons}] @ @{thms List.list.cases} @ @{thms Language.flatten_simps} @ @{thms Language.sequence.simps} @ @{thms Language.normalize_simps} @ @{thms Language.guards.simps} @ [@{thm fst_conv}, @{thm snd_conv}]; val K_rec_convs = []; val K_fun_convs = [@{thm StateFun.K_statefun_apply}, @{thm StateFun.K_statefun_comp}]; val K_convs = K_rec_convs @ K_fun_convs; val K_rec_congs = []; val K_fun_congs = [@{thm StateFun.K_statefun_cong}]; val K_congs = K_rec_congs @ K_fun_congs; (* misc. aux. functions *) (* first_subterm * yields result x of P for first subterm for which P is (SOME x), and all bound variables on the path * to that term *) fun first_subterm_dest P = let fun first abs_vars t = (case P t of SOME x => SOME (abs_vars,x) |_=> (case t of u $ v => (case first abs_vars u of NONE => first abs_vars v | SOME x => SOME x) | Abs (c,T,u) => first (abs_vars @ [(c,T)]) u | _ => NONE)) in first [] end; (* first_subterm * yields first subterm for which P holds, and all bound variables on the path * to that term *) fun first_subterm P = let fun P' t = if P t then SOME t else NONE; in first_subterm_dest P' end; (* max_subterm_dest * yields results of P for all maximal subterms for which P is (SOME x), * and all bound variables on the path to that subterm *) fun max_subterms_dest P = let fun collect abs_vars t = (case P t of SOME x => [(abs_vars,x)] |_=> (case t of u $ v => collect abs_vars u @ collect abs_vars v | Abs (c,T,u) => collect (abs_vars @ [(c,T)]) u | _ => [])) in collect [] end; fun last [] = raise Empty | last [x] = x | last (_::xs) = last xs; fun dest_splits (Const (@{const_name case_prod},_)$Abs (n,T,t)) = (n,T)::dest_splits t | dest_splits (Const (@{const_name case_prod},_)$Abs (n,T,t)$_) = (n,T)::dest_splits t | dest_splits (Abs (n,T,_)) = [(n,T)] | dest_splits _ = []; fun idx eq [] x = ~1 | idx eq (x::rs) y = if eq x y then 0 else let val i = idx eq rs y in if i < 0 then i else i+1 end; fun resuffix sfx1 sfx2 s = suffix sfx2 (unsuffix sfx1 s) handle Fail _ => s; (* state space representation dependent functions *) datatype state_kind = Record | Function fun state_simprocs Record = [Record.simproc] | state_simprocs Function = [Record.simproc, StateFun.lookup_simproc]; fun state_upd_simproc Record = Record.upd_simproc | state_upd_simproc Function = StateFun.update_simproc; fun state_ex_sel_eq_simproc Record = Record.ex_sel_eq_simproc | state_ex_sel_eq_simproc Function = StateFun.ex_lookup_eq_simproc; val state_split_simp_tac = Record.split_simp_tac val state_hierarchy = Record.dest_recTs fun stateT_id T = case (state_hierarchy T) of [] => NONE | Ts => SOME (last Ts); fun globalsT (Type (_, T :: _)) = SOME T | globalsT _ = NONE; fun stateT_ids T = (case stateT_id T of NONE => NONE | SOME sT => (case globalsT T of NONE => SOME [sT] | SOME gT => (case stateT_id gT of NONE => SOME [sT] | SOME gT' => SOME [sT,gT']))); datatype par_kind = In | Out (*** utilities ***) (* utils for variable name decorations *) val deco = "_'"; val proc_deco = "_'proc"; fun par_deco name = deco ^ name ^ deco; fun chopsfx sfx str = (case try (unsuffix sfx) str of SOME s => s | NONE => str) val is_state_var = can (unsuffix deco); (* removes the suffix of the string beginning with deco. * "xys_'a" --> "xys"; * The a is also chopped, since sometimes the bound variables * are renamed, I think SELECT_GOAL in rename_goal is to blame *) fun remdeco' str = let fun chop (p::ps) (x::xs) = chop ps xs | chop [] xs = [] | chop (p::ps) [] = error "remdeco: code should never be reached"; fun remove prf (s as (x::xs)) = if is_prefix (op =) prf s then chop prf s else (x::remove prf xs) | remove prf [] = []; in String.implode (remove (String.explode deco) (String.explode str)) end; fun extern ctxt s = (case try (Proof_Context.extern_const ctxt o Lexicon.unmark_const) s of NONE => s | SOME s' => s'); fun remdeco ctxt s = remdeco' (extern ctxt s); fun undeco ctxt (Const (c, T)) = Const (remdeco ctxt c, T) | undeco ctxt ((f as Const (@{syntax_const "_free"},_)) $ Free (x, T)) = (*f$*)Const (remdeco' x, T) | undeco ctxt (Const _ $ _ $ ((Const (@{syntax_const "_free"},_)) $ Free (x, T))) = (*f$*)Const (remdeco' x, T) | undeco ctxt (Free (c, T)) = Const (remdeco' c, T) | undeco ctxt x = x fun varname x = x ^ deco val dest_string = map (chr o HOLogic.dest_char) o HOLogic.dest_list; fun dest_string' t = (case try dest_string t of SOME s => implode s | NONE => (case t of Free (s,_) => s | Const (s,_) => Long_Name.base_name s | _ => raise TERM ("dest_string'",[t]))) fun is_state_space_var Tids t = let fun is_stateT T = (case stateT_id T of NONE => 0 | SOME id => if member (op =) Tids id then ~1 else 0); in (case t of Const _ $ Abs (_,T,_) => is_stateT T | Free (_,T) => is_stateT T | _ => 0) end; datatype callMode = Static | Parameter fun proc_name Static (Const (p,_)$_) = resuffix deco proc_deco (Long_Name.base_name p) | proc_name Static (Const (@{const_name StateFun.lookup},_)$_$Free (p,_)$_) = suffix proc_deco (remdeco' (Long_Name.base_name p)) | proc_name Static p = dest_string' p | proc_name Parameter (Const (p,_)) = resuffix deco proc_deco (Long_Name.base_name p) | proc_name Parameter (Abs (_,_,Const (p,_)$Bound 0)) = resuffix deco proc_deco (Long_Name.base_name p) | proc_name Parameter (Abs (_,_,Const (@{const_name StateFun.lookup},_)$_$Free (p,_)$_)) = suffix proc_deco (remdeco' (Long_Name.base_name p)) | proc_name _ t = raise TERM ("proc_name",[t]); fun dest_call (Const (@{const_name Language.call},_)$init$pname$return$c) = (init,pname,return,c,Static,true) | dest_call (Const (@{const_name Language.fcall},_)$init$pname$return$_$c) = (init,pname,return,c,Static,true) | dest_call (Const (@{const_name Language.com.Call},_)$pname) = (Bound 0,pname,Bound 0,Bound 0,Static,false) | dest_call (Const (@{const_name Language.dynCall},_)$init$pname$return$c) = (init,pname,return,c,Parameter,true) | dest_call t = raise TERM ("Hoare.dest_call: unexpected term",[t]); fun dest_whileAnno (Const (@{const_name Language.whileAnnoG},_) $gs$b$I$V$c) = (SOME gs,b,I,V,c,false) | dest_whileAnno (Const (@{const_name Language.whileAnno},_) $b$I$V$c) = (NONE,b,I,V,c,false) | dest_whileAnno (Const (@{const_name Language.whileAnnoGFix},_)$gs$b$I$V$c) = (SOME gs,b,I,V,c,true) | dest_whileAnno (Const (@{const_name Language.whileAnnoFix},_) $b$I$V$c) = (NONE,b,I,V,c,true) | dest_whileAnno t = raise TERM ("Hoare.dest_while: unexpected term",[t]); fun dest_Guard (Const (@{const_name Language.com.Guard},_)$f$g$c) = (f,g,c,false) | dest_Guard (Const (@{const_name Language.guaranteeStrip},_)$f$g$c) = (f,g,c,true) | dest_Guard t = raise TERM ("Hoare.dest_guard: unexpected term",[t]); (*** extend theory by procedure definition ***) fun add_declaration name decl thy = thy |> Named_Target.init [] name |> Local_Theory.declaration {syntax = false, pervasive = false} decl |> Local_Theory.exit |> Proof_Context.theory_of; (* data kind 'HOL/hoare' *) type proc_info = {params: ((par_kind * string) list), recursive: bool, state_kind: state_kind} type hoare_tac = (bool -> int -> tactic) -> Proof.context -> hoareMode -> int -> tactic; type hoare_data = {proc_info: proc_info Symtab.table, active_procs: string list list, default_state_kind: state_kind, generate_guard: (stamp * (Proof.context -> term -> term option)), wp_tacs: (string * hoare_tac) list, hoare_tacs: (string * hoare_tac) list, vcg_simps: thm list}; fun make_hoare_data proc_info active_procs default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps = {proc_info = proc_info, active_procs = active_procs, default_state_kind = default_state_kind, generate_guard = generate_guard, wp_tacs = wp_tacs, hoare_tacs = hoare_tacs, vcg_simps = vcg_simps}; structure Hoare_Data = Generic_Data ( type T = hoare_data; val empty = make_hoare_data (Symtab.empty: proc_info Symtab.table) ([]:string list list) (Function) (stamp (),(K (K NONE)): Proof.context -> term -> term option) ([]:(string * hoare_tac) list) ([]:(string * hoare_tac) list) ([]:thm list); - val extend = I; - (* FIXME exponential blowup due to append !? *) fun merge ({proc_info = proc_info1, active_procs = active_procs1, default_state_kind = _, generate_guard = (stmp1,generate_gaurd1), wp_tacs = wp_tacs1, hoare_tacs = hoare_tacs1, vcg_simps = vcg_simps1}, {proc_info = proc_info2, active_procs = active_procs2, default_state_kind = default_state_kind2, generate_guard = (stmp2, _), wp_tacs = wp_tacs2, hoare_tacs = hoare_tacs2, vcg_simps=vcg_simps2}) : T = if stmp1=stmp2 then make_hoare_data (Symtab.merge (K true) (proc_info1,proc_info2)) (active_procs1 @ active_procs2) (default_state_kind2) (stmp1,generate_gaurd1) (wp_tacs1 @ wp_tacs2) (hoare_tacs1 @ hoare_tacs2) (Thm.merge_thms (vcg_simps1,vcg_simps2)) else error ("Theories have different aux. functions to generate guards") ); val get_data = Hoare_Data.get o Context.Proof; (* access 'params' *) fun mk_free context name = let val ctxt = Context.proof_of context; val n' = Variable.intern_fixed ctxt name |> perhaps Long_Name.dest_hidden; val T' = Proof_Context.infer_type ctxt (n', dummyT) handle ERROR _ => dummyT in (Free (n',T')) end; fun morph_name context phi name = (case Morphism.term phi (mk_free context name) of Free (x,_) => x | _ => name); datatype 'a bodykind = BodyTyp of 'a | BodyTerm of 'a fun set_default_state_kind sk context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs sk generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; val get_default_state_kind = #default_state_kind o get_data; fun add_active_procs phi ps context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info ((map (morph_name context phi) ps)::active_procs) default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; fun add_hoare_tacs tacs context = let val {proc_info,active_procs, default_state_kind, generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs default_state_kind generate_guard wp_tacs (hoare_tacs@tacs) vcg_simps; in Hoare_Data.put data context end; fun map_vcg_simps f context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs default_state_kind generate_guard wp_tacs hoare_tacs (f vcg_simps); in Hoare_Data.put data context end; fun thy_attrib f = Thm.declaration_attribute (fn thm => map_vcg_simps (f thm)); val vcg_simpadd = Thm.add_thm val vcg_simpdel = Thm.del_thm val vcg_simp_add = thy_attrib vcg_simpadd; val vcg_simp_del = thy_attrib vcg_simpdel; (* add 'procedure' *) fun mk_proc_info params recursive state_kind = {params=params,recursive=recursive,state_kind=state_kind}; val empty_proc_info = {params=[],recursive=false,state_kind=Record}; fun map_proc_info_params f {params,recursive,state_kind} = mk_proc_info (f params) recursive state_kind; fun map_proc_info_recursive f {params,recursive,state_kind} = mk_proc_info params (f recursive) state_kind; fun map_proc_info_state_kind f {params,recursive,state_kind} = mk_proc_info params recursive (f state_kind); fun add_params phi name frmls context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val params = map (apsnd (morph_name context phi)) frmls; val f = map_proc_info_params (K params); val default = f empty_proc_info; val proc_info' = Symtab.map_default (morph_name context phi name,default) f proc_info; val data = make_hoare_data proc_info' active_procs default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; fun get_params name ctxt = Option.map #params (Symtab.lookup (#proc_info (get_data ctxt)) name); fun add_recursive phi name context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val f = map_proc_info_recursive (K true); val default = f empty_proc_info; val proc_info'= Symtab.map_default (morph_name context phi name,default) f proc_info; val data = make_hoare_data proc_info' active_procs default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; fun get_recursive name ctxt = Option.map #recursive (Symtab.lookup (#proc_info (get_data ctxt)) name); fun add_state_kind phi name sk context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val f = map_proc_info_state_kind (K sk); val default = f empty_proc_info; val proc_info'= Symtab.map_default (morph_name context phi name,default) f proc_info; val data = make_hoare_data proc_info' active_procs default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; fun get_state_kind name ctxt = Option.map #state_kind (Symtab.lookup (#proc_info (get_data ctxt)) name); fun install_generate_guard f context = let val {proc_info,active_procs, default_state_kind, generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs default_state_kind (stamp (), f) wp_tacs hoare_tacs vcg_simps in Hoare_Data.put data context end; fun generate_guard ctxt = snd (#generate_guard (get_data ctxt)) ctxt; fun check_procedures_definition procs thy = let val ctxt = Proof_Context.init_global thy; fun already_defined name = if is_some (get_params name ctxt) then ["procedure " ^ quote name ^ " already defined"] else [] val err_already_defined = maps (already_defined o #1) procs; fun duplicate_procs names = (case duplicates (op =) names of [] => [] | dups => ["Duplicate procedures " ^ commas_quote dups]); val err_duplicate_procs = duplicate_procs (map #1 procs); fun duplicate_pars name pars = (case duplicates (op =) (map fst pars) of [] => [] | dups => ["Duplicate parameters in procedure " ^ quote name ^ ": " ^ commas_quote dups]); val err_duplicate_pars = maps (fn (name,inpars,outpars,locals,_,_,_) => duplicate_pars name (inpars @ locals) @ duplicate_pars name (outpars @ locals)) procs; (* FIXME: Check that no global variables are used as result parameters *) val errs = err_already_defined @ err_duplicate_procs @ err_duplicate_pars; in if null errs then () else error (cat_lines errs) end; fun add_parameter_info phi cname (name,(inpars,outpars,state_kind)) context = let fun par_deco' T = if T = "" then deco else par_deco (cname name); val pars = map (fn (par,T) => (In,suffix (par_deco' T) par)) inpars@ map (fn (par,T) => (Out,suffix (par_deco' T) par)) outpars; in context |> add_params phi name pars |> add_state_kind phi name state_kind end; fun mk_loc_exp xs = let fun mk_expr s = (s,(("",false),(Expression.Named [],[]))) in (map mk_expr xs,[]) end; val parametersN = "_parameters"; val variablesN = "_variables"; val signatureN = "_signature"; val bodyN = "_body"; val implementationN = "_impl"; val cliqueN = "_clique"; val clique_namesN = "_clique_names"; val NoBodyN = @{const_name Vcg.NoBody}; val statetypeN = "StateType"; val proc_nameT = HOLogic.stringT; fun expression_no_pos (expr, fixes) : Expression.expression = (map (fn (name, inst) => ((name, Position.none), inst)) expr, fixes); fun add_locale name expr elems thy = thy |> Expression.add_locale (Binding.name name) (Binding.name name) [] expr elems |> snd |> Local_Theory.exit; fun add_locale' name expr elems thy = thy |> Expression.add_locale (Binding.name name) (Binding.name name) [] expr elems ||> Local_Theory.exit; fun add_locale_cmd name expr elems thy = thy |> Expression.add_locale_cmd (Binding.name name) (Binding.name name) [] (expression_no_pos expr) elems |> snd |> Local_Theory.exit; fun read_typ thy raw_T env = let val ctxt' = Proof_Context.init_global thy |> fold (Variable.declare_typ o TFree) env; val T = Syntax.read_typ ctxt' raw_T; val env' = Term.add_tfreesT T env; in (T, env') end; fun add_variable_statespaces (cname, (inpars, outpars, locvars)) thy = let val inpars' = if forall (fn (_,T) => T = "") inpars then [] else inpars; val outpars' = if forall (fn (_,T) => T = "") outpars then [] else outpars; fun prep_comp (n, T) env = let val (T', env') = read_typ thy T env handle ERROR msg => cat_error msg ("The error(s) above occurred in component " ^ quote n) in ((n, T'), env') end; val (in_outs,in_out_env) = fold_map prep_comp (distinct (op =) (inpars'@outpars')) []; val (locs,var_env) = fold_map prep_comp locvars in_out_env; val parSP = cname ^ parametersN; val in_outs' = map (apfst (suffix (par_deco cname))) in_outs; val in_out_args = map fst in_out_env; val varSP = cname ^ variablesN; val locs' = map (apfst (suffix (par_deco cname))) locs; val var_args = map fst var_env; in if null inpars' andalso null outpars' andalso null locvars then thy |> add_locale_cmd parSP ([],[]) [] |> Proof_Context.theory_of |> add_locale_cmd varSP ([],[]) [] |> Proof_Context.theory_of else thy |> StateSpace.define_statespace_i (SOME statetypeN) in_out_args parSP [] in_outs' |> StateSpace.define_statespace_i (SOME statetypeN) var_args varSP [((cname, false), ((map TFree in_out_env),parSP,[]))] locs' end; fun intern_locale thy = Locale.intern thy #> perhaps Long_Name.dest_hidden; fun apply_in_context thy lexp f t = let fun name_variant lname = if intern_locale thy lname = lname then lname else name_variant (lname ^ "'"); in thy (* Create a dummy locale in dummy theory just to read the term *) |> add_locale_cmd (name_variant "foo") lexp [] |> (fn ctxt => f ctxt t) end; fun add_abbrev loc mode name spec thy = thy |> Named_Target.init [] loc |> (fn lthy => let val t = Syntax.read_term (Local_Theory.target_of lthy) spec; in Local_Theory.abbrev mode ((Binding.name name, NoSyn), t) lthy end) |> #2 |> Local_Theory.exit |> Proof_Context.theory_of; exception TOPSORT of string fun topsort less [] = [] | topsort less xs = let fun list_all P xs = fold (fn x => fn b => b andalso P x) xs true; fun split_min n (x::xs) = if n=0 then raise TOPSORT "no minimum in list" else if list_all (less x) xs then (x,xs) else split_min (n-1) (xs@[x]); fun tsort [] = [] | tsort xs = let val (x,xs') = split_min (length xs) xs; in x::tsort xs' end; in tsort xs end; fun clique_name clique = (foldr1 (fn (a,b) => a ^ "_" ^ b) (map (unsuffix proc_deco) clique)); fun error_to_warning msg f thy = f thy handle ERROR msg' => (warning (msg' ^ "\n" ^ msg); thy); fun procedures_definition locname procs thy = let val procs' = map (fn (name,a,b,c,d,e,f) => (suffix proc_deco name,a,b,c,d,e,f)) procs; val _ = check_procedures_definition procs' thy; val name_pars = map (fn (name,inpars,outpars,_,_,_,sk) => (name,(inpars,outpars,sk))) procs'; val name_vars = map (fn (name,inpars,outpars,locals,_,_,_) => (name,(inpars,outpars,locals))) procs'; val name_body = map (fn (name,_,_,_,body,_,_) => (name,body)) procs'; val name_pars_specs = map (fn (name,inpars,outpars,_,_,specs,sk) => (name,(inpars,outpars,sk),specs)) procs'; val names = map #1 procs'; val sk = #7 (hd procs'); val thy = thy |> Context.theory_map (set_default_state_kind sk); val (all_callss,cliques,is_recursive,has_body) = let val context = Context.Theory thy |> fold (add_parameter_info Morphism.identity (unsuffix proc_deco)) name_pars |> StateSpace.set_silent true fun read_body (_, body) = Syntax.read_term (Context.proof_of context) body; val bodies = map read_body name_body; fun dcall t = (case try dest_call t of SOME (_,p,_,_,m,_) => SOME (proc_name m p) | _ => NONE); fun in_names x = if member (op =) names x then SOME x else NONE; fun add_edges n = fold (fn x => Graph.add_edge (n, x)); val all_callss = map (map snd o max_subterms_dest dcall) bodies; val callss = map (map_filter in_names) all_callss; val graph = fold (fn n => Graph.new_node (n, ())) names Graph.empty; val graph' = fold2 add_edges names callss graph; fun idx x = find_index (fn y => x=y) names; fun name_ord (a,b) = int_ord (idx a, idx b); val cliques = Graph.strong_conn graph'; val cliques' = map (sort name_ord) cliques; val my_calls = these o AList.lookup (op =) (names ~~ map (distinct (op =)) callss); val my_body = AList.lookup (op =) (names ~~ bodies); fun is_recursive n = exists (fn [_] => false | ns => member (op =) ns n) (Graph.strong_conn graph'); fun has_body n = (case my_body n of SOME (Const (c,_)) => c <> NoBodyN | _ => true) fun clique_less c1 c2 = null (inter (op =) (distinct (op =) (maps my_calls c1)) c2); val cliques'' = topsort clique_less cliques'; in (all_callss,cliques'',is_recursive,has_body) end; (* cliques may only depend on ones to the left, so it is safe to * add the locales from the left to the right. *) fun my_clique n = Library.find_first (fn c => member (op =) c n) cliques; fun lname sfx clique = suffix sfx (clique_name clique); fun cname n = clique_name (the (my_clique n)); fun parameter_info_decl phi = fold (add_parameter_info phi cname) name_pars; fun get_loc sfx clique n = if member (op =) clique n then NONE else SOME (resuffix proc_deco sfx n); fun parent_locales thy sfx clique = let val calls = distinct (op =) (flat (map_filter (AList.lookup (op =) (names ~~ all_callss)) clique)); in map (intern_locale thy) (distinct (op =) (map_filter (get_loc sfx clique) calls)) end; val names_all_callss = names ~~ map (distinct (op =)) all_callss; val get_calls = the o AList.lookup (op =) names_all_callss; fun clique_vars clique = let fun add name (ins,outs,locs) = let val (nins,nouts,nlocs) = the (AList.lookup (op =) name_vars name) in (ins@nins,outs@nouts,locs@nlocs) end; val (is,os,ls) = fold add clique ([],[],[]); in (lname "" clique, (distinct (op =) is, distinct (op =) os, distinct (op =) ls)) end; fun add_signature_locale (cname, name) thy = let val name' = unsuffix proc_deco name; val fixes = [Element.Fixes [(Binding.name name, SOME proc_nameT, NoSyn)]]; (* FIXME: may use HOLogic.typeT as soon as locale type-inference works properly *) val pE = mk_loc_exp [intern_locale thy (suffix parametersN cname)]; val sN = suffix signatureN name'; in thy |> add_locale sN pE fixes |> Proof_Context.theory_of |> (fn thy => add_declaration (intern_locale thy sN) parameter_info_decl thy) end; fun mk_bdy_def read_term name = let val name' = unsuffix proc_deco name; val bdy = read_term (the (AList.lookup (op =) name_body name)); val bdy_defN = suffix body_def_sfx name'; val b = Binding.name bdy_defN; in ((b, NoSyn), ((Thm.def_binding b, []), bdy)) end; fun add_body_locale (name, _) thy = let val name' = unsuffix proc_deco name; val callees = filter_out (fn n => n = name) (get_calls name) val fixes = [Element.Fixes [(Binding.name name, SOME proc_nameT, NoSyn)]]; (* FIXME: may use HOLogic.typeT as soon as locale type-inference works properly *) val pE = mk_loc_exp (map (intern_locale thy) ([lname variablesN (the (my_clique name))]@ the_list locname@ map (resuffix proc_deco signatureN) callees)); fun def lthy = let val read = Syntax.read_term (Context.proof_map (add_active_procs Morphism.identity (the (my_clique name))) (Local_Theory.target_of lthy)) in mk_bdy_def read name end; fun add_decl_and_def lname ctxt = ctxt |> Proof_Context.theory_of |> Named_Target.init [] lname |> Local_Theory.declaration {syntax = false, pervasive = false} parameter_info_decl |> (fn lthy => if has_body name then snd (Local_Theory.define (def lthy) lthy) else lthy) |> Local_Theory.exit |> Proof_Context.theory_of; in thy |> add_locale' (suffix bodyN name') pE fixes |-> add_decl_and_def end; fun mk_def_eq thy read_term name = if has_body name then let (* FIXME: All the read_term stuff is just because type-inference/abbrevs for * new locale elements does not work right now; * We read the term to expand the abbreviations, then we print it again * (without folding the abbreviation) and reread as string *) val name' = unsuffix proc_deco name; val bdy_defN = suffix body_def_sfx name'; val rhs = read_term ("Some " ^ bdy_defN); val nt = read_term name; val Free (gamma,_) = read_term programN; val eq = HOLogic.Trueprop$ HOLogic.mk_eq (Free (gamma,fastype_of nt --> fastype_of rhs)$nt,rhs) val consts = Sign.consts_of thy; val eqs = YXML.string_of_body (Term_XML.Encode.term consts (Consts.dummy_types consts eq)); val assms = Element.Assumes [((Binding.name (suffix bodyP name'), []),[(eqs,[])])] in [assms] end else []; fun add_impl_locales clique thy = let val cliqN = lname cliqueN clique; val cnamesN = lname clique_namesN clique; val multiple_procs = length clique > 1; val add_distinct_procs_namespace = if multiple_procs then StateSpace.namespace_definition cnamesN proc_nameT ([],[]) [] clique else I; val bodyLs = map (suffix bodyN o unsuffix proc_deco) clique; fun pE thy = mk_loc_exp (map (intern_locale thy) (hoare_ctxtL::bodyLs) @ (parent_locales thy implementationN clique) @ (if multiple_procs then [intern_locale thy cnamesN] else [])); fun read_term thy = apply_in_context thy (pE thy) Syntax.read_term; fun elems thy = maps (mk_def_eq thy (read_term thy)) clique; fun add_recursive_info phi name = if is_recursive name then (add_recursive phi name) else I; fun proc_declaration phi = add_active_procs phi clique; fun recursive_declaration phi context = context |> fold (add_recursive_info phi) clique; fun add_impl_locale name thy = let val implN = suffix implementationN (unsuffix proc_deco name); val parentN = intern_locale thy cliqN val parent = mk_loc_exp [parentN]; in thy |> add_locale_cmd implN parent [] |> Proof_Context.theory_of |> (fn thy => Interpretation.global_sublocale parentN (mk_loc_exp [intern_locale thy implN]) [] thy) |> Proof.global_terminal_proof ((Method.Basic (fn ctxt => Method.SIMPLE_METHOD (Locale.intro_locales_tac {strict = true, eager = false} ctxt [])), Position.no_range), NONE) |> Proof_Context.theory_of end; in thy |> add_distinct_procs_namespace |> (fn thy => add_locale_cmd cliqN (pE thy) (elems thy) thy) |> Proof_Context.theory_of |> fold add_impl_locale clique |> (fn thy => add_declaration (intern_locale thy cliqN) proc_declaration thy) |> (fn thy => add_declaration (intern_locale thy cliqN) recursive_declaration thy) end; fun add_spec_locales (name, _, specs) thy = let val name' = unsuffix proc_deco name; val ps = (suffix signatureN name' :: the_list locname); val ps' = hoare_ctxtL :: ps ; val pE = mk_loc_exp (map (intern_locale thy) ps) val pE' = mk_loc_exp (map (intern_locale thy) ps') fun read thy = apply_in_context thy (mk_loc_exp [intern_locale thy (suffix cliqueN (cname name))]) (Syntax.read_prop); fun proc_declaration phi = (*parameter_info_decl phi o already in signature *) add_active_procs phi (the (my_clique name)); fun add_locale'' (thm_name,spec) thy = let val spec' = read thy spec; val elem = Element.Assumes [((Binding.name thm_name, []), [(spec', [])])]; in thy |> add_locale thm_name pE' [elem] |> Proof_Context.theory_of |> (fn thy => add_declaration (intern_locale thy thm_name) proc_declaration thy) |> error_to_warning ("abbreviation: '" ^ thm_name ^ "' not added") (add_abbrev (intern_locale thy (suffix cliqueN (cname name))) Syntax.mode_input thm_name spec) end; in thy |> fold add_locale'' specs end; in thy |> fold (add_variable_statespaces o clique_vars) cliques |> fold (fn c => fold (fn n => add_signature_locale (lname "" c, n)) c) cliques |> fold add_body_locale name_pars |> fold add_impl_locales cliques |> fold add_spec_locales name_pars_specs end; (********************* theory extender interface ********************************) (** package setup **) (* outer syntax *) val var_declP = Parse.name -- (@{keyword "::"} |-- Parse.!!! Parse.embedded); val var_declP' = Parse.name >> (fn n => (n,"")); val localsP = Scan.repeat var_declP; val argP = var_declP; val argP' = var_declP'; val not_eqP = Scan.ahead (Scan.unless @{keyword "="} (Scan.one (K true))) val proc_decl_statespace = (Parse.short_ident --| @{keyword "("}) -- ((Parse.list argP) -- (Scan.optional (@{keyword "|"} |-- Parse.list argP) []) --| @{keyword ")"}) --| not_eqP val proc_decl_record = (Parse.short_ident --| @{keyword "("}) -- ((Parse.list argP') -- (Scan.optional (@{keyword "|"} |-- Parse.list argP') []) --| @{keyword ")"}) --| Scan.option @{keyword "="} val proc_decl = proc_decl_statespace >> pair Function || proc_decl_record >> pair Record; val loc_decl = Scan.optional (@{keyword "where"} |-- localsP --| @{keyword "in"}) [] val proc_body = Parse.embedded (*>> BodyTerm*) fun proc_specs x = (Parse.!!! (Scan.repeat (Parse_Spec.thm_name ":" -- Parse.embedded)) >> map (fn ((thm_name, _), prop) => (Binding.name_of thm_name, prop))) x val par_loc = Scan.option (@{keyword "("} |-- @{keyword "imports"} |-- Parse.name --| @{keyword ")"}); val _ = Outer_Syntax.command @{command_keyword procedures} "define procedures" (par_loc -- (Parse.and_list1 (proc_decl -- loc_decl -- proc_body -- proc_specs)) >> (fn (loc,decls) => let val decls' = map (fn ((((state_kind,(name,(ins,outs))),ls),bdy),specs) => (name,ins,outs,ls,bdy,specs,state_kind)) decls in Toplevel.theory (procedures_definition loc decls') end)); val _ = Outer_Syntax.command @{command_keyword hoarestate} "define state space for hoare logic" (StateSpace.statespace_decl >> (fn ((args,name),(parents,comps)) => Toplevel.theory (StateSpace.define_statespace args name parents (map (apfst (suffix deco)) comps)))); (*************************** Auxiliary Functions for integration of ********************) (*************************** automatic program analysers ********************) fun dest_conjs t = (case HOLogic.dest_conj t of [t1,t2] => dest_conjs t1 @ dest_conjs t2 | ts => ts); fun split_guard (Const (@{const_name Collect},CT)$(Abs (s,T,t))) = let fun mkCollect t = Const (@{const_name Collect},CT)$(Abs (s,T,t)); in map mkCollect (dest_conjs t) end | split_guard t = [t]; fun split_guards gs = let fun norm c f g = map (fn g => c$f$g) (split_guard g); fun norm_guard ((c as Const (@{const_name Pair},_))$f$g) = norm c f g | norm_guard ((c as Const (@{const_name Language.guaranteeStripPair},_))$f$g) = norm c f g | norm_guard t = [t]; in maps norm_guard (HOLogic.dest_list gs) end fun fold_com f t = let (* traverse does not descend into abstractions, like in DynCom, call, etc. *) fun traverse cnt (c as Const (@{const_name Language.com.Skip},_)) = (cnt,f cnt c [] []) | traverse cnt ((c as Const (@{const_name Language.com.Basic},_))$g) = (cnt, f cnt c [g] []) | traverse cnt ((c as Const (@{const_name Language.com.Spec},_))$r) = (cnt, f cnt c [r] []) | traverse cnt ((c as Const (@{const_name Language.com.Seq},_))$c1$c2) = let val (cnt1,v1) = traverse cnt c1; val (cnt2,v2) = traverse cnt1 c2; in (cnt2, f cnt c [] [v1,v2]) end | traverse cnt ((c as Const (@{const_name Language.com.Cond},_))$b$c1$c2) = let val (cnt1,v1) = traverse cnt c1; val (cnt2,v2) = traverse cnt1 c2; in (cnt2, f cnt c [b] [v1,v2]) end | traverse cnt ((c as Const (@{const_name Language.com.While},_))$b$c1) = let val (cnt1,v1) = traverse cnt c1 in (cnt1, f cnt c [b] [v1]) end | traverse cnt ((c as Const (@{const_name Language.com.Call},_))$p) = (cnt, f cnt c [p] []) | traverse cnt ((c as Const (@{const_name Language.com.DynCom},_))$c1) = (cnt, f cnt c [c1] []) | traverse cnt ((c as Const (@{const_name Language.com.Guard},_))$flt$g$c1) = let val (cnt1,v1) = traverse (cnt + length (split_guard g)) c1 in (cnt1, f cnt c [flt,g] [v1]) end | traverse cnt (c as Const (@{const_name Language.com.Throw},_)) = (cnt,f cnt c [] []) | traverse cnt ((c as Const (@{const_name Language.com.Catch},_))$c1$c2) = let val (cnt1,v1) = traverse cnt c1; val (cnt2,v2) = traverse cnt1 c2; in (cnt2, f cnt c [] [v1,v2]) end | traverse cnt ((c as Const (@{const_name Language.guards},_))$gs$c1) = let val (cnt1,v1) = traverse (cnt + length (split_guards gs)) c1; in (cnt1, f cnt c [gs] [v1]) end | traverse cnt ((c as Const (@{const_name Language.block},_))$init$c1$return$c2) = let val (cnt1,v1) = traverse cnt c1 in (cnt1, f cnt c [init,return,c2] [v1]) end | traverse cnt ((c as Const (@{const_name Language.call},_))$init$p$return$c1) = (cnt, f cnt c [init,p,return,c1] []) | traverse cnt ((c as Const (@{const_name Language.whileAnno},_))$b$I$V$c1) = let val (cnt1,v1) = traverse cnt c1 in (cnt1, f cnt c [b,I,V] [v1]) end | traverse cnt ((c as Const (@{const_name Language.whileAnnoG},_))$gs$b$I$V$c1) = let val (cnt1,v1) = traverse (cnt + length (split_guards gs)) c1 in (cnt1, f cnt c [gs,b,I,V] [v1]) end | traverse _ t = raise TERM ("fold_com: unknown command",[t]); in snd (traverse 0 t) end; (*************************** Tactics ****************************************************) (*** Aux. tactics ***) fun cond_rename_bvars cond name thm = let fun rename (tm as (Abs (x, T, t))) = if cond tm then Abs (name x, T, rename t) else Abs (x, T, rename t) | rename (t $ u) = rename t $ rename u | rename a = a; in Thm.renamed_prop (rename (Thm.prop_of thm)) thm end; val rename_bvars = cond_rename_bvars (K true); fun trace_tac ctxt str st = (if Config.get ctxt hoare_trace then tracing str else (); all_tac st); fun error_tac str st = (error str;no_tac st); fun rename_goal ctxt name = EVERY' [K (trace_tac ctxt "rename_goal -- START"), SELECT_GOAL (PRIMITIVE (rename_bvars name)), K (trace_tac ctxt "rename_goal -- STOP")]; (* splits applications of tupled arguments to a schematic Variables, e.g. * ALL a b. ?P (a,b) --> ?Q (a,b) gets * ALL a b. ?P a b --> ?Q a b * only tuples nested to the right are splitted. *) fun split_pair_apps ctxt thm = let val t = Thm.prop_of thm; fun mk_subst subst (Abs (x,T,t)) = mk_subst subst t | mk_subst subst (t as (t1$t2)) = (case strip_comb t of (var as Var (v,vT),args) => (if not (AList.defined (op =) subst var) then let val len = length args; val (argTs,bdyT) = strip_type vT; val (z, _) = Name.variant "z" (fold Term.declare_term_frees args Name.context); val frees = map (apfst (fn i => z^string_of_int i)) (0 upto (len - 1) ~~ argTs); fun splitT (Type (@{type_name Product_Type.prod}, [T1, T2])) = T1::splitT T2 | splitT T = [T]; fun pair_depth (Const (@{const_name Pair},aT)$t1$t2) = 1 + (pair_depth t2) | pair_depth _ = 0; fun mk_sel max free i = let val snds = funpow i HOLogic.mk_snd (Free free) in if i=max then snds else HOLogic.mk_fst snds end; fun split (free,arg) = let val depth = (pair_depth arg); in if depth = 0 then [Free free] else map (mk_sel depth free) (0 upto depth) end; val args' = maps split (frees ~~ args); val argTs' = maps splitT argTs; val inst = fold_rev absfree frees (list_comb (Var (v,argTs' ---> bdyT), args')) in subst@[(var,inst)] end else subst) | _ => mk_subst (mk_subst subst t1) t2) | mk_subst subst t = subst; val subst = map (fn (v,t) => (dest_Var v, Thm.cterm_of ctxt t)) (mk_subst [] t); in full_simplify (put_simpset HOL_basic_ss ctxt addsimps [@{thm fst_conv}, @{thm snd_conv}]) (Drule.instantiate_normalize (TVars.empty, Vars.make subst) thm) end; (* Generates split theorems, for !!,!,? quantifiers and for UN, e.g. * ALL x. P x = ALL a b. P a b *) fun mk_split_thms ctxt (vars as _::_) = let val thy = Proof_Context.theory_of ctxt; val names = map fst vars; val types = map snd vars; val free_vars = map Free vars; val pT = foldr1 HOLogic.mk_prodT types; val x = (singleton (Name.variant_list names) "x", pT); val xp = foldr1 HOLogic.mk_prod free_vars; val tfree_names = fold Term.add_tfree_names free_vars []; val zeta = TFree (singleton (Name.variant_list tfree_names) "z", Sign.defaultS thy); val split_meta_prop = let val P = Free (singleton (Name.variant_list names) "P", pT --> Term.propT) in Logic.mk_equals (Logic.all (Free x) (P $ Free x), fold_rev Logic.all free_vars (P $ xp)) end; val P = Free (singleton (Name.variant_list names) "P", pT --> HOLogic.boolT); val split_object_prop = let fun ALL vs t = Library.foldr (fn ((v,T),t) => HOLogic.mk_all (v,T,t)) (vs,t) in (ALL [x] (P $ Free x)) === (ALL vars (P $ xp)) end; val split_ex_prop = let fun EX vs t = Library.foldr (fn ((v,T),t) => HOLogic.mk_exists (v,T,t)) (vs,t) in (EX [x] (P $ Free x)) === (EX vars (P $ xp)) end; val split_UN_prop = let val P = Free (singleton (Name.variant_list names) "P", pT --> HOLogic.mk_setT zeta); fun UN vs t = Library.foldr mk_UN (vs, t) in (UN [x] (P $ Free x)) === (UN vars (P $ xp)) end; fun prove_simp simps prop = let val ([prop'], _) = Variable.importT_terms [prop] ctxt (* FIXME continue context!? *) in Goal.prove_global thy [] [] prop' (fn {context = goal_ctxt, ...} => ALLGOALS (simp_tac (put_simpset HOL_basic_ss goal_ctxt addsimps simps))) end; val split_meta = prove_simp [@{thm split_paired_all}] split_meta_prop; val split_object = prove_simp [@{thm split_paired_All}] split_object_prop; val split_ex = prove_simp [@{thm split_paired_Ex}] split_ex_prop; val split_UN = prove_simp [@{thm Hoare.split_paired_UN}] split_UN_prop; in [split_meta,split_object,split_ex,split_UN] end | mk_split_thms _ _ = raise Match; fun rename_aux_var name rule = let fun is_aux_var (Abs ("Z",TVar(_,_),_)) = true | is_aux_var _ = false; in cond_rename_bvars is_aux_var (K name) rule end; (* adapts single auxiliary variable in a rule to potentialy multiple auxiliary * variables in actual specification, e.g. if vars are a b, * split_app=false: ALL Z. ?P Z gets to ALL a b. ?P (a,b) * split_app=true: ALL Z. ?P Z gets to ALL a b. ?P a b * If only one auxiliary variable is given, the variables are just renamed, * If no auxiliary is given, unit is inserted for Z: * ALL Z. ?P Z gets P () *) fun adapt_aux_var ctxt split_app (vars as (_::_::_)) tvar_rules = let val thy = Proof_Context.theory_of ctxt; val max_idx = fold Integer.max (map (Thm.maxidx_of o snd) tvar_rules) 0; val types = map (fn i => TVar (("z",i),Sign.defaultS thy)) (max_idx + 1 upto (max_idx + length vars)); fun tvar n = (n, Sign.defaultS thy); val pT = Thm.ctyp_of ctxt (foldr1 HOLogic.mk_prodT types); val rules' = map (fn (z,r) => (Drule.instantiate_normalize (TVars.make [(tvar z,pT)], Vars.empty) r)) tvar_rules; val splits = mk_split_thms ctxt (vars ~~ types); val rules'' = map (full_simplify (put_simpset HOL_basic_ss ctxt addsimps splits)) rules'; in if split_app then (map (split_pair_apps ctxt) rules'') else rules'' end | adapt_aux_var _ _ ([name]) tvar_rules = map (rename_aux_var name o snd) tvar_rules | adapt_aux_var ctxt _ ([]) tvar_rules = let val thy = Proof_Context.theory_of ctxt; fun tvar n = (n, Sign.defaultS thy); val uT = Thm.ctyp_of ctxt HOLogic.unitT; val rules' = map (fn (z,r) => (Drule.instantiate_normalize (TVars.make [(tvar z,uT)], Vars.empty) r)) tvar_rules; val splits = [@{thm Hoare.unit_meta},@{thm Hoare.unit_object},@{thm Hoare.unit_ex},@{thm Hoare.unit_UN}]; val rules'' = map (full_simplify (put_simpset HOL_basic_ss ctxt addsimps splits)) rules'; in rules'' end (* Generates a rule for recursion for n procedures out of general recursion rule *) fun gen_call_rec_rule ctxt specs_name n rule = let val thy = Proof_Context.theory_of ctxt; val maxidx = Thm.maxidx_of rule; val vars = Term.add_vars (Thm.prop_of rule) []; fun get_type n = the (AList.lookup (op =) vars (n, 0)); val (Type (_, [Type (_, [assT, Type (_, [pT,_])])])) = get_type specs_name; val zT = TVar (("z",maxidx+1),Sign.defaultS thy) fun mk_var i n T = Var ((n ^ string_of_int i,0),T); val quadT = HOLogic.mk_prodT (assT, HOLogic.mk_prodT (pT, HOLogic.mk_prodT (assT,assT))); val quadT_set = HOLogic.mk_setT quadT; fun mk_spec i = let val quadruple = HOLogic.mk_ptuple (HOLogic.flat_tupleT_paths quadT) quadT [mk_var i "P" (zT --> assT)$Bound 0, mk_var i "p" pT, mk_var i "Q" (zT --> assT)$Bound 0, mk_var i "A" (zT --> assT)$Bound 0]; val single = HOLogic.mk_set quadT [quadruple]; in mk_UN' zT quadT_set (Abs ("Z", zT, single)) end; val Specs = foldr1 (mk_Un quadT_set) (map mk_spec (1 upto n)); val rule' = Thm.instantiate' [] [SOME (Thm.cterm_of ctxt Specs)] rule |> full_simplify (put_simpset (simpset_of @{theory_context Main}) ctxt addsimps [@{thm Hoare.conjE_simp},@{thm Hoare.in_Specs_simp},@{thm Hoare.in_set_Un_simp},@{thm split_all_conj}, @{thm image_Un},@{thm image_Un_single_simp}] ) |> rename_bvars (fn s => if member (op =) ["s","\"] s then s else "Z") in rule' end; fun gen_proc_rec ctxt mode n = gen_call_rec_rule ctxt "Specs" n (ProcRecSpecs mode); (*** verification condition generator ***) (* simplifications on "Collect" sets, like {s. P s} Int {s. Q s} = {s. P s & Q s} *) fun merge_assertion_simp_tac ctxt thms = simp_tac (put_simpset HOL_basic_ss ctxt addsimps ([@{thm Hoare.CollectInt_iff},@{thm HOL.conj_assoc},@{thm Hoare.Compl_Collect},singleton_conv_sym, @{thm Set.Int_empty_right},@{thm Set.Int_empty_left},@{thm Un_empty_right},@{thm Un_empty_left}]@thms)) ; (* The following probably shouldn't live here, but refactoring so that Hoare could depend on recursive_records does not look feasible. The upshot is that there's a duplicate foldcong_ss set here. *) structure FoldCongData = Theory_Data ( type T = simpset; val empty = HOL_basic_ss; - - val copy = I; - val extend = I; val merge = merge_ss; ) val get_foldcong_ss = FoldCongData.get fun add_foldcongs congs thy = FoldCongData.map (fn ss => Proof_Context.init_global thy |> put_simpset ss |> fold Simplifier.add_cong congs |> simpset_of) thy fun add_foldcongsimps simps thy = FoldCongData.map (fn ss => Proof_Context.init_global thy |> put_simpset ss |> (fn ctxt => ctxt addsimps simps) |> simpset_of) thy (* propagates state into "Collect" sets and simplifies selections updates like: * s:{s. P s} = P s *) fun in_assertion_simp_tac ctxt state_kind thms i = let val vcg_simps = #vcg_simps (get_data ctxt); val fold_simps = get_foldcong_ss (Proof_Context.theory_of ctxt) in EVERY [simp_tac (put_simpset HOL_basic_ss ctxt addsimps ([mem_Collect_eq,@{thm Set.Un_iff},@{thm Set.Int_iff}, @{thm Set.empty_subsetI}, @{thm Set.empty_iff}, UNIV_I, @{thm Hoare.Collect_False}]@thms@K_convs@vcg_simps) addsimprocs (state_simprocs state_kind) |> fold Simplifier.add_cong K_congs) i THEN_MAYBE (simp_tac (put_simpset fold_simps ctxt addsimprocs [state_upd_simproc state_kind]) i) ] end; fun assertion_simp_tac ctxt state_kind thms i = merge_assertion_simp_tac ctxt [] i THEN_MAYBE in_assertion_simp_tac ctxt state_kind thms i (* simplify equality test on strings (and datatype-constructors) and propagate result*) fun string_eq_simp_tac ctxt = simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms list.inject list.distinct char.inject cong_exp_iff_simps simp_thms}); fun assertion_string_eq_simp_tac ctxt state_kind thms i = assertion_simp_tac ctxt state_kind thms i THEN_MAYBE string_eq_simp_tac ctxt i; fun before_set2pred_simp_tac ctxt = (simp_tac (put_simpset HOL_basic_ss ctxt addsimps [singleton_conv_sym, @{thm Hoare.CollectInt_iff}, @{thm Hoare.Compl_Collect}])); (*****************************************************************************) (** set2pred transforms sets inclusion into predicates implication, **) (** maintaining the original variable names. **) (** Ex. "{x. x=0} <= {x. x <= 1}" -set2pred-> "x=0 --> x <= 1" **) (** Subgoals containing intersections (A Int B) or complement sets (-A) **) (** are first simplified by "before_set2pred_simp_tac", that returns only **) (** subgoals of the form "{x. P x} <= {x. Q x}", which are easily **) (** transformed. **) (** This transformation may solve very easy subgoals due to a ligth **) (** simplification done by full_simp_tac **) (*****************************************************************************) fun set2pred_tac ctxt i thm = ((before_set2pred_simp_tac ctxt i) THEN_MAYBE (EVERY [trace_tac ctxt "set2pred", resolve_tac ctxt [subsetI] i, resolve_tac ctxt [CollectI] i, dresolve_tac ctxt [CollectD] i, full_simp_tac (put_simpset HOL_basic_ss ctxt) i ])) thm (*****************************************************************************) (** BasicSimpTac is called to simplify all verification conditions. It does **) (** a light simplification by applying "mem_Collect_eq" **) (** then it tries to solve subgoals of the form "A <= A" and then if **) (** set2pred is true it **) (** transforms any other into predicates, applying then **) (** the tactic chosen by the user, which may solve the subgoal completely **) (** (MaxSimpTac). **) (*****************************************************************************) fun MaxSimpTac ctxt tac i = TRY (FIRST[resolve_tac ctxt [subset_refl] i, set2pred_tac ctxt i THEN_MAYBE tac i, trace_tac ctxt "final_tac failed" ]); fun BasicSimpTac ctxt state_kind set2pred thms tac i = EVERY [(trace_tac ctxt "BasicSimpTac -- START --"), assertion_simp_tac ctxt state_kind thms i THEN_MAYBE (if set2pred then MaxSimpTac ctxt tac i else TRY (resolve_tac ctxt [subset_refl] i)), (trace_tac ctxt "BasicSimpTac -- STOP --")]; (* EVERY [(trace_tac ctxt "BasicSimpTac -- START --"), simp_tac (HOL_basic_ss addsimps [mem_Collect_eq,@{thm Hoare.CollectInt_iff}, @{thm Set.empty_subsetI}, @{thm Set.empty_iff}, UNIV_I] addsimprocs [state_simproc sk]) i THEN_MAYBE simp_tac (HOL_basic_ss addsimprocs [state_upd_simproc sk]) i THEN_MAYBE (if set2pred then MaxSimpTac ctxt tac i else TRY (rtac subset_refl i)), (trace_tac ctxt "BasicSimpTac -- STOP --")]; *) (* fun simp_state_eq_tac Record state_space = full_simp_tac (HOL_basic_ss addsimprocs (state_simprocs Record)) THEN_MAYBE' full_simp_tac (HOL_basic_ss addsimprocs [state_upd_simproc Record]) THEN_MAYBE' (state_split_simp_tac [] state_space) | simp_state_eq_tac StateFun state_space = *) fun post_conforms_tac ctxt state_kind i = EVERY [REPEAT1 (resolve_tac ctxt [allI,impI] i), ((fn i => TRY (resolve_tac ctxt [conjI] i)) THEN_ALL_NEW (fn i => (REPEAT (resolve_tac ctxt [allI,impI] i)) THEN (full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps [mem_Collect_eq,@{thm Set.singleton_iff},@{thm Set.empty_iff},UNIV_I] addsimprocs (state_simprocs state_kind)) i))) i]; fun dest_hoare_raw (Const(@{const_name HoarePartialDef.hoarep},_)$G$T$F$P$C$Q$A) = (P,C,Q,A,Partial,G,T,F) | dest_hoare_raw (Const(@{const_name HoareTotalDef.hoaret},_)$G$T$F$P$C$Q$A) = (P,C,Q,A,Total,G,T,F) | dest_hoare_raw t = raise TERM ("Hoare.dest_hoare_raw: unexpected term",[t]) fun mk_hoare_abs Ts (P,C,Q,A,mode,G,T,F) = let val hoareT = map (curry fastype_of1 Ts) [G,T,F,P,C,Q,A] ---> HOLogic.boolT; val hoareC = (case mode of Partial => Const (@{const_name HoarePartialDef.hoarep},hoareT) | Total => Const (@{const_name HoareTotalDef.hoaret},hoareT)); in hoareC$G$T$F$P$C$Q$A end; val is_hoare = can dest_hoare_raw fun dest_hoare t = let val triple = (strip_qnt_body @{const_name "All"} o HOLogic.dest_Trueprop o strip_qnt_body @{const_name Pure.all}) t; in dest_hoare_raw triple end; fun get_aux_tvar rule = let fun aux_hoare (Abs ("Z",TVar (z,_),t)) = if is_hoare (strip_qnt_body @{const_name All} t) then SOME z else NONE | aux_hoare _ = NONE; in (case first_subterm_dest (aux_hoare) (Thm.prop_of rule) of SOME (_,z) => (z,rule) | NONE => raise TERM ("get_aux_tvar: No auxiliary variable of hoare-rule found", [Thm.prop_of rule])) end; fun strip_vars t = let val bdy = (HOLogic.dest_Trueprop o Logic.strip_assums_concl) t; in strip_qnt_vars @{const_name Pure.all} t @ strip_qnt_vars @{const_name All} bdy end; local (* ex_simps are necessary in case of multiple logical variables. The state will usually be the first variable. EX s a b. s=s' ... . We have to transport EX s to s=s' to perform the substitution *) val conseq1_ss_base = simpset_of (put_simpset HOL_basic_ss @{context} addsimps ([mem_Collect_eq,@{thm Set.singleton_iff},@{thm Set.Int_iff}, @{thm Set.empty_iff},UNIV_I, @{thm HOL.conj_assoc}, @{thm disj_assoc}] @ @{thms Hoare.all_imp_eq_triv} @K_convs @ @{thms simp_thms} @ @{thms ex_simps} @ @{thms all_simps}) delsimps [@{thm Hoare.all_imp_to_ex}] |> fold Simplifier.add_cong K_congs) val conseq1_ss_record = simpset_of (put_simpset conseq1_ss_base @{context} addsimprocs (state_simprocs Record)); val conseq1_ss_fun = simpset_of (put_simpset conseq1_ss_base @{context} addsimprocs (state_simprocs Function)); fun conseq1_ss Record = conseq1_ss_record | conseq1_ss Function = conseq1_ss_fun; val conseq2_ss_base = simpset_of (put_simpset HOL_basic_ss @{context} addsimps (@{thms Hoare.all_imp_eq_triv} @ @{thms simp_thms} @ @{thms ex_simps} @ @{thms all_simps}) delsimps [@{thm Hoare.all_imp_to_ex}] |> Simplifier.add_cong @{thm imp_cong}); val conseq2_ss_record = simpset_of (put_simpset conseq2_ss_base @{context} addsimprocs [state_upd_simproc Record, state_ex_sel_eq_simproc Record]); val conseq2_ss_fun = simpset_of (put_simpset conseq2_ss_base @{context} addsimprocs [state_upd_simproc Function, state_ex_sel_eq_simproc Function]); fun conseq2_ss Record = conseq2_ss_record | conseq2_ss Function = conseq2_ss_fun; in fun raw_conseq_simp_tac ctxt state_kind thms i = let val ctxt' = Config.put simp_depth_limit 0 ctxt; in simp_tac (put_simpset (conseq1_ss state_kind) ctxt' addsimps thms) i THEN_MAYBE simp_tac (put_simpset (conseq2_ss state_kind) ctxt') i end end val conseq_simp_tac = raw_conseq_simp_tac; (* Generates the hoare-quadruples that can be derived out of the hoare-context T *) fun gen_context_thms ctxt mode params G T F = let val Type (_,[comT]) = range_type (fastype_of G); fun destQuadruple (Const (@{const_name Set.insert},_) $ PpQA $ Const (@{const_name Orderings.bot}, _)) = PpQA | destQuadruple t = raise Match; fun mkCallQuadruple (Const (@{const_name Pair}, _) $ P $ (Const (@{const_name Pair}, _) $ p $ (Const(@{const_name Pair}, _) $ Q $ A))) = let val Call_p = Const (@{const_name Language.com.Call}, fastype_of p --> comT) $ p; in (P, Call_p, Q, A) end; fun mkHoare mode G T F (vars,PpQA) = let val hoare = (case mode of Partial => @{const_name HoarePartialDef.hoarep} | Total => @{const_name HoareTotalDef.hoaret}); (* FIXME: Use future Proof_Context.rename_vars or make closed term and remove by hand *) (* fun free_params ps t = foldr (fn ((x,xT),t) => snd (variant_abs (x,xT,t))) (ps,t); val PpQA' = mkCallQuadruple (strip_qnt_body @{const_name Pure.all} (free_params params (Term.list_all (vars,PpQA)))); *) val params' = (Variable.variant_frees ctxt [PpQA] params); val bnds = map Bound (0 upto (length vars - 1)); fun free_params_vars t = subst_bounds (bnds @ rev (map Free params' ), t) fun free_params t = subst_bounds (rev (map Free params' ), t) val (P',p',Q',A') = mkCallQuadruple (free_params_vars PpQA); val T' = free_params T; val G' = free_params G; val F' = free_params F; val bdy = mk_hoare_abs [] (P',p',Q',A',mode,G',T',F'); in (HOLogic.mk_Trueprop (HOLogic.list_all (vars,bdy)), map fst params') end; fun hoare_context_specs mode G T F = let fun mk t = try (mkHoare mode G T F o apsnd destQuadruple o dest_UN) t; in map_filter mk (dest_Un T) end; fun mk_prove mode (prop,params) = let val vars = map fst (strip_qnt_vars @{const_name All} (HOLogic.dest_Trueprop (Logic.strip_assums_concl prop))); in Goal.prove ctxt params [] prop (fn {context = ctxt', ...} => EVERY[trace_tac ctxt' "extracting specifications from hoare context", resolve_tac ctxt' (adapt_aux_var ctxt' true vars [get_aux_tvar (AsmUN mode)]) 1, DEPTH_SOLVE_1 (resolve_tac ctxt' [subset_refl,refl] 1 ORELSE ((resolve_tac ctxt' [@{thm Hoare.subset_unI1}] 1 APPEND resolve_tac ctxt' [@{thm Hoare.subset_unI2}] 1) ORELSE (resolve_tac ctxt' [@{thm Hoare.subset_singleton_insert1}] 1 APPEND resolve_tac ctxt' [@{thm Hoare.subset_singleton_insert2}] 1))) ORELSE error_tac ("vcg: cannot extract specifications from context") ]) end; val specs = hoare_context_specs mode G T F; in map (mk_prove mode) specs end; fun is_modifies_clause t = exists_subterm (fn (Const (@{const_name Hoare.meq},_)) => true| _ => false) (#3 (dest_hoare (Logic.strip_assums_concl t))) handle (TERM _) => false; val is_spec_clause = not o is_modifies_clause; (* e.g: Intg => the_Intg lift Intg => lift the_Intg map Ingt => map the_Intg Hp o lift Intg => lift the_Intg o the_Hp *) fun swap_constr_destr f (t as (Const (@{const_name Fun.id},_))) = t | swap_constr_destr f (t as (Const (c,Type ("fun",[T,valT])))) = (Const (f c, Type ("fun",[valT,T])) handle Empty => raise TERM ("Hoare.swap_constr_destr",[t])) | swap_constr_destr f (Const ("StateFun.map_fun",Type ("fun", (* FIXME unknown "StateFun.map_fun" !? *) [Type ("fun",[T,valT]), Type ("fun",[Type ("fun",[xT,T']), Type ("fun",[xT',valT'])])]))$g) = Const ("StateFun.map_fun",Type("fun",[Type ("fun",[valT,T]), Type ("fun",[Type ("fun",[xT,valT']), Type ("fun",[xT',T'])])]))$ swap_constr_destr f g | swap_constr_destr f (Const (@{const_name Fun.comp},Type ("fun", [Type ("fun",[bT',cT]), Type ("fun",[Type ("fun",[aT ,bT]), Type ("fun",[aT',cT'])])]))$h$g) = let val h'=swap_constr_destr f h; val g'=swap_constr_destr f g; in Const (@{const_name Fun.comp},Type ("fun", [Type ("fun",[bT,aT]), Type ("fun",[Type ("fun",[cT,bT']), Type ("fun",[cT',aT'])])]))$g'$h' end | swap_constr_destr f (Const (@{const_name List.map},Type ("fun", [Type ("fun",[aT,bT]), Type ("fun",[asT,bsT])]))$g) = (Const (@{const_name List.map},Type ("fun", [Type ("fun",[bT,aT]), Type ("fun",[bsT,asT])]))$swap_constr_destr f g) | swap_constr_destr f t = raise TERM ("Hoare.swap_constr_destr",[t]); (* FIXME: unused? *) val destr_to_constr = let fun convert c = let val (path,base) = split_last (Long_Name.explode c); in Long_Name.implode (path @ ["val",unprefix "the_" base]) end; in swap_constr_destr convert end; fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx pname return has_args _ = let val thy = Proof_Context.theory_of ctxt; val pname' = unsuffix proc_deco pname; val spec = (case AList.lookup (op =) asms pname of SOME s => SOME s | NONE => try (Proof_Context.get_thm ctxt) (suffix spec_sfx pname')); fun auxvars_for p t = (case first_subterm_dest (try dest_call) t of SOME (vars,(_,p',_,_,m,_)) => (if m=Static andalso p=(dest_string' p') then SOME vars else NONE) | NONE => NONE); fun get_auxvars_for p t = (case (map_filter ((auxvars_for p) o snd) (max_subterms_dest tap_UN t)) of (vars::_) => vars | _ => []); fun spec_tac ctxt' augment_rule augment_emptyFaults _ spec i = let val spec' = augment_emptyFaults OF [spec] handle THM _ => spec; in EVERY [resolve_tac ctxt' [augment_rule] i, resolve_tac ctxt' [spec'] (i+1), TRY (resolve_tac ctxt' [subset_refl, @{thm Set.empty_subsetI}, @{thm Set.Un_upper1}, @{thm Set.Un_upper2}] i)] end; fun check_spec name P thm = (case try dest_hoare (Thm.concl_of thm) of SOME spc => (case try dest_call (#2 spc) of SOME (_,p,_,_,m,_) => if proc_name m p = name andalso P (Thm.concl_of thm) then SOME (#5 spc,thm) else NONE | _ => NONE) | _ => NONE) fun find_dyn_specs name P thms = map_filter (check_spec name P) thms; fun get_spec name P thms = case find_dyn_specs name P thms of (spec_mode,spec)::_ => SOME (spec_mode,spec) | _ => NONE; fun solve_spec ctxt' augment_rule _ augment_emptyFaults mode _ (SOME spec_mode) (SOME spec) i= if mode=Partial andalso spec_mode=Total then resolve_tac ctxt' [@{thm HoareTotal.hoaret_to_hoarep'}] i THEN spec_tac ctxt' augment_rule augment_emptyFaults mode spec i else if mode=spec_mode then spec_tac ctxt' augment_rule augment_emptyFaults mode spec i else error("vcg: cannot use a partial correctness specification of " ^ pname' ^ " for a total correctness proof") | solve_spec ctxt' _ asmUN_rule _ mode Static _ _ i =(* try to infer spec out of context *) EVERY[trace_tac ctxt' "inferring specification from hoare context1", resolve_tac ctxt' [asmUN_rule] i, DEPTH_SOLVE_1 (resolve_tac ctxt' [subset_refl,refl] i ORELSE ((resolve_tac ctxt' [@{thm Hoare.subset_unI1}] i APPEND resolve_tac ctxt' [@{thm Hoare.subset_unI2}] i) ORELSE (resolve_tac ctxt' [@{thm Hoare.subset_singleton_insert1}] i APPEND resolve_tac ctxt' [@{thm Hoare.subset_singleton_insert2}] i))) ORELSE error_tac ("vcg: cannot infer specification of " ^ pname' ^ " from context") (* if tactic for DEPTH_SOLVE_1 would create new subgoals, use SELECT_GOAL and DEPTH_SOLVE *) ] | solve_spec ctxt' augment_rule asmUN_rule augment_emptyFaults mode Parameter _ _ i = (* try to infer spec out of assumptions *) let fun tac ({context = ctxt'', prems, ...}: Subgoal.focus) = (case (find_dyn_specs pname is_spec_clause prems) of (spec_mode,spec)::_ => solve_spec ctxt'' augment_rule asmUN_rule augment_emptyFaults mode Parameter (SOME spec_mode) (SOME spec) 1 | _ => all_tac) in Subgoal.FOCUS tac ctxt' i end val strip_spec_vars = strip_qnt_vars @{const_name All} o HOLogic.dest_Trueprop; fun apply_call_tac ctxt' pname mode cmode spec_mode spec_goal is_abr spec (subgoal,i) = let val spec_vars = map fst (case spec of SOME sp => (strip_spec_vars (Thm.concl_of sp)) | NONE => (case try (dest_hoare) subgoal of SOME (_,_,_,_,_,_,Theta,_) => get_auxvars_for pname Theta | _ => [])); fun get_call_rule Static mode is_abr = if is_abr then Proc mode else ProcNoAbr mode | get_call_rule Parameter mode is_abr = if is_abr then DynProcProcPar mode else DynProcProcParNoAbr mode; val [call_rule,augment_ctxt_rule,asmUN_rule, augment_emptyFaults] = adapt_aux_var ctxt' true spec_vars (map get_aux_tvar [get_call_rule cmode mode is_abr, AugmentContext mode, AsmUN mode, AugmentEmptyFaults mode]); in EVERY [resolve_tac ctxt' [call_rule] i, trace_tac ctxt' "call_tac -- basic_tac -- solving spec", solve_spec ctxt' augment_ctxt_rule asmUN_rule augment_emptyFaults mode cmode spec_mode spec spec_goal] end; fun basic_tac ctxt' spec i = let val msg ="Theorem " ^pname'^spec_sfx ^ " is no proper specification for procedure " ^pname'^ "; trying to infer specification from hoare context"; fun spec' s mode abr = if is_modifies_clause (Thm.concl_of s) then if abr then (TrivPost mode) OF [s] else (TrivPostNoAbr mode) OF [s] else s; val (is_abr,spec_mode,spec,spec_has_args) = (* is there a proper specification fact? *) case spec of NONE => (true,NONE,NONE,false) | SOME s => case try dest_hoare (Thm.concl_of s) of NONE => (warning msg;(true,NONE,NONE,false)) | SOME (_,c,Q,spec_abr,spec_mode,_,_,_) => case try dest_call c of NONE => (warning msg;(true,NONE,NONE,false)) | SOME (_,p,_,_,m,spec_has_args) => if proc_name m p = pname then if (mode=Total andalso spec_mode=Partial) then (warning msg;(true,NONE,NONE,false)) else if is_empty_set spec_abr then (false,SOME spec_mode, SOME (spec' s spec_mode false),spec_has_args) else (true,SOME spec_mode, SOME (spec' s spec_mode true),spec_has_args) else (warning msg;(true,NONE,NONE,false)); val () = if spec_has_args then error "procedure call in specification must be parameterless!" else (); val spec_goal = i+2; in EVERY[trace_tac ctxt' "call_tac -- basic_tac -- START --", SUBGOAL (apply_call_tac ctxt' pname mode cmode spec_mode spec_goal is_abr spec) i, resolve_tac ctxt' [allI] (i+1), resolve_tac ctxt' [allI] (i+1), cont_tac ctxt' (i+1), trace_tac ctxt' "call_tac -- basic_tac -- simplify", conseq_simp_tac ctxt' state_kind [@{thm StateSpace.upd_globals_def}] i, trace_tac ctxt' "call_tac -- basic_tac -- STOP --"] end; fun get_modifies (Const (@{const_name Collect},_) $ Abs (_,_,m)) = m | get_modifies t = raise TERM ("gen_call_tac.get_modifies",[t]); fun get_updates (Abs (_,_,t)) = get_updates t | get_updates (Const (@{const_name Hoare.mex},_) $ t) = get_updates t | get_updates (Const (@{const_name Hoare.meq},T) $ _ $ upd) = (T,upd) | get_updates t = raise TERM ("gen_call_tac.get_updates",[t]); (* return has the form: %s t. s(|globals:=globals t,...|) * should be translated to %s t. s(|globals := globals s(|m := m (globals t),...|),...|) * for all m in the modifies list. *) fun mk_subst gT meqT = fst (Sign.typ_unify thy (gT,domain_type meqT) (Vartab.empty,0)); fun mk_selR subst gT (upd,uT) = let val vT = range_type (hd (binder_types uT)); in Const (unsuffix Record.updateN upd,gT --> (Envir.norm_type subst vT)) end; (* lookup:: "('v => 'a) => 'n => ('n => 'v) => 'a" * update:: "('v => 'a) => ('a => 'v) => 'n => ('a => 'a) => ('n => 'v) => ('n => 'v)" *) fun mk_selF subst uT d n = let val vT_a::a_vT::nT::aT_aT::n_vT::_ = binder_types uT; val lT = (Envir.norm_type subst (vT_a --> nT --> n_vT --> (domain_type aT_aT))); val d' = map_types (Envir.norm_type subst) d; in Const (@{const_name StateFun.lookup},lT)$d'$n end; fun mk_rupdR subst gT (upd,uT) = let val [vT,_] = binder_types uT in Const (upd,(Envir.norm_type subst vT) --> gT --> gT) end; fun K_fun kn uT = let val T=range_type (hd (binder_types uT)) in Const (kn,T --> T --> T) end; fun K_rec uT t = let val T=range_type (hd (binder_types uT)) in Abs ("_", T, incr_boundvars 1 t) end; fun mk_supdF subst uT d c n = let val uT' = Envir.norm_type subst uT; val c' = map_types (Envir.norm_type subst) c; val d' = map_types (Envir.norm_type subst) d; in Const (@{const_name StateFun.update},uT')$d'$c'$n end; fun modify_updatesR subst gT glob ((Const (upd,uT))$_$(Const _$Z)) = mk_rupdR subst gT (upd,uT)$ (K_rec uT (mk_selR subst gT (upd,uT)$(glob$Bound 0)))$(glob$Bound 1) | modify_updatesR subst gT glob ((Const (upd,uT))$_$s) = mk_rupdR subst gT (upd,uT)$ (K_rec uT (mk_selR subst gT (upd,uT)$(glob$Bound 0)))$ modify_updatesR subst gT glob s | modify_updatesR subst gT glob ((_$Z)) = (glob$Bound 1) (* may_not_modify *) | modify_updatesR _ _ _ t = raise TERM ("gen_call_tac.modify_updatesR",[t]); fun modify_updatesF subst _ glob (Const (@{const_name StateFun.update},uT)$d$c$n$_$(Const globs$Z)) = mk_supdF subst uT d c n$ (K_fun KNF uT$(mk_selF subst uT d n$(glob$Bound 0)))$(glob$Bound 1) | modify_updatesF subst gT glob (Const (@{const_name StateFun.update},uT)$d$c$n$_$s) = mk_supdF subst uT d c n$ (K_fun KNF uT$(mk_selF subst uT d n$(glob$Bound 0)))$modify_updatesF subst gT glob s | modify_updatesF subst _ glob ((globs$Z)) = (glob$Bound 1) (* may_not_modify *) | modify_updatesF _ _ _ t = raise TERM ("gen_call_tac.modify_updatesF",[t]); fun modify_updates Record = modify_updatesR | modify_updates _ = modify_updatesF fun globalsT (Const (gupd,T)) = domain_type (hd (binder_types T)) | globalsT t = raise TERM ("gen_call_tac.globalsT",[t]); fun mk_upd meqT mods (gupd$(Abs (dmy,dmyT,(glob$Bound 1)))$Bound 1) = let val gT = (globalsT gupd); val subst = mk_subst gT meqT; in (gupd$(Abs (dmy,dmyT,incr_boundvars 1 (modify_updates state_kind subst gT glob mods)))$Bound 1) end | mk_upd meqT mods (upd$v$s) = upd$v$mk_upd meqT mods s | mk_upd _ _ t = raise TERM ("gen_call_tac.mk_upd",[t]); fun modify_return (meqT,mods) (Abs (s,T,Abs (t,U,upd))) = (Abs (s,T,Abs (t,U,mk_upd meqT mods upd))) | modify_return _ t = raise TERM ("get_call_tac.modify_return",[t]); fun modify_tac ctxt' spec modifies_thm i = try (fn () => let val (_,call,modif_spec_nrm,modif_spec_abr,modif_spec_mode,G,Theta,_) = dest_hoare (Thm.concl_of modifies_thm); val is_abr = not (is_empty_set modif_spec_abr); val emptyTheta = is_empty_set Theta; (*val emptyFaults = is_empty_set F;*) val spec_has_args = #6 (dest_call call); val () = if spec_has_args then error "procedure call in modifies-specification must be parameterless!" else (); val (mxprem,ModRet) = (case cmode of Static => (8,if is_abr then if emptyTheta then (ProcModifyReturn mode) else (ProcModifyReturnSameFaults mode) else if emptyTheta then (ProcModifyReturnNoAbr mode) else (ProcModifyReturnNoAbrSameFaults mode)) | Parameter => (9,if is_abr then if emptyTheta then (ProcProcParModifyReturn mode) else (ProcProcParModifyReturnSameFaults mode) else if emptyTheta then (ProcProcParModifyReturnNoAbr mode) else (ProcProcParModifyReturnNoAbrSameFaults mode))); val to_prove_prem = (case cmode of Static => 0 | Parameter => 1); val spec_goal = if is_abr then i + mxprem - 5 else i + mxprem - 6 val mods_nrm = modif_spec_nrm |> get_modifies |> get_updates; val return' = modify_return mods_nrm return; (* val return' = if is_abr then let val mods_abr = modif_spec_abr |> get_modifies |> get_updates; in modify_return mods_abr return end else return;*) val cret = Thm.cterm_of ctxt' return'; val (_,_,return'_var,_,_,_) = nth (Thm.prems_of ModRet) to_prove_prem |> dest_hoare |> #2 |> dest_call; val ModRet' = infer_instantiate ctxt' [(#1 (dest_Var return'_var), cret)] ModRet; val modifies_thm_partial = if modif_spec_mode = Total then @{thm HoareTotal.hoaret_to_hoarep'} OF [modifies_thm] else modifies_thm; fun solve_modifies_tac i = (clarsimp_tac ((ctxt' |> put_claset (claset_of @{theory_context Set}) |> put_simpset (simpset_of @{theory_context Set})) addsimps ([@{thm Hoare.mex_def},@{thm Hoare.meq_def},@{thm StateSpace.upd_globals_def}]@K_convs) addsimprocs (state_upd_simproc Record::(state_simprocs state_kind)) |> fold Simplifier.add_cong K_congs) i) THEN_MAYBE EVERY [trace_tac ctxt' "modify_tac: splitting record", state_split_simp_tac ctxt' [] state_space i]; val cnt = i + mxprem; in EVERY[trace_tac ctxt' "call_tac -- modifies_tac --", resolve_tac ctxt' [ModRet'] i, solve_spec ctxt' (AugmentContext Partial) (AsmUN Partial) (AugmentEmptyFaults Partial) Partial Static (SOME Partial) (SOME modifies_thm_partial) spec_goal, if is_abr then EVERY [trace_tac ctxt' "call_tac -- Solving abrupt modifies --", solve_modifies_tac (cnt - 6)] else all_tac, trace_tac ctxt' "call_tac -- Solving Modifies --", solve_modifies_tac (cnt - 7), basic_tac ctxt' spec (cnt - 8), if cmode = Parameter then EVERY [resolve_tac ctxt' [subset_refl] (cnt - 8), simp_tac (put_simpset HOL_basic_ss ctxt' addsimps (@{thm Hoare.CollectInt_iff} :: @{thms simp_thms})) 1] else all_tac] end) () |> (fn SOME res => res | NONE => raise TERM ("get_call_tac.modify_tac: no proper modifies spec", [])); fun specs_of_assms_tac ({context = ctxt', prems, ...}: Subgoal.focus) = (case get_spec pname is_spec_clause prems of SOME (_,spec) => (case get_spec pname is_modifies_clause prems of SOME (_,modifies_thm) => modify_tac ctxt' (SOME spec) modifies_thm 1 | NONE => basic_tac ctxt' (SOME spec) 1) | NONE => (warning ("no proper specification for procedure " ^pname^ " in assumptions"); all_tac)); val test_modify_in_ctxt_tac = let val mname = (suffix modifysfx pname'); val mspec = (case try (Proof_Context.get_thm ctxt) mname of SOME s => SOME s | NONE => (case AList.lookup (op =) asms pname of SOME s => if is_modifies_clause (Thm.concl_of s) then SOME s else NONE | NONE => NONE)); in (case mspec of NONE => basic_tac ctxt spec | SOME modifies_thm => (case check_spec pname is_modifies_clause modifies_thm of SOME _ => modify_tac ctxt spec modifies_thm | NONE => (warning ("ignoring theorem " ^ (suffix modifysfx pname') ^ "; no proper modifies specification for procedure "^pname'); basic_tac ctxt spec))) end; fun inline_bdy_tac has_args i = (case try (Proof_Context.get_thm ctxt) (suffix bodyP pname') of NONE => no_tac | SOME impl => (case try (Proof_Context.get_thm ctxt) (suffix (body_def_sfx^"_def") pname') of NONE => no_tac | SOME bdy => (tracing ("No specification found for procedure \"" ^ pname' ^ "\". Inlining procedure!"); if has_args then EVERY [trace_tac ctxt "inline_bdy_tac args", resolve_tac ctxt [CallBody mode] i, resolve_tac ctxt [impl] (i+3), resolve_tac ctxt [allI] (i+2), resolve_tac ctxt [allI] (i+2), in_assertion_simp_tac ctxt state_kind [] (i+2), cont_tac ctxt (i+2), resolve_tac ctxt [allI] (i+1),in_assertion_simp_tac ctxt state_kind [bdy] (i+1), cont_tac ctxt (i+1), in_assertion_simp_tac ctxt state_kind [@{thm StateSpace.upd_globals_def}] i] else EVERY [trace_tac ctxt "inline_bdy_tac no args", resolve_tac ctxt [ProcBody mode] i, resolve_tac ctxt [impl] (i+2), simp_tac (put_simpset HOL_basic_ss ctxt addsimps [bdy]) (i+1), cont_tac ctxt (i+1)]))); in (case cmode of Static => if get_recursive pname ctxt = SOME false andalso is_none spec then inline_bdy_tac has_args else test_modify_in_ctxt_tac | Parameter => (case spec of NONE => (tracing "no spec found!"; Subgoal.FOCUS specs_of_assms_tac ctxt) | SOME spec => (tracing "found spec!"; case check_spec pname is_spec_clause spec of SOME _ => test_modify_in_ctxt_tac | NONE => (warning ("ignoring theorem " ^ (suffix spec_sfx pname') ^ "; no proper specification for procedure " ^pname'); Subgoal.FOCUS specs_of_assms_tac ctxt)))) end; fun call_tac cont_tac mode state_kind state_space ctxt asms spec_sfx t = let val (_,c,_,_,_,_,_,F) = dest_hoare (Logic.strip_assums_concl t); fun gen_tac (_,pname,return,c,cmode,has_args) = gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx (proc_name cmode pname) return has_args F; in gen_tac (dest_call c) end handle TERM _ => K no_tac; fun solve_in_Faults_tac ctxt i = resolve_tac ctxt [UNIV_I, @{thm in_insert_hd}] i ORELSE SELECT_GOAL (SOLVE (simp_tac (put_simpset (simpset_of @{theory_context Set}) ctxt) 1)) i; local fun triv_simp ctxt = merge_assertion_simp_tac ctxt [mem_Collect_eq] THEN' simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms simp_thms} |> fold Simplifier.add_cong [@{thm conj_cong}, @{thm imp_cong}]); (* a guarded while produces stupid things, since the guards are put at the end of the body and in the invariant (rule WhileAnnoG): - guard: g /\ g - guarantee: g --> g *) in fun guard_tac ctxt strip cont_tac mode (t,i) = let val (_,c,_,_,_,_,_,F) = dest_hoare (Logic.strip_assums_concl t); val (_,_,_,doStrip) = dest_Guard c; val guarantees = if strip orelse doStrip then [GuardStrip mode, GuaranteeStrip mode] else [Guarantee mode] fun basic_tac i = EVERY [resolve_tac ctxt [Guard mode, GuaranteeAsGuard mode] i, trace_tac ctxt "Guard", cont_tac ctxt (i+1), triv_simp ctxt i] fun guarantee_tac i = EVERY [resolve_tac ctxt guarantees i, solve_in_Faults_tac ctxt (i+2), cont_tac ctxt (i+1), triv_simp ctxt i] in if is_empty_set F then EVERY [trace_tac ctxt "Guard: basic_tac", basic_tac i] else EVERY [trace_tac ctxt "Guard: trying guarantee_tac", guarantee_tac i ORELSE basic_tac i] end handle TERM _ => no_tac end; fun wf_tac ctxt = simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm Wellfounded.wf_measure},@{thm Wellfounded.wf_lex_prod},@{thm Wfrec.wf_same_fst}, @{thm Hoare.wf_measure_lex_prod},@{thm Wellfounded.wf_inv_image}]); fun in_rel_simp ctxt = simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm Hoare.in_measure_iff},@{thm Hoare.in_lex_iff},@{thm Hoare.in_mlex_iff},@{thm Hoare.in_inv_image_iff}, @{thm split_conv}]); fun while_annotate_tac ctxt inv i st = let val annotateWhile = Thm.lift_rule (Thm.cprem_of st i) @{thm HoarePartial.reannotateWhileNoGuard}; val lifted_inv = fold_rev Term.abs (Logic.strip_params (Logic.get_goal (Thm.prop_of st) i)) inv; val invVar = (#1 o strip_comb o #3 o dest_whileAnno o #2 o dest_hoare) (List.last (Thm.prems_of annotateWhile)); val annotate = infer_instantiate ctxt [(#1 (dest_Var invVar), Thm.cterm_of ctxt lifted_inv)] annotateWhile; in ((trace_tac ctxt ("annotating While with: " ^ Syntax.string_of_term ctxt lifted_inv )) THEN compose_tac ctxt (false,annotate,1) i) st end; fun cond_annotate_tac ctxt inv mode (_,i) st = let val annotateCond = Thm.lift_rule (Thm.cprem_of st i) (CondInv' mode); val lifted_inv = fold_rev Term.abs (Logic.strip_params (Logic.get_goal (Thm.prop_of st) i)) inv; val invVar = List.last (Thm.prems_of annotateCond) |> dest_hoare |> #3 |> strip_comb |> #1; val annotate = infer_instantiate ctxt [(#1 (dest_Var invVar), Thm.cterm_of ctxt lifted_inv)] annotateCond; in ((trace_tac ctxt ("annotating Cond with: "^ Syntax.string_of_term ctxt lifted_inv)) THEN compose_tac ctxt (false,annotate,5) i) st end; fun basic_while_tac ctxt state_kind cont_tac tac mode i = let fun common_tac i = EVERY[if mode=Total then wf_tac ctxt (i+3) else all_tac, BasicSimpTac ctxt state_kind true [] tac (i+2), if mode=Total then in_rel_simp ctxt (i+1) THEN (resolve_tac ctxt [allI] (i+1)) else all_tac, cont_tac ctxt (i+1) ] fun basic_tac i = EVERY [resolve_tac ctxt [While mode] i, common_tac i] in EVERY [trace_tac ctxt "basic_while_tac: basic_tac", basic_tac i] end; fun while_tac ctxt state_kind inv cont_tac tac mode t i= let val basic_tac = basic_while_tac ctxt state_kind cont_tac tac mode; in (case inv of NONE => basic_tac i | SOME I => EVERY [while_annotate_tac ctxt I i, basic_tac i]) end handle TERM _ => no_tac fun dest_split (Abs (x,T,t)) = let val (vs,recomb,bdy) = dest_split t; in ((x,T)::vs,fn t' => Abs (x,T,recomb t'),bdy) end | dest_split (c as Const (@{const_name case_prod},_)$Abs(x,T,t)) = let val (vs,recomb,bdy) = dest_split t; in ((x,T)::vs,fn t' => c$Abs (x,T,recomb t'),bdy) end | dest_split t = ([],I,t); fun whileAnnoG_tac ctxt strip_guards mode t i st = let val (_,c,_,_,_,_,_,F) = dest_hoare (Logic.strip_assums_concl t); val (SOME grds,_,I,_,_,fix) = dest_whileAnno c; val Rule = if fix then WhileAnnoGFix mode else WhileAnnoG mode; fun extract_faults (Const (@{const_name Set.insert}, _) $ t $ _) = [t] | extract_faults _ = []; fun leave_grd fs (Const (@{const_name Pair}, _) $ f $ g) = if member (op =) fs f andalso strip_guards then NONE else SOME g | leave_grd fs (Const (@{const_name Language.guaranteeStripPair}, _) $ f $ g) = if member (op =) fs f then NONE else SOME g | leave_grd fs _ = NONE; val (I_vs,I_recomb,I') = dest_split I; val grds' = map_filter (leave_grd (extract_faults F)) (HOLogic.dest_list grds); val pars = (Logic.strip_params (Logic.get_goal (Thm.prop_of st) i)); val J = fold_rev Term.abs pars (I_recomb (fold_rev (mk_Int (map snd (pars@I_vs))) grds' I')); val WhileG = Thm.lift_rule (Thm.cprem_of st i) Rule; val invVar = (fst o strip_comb o #3 o dest_whileAnno o (fn xs => nth xs 1) o snd o strip_comb o #2 o dest_hoare) (List.last (Thm.prems_of WhileG)); val WhileGInst = infer_instantiate ctxt [(#1 (dest_Var invVar), Thm.cterm_of ctxt J)] WhileG; in ((trace_tac ctxt ("WhileAnnoG, adding guards to invariant: " ^ Syntax.string_of_term ctxt J)) THEN compose_tac ctxt (false,WhileGInst,1) i) st end handle TERM _ => no_tac st | Bind => no_tac st (* renames bound state variable according to name given in goal, * before rule specAnno is applied, and solves sidecondition *) fun gen_Anno_tac dest rules tac cont_tac ctxt state_kind (t,i) st = let val vars = (dest o #2 o dest_hoare) (Logic.strip_assums_concl t); val rules' = (case (List.filter (not o null) (map dest_splits vars)) of [] => rules |(xs::_) => adapt_aux_var ctxt false (map fst xs) (map get_aux_tvar rules)); in EVERY [resolve_tac ctxt rules' i, tac, simp_tac (put_simpset HOL_basic_ss ctxt addsimps ([@{thm split_conv}, refl, @{thm Hoare.triv_All_eq}]@anno_defs) addsimprocs [@{simproc case_prod_beta}]) (i+2), simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm split_conv}]) (i+1), simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm split_conv}]) i, REPEAT (resolve_tac ctxt [allI] (i+1)), cont_tac ctxt (i+1), conseq_simp_tac ctxt state_kind [] i] st end handle TERM _ => no_tac st; fun specAnno_tac ctxt state_kind cont_tac mode = let fun dest_specAnno (Const (@{const_name Language.specAnno},_)$P$c$Q$A) = [P,c,Q,A] | dest_specAnno t = raise TERM ("dest_specAnno",[t]); val rules = [SpecAnnoNoAbrupt mode,SpecAnno mode]; in gen_Anno_tac dest_specAnno rules all_tac cont_tac ctxt state_kind end; fun whileAnnoFix_tac ctxt state_kind cont_tac mode (t,i) = let fun dest (Const (@{const_name Language.whileAnnoFix},_)$b$I$V$c) = [I,V,c] | dest t = raise TERM ("dest_whileAnnoFix",[t]); val rules = [WhileAnnoFix mode]; fun wf_tac' i = EVERY [REPEAT (resolve_tac ctxt [allI] i), simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm split_conv}]) i, wf_tac ctxt i]; val tac = if mode=Total then EVERY [wf_tac' (i+3),in_rel_simp ctxt (i+1)] else all_tac in gen_Anno_tac dest rules tac cont_tac ctxt state_kind (t,i) end; fun lemAnno_tac ctxt state_kind mode (t,i) st = let fun dest_name (Const (x,_)) = x | dest_name (Free (x,_)) = x | dest_name t = raise TERM ("dest_name",[t]); fun dest_lemAnno (Const (@{const_name Language.lem},_)$n$c) = let val x = Long_Name.base_name (dest_name n); in (case try (Proof_Context.get_thm ctxt) x of NONE => error ("No lemma: '" ^ x ^ "' found.") | SOME spec => (strip_qnt_vars @{const_name All} (HOLogic.dest_Trueprop (Thm.concl_of spec)),spec)) end | dest_lemAnno t = raise TERM ("dest_lemAnno",[t]); val (vars,spec) = dest_lemAnno (#2 (dest_hoare t)); val rules = [LemAnnoNoAbrupt mode,LemAnno mode]; val rules' = (case vars of [] => rules | xs => adapt_aux_var ctxt true (map fst xs) (map get_aux_tvar rules)); in EVERY [resolve_tac ctxt rules' i, resolve_tac ctxt [spec] (i+1), conseq_simp_tac ctxt state_kind [] i] st end handle TERM _ => no_tac st; fun prems_tac ctxt i = TRY (resolve_tac ctxt (Assumption.all_prems_of ctxt) i); fun mk_proc_assoc thms = let fun name (_,p,_,_,cmode,_) = proc_name cmode p; fun proc_name thm = thm |> Thm.concl_of |> dest_hoare |> #2 |> dest_call |> name; in map (fn thm => (proc_name thm,thm)) thms end; fun mk_hoare_tac cont ctxt mode i (name,tac) = EVERY [trace_tac ctxt ("trying: " ^ name),tac cont ctxt mode i]; (* the main hoare tactic *) fun HoareTac annotate_inv exspecs strip_guards mode state_kind state_space spec_sfx ctxt tac st = let val (P,c,Q,A,_,G,T,F) = dest_hoare (Logic.strip_assums_concl (Logic.get_goal (Thm.prop_of st) 1)); val wp_tacs = #wp_tacs (get_data ctxt); val hoare_tacs = #hoare_tacs (get_data ctxt); val params = (strip_vars (Logic.get_goal (Thm.prop_of st) 1)); val Inv = (if annotate_inv then (* Take the postcondition of the triple as invariant for all *) (* while loops (makes sense for the modifies clause) *) SOME Q else NONE); val exspecthms = map (Proof_Context.get_thm ctxt) exspecs; val asms = try (fn () => mk_proc_assoc (gen_context_thms ctxt mode params G T F @ exspecthms)) () |> the_default []; fun while_annoG_tac (t,i) = whileAnnoG_tac ctxt (annotate_inv orelse strip_guards) mode t i; fun WlpTac tac i = (* WlpTac does not end with subset_refl *) FIRST ([EVERY [resolve_tac ctxt [Seq mode] i,trace_tac ctxt "Seq",HoareRuleTac tac false ctxt (i+1)], EVERY [resolve_tac ctxt [Catch mode] i,trace_tac ctxt "Catch",HoareRuleTac tac false ctxt (i+1)], EVERY [resolve_tac ctxt [CondCatch mode] i,trace_tac ctxt "CondCatch",HoareRuleTac tac false ctxt (i+1)], EVERY [resolve_tac ctxt [BSeq mode] i,trace_tac ctxt "BSeq",HoareRuleTac tac false ctxt (i+1)], EVERY [resolve_tac ctxt [FCall mode] i,trace_tac ctxt "FCall"], EVERY [resolve_tac ctxt [GuardsNil mode] i,trace_tac ctxt "GuardsNil"], EVERY [resolve_tac ctxt [GuardsConsGuaranteeStrip mode] i, trace_tac ctxt "GuardsConsGuaranteeStrip"], EVERY [resolve_tac ctxt [GuardsCons mode] i,trace_tac ctxt "GuardsCons"], EVERY [SUBGOAL while_annoG_tac i] ] @ map (mk_hoare_tac (fn p => HoareRuleTac tac p ctxt) ctxt mode i) wp_tacs) and HoareRuleTac tac pre_cond ctxt i st = let fun call (t,i) = call_tac (HoareRuleTac tac false) mode state_kind state_space ctxt asms spec_sfx t i fun cond_tac i = if annotate_inv andalso Config.get ctxt use_cond_inv_modifies then EVERY[SUBGOAL (cond_annotate_tac ctxt (the Inv) mode) i, HoareRuleTac tac false ctxt (i+4), HoareRuleTac tac false ctxt (i+3), BasicSimpTac ctxt state_kind true [] tac (i+2), BasicSimpTac ctxt state_kind true [] tac (i+1) ] else EVERY[resolve_tac ctxt [Cond mode] i,trace_tac ctxt "Cond", HoareRuleTac tac false ctxt (i+2), HoareRuleTac tac false ctxt (i+1)]; fun switch_tac i = EVERY[resolve_tac ctxt [SwitchNil mode] i, trace_tac ctxt "SwitchNil"] ORELSE EVERY[resolve_tac ctxt [SwitchCons mode] i,trace_tac ctxt "SwitchCons", HoareRuleTac tac false ctxt (i+2), HoareRuleTac tac false ctxt (i+1)]; fun while_tac' (t,i) = while_tac ctxt state_kind Inv (HoareRuleTac tac true) tac mode t i; in st |> ( (WlpTac tac i THEN HoareRuleTac tac pre_cond ctxt i) ORELSE (FIRST([EVERY[resolve_tac ctxt [Skip mode] i,trace_tac ctxt "Skip"], EVERY[resolve_tac ctxt [BasicCond mode] i, trace_tac ctxt "BasicCond", assertion_simp_tac ctxt state_kind [] i], (resolve_tac ctxt [Basic mode] i THEN trace_tac ctxt "Basic") THEN_MAYBE (assertion_simp_tac ctxt state_kind [] i), (* we don't really need simplificaton here. The question is if it is better to simplify the assertion after each Basic step, so that intermediate assertions stay "small", or if we just accumulate the raw assertions and leave the simplification to the final BasicSimpTac *) EVERY[resolve_tac ctxt [Throw mode] i, trace_tac ctxt "Throw"], (resolve_tac ctxt [Raise mode] i THEN trace_tac ctxt "Raise") THEN_MAYBE (assertion_string_eq_simp_tac ctxt state_kind [] i), cond_tac i, switch_tac i, EVERY[resolve_tac ctxt [Block mode] i, trace_tac ctxt "Block", resolve_tac ctxt [allI] (i+2), resolve_tac ctxt [allI] (i+2), HoareRuleTac tac false ctxt (i+2), resolve_tac ctxt [allI] (i+1), in_assertion_simp_tac ctxt state_kind [] (i+1), HoareRuleTac tac false ctxt (i+1)], SUBGOAL while_tac' i, SUBGOAL (guard_tac ctxt (annotate_inv orelse strip_guards) (HoareRuleTac tac false) mode) i, EVERY[SUBGOAL (specAnno_tac ctxt state_kind (HoareRuleTac tac true) mode) i], EVERY[SUBGOAL (whileAnnoFix_tac ctxt state_kind (HoareRuleTac tac true) mode) i], EVERY[resolve_tac ctxt [SpecIf mode] i, trace_tac ctxt "SpecIf", assertion_simp_tac ctxt state_kind [] i], (resolve_tac ctxt [Spec mode] i THEN trace_tac ctxt "Spec") THEN_MAYBE (assertion_simp_tac ctxt state_kind [@{thm split_conv}] i), EVERY[resolve_tac ctxt [BindR mode] i, trace_tac ctxt "Bind", resolve_tac ctxt [allI] (i+1), HoareRuleTac tac false ctxt (i+1)], EVERY[resolve_tac ctxt [DynCom mode] i, trace_tac ctxt "DynCom"], EVERY[trace_tac ctxt "calling call_tac",SUBGOAL call i], EVERY[trace_tac ctxt "LemmaAnno",SUBGOAL (lemAnno_tac ctxt state_kind mode) i]] @ map (mk_hoare_tac (fn p => HoareRuleTac tac p ctxt) ctxt mode i) hoare_tacs) THEN (if pre_cond then EVERY [trace_tac ctxt "pre_cond", TRY (BasicSimpTac ctxt state_kind true [] tac i), (* FIXME: Do we need TRY *) trace_tac ctxt "after BasicSimpTac"] else (resolve_tac ctxt [subset_refl] i)))) end; in ((K (EVERY [REPEAT (resolve_tac ctxt [allI] 1), HoareRuleTac tac true ctxt 1])) THEN_ALL_NEW (prems_tac ctxt)) 1 st (*Procedure specifications may have an locale assumption as premise. These are accumulated by the vcg and are be solved afterward by prems_tac *) end; fun prefer_tac i = (Tactic.defer_tac i THEN PRIMITIVE (Thm.permute_prems 0 ~1)); fun HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac st = let val asms = try (fn () => let val (_,_,_,_,_,G,T,F) = dest_hoare (Logic.strip_assums_concl (Logic.get_goal (Thm.prop_of st) 1)); val params = (strip_vars (Logic.get_goal (Thm.prop_of st) 1)); in mk_proc_assoc (gen_context_thms ctxt mode params G T F) end) () |> the_default []; fun result_tac ctxt' i = TRY (EVERY [resolve_tac ctxt' [Basic mode] i, resolve_tac ctxt' [subset_refl] i]); fun call (t,i) = call_tac result_tac mode state_kind state_space ctxt asms spec_sfx t i fun final_simp_tac i = EVERY [full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps [mem_Collect_eq]) i, REPEAT (eresolve_tac ctxt [conjE] i), TRY (hyp_subst_tac_thin true ctxt i), BasicSimpTac ctxt state_kind true [] tac i] fun while_annoG_tac (t,i) = whileAnnoG_tac ctxt strip_guards mode t i; in st |> (REPEAT (resolve_tac ctxt [allI] 1) THEN FIRST [resolve_tac ctxt [subset_refl] 1, EVERY[resolve_tac ctxt [Skip mode] 1,TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [BasicCond mode] 1,trace_tac ctxt "BasicCond", TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [Basic mode] 1,TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [Throw mode] 1,TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [Raise mode] 1,TRY (assertion_string_eq_simp_tac ctxt state_kind [] 1)], resolve_tac ctxt [SeqSwap mode] 1 THEN_MAYBE HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac, EVERY[resolve_tac ctxt [BSeq mode] 1, prefer_tac 2 THEN_MAYBE HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac], resolve_tac ctxt [CondSwap mode] 1, resolve_tac ctxt [SwitchNil mode] 1, resolve_tac ctxt [SwitchCons mode] 1, EVERY [SUBGOAL while_annoG_tac 1], EVERY[resolve_tac ctxt [While mode] 1, if mode=Total then wf_tac ctxt 4 else all_tac, BasicSimpTac ctxt state_kind false [] tac 3, if mode=Total then in_rel_simp ctxt 2 THEN (resolve_tac ctxt [allI] 2) else all_tac, BasicSimpTac ctxt state_kind false [] tac 1], resolve_tac ctxt [CatchSwap mode] 1, resolve_tac ctxt [CondCatchSwap mode] 1, EVERY[resolve_tac ctxt [BlockSwap mode] 1, resolve_tac ctxt [allI] 1, resolve_tac ctxt [allI] 1, resolve_tac ctxt [allI] 2, BasicSimpTac ctxt state_kind false [] tac 2], resolve_tac ctxt [GuardsNil mode] 1, resolve_tac ctxt [GuardsConsGuaranteeStrip mode] 1, resolve_tac ctxt [GuardsCons mode] 1, SUBGOAL (guard_tac ctxt strip_guards (K (K all_tac)) mode) 1, EVERY[SUBGOAL (specAnno_tac ctxt state_kind (K (K all_tac)) mode) 1], EVERY[SUBGOAL (whileAnnoFix_tac ctxt state_kind (K (K all_tac)) mode) 1], EVERY[resolve_tac ctxt [SpecIf mode] 1,trace_tac ctxt "SpecIf", TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [Spec mode] 1, TRY (BasicSimpTac ctxt state_kind false [@{thm split_conv}] tac 1)], EVERY[resolve_tac ctxt [BindR mode] 1, resolve_tac ctxt [allI] 2, prefer_tac 2], EVERY[resolve_tac ctxt [FCall mode] 1], EVERY[resolve_tac ctxt [DynCom mode] 1], EVERY[SUBGOAL call 1, BasicSimpTac ctxt state_kind false [] tac 1], EVERY[SUBGOAL (lemAnno_tac ctxt state_kind mode) 1, BasicSimpTac ctxt state_kind false [] tac 1], final_simp_tac 1 ]) end; (*****************************************************************************) (** Generalise verification condition **) (*****************************************************************************) structure RecordSplitState : SPLIT_STATE = struct val globals = @{const_name StateSpace.state.globals}; fun isState (Const _$Abs (s,T,t)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" andalso is_none (try dest_hoare_raw (strip_qnt_body @{const_name All} t)) | _ => false) | isState _ = false; fun isFreeState (Free (_,T)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" | _ => false) | isFreeState _ = false; val abs_state = Option.map snd o first_subterm isFreeState; fun sel_eq (Const (x,_)$_) y = (x=y) | sel_eq t y = raise TERM ("RecordSplitState.sel_eq",[t]); val sel_idx = idx sel_eq; fun bound xs (t as (Const (x,_)$_)) = let val i = sel_idx xs x in if i < 0 then (length xs, xs@[t]) else (i,xs) end | bound xs t = raise TERM ("RecordSplitState.bound",[t]); fun abs_var _ (Const (x,T)$_) = (remdeco' (Long_Name.base_name x),range_type T) | abs_var _ t = raise TERM ("RecordSplitState.abs_var",[t]); fun fld_eq (x, _) y = (x = y) fun fld_idx xs x = idx fld_eq xs x; fun sort_vars ctxt T vars = let val thy = Proof_Context.theory_of ctxt; val (flds,_) = Record.get_recT_fields thy T; val gT = the (AList.lookup (fn (x:string,y) => x=y) flds globals); val (gflds,_) = (Record.get_recT_fields thy gT handle TYPE _ => ([],("",dummyT))); fun compare (Const _$Free _, Const _$(Const _$Free _)) = GREATER | compare (Const (s1,_)$Free _, Const (s2,_)$Free _) = int_ord (fld_idx flds s1, fld_idx flds s2) | compare (Const (s1,_)$(Const _$Free _), Const (s2,_)$(Const _$Free _)) = int_ord (fld_idx gflds s1, fld_idx gflds s2) | compare _ = LESS; in sort (rev_order o compare) vars end; fun fold_state_prop loc glob app abs other inc s res (t as (Const (sel,_)$Free (s',_))) = if s'=s then if is_state_var sel then loc inc res t else raise TERM ("RecordSplitState.fold_state_prop",[t]) else other res t | fold_state_prop loc glob app abs other inc s res (t as ((t1 as (Const (sel,_)))$(t2 as (Const (glb,_)$Free (s',_))))) = if s'=s andalso is_state_var sel andalso (glb=globals) then glob inc res t else let val res1 = fold_state_prop loc glob app abs other inc s res t1 val res2 = fold_state_prop loc glob app abs other inc s res1 t2 in app res1 res2 end | fold_state_prop loc glob app abs other inc s res (t as (Free (s',_))) = if s'=s then raise TERM ("RecordSplitState.fold_state_prop",[t]) else other res t | fold_state_prop loc glob app abs other inc s res (t1$t2) = let val res1 = fold_state_prop loc glob app abs other inc s res t1 val res2 = fold_state_prop loc glob app abs other inc s res1 t2 in app res1 res2 end | fold_state_prop loc glob app abs other inc s res (Abs (x,T,t)) = let val res1 = fold_state_prop loc glob app abs other (inc+1) s res t in abs x T res1 end | fold_state_prop loc glob app abs other inc s res t = other res t fun collect_vars s t = let fun loc _ vars t = snd (bound vars t); fun glob _ vars t = snd (bound vars t); fun app _ vars2 = vars2; fun abs _ _ vars = vars; fun other vars _ = vars; in fold_state_prop loc glob app abs other 0 s [] t end; fun abstract_vars vars s t = let fun loc inc _ t = let val i = fst (bound vars t) in Bound (i+inc) end; fun glob inc _ t = let val i = fst (bound vars t) in Bound (i+inc) end; fun app t1 t2 = t1$t2; fun abs x T t = Abs (x,T,t); fun other _ t = t; val dummy = Bound 0; in fold_state_prop loc glob app abs other 0 s dummy t end; fun split_state ctxt s T t = let val vars = collect_vars s t; val vars' = if Config.get ctxt sort_variables then sort_vars ctxt T vars else vars; in (abstract_vars vars' s t,rev vars') end; fun ex_tac ctxt _ st = Record.split_simp_tac ctxt @{thms simp_thms} (K ~1) 1 st; end; structure FunSplitState : SPLIT_STATE = struct val full_globalsN = @{const_name StateSpace.state.globals}; fun isState (Const _$Abs (s,T,t)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" andalso is_none (try dest_hoare_raw (strip_qnt_body @{const_name All} t)) | _ => false) | isState _ = false; fun isFreeState (Free (_,T)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" | _ => false) | isFreeState _ = false; val abs_state = Option.map snd o first_subterm isFreeState; fun comp_name t = case try (implode o dest_string) t of SOME str => str | NONE => (case t of Free (s,_) => s | Const (s,_) => s | t => raise TERM ("FunSplitState.comp_name",[t])) fun sel_name (Const _$_$name$_) = comp_name name | sel_name t = raise TERM ("FunSplitState.sel_name",[t]); fun sel_raw_name (Const _$_$name$_) = name | sel_raw_name t = raise TERM ("FunSplitState.sel_raw_name",[t]); fun component_type (Const _$_$_$(sel$_)) = range_type (fastype_of sel) | component_type t = raise TERM ("FunSplitState.component_type",[t]); fun component_name (Const _$_$_$((Const (sel,_)$_))) = sel | component_name t = raise TERM ("FunSplitState.component_name",[t]); fun sel_type (Const _$destr$_$_) = range_type (fastype_of destr) | sel_type t = raise TERM ("FunSplitState.sel_type",[t]); fun sel_destr (Const _$destr$_$_) = destr | sel_destr t = raise TERM ("FunSplitState.sel_destr",[t]); fun sel_eq t y = (sel_name t = y) | sel_eq t y = raise TERM ("FunSplitState.sel_eq",[t]); val sel_idx = idx sel_eq; fun bound xs t = let val i = sel_idx xs (sel_name t) in if i < 0 then (length xs, xs@[t]) else (i,xs) end | bound xs t = raise TERM ("FunSplitState.bound",[t]); fun fold_state_prop var app abs other inc s res (t as (Const (@{const_name StateFun.lookup},_)$destr$name$(Const _$Free (s',_)))) = if s'=s then var inc res t else other res t (*raise TERM ("FunSplitState.fold_state_prop",[t])*) | fold_state_prop var app abs other inc s res (t as (Free (s',_))) = if s'=s then raise TERM ("FunSplitState.fold_state_prop",[t]) else other res t | fold_state_prop var app abs other inc s res (t1$t2) = let val res1 = fold_state_prop var app abs other inc s res t1 val res2 = fold_state_prop var app abs other inc s res1 t2 in app res1 res2 end | fold_state_prop var app abs other inc s res (Abs (x,T,t)) = let val res1 = fold_state_prop var app abs other (inc+1) s res t in abs x T res1 end | fold_state_prop var app abs other inc s res t = other res t fun collect_vars s t = let fun var _ vars t = snd (bound vars t); fun app _ vars2 = vars2; fun abs _ _ vars = vars; fun other vars _ = vars; in fold_state_prop var app abs other 0 s [] t end; fun abstract_vars vars s t = let fun var inc _ t = let val i = fst (bound vars t) in Bound (i+inc) end; fun app t1 t2 = t1$t2; fun abs x T t = Abs (x,T,t); fun other _ t = t; val dummy = Bound 0; in fold_state_prop var app abs other 0 s dummy t end; fun sort_vars _ vars = let val fld_idx = idx (fn s1:string => fn s2 => s1 = s2); fun compare (_$_$n$(Const (s1,_)$_),_$_$m$(Const (s2,_)$_)) = let val n' = remdeco' (comp_name n); val m' = remdeco' (comp_name m); in if s1 = full_globalsN then if s2 = full_globalsN then string_ord (n',m') else LESS else if s2 = full_globalsN then GREATER else string_ord (n',m') end | compare (t1,t2) = raise TERM ("FunSplitState.sort_vars.compare",[t1,t2]); in sort (rev_order o compare) vars end; fun split_state ctxt s _ t = let val vars = collect_vars s t; val vars' = if Config.get ctxt sort_variables then sort_vars ctxt vars else vars; in (abstract_vars vars' s t,rev vars') end; fun abs_var _ t = (remdeco' (sel_name t), sel_type t); (* Proof for: EX x_1 ... x_n. P x_1 ... x_n * ==> EX s. P (lookup destr_1 "x_1" s) ... (lookup destr_n "x_n" s) * Implementation: * 1. Eliminate existential quantifiers in premise * 2. Instantiate s with: (%x. undefined)("x_1" := constr_1 x_1, ..., "x_n" := constr_n x_n) * 3. Simplify *) local val ss = simpset_of (put_simpset (simpset_of @{theory_context Fun}) @{context} addsimps (@{thm StateFun.lookup_def} :: @{thm StateFun.id_id_cancel} :: @{thms list.inject list.distinct char.inject cong_exp_iff_simps simp_thms}) addsimprocs [Record.simproc, StateFun.lazy_conj_simproc] |> fold Simplifier.add_cong @{thms block_conj_cong}); in fun ex_tac ctxt vs st = let val vs' = rev vs; val (Const (_,exT)$_) = HOLogic.dest_Trueprop (Logic.strip_imp_concl (Logic.get_goal (Thm.prop_of st) 1)); val sT = domain_type (domain_type exT); val s0 = Const (@{const_name HOL.undefined},sT); fun streq (s1:string,s2) = s1=s2 ; fun mk_init [] = [] | mk_init (t::ts) = let val xs = mk_init ts; val n = component_name t; val T = component_type t; in if AList.defined streq xs n then xs else (n,(T,Const (n,sT --> component_type t)$s0))::xs end; fun mk_upd (i,t) xs = let val selN = component_name t; val selT = component_type t; val (_,s) = the (AList.lookup streq xs selN); val strT = domain_type selT; val valT = range_type selT; val constr = destr_to_constr (sel_destr t); val name = (sel_raw_name t); val upd = Const (@{const_name Fun.fun_upd}, (strT --> valT)-->strT-->valT--> (strT --> valT)) $ s $ name $ (constr $ Bound i) in AList.update streq (selN,(selT,upd)) xs end; val upds = fold_index mk_upd vs' (mk_init vs'); val upd = fold (fn (n,(T,upd)) => fn s => Const (n ^ Record.updateN, T --> sT --> sT)$upd$s) upds s0; val inst = fold_rev (Term.abs o (fn t => (sel_name t, sel_type t))) vs upd; fun lift_inst_ex_tac i st = let val rule = Thm.lift_rule (Thm.cprem_of st i) (Drule.incr_indexes st exI); val (_$x) = HOLogic.dest_Trueprop (Logic.strip_assums_concl (hd (Thm.prems_of rule))); val inst_rule = infer_instantiate ctxt [(#1 (dest_Var (head_of x)), Thm.cterm_of ctxt inst)] rule; in (compose_tac ctxt (false,inst_rule, Thm.nprems_of exI) i st) end; in EVERY [REPEAT_DETERM_N (length vs) (eresolve_tac ctxt [exE] 1), lift_inst_ex_tac 1, simp_tac (put_simpset ss ctxt) 1 ] st end end (* Test: What happens when there are no lookups., EX s. True *) end; structure GeneraliseRecord = GeneraliseFun (structure SplitState=RecordSplitState); structure GeneraliseStateFun = GeneraliseFun (structure SplitState=FunSplitState); fun generalise Record = GeneraliseRecord.GENERALISE | generalise Function = GeneraliseStateFun.GENERALISE; (*****************************************************************************) (** record_vanish_tac splits up the records of a verification condition, **) (** trying to generate a predicate without records. **) (** A typical verification condition with a procedure call will have the **) (** form "!!s Z. s=Z ==> ..., where s and Z are records **) (*****************************************************************************) (* FIXME: Check out if removing the useless vars is a performance issue. If so, maybe we can remove all useless vars at once (no iterated simplification) or try to avoid introducing them. Bevore splitting the gaol we can simplifiy the goal with state_simproc this may leed to better performance... *) fun record_vanish_tac ctxt state_kind state_space i = if Config.get ctxt record_vanish then let val rem_useless_vars_simps = [Drule.triv_forall_equality,@{thm Hoare.triv_All_eq},@{thm Hoare.triv_Ex_eq}]; val rem_useless_vars_simpset = empty_simpset ctxt addsimps rem_useless_vars_simps; fun no_spec (t as (Const (@{const_name All},_)$_)) = is_none (try dest_hoare_raw (strip_qnt_body @{const_name All} t)) | no_spec _ = true; fun state_space_no_spec t = if state_space t <> 0 andalso no_spec t then ~1 else 0; in EVERY [trace_tac ctxt "record_vanish_tac -- START --", REPEAT (eresolve_tac ctxt [conjE] i), trace_tac ctxt "record_vanish_tac -- hyp_subst_tac ctxt --", TRY (hyp_subst_tac_thin true ctxt i), full_simp_tac rem_useless_vars_simpset i, (* hyp_subst_tac may have made some state variables unnecessary. We do not want to split them to avoid naming conflicts and increase performance *) trace_tac ctxt "record_vanish_tac -- Splitting records --", if Config.get ctxt use_generalise orelse state_kind = Function then generalise state_kind ctxt i else state_split_simp_tac ctxt rem_useless_vars_simps state_space_no_spec i (*THEN_MAYBE EVERY [trace_tac ctxt "record_vanish_tac -- removing useless vars --", full_simp_tac rem_useless_vars_simpset i, trace_tac ctxt "record_vanish_tac -- STOP --"]*) ] end else all_tac; (* solve_modifies_tac tries to solve modifies-clauses automatically; * The following strategy is followed: * After clar-simplifying the modifies clause we remain with a goal of the form * * EX a b. s(|A := x|) = s(|A:=a,B:=b|) * * (or because of conditional statements conjunctions of these kind of goals) * We split up the state-records and simplify (record_vanish_tac) and get to a goal of the form: * * EX a b. (|A=x,B=B|) = (|A=a,B=b|). * * If the modifies clause was correct we just have to introduce the existential quantifies * and apply reflexivity. * If not we just simplify the goal. *) local val state_fun_update_ss = simpset_of (put_simpset HOL_basic_ss @{context} addsimps ([@{thm StateFun.update_def}, @{thm id_def}, @{thm fun_upd_apply}, @{thm if_True}, @{thm if_False}] @ @{thms list.inject list.distinct char.inject cong_exp_iff_simps simp_thms} @ K_fun_convs) addsimprocs [DistinctTreeProver.distinct_simproc ["distinct_fields", "distinct_fields_globals"]] |> Simplifier.add_cong @{thm imp_cong} (* K_fun_congs FIXME: Stefan fragen*) |> Splitter.add_split @{thm if_split}); in fun solve_modifies_tac ctxt state_kind state_space i st = let val thy = Proof_Context.theory_of ctxt; fun is_split_state (trm as (Const (@{const_name Pure.all},_)$Abs(x,T,t))) = if state_space trm <> 0 then try (fn () => let fun seed (_ $ v $ st) = seed st | seed (_ $ t) = (1,t) (* split only state pair *) | seed t = (~1,t) (* split globals completely *) val all_vars = strip_qnt_vars @{const_name Pure.all} t; val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl t); val ex_vars = strip_qnt_vars @{const_name Ex} concl; val state = Bound (length all_vars + length ex_vars); val (Const (@{const_name HOL.eq},_)$x_upd$x_upd') = strip_qnt_body @{const_name Ex} concl; val (split,sd) = seed x_upd; in if sd = state then split else 0 end) () |> the_default 0 else 0 | is_split_state t = 0; val simp_ctxt = put_simpset HOL_ss ctxt addsimps (@{thm Ex_True} :: @{thm Ex_False} :: Record.get_extinjects thy); fun try_solve Record i = (*(SOLVE*) (((fn k => (TRY (REPEAT_ALL_NEW (resolve_tac ctxt [conjI, impI, allI]) k))) THEN_ALL_NEW (fn k => EVERY [state_split_simp_tac ctxt [] is_split_state k, simp_tac simp_ctxt k THEN_MAYBE rename_goal ctxt remdeco' k ])) i) (*)*) | try_solve _ i = ((fn k => (TRY (REPEAT_ALL_NEW (resolve_tac ctxt [conjI, impI, allI]) k))) THEN_ALL_NEW (fn k => REPEAT (resolve_tac ctxt [exI] k) THEN resolve_tac ctxt [ext] k THEN simp_tac (put_simpset state_fun_update_ss ctxt) k THEN_MAYBE (REPEAT_ALL_NEW (resolve_tac ctxt [conjI,impI,refl]) k))) i in ((trace_tac ctxt "solve_modifies_tac" THEN clarsimp_tac ((ctxt |> put_claset (claset_of @{theory_context HOL}) |> put_simpset (simpset_of @{theory_context Set})) addsimps ([@{thm Hoare.mex_def},@{thm Hoare.meq_def}]@K_convs) addsimprocs (state_upd_simproc Record::(state_simprocs Record)) |> fold Simplifier.add_cong K_congs) i) THEN_MAYBE try_solve state_kind i) st end; end fun proc_lookup_simp_tac ctxt i st = try (fn () => let val name = (Logic.concl_of_goal (Thm.prop_of st) i) |> dest_hoare |> #2 |> strip_comb |> #2 |> last |> strip_comb |> #2 |> last; (* the$(Gamma$name) or the$(strip$Gamma$name) *) val pname = (unsuffix proc_deco (dest_string' name)); val thms = map_filter I (map (try (Proof_Context.get_thm ctxt)) [suffix bodyP pname, suffix (body_def_sfx^"_def") pname, suffix procL pname^"."^ (suffix (body_def_sfx^"_def") pname)]); in simp_tac (put_simpset HOL_basic_ss ctxt addsimps thms @ strip_simps @ @{thms option.sel}) i st end) () |> the_default (Seq.single st); fun proc_lookup_in_dom_simp_tac ctxt i st = try (fn () => let val _$name$_ = (HOLogic.dest_Trueprop (Logic.concl_of_goal (Thm.prop_of st) i)); (* name : Gamma *) val pname = (unsuffix proc_deco (dest_string' name)); val thms = map_filter I (map (try (Proof_Context.get_thm ctxt)) [suffix bodyP pname]); in simp_tac (put_simpset HOL_basic_ss ctxt addsimps (@{thm Hoare.lookup_Some_in_dom} :: @{thm dom_strip} :: thms)) i st end) () |> the_default (Seq.single st); fun HoareRuleTac ctxt insts fixes st = let val annotate_simp_tac = simp_tac (put_simpset HOL_basic_ss ctxt addsimps (anno_defs@normalize_simps) addsimprocs [@{simproc case_prod_beta}]); fun is_com_eq (Const (@{const_name Trueprop},_)$(Const (@{const_name HOL.eq},T)$_$_)) = (case (binder_types T) of (Type (@{type_name Language.com},_)::_) => true | _ => false) | is_com_eq _ = false; fun annotate_tac i st = if is_com_eq (Logic.concl_of_goal (Thm.prop_of st) i) then annotate_simp_tac i st else all_tac st; in ((fn i => REPEAT (resolve_tac ctxt [allI] i)) THEN' Rule_Insts.res_inst_tac ctxt insts fixes st) THEN_ALL_NEW annotate_tac end; fun HoareCallRuleTac state_kind state_space ctxt thms i st = let fun dest_All (Const (@{const_name All},_)$t) = SOME t | dest_All _ = NONE; fun auxvars t = (case (map_filter ((first_subterm is_hoare) o snd) (max_subterms_dest dest_All t)) of ((vars,_)::_) => vars | _ => []); fun auxtype rule = (case (auxvars (Thm.prop_of rule)) of [] => NONE | vs => (case (last vs) of (_,TVar (z,_)) => SOME (z,rule) | _ => NONE)); val thms' = let val auxvs = map fst (auxvars (Logic.concl_of_goal (Thm.prop_of st) i)); val tvar_thms = map_filter auxtype thms in if length thms = length tvar_thms then adapt_aux_var ctxt true auxvs tvar_thms else thms end; val is_sidecondition = not o can dest_hoare; fun solve_sidecondition_tac (t,i) = if is_sidecondition t then FIRST [CHANGED_PROP (wf_tac ctxt i), (*init_conforms_tac state_kind state_space i,*) post_conforms_tac ctxt state_kind i THEN_MAYBE (if is_modifies_clause t then solve_modifies_tac ctxt state_kind state_space i else all_tac), proc_lookup_in_dom_simp_tac ctxt i ] else in_rel_simp ctxt i THEN simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm Un_empty_left},@{thm Un_empty_right}]) i THEN proc_lookup_simp_tac ctxt i fun basic_tac i = (((resolve_tac ctxt thms') THEN_ALL_NEW (fn k => (SUBGOAL solve_sidecondition_tac k))) i) in (basic_tac ORELSE' (fn k => (REPEAT (resolve_tac ctxt [allI] k)) THEN EVERY [resolve_tac ctxt thms' k])) i st end; (* vcg_polish_tac tries to solve modifies-clauses automatically; for other specifications the * records are only splitted and simplified. *) fun vcg_polish_tac solve_modifies ctxt state_kind state_space i = if solve_modifies then solve_modifies_tac ctxt state_kind state_space i else record_vanish_tac ctxt state_kind state_space i THEN_MAYBE EVERY [rename_goal ctxt remdeco' i(*, simp_tac (HOL_basic_ss addsimps @{thms simp_thms})) i*)]; fun is_funtype (Type ("fun", _)) = true | is_funtype _ = false; fun state_kind_of ctxt T = let val thy = Proof_Context.theory_of ctxt; val (s,sT) = nth (fst (Record.get_recT_fields thy T)) 1; in if Long_Name.base_name s = "locals" andalso is_funtype sT then Function else Record end handle Subscript => Record; fun find_state_space_in_triple ctxt t = try (fn () => (case first_subterm is_hoare t of NONE => NONE | SOME (abs_vars,triple) => let val (_,com,_,_,mode,_,_,_) = dest_hoare_raw triple; val T = fastype_of1 (map snd abs_vars,com) val Type(_,state_spaceT::_) = T; val SOME Tids = stateT_ids state_spaceT; in SOME (Tids,mode, state_kind_of ctxt state_spaceT) end)) () |> Option.join; fun get_state_space_in_subset_eq ctxt t = (* get state type from the following kind of terms: P <= Q, s: P *) try (fn () => let val (subset_eq,_) = (strip_comb o HOLogic.dest_Trueprop o strip_qnt_body @{const_name Pure.all}) t; val Ts = map snd (strip_vars t); val T = fastype_of1 (Ts,subset_eq); val Type (_, [_,Type (_, [Type (_, [state_spaceT]), _])]) = T; (* also works for "in": x : P *) val SOME Tids = stateT_ids state_spaceT; in (Tids,Partial, state_kind_of ctxt state_spaceT) end) (); fun get_state_space ctxt i st = (case try (Logic.concl_of_goal (Thm.prop_of st)) i of SOME t => (case find_state_space_in_triple ctxt t of SOME sp => SOME sp | NONE => get_state_space_in_subset_eq ctxt t) | NONE => NONE); fun mk_hoare_tac hoare_tac finish_tac annotate_inv exnames strip_guards spec_sfx ctxt i st = case get_state_space ctxt i st of SOME (Tids,mode,kind) => SELECT_GOAL (hoare_tac annotate_inv exnames strip_guards mode kind (is_state_space_var Tids) spec_sfx ctxt (finish_tac kind (is_state_space_var Tids))) i st | NONE => no_tac st fun vcg_tac spec_sfx strip_guards exnames ctxt i st = mk_hoare_tac HoareTac (vcg_polish_tac (spec_sfx="_modifies") ctxt) (spec_sfx="_modifies") exnames (strip_guards="true") spec_sfx ctxt i st; fun hoare_tac spec_sfx strip_guards _ ctxt i st = let fun tac state_kind state_space i = if spec_sfx="_modifies" then solve_modifies_tac ctxt state_kind state_space i else all_tac; in mk_hoare_tac HoareTac tac (spec_sfx="_modifies") [] (strip_guards="true") spec_sfx ctxt i st end; fun hoare_raw_tac spec_sfx strip_guards exnames ctxt i st = mk_hoare_tac HoareTac (K (K (K all_tac))) (spec_sfx="_modifies") [] (strip_guards="true") spec_sfx ctxt i st; fun hoare_step_tac spec_sfx strip_guards exnames ctxt i st = mk_hoare_tac (K (K HoareStepTac)) (vcg_polish_tac (spec_sfx="_modifies") ctxt) false [] (strip_guards="true") spec_sfx ctxt i st; fun hoare_rule_tac ctxt thms i st = SUBGOAL (fn _ => (case get_state_space ctxt i st of SOME (Tids,_,kind) => HoareCallRuleTac kind (is_state_space_var Tids) ctxt thms i | NONE => error "could not find proper state space type (structure or record) in goal")) i st; (*** Methods ***) val hoare_rule = Rule_Insts.method HoareRuleTac hoare_rule_tac; val argP = Args.name --| @{keyword "="} -- Args.name val argsP = Scan.repeat argP val default_args = [("spec","spec"),("strip_guards","false")] val vcg_simp_modifiers = [Args.add -- Args.colon >> K (Method.modifier vcg_simp_add \<^here>), Args.del -- Args.colon >> K (Method.modifier vcg_simp_del \<^here>)]; fun assocs2 key = map snd o filter (curry (op =) key o fst); fun gen_simp_method tac = Scan.lift (argsP >> (fn args => args @ default_args)) --| Method.sections vcg_simp_modifiers >> (fn args => fn ctxt => Method.SIMPLE_METHOD' (tac ("_" ^ the (AList.lookup (op =) args "spec")) (the (AList.lookup (op =) args "strip_guards")) (assocs2 "exspec" args) ctxt)); val hoare = gen_simp_method hoare_tac; val hoare_raw = gen_simp_method hoare_raw_tac; val vcg = gen_simp_method vcg_tac; val vcg_step = gen_simp_method hoare_step_tac; val trace_hoare_users = Unsynchronized.ref false fun print_subgoal_tac ctxt s i = SUBGOAL (fn (prem, _) => trace_tac ctxt (s ^ (Syntax.string_of_term ctxt prem))) i fun mk_hoare_thm thm _ ctxt _ i = EVERY [resolve_tac ctxt [thm] i, if !trace_hoare_users then print_subgoal_tac ctxt "Tracing: " i else all_tac] val vcg_hoare_add = Thm.declaration_attribute (fn thm => add_hoare_tacs [(Thm.derivation_name thm, mk_hoare_thm thm)]) exception UNDEF val vcg_hoare_del = Thm.declaration_attribute (fn _ => fn _ => raise UNDEF) (* setup theory *) val _ = Theory.setup (Attrib.setup @{binding vcg_simp} (Attrib.add_del vcg_simp_add vcg_simp_del) "declaration of Simplifier rule for vcg" #> Attrib.setup @{binding vcg_hoare} (Attrib.add_del vcg_hoare_add vcg_hoare_del) "declaration of wp rule for vcg") (*#> add_wp_tacs initial_wp_tacs*) end; diff --git a/thys/SpecCheck/Dynamic/dynamic_construct.ML b/thys/SpecCheck/Dynamic/dynamic_construct.ML --- a/thys/SpecCheck/Dynamic/dynamic_construct.ML +++ b/thys/SpecCheck/Dynamic/dynamic_construct.ML @@ -1,188 +1,187 @@ (* Title: SpecCheck/Dynamic/dynamic_construct.ML Author: Lukas Bulwahn and Nicolai Schaffroth, TU Muenchen Dynamic construction of generators and show functions (returned as strings that need to be compiled) from a given string representing ML code to be tested as a SpecCheck test. *) signature SPECCHECK_DYNAMIC_CONSTRUCT = sig val register : string * (string * string) -> theory -> theory type mltype val parse_pred : string -> string * mltype val build_check : Proof.context -> string -> mltype * string -> string (*val safe_check : string -> mltype * string -> string*) val string_of_bool : bool -> string val string_of_ref : ('a -> string) -> 'a Unsynchronized.ref -> string end; structure SpecCheck_Dynamic_Construct : SPECCHECK_DYNAMIC_CONSTRUCT = struct (* Parsing ML types *) datatype mltype = Var | Con of string * mltype list | Tuple of mltype list; (*Split string into tokens for parsing*) fun split s = let fun split_symbol #"(" = "( " | split_symbol #")" = " )" | split_symbol #"," = " ," | split_symbol #":" = " :" | split_symbol c = Char.toString c fun is_space c = c = #" " in String.tokens is_space (String.translate split_symbol s) end; (*Accept anything that is not a recognized symbol*) val scan_name = Scan.one (fn s => not (String.isSubstring s "(),*->;")); (*Turn a type list into a nested Con*) fun make_con [] = raise Empty | make_con [c] = c | make_con (Con (s, _) :: cl) = Con (s, [make_con cl]); (*Parse a type*) fun parse_type s = (parse_fun || parse_tuple || parse_type_single) s and parse_type_arg s = (parse_tuple || parse_type_single) s and parse_type_single s = (parse_con || parse_type_basic) s and parse_type_basic s = (parse_var || $$ "(" |-- parse_type --| $$ ")") s and parse_list s = ($$ "(" |-- parse_type -- Scan.repeat1 ($$ "," |-- parse_type) --| $$ ")" >> op::) s and parse_var s = (Scan.one (String.isPrefix "'") >> (fn _ => Var)) s and parse_con s = ((parse_con_nest || parse_type_basic -- parse_con_nest >> (fn (b, Con (t, _) :: tl) => Con (t, [b]) :: tl) || parse_list -- parse_con_nest >> (fn (l, Con (t, _) :: tl) => Con (t, l) :: tl)) >> (make_con o rev)) s and parse_con_nest s = Scan.unless parse_var (Scan.repeat1 (scan_name >> (fn t => Con (t, [])))) s and parse_fun s = (parse_type_arg -- $$ "->" -- parse_type >> (fn ((a, f), r) => Con (f, [a, r]))) s and parse_tuple s = (parse_type_single -- Scan.repeat1 ($$ "*" |-- parse_type_single) >> (fn (t, tl) => Tuple (t :: tl))) s; (*Parse entire type + name*) fun parse_function s = let val p = $$ "val" |-- scan_name --| ($$ "=" -- $$ "fn" -- $$ ":") val (name, ty) = p (split s) val stop = Scan.stopper (fn _ => ";") (fn s => s = ";"); val (typ, _) = Scan.finite stop parse_type ty in (name, typ) end; (*Create desired output*) fun parse_pred s = let val (name, Con ("->", t :: _)) = parse_function s in (name, t) end; (* Construct Generators and Pretty Printers *) (*copied from smt_config.ML *) fun string_of_bool b = if b then "true" else "false" fun string_of_ref f r = f (!r) ^ " ref"; val initial_content = Symtab.make [ ("bool", ("SpecCheck_Generator.bernoulli 0.5", "Gen_Construction.string_of_bool")), ("option", ("SpecCheck_Generator.option (SpecCheck_Generator.bernoulli (2.0 / 3.0))", "ML_Syntax.print_option")), ("list", ("SpecCheck_Generator.unfold_while (K (SpecCheck_Generator.bernoulli (2.0 / 3.0)))", " ML_Syntax.print_list")), ("unit", ("gen_unit", "fn () => \"()\"")), ("int", ("SpecCheck_Generator.range_int (~2147483647,2147483647)", "string_of_int")), ("real", ("SpecCheck_Generator.real", "string_of_real")), ("char", ("SpecCheck_Generator.char", "fn c => \"#'\" ^ (Char.toString c) ^ \"'\"")), ("string", ("SpecCheck_Generator.string (SpecCheck_Generator.nonneg 100) SpecCheck_Generator.char", "ML_Syntax.print_string")), ("->", ("SpecCheck_Generator.function' o snd", "fn (_, _) => fn _ => \"fn\"")), ("typ", ("SpecCheck_Generator.typ'' (SpecCheck_Generator.return 8) (SpecCheck_Generator.nonneg 4) (SpecCheck_Generator.nonneg 4) (1,1,1)", "Pretty.string_of o Syntax.pretty_typ (Context.the_local_context ())")), ("term", ("SpecCheck_Generator.term_tree (fn h => fn _ => " ^ "let val ngen = SpecCheck_Generator.nonneg (Int.max (0, 4-h))\n" ^ " val aterm_gen = SpecCheck_Generator.aterm' (SpecCheck_Generator.return 8) ngen (1,1,1,0)\n" ^ "in SpecCheck_Generator.zip aterm_gen ngen end)", "Pretty.string_of o Syntax.pretty_term (Context.the_local_context ())"))] structure Data = Theory_Data ( type T = (string * string) Symtab.table val empty = initial_content - val extend = I fun merge data : T = Symtab.merge (K true) data ) fun data_of ctxt tycon = (case Symtab.lookup (Data.get (Proof_Context.theory_of ctxt)) tycon of SOME data => data | NONE => error ("No generator and printer defined for ML type constructor " ^ quote tycon)) val generator_of = fst oo data_of val printer_of = snd oo data_of fun register (ty, data) = Data.map (Symtab.update (ty, data)) (* fun remove_gen ty = gen_table := AList.delete (op =) ty (!gen_table); *) fun combine dict [] = dict | combine dict dicts = enclose "(" ")" dict ^ " " ^ enclose "(" ")" (commas dicts) fun compose_generator _ Var = "SpecCheck_Generator.range_int (~2147483647, 2147483647)" | compose_generator ctxt (Con (s, types)) = combine (generator_of ctxt s) (map (compose_generator ctxt) types) | compose_generator ctxt (Tuple t) = let fun tuple_body t = space_implode "" (map (fn (ty, n) => implode ["val (x", string_of_int n, ", r", string_of_int n, ") = ", compose_generator ctxt ty, " r", string_of_int (n - 1), " "]) (t ~~ (1 upto (length t)))) fun tuple_ret a = commas (map (fn n => "x" ^ string_of_int n) (1 upto a)) in "fn r0 => let " ^ tuple_body t ^ "in ((" ^ tuple_ret (length t) ^ "), r" ^ string_of_int (length t) ^ ") end" end fun compose_printer _ Var = "Int.toString" | compose_printer ctxt (Con (s, types)) = combine (printer_of ctxt s) (map (compose_printer ctxt) types) | compose_printer ctxt (Tuple t) = let fun tuple_head a = commas (map (fn n => "x" ^ string_of_int n) (1 upto a)) fun tuple_body t = space_implode " ^ \", \" ^ " (map (fn (ty, n) => "(" ^ compose_printer ctxt ty ^ ") x" ^ string_of_int n) (t ~~ (1 upto (length t)))) in implode ["fn (", tuple_head (length t), ") => \"(\" ^ ", tuple_body t, " ^ \")\""] end (*produce compilable string*) fun build_check ctxt name (ty, spec) = implode ["SpecCheck.check (Pretty.str o (", compose_printer ctxt ty, ")) (", compose_generator ctxt ty, ") \"", name, "\" (SpecCheck_Property.prop (", spec, ")) (Context.the_local_context ()) (SpecCheck_Random.new ());"] (*produce compilable string - non-eqtype functions*) (* fun safe_check name (ty, spec) = let val default = (case AList.lookup (op =) (!gen_table) "->" of NONE => ("gen_function_rand", "fn (_, _) => fn _ => \"fn\"") | SOME entry => entry) in (gen_table := AList.update (op =) ("->", ("gen_function_safe", "fn (_, _) => fn _ => \"fn\"")) (!gen_table); build_check name (ty, spec) before gen_table := AList.update (op =) ("->", default) (!gen_table)) end; *) end; diff --git a/thys/Stream_Fusion_Code/stream_fusion.ML b/thys/Stream_Fusion_Code/stream_fusion.ML --- a/thys/Stream_Fusion_Code/stream_fusion.ML +++ b/thys/Stream_Fusion_Code/stream_fusion.ML @@ -1,184 +1,183 @@ (* Title: stream_fusion.ML Author: Alexandra Maximova, ETH Zurich, Andreas Lochbihler, ETH Zurich Implementation of the stream fusion transformation as a simproc for the preprocessor of the code generator *) signature STREAM_FUSION = sig val get_rules: Proof.context -> thm list val get_conspats: Proof.context -> (term * thm) list val match_consumer: Proof.context -> term -> bool val add_fusion_rule: thm -> Context.generic -> Context.generic val del_fusion_rule: thm -> Context.generic -> Context.generic val add_unstream: string -> Context.generic -> Context.generic val del_unstream: string -> Context.generic -> Context.generic val get_unstream: Proof.context -> string list val fusion_add: attribute val fusion_del: attribute val fusion_conv: Proof.context -> conv val fusion_simproc: Proof.context -> cterm -> thm option val trace: bool Config.T end; structure Stream_Fusion : STREAM_FUSION = struct type fusion_rules = { rules : thm Item_Net.T, conspats : (term * thm) Item_Net.T, unstream : string list } fun map_fusion_rules f1 f2 f3 {rules, conspats, unstream} = {rules = f1 rules, conspats = f2 conspats, unstream = f3 unstream}; fun map_rules f = map_fusion_rules f I I; fun map_conspats f = map_fusion_rules I f I; fun map_unstream f = map_fusion_rules I I f; (* producers: theorems about producers, have 'unstream' only on the lhs *) (* consumers: theorems about consumers, have 'unstream' only on the rhs *) (* transformers: theorems about transformers, have 'unstream' on both sides *) (* conspats: patterns of consumers that have matching theorems in consumers *) structure Fusion_Rules = Generic_Data ( type T = fusion_rules; val empty = {rules = Thm.item_net, conspats = Item_Net.init (Thm.eq_thm_prop o apply2 snd) (single o fst), unstream = []}; - val extend = I; fun merge ({rules = r, conspats = cp, unstream = u}, {rules = r', conspats = cp', unstream = u'}) = {rules = Item_Net.merge (r, r'), conspats = Item_Net.merge (cp, cp'), unstream = Library.merge (op =) (u, u')} ); val get_rules = Item_Net.content o #rules o Fusion_Rules.get o Context.Proof; val get_conspats = Item_Net.content o #conspats o Fusion_Rules.get o Context.Proof; val get_unstream = #unstream o Fusion_Rules.get o Context.Proof; fun match_consumer ctxt t = Context.Proof ctxt |> Fusion_Rules.get |> #conspats |> (fn net => Item_Net.retrieve_matching net t) |> not o null datatype classification = ProducerTransformer | Consumer of term (* used to find out if a 'unstream' is present in a term *) fun occur_in ts ((Const (c, _)) $ t) = member (op =) ts c orelse occur_in ts t | occur_in ts (op $ (u, t)) = occur_in ts u orelse occur_in ts t | occur_in ts (Abs (_, _, t)) = occur_in ts t | occur_in _ _ = false; fun first_depth (t1 $ _) = let val (f,d) = first_depth t1 in (f,d+1) end | first_depth t1 = (t1,0) fun mk_conspat rhs ctxt = let val (f,d) = first_depth rhs val types = binder_types (fastype_of f) val (vfixes, ctxt1) = Variable.variant_fixes (replicate d "x") ctxt in (hd o Variable.export_terms ctxt1 ctxt o single) (list_comb (f, map Free (vfixes ~~ types))) end fun classify ctxt thm = case Thm.full_prop_of thm of (@{const Trueprop} $ (Const (@{const_name "HOL.eq"}, _) $ lhs $ rhs)) => let val unstream = get_unstream ctxt in if occur_in unstream lhs then SOME ProducerTransformer else if occur_in unstream rhs then SOME (Consumer (mk_conspat rhs ctxt)) else NONE end | _ => NONE; fun sym thm = thm RS @{thm sym} fun format_error ctxt thm = warning (Pretty.string_of (Pretty.block [ Pretty.str "Wrong format for fusion rule: ", Pretty.brk 2, Syntax.pretty_term (Context.proof_of ctxt) (Thm.prop_of thm)])) fun register thm NONE = (fn ctxt => let val _ = format_error ctxt thm in ctxt end) | register thm (SOME ProducerTransformer) = Fusion_Rules.map ( map_rules (Item_Net.update (sym thm))) | register thm (SOME (Consumer cp)) = Fusion_Rules.map ( map_rules (Item_Net.update (sym thm)) o map_conspats (Item_Net.update (cp, thm))); fun unregister thm NONE = (fn ctxt => let val _ = format_error ctxt thm in ctxt end) | unregister thm (SOME ProducerTransformer) = Fusion_Rules.map ( map_rules (Item_Net.remove (sym thm))) | unregister thm (SOME (Consumer cp)) = Fusion_Rules.map ( map_rules (Item_Net.remove (sym thm)) o map_conspats (Item_Net.remove (cp, thm))); fun add_fusion_rule thm ctxt = register thm (classify (Context.proof_of ctxt) thm) ctxt fun del_fusion_rule thm ctxt = unregister thm (classify (Context.proof_of ctxt) thm) ctxt fun add_unstream c = Fusion_Rules.map (map_unstream (insert (op =) c)) fun del_unstream c = Fusion_Rules.map (map_unstream (remove (op =) c)) (* attributes and setup *) val fusion_add = Thm.declaration_attribute add_fusion_rule; val fusion_del = Thm.declaration_attribute del_fusion_rule; val _ = Theory.setup (Attrib.setup @{binding "stream_fusion"} (Attrib.add_del fusion_add fusion_del) "declaration of a rule for stream fusion" #> Global_Theory.add_thms_dynamic (@{binding "stream_fusion"}, Item_Net.content o #rules o Fusion_Rules.get)); val trace = Attrib.setup_config_bool @{binding "stream_fusion_trace"} (K false) fun tracing ctxt msg = if Config.get ctxt trace then Output.tracing (msg ()) else () fun fusion_conv ctxt = Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps get_rules ctxt) fun fusion_simproc ctxt ct = let val matches = match_consumer ctxt (Thm.term_of ct) in if matches then let val _ = tracing ctxt (fn _ => Pretty.string_of (Pretty.block [Pretty.str "Trying stream fusion on ", Pretty.brk 2, Syntax.pretty_term ctxt (Thm.term_of ct)])) val thm = fusion_conv ctxt ct val failed = Thm.is_reflexive thm orelse occur_in (get_unstream ctxt) (Thm.term_of (Thm.rhs_of thm)) val _ = tracing ctxt (fn _ => Pretty.string_of (Pretty.block [Pretty.str (if failed then "FAILED: " else "SUCCEEDED: "), Pretty.brk 2, Syntax.pretty_term ctxt (Thm.prop_of thm)])) in if failed then NONE else SOME thm end else NONE end end; diff --git a/thys/Types_To_Sets_Extension/ETTS/ETTS_Substitution.ML b/thys/Types_To_Sets_Extension/ETTS/ETTS_Substitution.ML --- a/thys/Types_To_Sets_Extension/ETTS/ETTS_Substitution.ML +++ b/thys/Types_To_Sets_Extension/ETTS/ETTS_Substitution.ML @@ -1,354 +1,353 @@ (* Title: ETTS/ETTS_Substitution.ML Author: Mihails Milehins Copyright 2021 (C) Mihails Milehins Implementation of the functionality associated with the sbterms. *) signature ETTS_SUBSTITUTION = sig val sbt_data_of : Proof.context -> Ctermtab.key -> thm option val is_sbt_data_key : Proof.context -> cterm -> bool val process_tts_register_sbts : string * string list -> Proof.context -> Proof.state end; structure ETTS_Substitution : ETTS_SUBSTITUTION = struct (**** Prerequisites ****) open ETTS_Utilities; open ETTS_RI; (**** Data containers ****) (*** Data ***) structure SBTData_Args = struct type T = thm Ctermtab.table val empty = Ctermtab.empty - val extend = I val merge : (T * T -> T) = Ctermtab.merge (K true) fun init _ = Ctermtab.empty end; structure Global_SBTData = Theory_Data (SBTData_Args); structure Local_SBTData = Proof_Data (SBTData_Args); (*** Generic operations ***) val sbt_data_of = Local_SBTData.get #> Ctermtab.lookup; val sbt_data_keys = Local_SBTData.get #> Ctermtab.keys fun map_sbt_data f (Context.Proof ctxt) = ctxt |> Local_SBTData.map f |> Context.Proof | map_sbt_data f (Context.Theory thy) = thy |> Global_SBTData.map f |> Context.Theory; fun update_sbt_data k v = let fun declaration phi = (Morphism.cterm phi k, Morphism.thm phi v) |> Ctermtab.update |> map_sbt_data in Local_Theory.declaration {pervasive=true, syntax=false} declaration end; fun is_sbt_data_key ctxt ct = member (op aconvc) (sbt_data_keys ctxt) ct; (**** Evaluation : tts_find_sbts *****) fun process_tts_find_sbts args st = let val ctxt = Toplevel.context_of st val args = case args of [] => sbt_data_keys ctxt | args => map (ctxt |> Syntax.read_term #> Thm.cterm_of ctxt) args in args |> map (sbt_data_of ctxt #> the #> Thm.string_of_thm ctxt |> apdupr) |> map (Thm.term_of #> Syntax.string_of_term ctxt |> apfst) |> map ((fn (c, thmc) => c ^ " : " ^ thmc) #> writeln) |> K () end; (**** Parser : tts_find_sbts ****) val parse_tts_find_sbts = Parse.and_list Parse.term; (**** Interface : tts_find_sbts *****) val _ = Outer_Syntax.command \<^command_keyword>\tts_find_sbts\ "lookup a theorem associated with a constant or a fixed variable" (parse_tts_find_sbts >> (process_tts_find_sbts #> Toplevel.keep)); (**** Evaluation : tts_register_sbts *****) local fun mk_msg_tts_register_sbts msg = "tts_register_sbts: " ^ msg; (*create the goals for the function register_sbts_cmd*) fun mk_goal_register_sbts ctxt sbt risset = let val msg_repeated_risset = mk_msg_tts_register_sbts "the type variables associated with the risset must be distinct" (*auxiliary functions*) fun mk_rel_assms (brelt, rissett) = [ mk_Domainp_sc brelt rissett, Transfer.mk_bi_unique brelt, Transfer.mk_right_total brelt ]; (*risset \ unique ftvs of risset*) val rissetftv_specs = map (type_of #> dest_rissetT) risset (*input verification*) val _ = rissetftv_specs |> has_duplicates op= |> not orelse error msg_repeated_risset (*sbt \ (sbt, ftvs of sbt)*) val sbt = sbt |> (type_of #> (fn t => Term.add_tfreesT t []) |> apdupr) (* (sbt, ftvs of sbt), rissetftv_specs \ ((sbtftv_int, rcdftv_int)s, (sbtftv_sub, rcdftv_sub)s), ctxt), where sbtftv_ints = unique ftvs of sbt \ ftvs of risset sbtftv_subs = unique ftvs of sbt - ftvs of risset *) val (sbtftv_specs, ctxt) = let fun mk_ri_rhs_Ts ctxt f = map (apdupr f) #> map_slice_side_r (fn Ss => Variable.invent_types Ss ctxt) in sbt |> #2 |> distinct op= |> dup |>> inter op= rissetftv_specs ||> subtract op= rissetftv_specs |>> mk_ri_rhs_Ts ctxt (K \<^sort>\HOL.type\) |>> swap |> reroute_ps_sp |> swap |>> apsnd (map dup) end (*(sbt, ftvs of sbt) \ (sbt, sbtftv_ints)*) val sbt = apsnd (filter (member op= (sbtftv_specs |> #1 |> map #1))) sbt (* (sbtftv_int, rcdftv_int)s, sbtftv_subs) \ (((sbtftv, rcdftv), ri brel)s, ctxt) *) val (sbtftv_specs, ctxt') = let val un_of_typ = #1 #> term_name_of_type_name in sbtftv_specs |>> map (apfst un_of_typ #> apsnd un_of_typ |> apdupr) |>> map (apsnd op^) |>> map_slice_side_r (fn cs => Variable.variant_fixes cs ctxt) |>> (apfst TFree #> apsnd TFree |> apdupr |> apfst |> map |> apfst) |>> (reroute_ps_sp |> map |> apfst) |>> (swap #> HOLogic.mk_rel |> apsnd |> map |> apfst) |>> swap |> reroute_ps_sp |> swap |>> (#1 #> TFree #> HOLogic.eq_const |> apdupr |> map |> apsnd) end (*((sbtftv, rcdftv), ri brel)s, ctxt \ (premises, conclusion)*) val sbt_specs = let val ftv_map = sbtftv_specs |> #1 |> map (apfst #1) |> AList.lookup op= #> the val ftv_map' = sbtftv_specs |> op@ |> map (apfst #1) val risset_of_ftv_spec = ((risset |> map (type_of #> dest_rissetT)) ~~ risset) |> AList.lookup op= val map_specTs_to_rcdTs = sbtftv_specs |> op@ |> map (#1 #> apsnd TFree) |> AList.lookup op= #> the val (rct_name, ctxt'') = ctxt' |> Variable.variant_fixes (single "rcdt") |>> the_single in sbt |> ( ( ftv_map |> apdupl #> (risset_of_ftv_spec #> the |> apsnd) #> mk_rel_assms |> map #> flat #> map HOLogic.mk_Trueprop |> apsnd ) #> (#1 #> type_of |> apdupl) #> (ftv_map' |> CTR_Relators.pr_of_typ ctxt'' |> apfst) ) |> (fn x => (x, rct_name)) |> ( (#1 #> #2 #> #1 #> type_of |> apdupr) #> (map_specTs_to_rcdTs |> map_type_tfree |> apsnd) #> reroute_ps_sp #> (Free |> apdupl |> apsnd) ) |> reroute_sp_ps |> ( apfst reroute_sp_ps #> reroute_ps_sp #> apsnd swap |> apfst #> apfst reroute_sp_ps #> reroute_ps_sp #> apsnd swap #> reroute_sp_ps ) |> ( apfst op$ #> op$ |> apfst #> swap #> reroute_ps_triple #> HOLogic.mk_exists #> HOLogic.mk_Trueprop #> Syntax.check_term ctxt'' |> apfst ) |> swap end (*introduce the side conditions for each ex_pr*) val goal = let fun add_premts (premts, conclt) = fold_rev (fn premt => fn t => Logic.mk_implies (premt, t)) premts conclt in add_premts sbt_specs end in (goal, ctxt') end in (*implementation of the functionality of the command tts_register_sbts*) fun process_tts_register_sbts args ctxt = let (*error messages*) val msg_fv_not_fixed = mk_msg_tts_register_sbts "all fixed variables that occur in the sbterm " ^ "must be fixed in the context" val msg_ftv_not_fixed = mk_msg_tts_register_sbts "all fixed type variables that occur in the sbterm " ^ "must be fixed in the context" val msg_sv = mk_msg_tts_register_sbts "the sbterm must contain no schematic variables" val msg_stv = mk_msg_tts_register_sbts "the sbterm must contain no schematic type variables" (*pre-processing and input verification*) val sbt = args |> #1 |> Syntax.read_term ctxt val risset = args |> #2 |> map (Syntax.read_term ctxt) val _ = ETTS_RI.risset_input ctxt "tts_register_sbts" risset val _ = sbt |> (fn t => Term.add_frees t []) |> distinct op= |> map #1 |> map (Variable.is_fixed ctxt) |> List.all I orelse error msg_fv_not_fixed val _ = sbt |> (fn t => Term.add_tfrees t []) |> distinct op= |> map #1 |> map (Variable.is_declared ctxt) |> List.all I orelse error msg_ftv_not_fixed val _ = sbt |> (fn t => Term.add_vars t []) |> length |> curry op= 0 orelse error msg_sv val _ = sbt |> (fn t => Term.add_tvars t []) |> length |> curry op= 0 orelse error msg_stv (*main*) val (goalt, _) = mk_goal_register_sbts ctxt sbt risset val goal_specs = (goalt, []) |> single |> single val ct = Thm.cterm_of ctxt sbt fun after_qed thmss lthy = update_sbt_data ct (thmss |> hd |> hd) lthy in Proof.theorem NONE after_qed goal_specs ctxt end; end; (**** Parser : tts_register_sbts ****) val parse_tts_register_sbts = Parse.term -- (\<^keyword>\|\ |-- Parse.and_list Parse.term); (**** Interface : tts_register_sbts ****) val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\tts_register_sbts\ "command for the registration of the set-based terms" (parse_tts_register_sbts >> process_tts_register_sbts) end; \ No newline at end of file diff --git a/thys/UTP/toolkit/Total_Recall.ML b/thys/UTP/toolkit/Total_Recall.ML --- a/thys/UTP/toolkit/Total_Recall.ML +++ b/thys/UTP/toolkit/Total_Recall.ML @@ -1,207 +1,207 @@ (******************************************************************************) (* Project: The Isabelle/UTP Proof System *) (* File: TotalRecall.ML *) (* Authors: Simon Foster & Frank Zeyda (University of York, UK) *) (* Emails: simon.foster@york.ac.uk frank.zeyda@york.ac.uk *) (******************************************************************************) (* An improvement may be to respectively collect no_syntax and no_notation items into a single undecl_item as part of the execute_all function. This may result in a more efficient execution of undeclarations. A known issue is that we have no guarantee that an undeclaration will still be correctly parsed and executed in a sub-theory: there ought to be some error-catching and reporting mechanism at least (a more robust approach could replaced names i.e. for constants and types by their full-qualified names). *) (* Signature ORDERS *) signature ORDERS = sig val triple_ord : ('a * 'b -> order) -> ('c * 'd -> order) -> ('e * 'f -> order) -> ('a * 'c * 'e) * ('b * 'd * 'f) -> order val mode_ord : (string * bool) * (string * bool) -> order val source_ord : Input.source * Input.source -> order val input_ord : string * string -> order val mixfix_ord : mixfix * mixfix -> order end (* Structure Orders *) structure Orders : ORDERS = struct fun triple_ord f g h ((x1, y1, z1), (x2, y2, z2)) = (prod_ord f (prod_ord g h)) ((x1, (y1, z1)), (x2, (y2, z2))); val mode_ord = prod_ord string_ord bool_ord; val source_ord = string_ord o (apply2 (Input.source_content #> fst)); val input_ord = source_ord o (apply2 Syntax.read_input); local val mixfix_ctor_ord = let fun mixfix_ctor_num NoSyn = 0 | mixfix_ctor_num (Mixfix _) = 1 | mixfix_ctor_num (Infix _) = 2 | mixfix_ctor_num (Infixl _) = 3 | mixfix_ctor_num (Infixr _) = 4 | mixfix_ctor_num (Binder _) = 5 | mixfix_ctor_num (Structure _) = 6 in int_ord o (apply2 mixfix_ctor_num) end; in fun mixfix_ord (Mixfix (sy, ps, p, _), Mixfix (sy', ps', p', _)) = (prod_ord source_ord (prod_ord (list_ord int_ord) int_ord)) ((sy, (ps, p)), (sy', (ps', p'))) | mixfix_ord (Infix (sy, p, _), Infix (sy', p', _)) = (prod_ord source_ord int_ord) ((sy, p), (sy', p')) | mixfix_ord (Infixl (sy, p, _), Infixl (sy', p', _)) = (prod_ord source_ord int_ord) ((sy, p), (sy', p')) | mixfix_ord (Infixr (sy, p, _), Infixr (sy', p', _)) = (prod_ord source_ord int_ord) ((sy, p), (sy', p')) | mixfix_ord (Binder (sy, p, q, _), Binder (sy', p', q', _)) = (prod_ord source_ord (prod_ord int_ord int_ord)) ((sy, (p, q)), (sy', (p', q'))) | mixfix_ord (m1, m2) = mixfix_ctor_ord (m1, m2); end; end; (* Signature STRINGOF *) signature STRINGOF = sig val list : string * string * string -> ('a -> string) -> 'a list -> string val mode : string * bool -> string val input : string -> string val mixfix : mixfix -> string end (* Structure StringOf *) structure StringOf : STRINGOF = struct fun list (left_delim, sep, right_delim) string_of_item list = let fun string_of_list_rec [] = "" | string_of_list_rec [x] = (string_of_item x) | string_of_list_rec (h :: t) = (string_of_item h) ^ sep ^ (string_of_list_rec t) in left_delim ^ (string_of_list_rec list) ^ right_delim end; fun mode (mode as (prmode, both)) = if mode = Syntax.mode_default then "" else (if mode = Syntax.mode_input then "(input)" else "(" ^ prmode ^ (if both then "" else " output") ^ ")"); val input = ((Input.source_content #> fst) o Syntax.read_input); val mixfix = (Pretty.string_of o Mixfix.pretty_mixfix); end; (* Signature TOTALRECALL *) signature TOTALRECALL = sig val record_no_syntax : Syntax.mode -> (string * string * mixfix) list -> theory -> theory val record_no_notation : Syntax.mode -> (string * mixfix) list -> theory -> theory val execute_all : theory -> theory end; (* Structure TotalRecall *) structure TotalRecall : TOTALRECALL = struct open Orders; datatype undecl_item = no_syntax of Syntax.mode * (string * string * mixfix) list | no_notation of Syntax.mode * (string * mixfix) list; (* fun flatten_undecl_item (no_syntax (mode, args)) = map (fn arg => no_syntax (mode, [arg])) args | flatten_undecl_item (no_notation (mode, args)) = map (fn arg => no_notation (mode, [arg])) args; *) (* An order on undecl_item is needed for efficient storage using Ord_List. *) local val undecl_item_ctor_ord = let fun undecl_item_ctor_num (no_syntax _) = 0 | undecl_item_ctor_num (no_notation _) = 1 in int_ord o (apply2 undecl_item_ctor_num) end; in fun undecl_item_ord (no_syntax args, no_syntax args') = (prod_ord mode_ord (list_ord (triple_ord string_ord input_ord mixfix_ord))) (args, args') | undecl_item_ord (no_notation args, no_notation args') = (prod_ord mode_ord (list_ord (prod_ord input_ord mixfix_ord))) (args, args') | undecl_item_ord (r1, r2) = undecl_item_ctor_ord (r1, r2); end; local fun space s = (if s = "" then "" else " " ^ s); fun quote s = ("\"" ^ s ^ "\""); in fun string_of_undecl_item item = (case item of no_syntax (mode, args) => "no_syntax" ^ space(StringOf.mode mode) ^ (StringOf.list ("\n ", "\n ", "\n") (fn (syntax, typ, mixfix) => space(quote(syntax)) ^ " :: " ^ quote(StringOf.input typ) ^ space(StringOf.mixfix mixfix))) args | no_notation (mode, args) => "no_notation" ^ space(StringOf.mode mode) ^ (StringOf.list ("\n ", " and\n ", "\n") (fn (const, mixfix) => space(const) ^ space(StringOf.mixfix mixfix))) args); end; (* Theory Data *) - structure Undecl_Data = Theory_Data ( + structure Undecl_Data = Theory_Data + ( type T = undecl_item Ord_List.T; val empty = []; - val extend = I; val merge = uncurry (Ord_List.union undecl_item_ord); ); fun insert_undecl_item item = (Undecl_Data.map (Ord_List.insert undecl_item_ord(*'*) item)); fun record_no_syntax mode args = insert_undecl_item (no_syntax (mode, args)); fun record_no_notation mode args = insert_undecl_item (no_notation (mode, args)); (* We collapse similar-type items for efficiency reasons since execution can become very slow with a lot of individual no_syntax and no_notation items. We get away with the simple code since the items are lexically ordered. *) fun collaps_items (no_syntax (m1, args1) :: no_syntax (m2, args2) :: t) = (if m1 = m2 then (collaps_items (no_syntax (m1, args1 @ args2) :: t)) else no_syntax (m1, args1) :: (collaps_items ((no_syntax (m2, args2)) :: t))) | collaps_items (no_notation (m1, args1) :: no_notation (m2, args2) :: t) = (if m1 = m2 then (collaps_items (no_notation (m1, args1 @ args2) :: t)) else no_notation (m1, args1) :: (collaps_items ((no_notation (m2, args2)) :: t))) | collaps_items (h :: t) = h :: (collaps_items t) | collaps_items [] = []; fun execute_one item = (Output.writeln (string_of_undecl_item item); (case item of (no_syntax (mode, args)) => (Sign.syntax_cmd false mode args) | (no_notation (mode, args)) => (Named_Target.theory_map (Local_Theory.notation_cmd false mode args)))); fun execute_all thy = (Output.writeln "Restoring purged notations and syntax...\n"; (fold execute_one (collaps_items (Undecl_Data.get thy)) thy)); end; \ No newline at end of file diff --git a/thys/UTP/utp/uexpr_rep_eq.ML b/thys/UTP/utp/uexpr_rep_eq.ML --- a/thys/UTP/utp/uexpr_rep_eq.ML +++ b/thys/UTP/utp/uexpr_rep_eq.ML @@ -1,45 +1,45 @@ (******************************************************************************) (* Project: The Isabelle/UTP Proof System *) (* File: uexpr_rep_eq.ML *) (* Authors: Simon Foster & Frank Zeyda (University of York, UK) *) (* Emails: simon.foster@york.ac.uk frank.zeyda@york.ac.uk *) (******************************************************************************) (* LAST REVIEWED: 2 Mar 2017 *) (* UEXPR_REP_EQ Signature *) signature UEXPR_REP_EQ = sig val get_uexpr_rep_eq_thms : theory -> thm list val read_uexpr_rep_eq_thms : theory -> theory end; (* uexpr_rep_eq Structure *) structure uexpr_rep_eq : UEXPR_REP_EQ = struct (* Theory Data to store the relevant transfer laws. *) - structure UTP_Tactics_Data = Theory_Data ( + structure UTP_Tactics_Data = Theory_Data + ( type T = thm list; val empty = []; - val extend = I; val merge = Thm.merge_thms; ); val get_uexpr_rep_eq_thms = UTP_Tactics_Data.get; val put_uexpr_rep_eq_thms = UTP_Tactics_Data.put; val uexpr_rep_eq_query = let val query_string = "name:\"rep_eq\" \"Rep_uexpr ?e = ?t\"" in Find_Theorems.read_query Position.none query_string end; fun read_uexpr_rep_eq_thms thy = let val ctxt = Proof_Context.init_global thy; val facts = Find_Theorems.find_theorems_cmd ctxt NONE NONE true uexpr_rep_eq_query; in (put_uexpr_rep_eq_thms (map snd (snd facts)) thy) end; end; \ No newline at end of file