diff -r d35f7a9f92e2 -r 123acfd5fe35 src/HOL/Library/Pattern_Aliases.thy --- a/src/HOL/Library/Pattern_Aliases.thy Tue Aug 22 08:55:07 2017 +0200 +++ b/src/HOL/Library/Pattern_Aliases.thy Tue Aug 22 11:48:57 2017 +0200 @@ -1,5 +1,5 @@ (* Title: HOL/Library/Pattern_Aliases.thy - Author: Lars Hupel, Ondrej Kuncar + Author: Lars Hupel, Ondrej Kuncar, Tobias Nipkow *) section \Input syntax for pattern aliases (or ``as-patterns'' in Haskell)\ @@ -22,7 +22,9 @@ \<^item> Terms that do not adhere to the above shape may either stay untranslated or produce an error message. The @{command fun} command will complain if pattern aliases are left untranslated. In particular, there are no checks whether the patterns are wellformed or linear. - \<^item> The corresponding uncheck phase attempts to reverse the translation (no guarantee). + \<^item> The corresponding uncheck phase attempts to reverse the translation (no guarantee). The + additionally introduced variables are bound using a ``fake quantifier'' that does not + appear in the output. \<^item> To obtain reasonable induction principles in function definitions, the bundle also declares a custom congruence rule for @{const Let} that only affects @{command fun}. This congruence rule might lead to an explosion in term size (although that is rare)! @@ -31,11 +33,15 @@ subsection \Definition\ -consts as :: "'a \ 'a \ 'a" +consts + as :: "'a \ 'a \ 'a" + fake_quant :: "('a \ prop) \ prop" lemma let_cong_unfolding: "M = N \ f N = g N \ Let M f = Let N g" by simp +translations "P" <= "CONST fake_quant (\x. P)" + ML\ local @@ -71,6 +77,16 @@ | _ => (t, false) in fst (go t) end +(* adapted from logic.ML *) +fun fake_const T = Const (@{const_name fake_quant}, (T --> propT) --> propT); + +fun dependent_fake_name v t = + let + val x = Term.term_name v + val T = Term.fastype_of v + val t' = Term.abstract_over (v, t) + in if Term.is_dependent t' then fake_const T $ Abs (x, T, t') else t end + in fun check_pattern_syntax t = @@ -106,6 +122,7 @@ case strip_all t of (vars, @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ lhs $ rhs)) => let + (* restricted to going down abstractions; ignores eta-contracted rhs *) fun go lhs (rhs as Const (@{const_name Let}, _) $ pat $ Abs (name, typ, t)) ctxt frees = if exists_subterm (fn t' => t' = pat) lhs then let @@ -125,7 +142,8 @@ val res = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs', rhs')) - |> fold (fn v => Logic.dependent_all_name ("", v)) (map Free vars @ frees) + |> fold (fn v => Logic.dependent_all_name ("", v)) (map Free vars) + |> fold dependent_fake_name frees in if null frees then t else res end @@ -145,7 +163,8 @@ end -hide_const (open) as +hide_const as +hide_const fake_quant subsection \Usage\ @@ -175,7 +194,7 @@ |> Thm.prop_of |> Syntax.string_of_term @{context} |> YXML.content_of - val expected = "\x x'. test_2 (?y # (?y' # ?ys =: x') =: x) = x @ x' @ x'" + val expected = "test_2 (?y # (?y' # ?ys =: x') =: x) = x @ x' @ x'" in @{assert} (actual = expected) end \