merged, resolving conflicts in Admin/isatest/settings/afp-poly and src/HOL/Tools/Nitpick/nitpick_model.ML;
authorwenzelm
Mon May 25 22:11:43 2015 +0200 (2015-05-25)
changeset 60301ff82ba1893c8
parent 60185 cc71f01f9fde
parent 60300 82453d0f49ee
child 60302 6dcb8aa0966a
merged, resolving conflicts in Admin/isatest/settings/afp-poly and src/HOL/Tools/Nitpick/nitpick_model.ML;
Admin/isatest/settings/afp-poly
CONTRIBUTORS
NEWS
src/Doc/Datatypes/Datatypes.thy
src/Doc/Isar_Ref/document/root.tex
src/Doc/Nitpick/document/root.tex
src/Doc/manual.bib
src/HOL/Binomial.thy
src/HOL/Transcendental.thy
     1.1 --- a/.hgtags	Sat May 23 22:13:24 2015 +0200
     1.2 +++ b/.hgtags	Mon May 25 22:11:43 2015 +0200
     1.3 @@ -31,3 +31,8 @@
     1.4  8f4a332500e41bb67efc3e141608829473606a72 Isabelle2014
     1.5  42d34eeb283c645de7792a327e86d846f9cfb5f9 Isabelle2015-RC0
     1.6  c9760373aa0f9a941d0e58d1432a823eaa14a0cc Isabelle2015-RC1
     1.7 +8483c2883c8c73d94ff05627d5d9de0c821e78ac Isabelle2015-RC2
     1.8 +e0c3e11e9bea53656fdd1a258ac66c2e74390582 Isabelle2015-RC3
     1.9 +05fe9bdc4f8f2f550b44c4ded6bbc578408b7a14 Isabelle2015-RC4
    1.10 +d7f636331176ed8baa0c6f40d9fbb18838829156 Isabelle2015-RC5
    1.11 +5ae2a2e74c93eafeb00b1ddeef0404256745ebba Isabelle2015
     2.1 --- a/Admin/Release/CHECKLIST	Sat May 23 22:13:24 2015 +0200
     2.2 +++ b/Admin/Release/CHECKLIST	Mon May 25 22:11:43 2015 +0200
     2.3 @@ -7,10 +7,6 @@
     2.4  
     2.5  - test polyml-5.4.1, polyml-5.4.0, polyml-5.3.0, smlnj;
     2.6  
     2.7 -- test Isabelle/jEdit on single-core;
     2.8 -
     2.9 -- test Isabelle/jEdit on airy device;
    2.10 -
    2.11  - test 'display_drafts' command;
    2.12  
    2.13  - test "#!/usr/bin/env isabelle_scala_script";
    2.14 @@ -20,6 +16,8 @@
    2.15  
    2.16  - check ANNOUNCE, README, NEWS, COPYRIGHT, CONTRIBUTORS;
    2.17  
    2.18 +- check versions in src/Tools/jEdit/Isabelle.props;
    2.19 +
    2.20  - check funny base directory, e.g. "Test 中国";
    2.21  
    2.22  - check scalable fonts, e.g. src/Doc/Prog_Prove (NOTE: T1 encoding
    2.23 @@ -42,7 +40,9 @@
    2.24      Admin/build jars_test
    2.25  
    2.26  - test Isabelle/jEdit:
    2.27 -    print buffer
    2.28 +    . print buffer
    2.29 +    . on single-core
    2.30 +    . on airy device
    2.31  
    2.32  - test contrib components:
    2.33      x86_64-linux without 32bit C/C++ libraries
    2.34 @@ -83,8 +83,8 @@
    2.35    default = http://bitbucket.org/isabelle_project/isabelle-release
    2.36    default = ssh://hg@bitbucket.org/isabelle_project/isabelle-release
    2.37  
    2.38 -- isatest@macbroy28:hg-isabelle/.hg/hgrc
    2.39 -- isatest@macbroy28:devel-page/content/index.content
    2.40 +- isatest@lxbroy2:hg-isabelle/.hg/hgrc
    2.41 +- isatest@lxbroy2:devel-page/content/index.content
    2.42  
    2.43  
    2.44  Post-release
     3.1 --- a/Admin/Release/build	Sat May 23 22:13:24 2015 +0200
     3.2 +++ b/Admin/Release/build	Mon May 25 22:11:43 2015 +0200
     3.3 @@ -115,7 +115,7 @@
     3.4  
     3.5  # make bundles
     3.6  
     3.7 -for PLATFORM_FAMILY in linux macos windows
     3.8 +for PLATFORM_FAMILY in linux windows macos
     3.9  do
    3.10  
    3.11  echo
     4.1 --- a/Admin/Release/build_library	Sat May 23 22:13:24 2015 +0200
     4.2 +++ b/Admin/Release/build_library	Mon May 25 22:11:43 2015 +0200
     4.3 @@ -87,6 +87,7 @@
     4.4  cd ..
     4.5  
     4.6  if [ "$RC" = 0 ]; then
     4.7 +  chmod -R a+r "$ISABELLE_NAME"
     4.8    chmod -R g=o "$ISABELLE_NAME"
     4.9    tar -c -z -f "$ARCHIVE_DIR/${ISABELLE_NAME}_library.tar.gz" "$ISABELLE_NAME/browser_info"
    4.10  fi
     5.1 --- a/Admin/components/components.sha1	Sat May 23 22:13:24 2015 +0200
     5.2 +++ b/Admin/components/components.sha1	Mon May 25 22:11:43 2015 +0200
     5.3 @@ -1,6 +1,7 @@
     5.4  70105fd6fbfd1a868383fc510772b95234325d31  csdp-6.x.tar.gz
     5.5  2f6417b8e96a0e4e8354fe0f1a253c18fb55d9a7  cvc3-2.4.1.tar.gz
     5.6  a5e02b5e990da4275dc5d4480c3b72fc73160c28  cvc4-1.5pre-1.tar.gz
     5.7 +4d9658fd2688ae8ac78da8fdfcbf85960f871b71  cvc4-1.5pre-2.tar.gz
     5.8  03aec2ec5757301c9df149f115d1f4f1d2cafd9e  cvc4-1.5pre.tar.gz
     5.9  842d9526f37b928cf9e22f141884365129990d63  cygwin-20130110.tar.gz
    5.10  cb3b0706d208f104b800267697204f6d82f7b48a  cygwin-20130114.tar.gz
    5.11 @@ -26,6 +27,7 @@
    5.12  ae7ee5becb26512f18c609e83b34612918bae5f0  exec_process-1.0.tar.gz
    5.13  59a71e08c34ff01f3f5c4af00db5e16369527eb7  Haskabelle-2013.tar.gz
    5.14  23a96ff4951d72f4024b6e8843262eda988bc151  Haskabelle-2014.tar.gz
    5.15 +eccff31931fb128c1dd522cfc85495c9b66e67af  Haskabelle-2015.tar.gz
    5.16  683acd94761ef460cca1a628f650355370de5afb  hol-light-bundle-0.5-126.tar.gz
    5.17  8d83e433c1419e0c0cc5fd1762903d11b4a5752c  jdk-6u31.tar.gz
    5.18  38d2d2a91c66714c18430e136e7e5191af3996e6  jdk-7u11.tar.gz
    5.19 @@ -86,6 +88,7 @@
    5.20  36f78f27291a9ceb13bf1120b62a45625afd44a6  polyml-5.5.1.tar.gz
    5.21  a588640dbf5da9ae15455b02ef709764a48637dc  polyml-5.5.2-1.tar.gz
    5.22  4b690390946f7bfb777b89eb16d6f08987cca12f  polyml-5.5.2-2.tar.gz
    5.23 +5b31ad8556e41dfd6d5e85f407818be399aa3d2a  polyml-5.5.2-3.tar.gz
    5.24  532f6e8814752aeb406c62fabcfd2cc05f8a7ca8  polyml-5.5.2.tar.gz
    5.25  8ee375cfc38972f080dbc78f07b68dac03efe968  ProofGeneral-3.7.1.1.tar.gz
    5.26  847b52c0676b5eb0fbf0476f64fc08c2d72afd0c  ProofGeneral-4.1.tar.gz
     6.1 --- a/Admin/components/main	Sat May 23 22:13:24 2015 +0200
     6.2 +++ b/Admin/components/main	Mon May 25 22:11:43 2015 +0200
     6.3 @@ -1,15 +1,15 @@
     6.4  #main components for everyday use, without big impact on overall build time
     6.5  csdp-6.x
     6.6 -cvc4-1.5pre-1
     6.7 +cvc4-1.5pre-2
     6.8  e-1.8
     6.9  exec_process-1.0.3
    6.10 -Haskabelle-2014
    6.11 +Haskabelle-2015
    6.12  jdk-7u80
    6.13  jedit_build-20150228
    6.14  jfreechart-1.0.14-1
    6.15  jortho-1.0-2
    6.16  kodkodi-1.5.2
    6.17 -polyml-5.5.2-2
    6.18 +polyml-5.5.2-3
    6.19  scala-2.11.6
    6.20  spass-3.8ds
    6.21  xz-java-1.2-1
     7.1 --- a/Admin/isatest/settings/afp-poly	Sat May 23 22:13:24 2015 +0200
     7.2 +++ b/Admin/isatest/settings/afp-poly	Mon May 25 22:11:43 2015 +0200
     7.3 @@ -2,9 +2,9 @@
     7.4  
     7.5  init_components /home/isabelle/contrib "$HOME/admin/components/main"
     7.6  
     7.7 -  ML_PLATFORM="x86_64-darwin"
     7.8 -  ML_HOME="$POLYML_HOME/$ML_PLATFORM"
     7.9 -  ML_OPTIONS="-H 2000"
    7.10 +ML_PLATFORM="$ISABELLE_PLATFORM64"
    7.11 +ML_HOME="$POLYML_HOME/$ML_PLATFORM"
    7.12 +ML_OPTIONS="-H 2000"
    7.13  
    7.14  ISABELLE_GHC=ghc
    7.15  
     8.1 --- a/Admin/isatest/settings/at-poly-e	Sat May 23 22:13:24 2015 +0200
     8.2 +++ b/Admin/isatest/settings/at-poly-e	Mon May 25 22:11:43 2015 +0200
     8.3 @@ -2,8 +2,8 @@
     8.4  
     8.5  init_components /home/isabelle/contrib "$HOME/admin/components/main"
     8.6  
     8.7 -  POLYML_HOME="/home/polyml/polyml-5.3.0"
     8.8 -  ML_SYSTEM="polyml-5.3.0"
     8.9 +  POLYML_HOME="/home/polyml/polyml-5.4.1"
    8.10 +  ML_SYSTEM="polyml-5.4.1"
    8.11    ML_PLATFORM="x86-linux"
    8.12    ML_HOME="$POLYML_HOME/$ML_PLATFORM"
    8.13    ML_OPTIONS="-H 1000"
     9.1 --- a/Admin/isatest/settings/at64-poly	Sat May 23 22:13:24 2015 +0200
     9.2 +++ b/Admin/isatest/settings/at64-poly	Mon May 25 22:11:43 2015 +0200
     9.3 @@ -2,11 +2,9 @@
     9.4  
     9.5  init_components /home/isabelle/contrib "$HOME/admin/components/main"
     9.6  
     9.7 -  POLYML_HOME="/home/polyml/polyml-5.5.2"
     9.8 -  ML_SYSTEM="polyml-5.5.2"
     9.9 -  ML_PLATFORM="x86_64-linux"
    9.10 -  ML_HOME="$POLYML_HOME/$ML_PLATFORM"
    9.11 -  ML_OPTIONS="--minheap 2000 --maxheap 8000 --gcthreads 1"
    9.12 +ML_PLATFORM="$ISABELLE_PLATFORM64"
    9.13 +ML_HOME="$POLYML_HOME/$ML_PLATFORM"
    9.14 +ML_OPTIONS="--minheap 2000 --maxheap 8000 --gcthreads 1"
    9.15  
    9.16  ISABELLE_HOME_USER=~/isabelle-at64-poly
    9.17  
    10.1 --- a/Admin/isatest/settings/mac-poly-M2-alternative	Sat May 23 22:13:24 2015 +0200
    10.2 +++ b/Admin/isatest/settings/mac-poly-M2-alternative	Mon May 25 22:11:43 2015 +0200
    10.3 @@ -4,9 +4,8 @@
    10.4  init_components /home/isabelle/contrib "$HOME/admin/components/optional"
    10.5  init_components /home/isabelle/contrib "$HOME/admin/components/nonfree"
    10.6  
    10.7 -ML_SYSTEM="polyml-5.5.2"
    10.8 -ML_PLATFORM="x86-darwin"
    10.9 -ML_HOME="/home/polyml/polyml-5.5.2/$ML_PLATFORM"
   10.10 +ML_PLATFORM="$ISABELLE_PLATFORM32"
   10.11 +ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   10.12  ML_OPTIONS="-H 1000"
   10.13  
   10.14  ISABELLE_HOME_USER=~/isabelle-mac-poly-M2-alternative
    11.1 --- a/Admin/isatest/settings/mac-poly-M4	Sat May 23 22:13:24 2015 +0200
    11.2 +++ b/Admin/isatest/settings/mac-poly-M4	Mon May 25 22:11:43 2015 +0200
    11.3 @@ -2,11 +2,9 @@
    11.4  
    11.5  init_components /home/isabelle/contrib "$HOME/admin/components/main"
    11.6  
    11.7 -  POLYML_HOME="/home/polyml/polyml-5.5.2"
    11.8 -  ML_SYSTEM="polyml-5.5.2"
    11.9 -  ML_PLATFORM="x86-darwin"
   11.10 -  ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   11.11 -  ML_OPTIONS="-H 500 --gcthreads 4"
   11.12 +ML_PLATFORM="$ISABELLE_PLATFORM32"
   11.13 +ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   11.14 +ML_OPTIONS="-H 500 --gcthreads 4"
   11.15  
   11.16  ISABELLE_HOME_USER=~/isabelle-mac-poly-M4
   11.17  
    12.1 --- a/Admin/isatest/settings/mac-poly-M8	Sat May 23 22:13:24 2015 +0200
    12.2 +++ b/Admin/isatest/settings/mac-poly-M8	Mon May 25 22:11:43 2015 +0200
    12.3 @@ -2,11 +2,9 @@
    12.4  
    12.5  init_components /home/isabelle/contrib "$HOME/admin/components/main"
    12.6  
    12.7 -  POLYML_HOME="/home/polyml/polyml-5.5.2"
    12.8 -  ML_SYSTEM="polyml-5.5.2"
    12.9 -  ML_PLATFORM="x86-darwin"
   12.10 -  ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   12.11 -  ML_OPTIONS="-H 500 --gcthreads 8"
   12.12 +ML_PLATFORM="$ISABELLE_PLATFORM32"
   12.13 +ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   12.14 +ML_OPTIONS="-H 500 --gcthreads 8"
   12.15  
   12.16  ISABELLE_HOME_USER=~/isabelle-mac-poly-M8
   12.17  
    13.1 --- a/Admin/isatest/settings/mac-poly-M8-quick_and_dirty	Sat May 23 22:13:24 2015 +0200
    13.2 +++ b/Admin/isatest/settings/mac-poly-M8-quick_and_dirty	Mon May 25 22:11:43 2015 +0200
    13.3 @@ -2,8 +2,8 @@
    13.4  
    13.5  init_components /home/isabelle/contrib "$HOME/admin/components/main"
    13.6  
    13.7 -  POLYML_HOME="/home/polyml/polyml-5.4.1"
    13.8 -  ML_SYSTEM="polyml-5.4.1"
    13.9 +  POLYML_HOME="/home/polyml/polyml-5.5.1"
   13.10 +  ML_SYSTEM="polyml-5.5.1"
   13.11    ML_PLATFORM="x86-darwin"
   13.12    ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   13.13    ML_OPTIONS="-H 1000"
    14.1 --- a/Admin/isatest/settings/mac-poly64-M2	Sat May 23 22:13:24 2015 +0200
    14.2 +++ b/Admin/isatest/settings/mac-poly64-M2	Mon May 25 22:11:43 2015 +0200
    14.3 @@ -2,8 +2,8 @@
    14.4  
    14.5  init_components /home/isabelle/contrib "$HOME/admin/components/main"
    14.6  
    14.7 -  POLYML_HOME="/home/polyml/polyml-5.4.0"
    14.8 -  ML_SYSTEM="polyml-5.4.0"
    14.9 +  POLYML_HOME="/home/polyml/polyml-5.5.0"
   14.10 +  ML_SYSTEM="polyml-5.5.0"
   14.11    ML_PLATFORM="x86_64-darwin"
   14.12    ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   14.13    ML_OPTIONS="-H 1000"
    15.1 --- a/Admin/isatest/settings/mac-poly64-M4	Sat May 23 22:13:24 2015 +0200
    15.2 +++ b/Admin/isatest/settings/mac-poly64-M4	Mon May 25 22:11:43 2015 +0200
    15.3 @@ -2,11 +2,9 @@
    15.4  
    15.5  init_components /home/isabelle/contrib "$HOME/admin/components/main"
    15.6  
    15.7 -  POLYML_HOME="/home/polyml/polyml-5.5.2"
    15.8 -  ML_SYSTEM="polyml-5.5.2"
    15.9 -  ML_PLATFORM="x86_64-darwin"
   15.10 -  ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   15.11 -  ML_OPTIONS="-H 2000 --gcthreads 4"
   15.12 +ML_PLATFORM="$ISABELLE_PLATFORM64"
   15.13 +ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   15.14 +ML_OPTIONS="-H 2000 --gcthreads 4"
   15.15  
   15.16  ISABELLE_GHC=ghc
   15.17  
    16.1 --- a/Admin/isatest/settings/mac-poly64-M8	Sat May 23 22:13:24 2015 +0200
    16.2 +++ b/Admin/isatest/settings/mac-poly64-M8	Mon May 25 22:11:43 2015 +0200
    16.3 @@ -2,11 +2,9 @@
    16.4  
    16.5  init_components /home/isabelle/contrib "$HOME/admin/components/main"
    16.6  
    16.7 -  POLYML_HOME="/home/polyml/polyml-5.5.2"
    16.8 -  ML_SYSTEM="polyml-5.5.2"
    16.9 -  ML_PLATFORM="x86_64-darwin"
   16.10 -  ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   16.11 -  ML_OPTIONS="-H 2000 --gcthreads 8"
   16.12 +ML_PLATFORM="$ISABELLE_PLATFORM64"
   16.13 +ML_HOME="$POLYML_HOME/$ML_PLATFORM"
   16.14 +ML_OPTIONS="-H 2000 --gcthreads 8"
   16.15  
   16.16  ISABELLE_GHC=ghc
   16.17  
    17.1 --- a/Admin/polyml/README	Sat May 23 22:13:24 2015 +0200
    17.2 +++ b/Admin/polyml/README	Mon May 25 22:11:43 2015 +0200
    17.3 @@ -3,7 +3,7 @@
    17.4  
    17.5  This compilation of Poly/ML 5.5.2 is based on
    17.6  http://sourceforge.net/p/polyml/code/HEAD/tree/fixes-5.5.2 version
    17.7 -2007.  See also fixes-5.5.2.diff for the differences to the official
    17.8 +2009.  See also fixes-5.5.2.diff for the differences to the official
    17.9  source distribution polyml.5.5.2.tar.gz from
   17.10  http://sourceforge.net/projects/polyml/.
   17.11  
   17.12 @@ -21,4 +21,4 @@
   17.13  
   17.14  
   17.15          Makarius
   17.16 -        17-Apr-2015
   17.17 +        22-Apr-2015
    18.1 --- a/CONTRIBUTORS	Sat May 23 22:13:24 2015 +0200
    18.2 +++ b/CONTRIBUTORS	Mon May 25 22:11:43 2015 +0200
    18.3 @@ -13,6 +13,10 @@
    18.4  * 2014/2015: Daniel Matichuk, Toby Murray, NICTA and Makarius Wenzel
    18.5    The Eisbach proof method language and "match" method.
    18.6  
    18.7 +* Winter 2014 and Spring 2015: Ondrej Kuncar, TUM
    18.8 +  Extension of lift_definition to execute lifted functions that have as a
    18.9 +  return type a datatype containing a subtype.
   18.10 +
   18.11  * March 2015: Jasmin Blanchette, Inria & LORIA & MPII, Mathias Fleury, MPII,
   18.12    and Dmitriy Traytel, TUM
   18.13    More multiset theorems, syntax, and operations.
    19.1 --- a/NEWS	Sat May 23 22:13:24 2015 +0200
    19.2 +++ b/NEWS	Mon May 25 22:11:43 2015 +0200
    19.3 @@ -70,8 +70,9 @@
    19.4  by combining existing ones with their usual syntax. The "match" proof
    19.5  method provides basic fact/term matching in addition to
    19.6  premise/conclusion matching through Subgoal.focus, and binds fact names
    19.7 -from matches as well as term patterns within matches. See also
    19.8 -~~/src/HOL/Eisbach/Eisbach.thy and the included examples.
    19.9 +from matches as well as term patterns within matches. The Isabelle
   19.10 +documentation provides an entry "eisbach" for the Eisbach User Manual.
   19.11 +Sources and various examples are in ~~/src/HOL/Eisbach/.
   19.12  
   19.13  
   19.14  *** Prover IDE -- Isabelle/Scala/jEdit ***
   19.15 @@ -87,14 +88,14 @@
   19.16  marker, SideKick parser.
   19.17  
   19.18  * Document antiquotation @{cite} provides formal markup, which is
   19.19 -interpreted semi-formally based on .bib files that happen to be opened
   19.20 -in the editor (hyperlinks, completion etc.).
   19.21 +interpreted semi-formally based on .bib files that happen to be open in
   19.22 +the editor (hyperlinks, completion etc.).
   19.23  
   19.24  * Less waste of vertical space via negative line spacing (see Global
   19.25  Options / Text Area).
   19.26  
   19.27  * Improved graphview panel with optional output of PNG or PDF, for
   19.28 -display of 'thy_deps', 'locale_deps', 'class_deps' etc.
   19.29 +display of 'thy_deps', 'class_deps' etc.
   19.30  
   19.31  * The commands 'thy_deps' and 'class_deps' allow optional bounds to
   19.32  restrict the visualized hierarchy.
   19.33 @@ -139,6 +140,11 @@
   19.34  antiquotations need to observe the margin explicitly according to
   19.35  Thy_Output.string_of_margin. Minor INCOMPATIBILITY.
   19.36  
   19.37 +* Specification of 'document_files' in the session ROOT file is
   19.38 +mandatory for document preparation. The legacy mode with implicit
   19.39 +copying of the document/ directory is no longer supported. Minor
   19.40 +INCOMPATIBILITY.
   19.41 +
   19.42  
   19.43  *** Pure ***
   19.44  
   19.45 @@ -223,6 +229,10 @@
   19.46      of rel_prod_def and rel_sum_def.
   19.47      Minor INCOMPATIBILITY: (rarely used by name) transfer theorem names
   19.48      changed (e.g. map_prod_transfer ~> prod.map_transfer).
   19.49 +  - Parametricity theorems for map functions, relators, set functions,
   19.50 +    constructors, case combinators, discriminators, selectors and
   19.51 +    (co)recursors are automatically proved and registered as transfer
   19.52 +    rules.
   19.53  
   19.54  * Old datatype package:
   19.55    - The old 'datatype' command has been renamed 'old_datatype', and
   19.56 @@ -268,6 +278,11 @@
   19.57    - New option 'smt_statistics' to display statistics of the new 'smt'
   19.58      method, especially runtime statistics of Z3 proof reconstruction.
   19.59  
   19.60 +* Lifting: command 'lift_definition' allows to execute lifted constants
   19.61 +that have as a return type a datatype containing a subtype. This
   19.62 +overcomes long-time limitations in the area of code generation and
   19.63 +lifting, and avoids tedious workarounds.
   19.64 +
   19.65  * Command and antiquotation "value" provide different evaluation slots
   19.66  (again), where the previous strategy (NBE after ML) serves as default.
   19.67  Minor INCOMPATIBILITY.
    20.1 --- a/doc/Contents	Sat May 23 22:13:24 2015 +0200
    20.2 +++ b/doc/Contents	Mon May 25 22:11:43 2015 +0200
    20.3 @@ -8,6 +8,7 @@
    20.4    codegen         Tutorial on Code Generation
    20.5    nitpick         User's Guide to Nitpick
    20.6    sledgehammer    User's Guide to Sledgehammer
    20.7 +  eisbach         The Eisbach User Manual
    20.8    sugar           LaTeX Sugar for Isabelle documents
    20.9  
   20.10  Reference Manuals!
    21.1 --- a/etc/settings	Sat May 23 22:13:24 2015 +0200
    21.2 +++ b/etc/settings	Mon May 25 22:11:43 2015 +0200
    21.3 @@ -18,7 +18,11 @@
    21.4  
    21.5  classpath "$ISABELLE_HOME/lib/classes/Pure.jar"
    21.6  
    21.7 -#paranoia setting -- avoid problems of Java/Swing versus XIM/IBus etc.
    21.8 +#paranoia settings -- avoid intrusion of alien options
    21.9 +unset "_JAVA_OPTIONS"
   21.10 +unset "JAVA_TOOL_OPTIONS"
   21.11 +
   21.12 +#paranoia settings -- avoid problems of Java/Swing versus XIM/IBus etc.
   21.13  unset XMODIFIERS
   21.14  
   21.15  
    22.1 --- a/src/Doc/Datatypes/Datatypes.thy	Sat May 23 22:13:24 2015 +0200
    22.2 +++ b/src/Doc/Datatypes/Datatypes.thy	Mon May 25 22:11:43 2015 +0200
    22.3 @@ -100,7 +100,7 @@
    22.4  describes how to specify datatypes using the @{command datatype} command.
    22.5  
    22.6  \item Section \ref{sec:defining-primitively-recursive-functions}, ``Defining
    22.7 -Primitively Recursive Functions,'' describes how to specify recursive functions
    22.8 +Primitively Recursive Functions,'' describes how to specify functions
    22.9  using @{command primrec}. (A separate tutorial @{cite "isabelle-function"}
   22.10  describes the more general \keyw{fun} and \keyw{function} commands.)
   22.11  
   22.12 @@ -109,7 +109,7 @@
   22.13  
   22.14  \item Section \ref{sec:defining-primitively-corecursive-functions},
   22.15  ``Defining Primitively Corecursive Functions,'' describes how to specify
   22.16 -corecursive functions using the @{command primcorec} and
   22.17 +functions using the @{command primcorec} and
   22.18  @{command primcorecursive} commands.
   22.19  
   22.20  \item Section \ref{sec:registering-bounded-natural-functors}, ``Registering
   22.21 @@ -124,7 +124,7 @@
   22.22  @{command datatype} and @{command codatatype}.
   22.23  
   22.24  %\item Section \ref{sec:using-the-standard-ml-interface}, ``Using the Standard
   22.25 -ML Interface,'' %describes the package's programmatic interface.
   22.26 +%ML Interface,'' describes the package's programmatic interface.
   22.27  
   22.28  \item Section \ref{sec:selecting-plugins}, ``Selecting Plugins,'' is concerned
   22.29  with the package's interoperability with other Isabelle packages and tools, such
   22.30 @@ -161,7 +161,7 @@
   22.31  text {*
   22.32  Datatypes are illustrated through concrete examples featuring different flavors
   22.33  of recursion. More examples can be found in the directory
   22.34 -\verb|~~/src/HOL/|\allowbreak\verb|BNF/Examples|.
   22.35 +\verb|~~/src/HOL/|\allowbreak\verb|Datatype_Examples|.
   22.36  *}
   22.37  
   22.38  
   22.39 @@ -1667,7 +1667,7 @@
   22.40  Codatatypes can be specified using the @{command codatatype} command. The
   22.41  command is first illustrated through concrete examples featuring different
   22.42  flavors of corecursion. More examples can be found in the directory
   22.43 -\verb|~~/src/HOL/|\allowbreak\verb|BNF/Examples|. The
   22.44 +\verb|~~/src/HOL/|\allowbreak\verb|Datatype_Examples|. The
   22.45  \emph{Archive of Formal Proofs} also includes some useful codatatypes, notably
   22.46  for lazy lists @{cite "lochbihler-2010"}.
   22.47  *}
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/Doc/Eisbach/Base.thy	Mon May 25 22:11:43 2015 +0200
    23.3 @@ -0,0 +1,39 @@
    23.4 +section \<open>Basic setup that is not included in the document\<close>
    23.5 +
    23.6 +theory Base
    23.7 +imports Main
    23.8 +begin
    23.9 +
   23.10 +ML_file "~~/src/Doc/antiquote_setup.ML"
   23.11 +
   23.12 +ML\<open>
   23.13 +fun get_split_rule ctxt target =
   23.14 +  let
   23.15 +    val (head, args) = strip_comb (Envir.eta_contract target);
   23.16 +    val (const_name, _) = dest_Const head;
   23.17 +    val const_name_components = Long_Name.explode const_name;
   23.18 +
   23.19 +    val _ =
   23.20 +      if String.isPrefix "case_" (List.last const_name_components) then ()
   23.21 +      else raise TERM ("Not a case statement", [target]);
   23.22 +
   23.23 +    val type_name = Long_Name.implode (rev (tl (rev const_name_components)));
   23.24 +    val split = Proof_Context.get_thm ctxt (type_name ^ ".split");
   23.25 +    val vars = Term.add_vars (Thm.prop_of split) [];
   23.26 +
   23.27 +    val datatype_name = nth (rev const_name_components) 1;
   23.28 +
   23.29 +    fun is_datatype (Type (a, _)) = Long_Name.base_name a = Long_Name.base_name datatype_name
   23.30 +      | is_datatype _ = false;
   23.31 +
   23.32 +    val datatype_var =
   23.33 +      (case find_first (fn (_, T') => is_datatype T') vars of
   23.34 +        SOME var => Thm.cterm_of ctxt (Term.Var var)
   23.35 +      | NONE => error ("Couldn't find datatype in thm: " ^ datatype_name));
   23.36 +  in
   23.37 +    SOME (Drule.cterm_instantiate [(datatype_var, Thm.cterm_of ctxt (List.last args))] split)
   23.38 +  end
   23.39 +  handle TERM _ => NONE;
   23.40 +\<close>
   23.41 +
   23.42 +end
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/Doc/Eisbach/Manual.thy	Mon May 25 22:11:43 2015 +0200
    24.3 @@ -0,0 +1,971 @@
    24.4 +(*:wrap=hard:maxLineLen=78:*)
    24.5 +
    24.6 +theory Manual
    24.7 +imports Base "../Eisbach_Tools"
    24.8 +begin
    24.9 +
   24.10 +chapter \<open>The method command\<close>
   24.11 +
   24.12 +text \<open>
   24.13 +  The @{command_def method} command provides the ability to write proof
   24.14 +  methods by combining existing ones with their usual syntax. Specifically it
   24.15 +  allows compound proof methods to be named, and to extend the name space of
   24.16 +  basic methods accordingly. Method definitions may abstract over parameters:
   24.17 +  terms, facts, or other methods.
   24.18 +
   24.19 +  \medskip The syntax diagram below refers to some syntactic categories that
   24.20 +  are further defined in @{cite "isabelle-isar-ref"}.
   24.21 +
   24.22 +  @{rail \<open>
   24.23 +    @@{command method} name args @'=' method
   24.24 +    ;
   24.25 +    args: term_args? method_args? \<newline> fact_args? decl_args?
   24.26 +    ;
   24.27 +    term_args: @'for' @{syntax "fixes"}
   24.28 +    ;
   24.29 +    method_args: @'methods' (name+)
   24.30 +    ;
   24.31 +    fact_args: @'uses' (name+)
   24.32 +    ;
   24.33 +    decl_args: @'declares' (name+)
   24.34 +  \<close>}
   24.35 +\<close>
   24.36 +
   24.37 +
   24.38 +section \<open>Basic method definitions\<close>
   24.39 +
   24.40 +text \<open>
   24.41 +  Consider the following proof that makes use of usual Isar method
   24.42 +  combinators.
   24.43 +\<close>
   24.44 +
   24.45 +    lemma "P \<and> Q \<longrightarrow> P"
   24.46 +      by ((rule impI, (erule conjE)?) | assumption)+
   24.47 +
   24.48 +text \<open>
   24.49 +  It is clear that this compound method will be applicable in more cases than
   24.50 +  this proof alone. With the @{command method} command we can define a proof
   24.51 +  method that makes the above functionality available generally.
   24.52 +\<close>
   24.53 +
   24.54 +    method prop_solver\<^sub>1 =
   24.55 +      ((rule impI, (erule conjE)?) | assumption)+
   24.56 +
   24.57 +    lemma "P \<and> Q \<and> R \<longrightarrow> P"
   24.58 +      by prop_solver\<^sub>1
   24.59 +
   24.60 +text \<open>
   24.61 +  In this example, the facts @{text impI} and @{text conjE} are static. They
   24.62 +  are evaluated once when the method is defined and cannot be changed later.
   24.63 +  This makes the method stable in the sense of \emph{static scoping}: naming
   24.64 +  another fact @{text impI} in a later context won't affect the behaviour of
   24.65 +  @{text "prop_solver\<^sub>1"}.
   24.66 +\<close>
   24.67 +
   24.68 +
   24.69 +section \<open>Term abstraction\<close>
   24.70 +
   24.71 +text \<open>
   24.72 +  Methods can also abstract over terms using the @{keyword_def "for"} keyword,
   24.73 +  optionally providing type constraints. For instance, the following proof
   24.74 +  method @{text intro_ex} takes a term @{term y} of any type, which it uses to
   24.75 +  instantiate the @{term x}-variable of @{text exI} (existential introduction)
   24.76 +  before applying the result as a rule. The instantiation is performed here by
   24.77 +  Isar's @{attribute_ref "where"} attribute. If the current subgoal is to find
   24.78 +  a witness for the given predicate @{term Q}, then this has the effect of
   24.79 +  committing to @{term y}.
   24.80 +\<close>
   24.81 +
   24.82 +    method intro_ex for Q :: "'a \<Rightarrow> bool" and y :: 'a =
   24.83 +      (rule exI ["where" P = Q and x = y])
   24.84 +
   24.85 +
   24.86 +text \<open>
   24.87 +  The term parameters @{term y} and @{term Q} can be used arbitrarily inside
   24.88 +  the method body, as part of attribute applications or arguments to other
   24.89 +  methods. The expression is type-checked as far as possible when the method
   24.90 +  is defined, however dynamic type errors can still occur when it is invoked
   24.91 +  (e.g.\ when terms are instantiated in a parameterized fact). Actual term
   24.92 +  arguments are supplied positionally, in the same order as in the method
   24.93 +  definition.
   24.94 +\<close>
   24.95 +
   24.96 +    lemma "P a \<Longrightarrow> \<exists>x. P x"
   24.97 +      by (intro_ex P a)
   24.98 +
   24.99 +
  24.100 +section \<open>Fact abstraction\<close>
  24.101 +
  24.102 +subsection \<open>Named theorems\<close>
  24.103 +
  24.104 +text \<open>
  24.105 +  A @{text "named theorem"} is a fact whose contents are produced dynamically
  24.106 +  within the current proof context. The Isar command @{command_ref
  24.107 +  "named_theorems"} provides simple access to this concept: it declares a
  24.108 +  dynamic fact with corresponding \emph{attribute} for managing
  24.109 +  this particular data slot in the context.
  24.110 +\<close>
  24.111 +
  24.112 +    named_theorems intros
  24.113 +
  24.114 +text \<open>
  24.115 +  So far @{text "intros"} refers to the empty fact. Using the Isar command
  24.116 +  @{command_ref "declare"} we may apply declaration attributes to the context.
  24.117 +  Below we declare both @{text "conjI"} and @{text "impI"} as @{text
  24.118 +  "intros"}, adding them to the named theorem slot.
  24.119 +\<close>
  24.120 +
  24.121 +    declare conjI [intros] and impI [intros]
  24.122 +
  24.123 +text \<open>
  24.124 +  We can refer to named theorems as dynamic facts within a particular proof
  24.125 +  context, which are evaluated whenever the method is invoked. Instead of
  24.126 +  having facts hard-coded into the method, as in @{text prop_solver\<^sub>1}, we can
  24.127 +  instead refer to these named theorems.
  24.128 +\<close>
  24.129 +
  24.130 +    named_theorems elims
  24.131 +    declare conjE [elims]
  24.132 +
  24.133 +    method prop_solver\<^sub>3 =
  24.134 +      ((rule intros, (erule elims)?) | assumption)+
  24.135 +
  24.136 +    lemma "P \<and> Q \<longrightarrow> P"
  24.137 +      by prop_solver\<^sub>3
  24.138 +
  24.139 +text \<open>
  24.140 +  Often these named theorems need to be augmented on the spot, when a method
  24.141 +  is invoked. The @{keyword_def "declares"} keyword in the signature of
  24.142 +  @{command method} adds the common method syntax @{text "method decl: facts"}
  24.143 +  for each named theorem @{text decl}.
  24.144 +\<close>
  24.145 +
  24.146 +    method prop_solver\<^sub>4 declares intros elims =
  24.147 +      ((rule intros, (erule elims)?) | assumption)+
  24.148 +
  24.149 +    lemma "P \<and> (P \<longrightarrow> Q) \<longrightarrow> Q \<and> P"
  24.150 +      by (prop_solver\<^sub>4 elims: impE intros: conjI)
  24.151 +
  24.152 +
  24.153 +subsection \<open>Simple fact abstraction\<close>
  24.154 +
  24.155 +text \<open>
  24.156 +  The @{keyword "declares"} keyword requires that a corresponding dynamic fact
  24.157 +  has been declared with @{command_ref named_theorems}. This is useful for
  24.158 +  managing collections of facts which are to be augmented with declarations,
  24.159 +  but is overkill if we simply want to pass a fact to a method.
  24.160 +
  24.161 +  We may use the @{keyword_def "uses"} keyword in the method header to provide
  24.162 +  a simple fact parameter. In contrast to @{keyword "declares"}, these facts
  24.163 +  are always implicitly empty unless augmented when the method is invoked.
  24.164 +\<close>
  24.165 +
  24.166 +    method rule_twice uses my_rule =
  24.167 +      (rule my_rule, rule my_rule)
  24.168 +
  24.169 +    lemma "P \<Longrightarrow> Q \<Longrightarrow> (P \<and> Q) \<and> Q"
  24.170 +      by (rule_twice my_rule: conjI)
  24.171 +
  24.172 +
  24.173 +section \<open>Higher-order methods\<close>
  24.174 +
  24.175 +text \<open>
  24.176 +  The \emph{structured concatenation} combinator ``@{text "method\<^sub>1 ;
  24.177 +  method\<^sub>2"}'' was introduced in Isabelle2015, motivated by development of
  24.178 +  Eisbach. It is similar to ``@{text "method\<^sub>1, method\<^sub>2"}'', but @{text
  24.179 +  method\<^sub>2} is invoked on on \emph{all} subgoals that have newly emerged from
  24.180 +  @{text method\<^sub>1}. This is useful to handle cases where the number of
  24.181 +  subgoals produced by a method is determined dynamically at run-time.
  24.182 +\<close>
  24.183 +text_raw\<open>\vbox{\<close>
  24.184 +    method conj_with uses rule =
  24.185 +      (intro conjI ; intro rule)
  24.186 +
  24.187 +    lemma
  24.188 +      assumes A: "P"
  24.189 +      shows "P \<and> P \<and> P"
  24.190 +      by (conj_with rule: A)
  24.191 +text_raw\<open>}\<close>
  24.192 +text \<open>
  24.193 +  Method definitions may take other methods as arguments, and thus implement
  24.194 +  method combinators with prefix syntax. For example, to more usefully exploit
  24.195 +  Isabelle's backtracking, the explicit requirement that a method solve all
  24.196 +  produced subgoals is frequently useful. This can easily be written as a
  24.197 +  \emph{higher-order method} using ``@{text ";"}''. The @{keyword "methods"}
  24.198 +  keyword denotes method parameters that are other proof methods to be invoked
  24.199 +  by the method being defined.
  24.200 +\<close>
  24.201 +
  24.202 +    method solve methods m = (m ; fail)
  24.203 +
  24.204 +text \<open>
  24.205 +  Given some method-argument @{text m}, @{text "solve \<open>m\<close>"} applies the
  24.206 +  method @{text m} and then fails whenever @{text m} produces any new unsolved
  24.207 +  subgoals --- i.e. when @{text m} fails to completely discharge the goal it
  24.208 +  was applied to.
  24.209 +\<close>
  24.210 +
  24.211 +
  24.212 +section \<open>Example\<close>
  24.213 +
  24.214 +text \<open>
  24.215 +  With these simple features we are ready to write our first non-trivial proof
  24.216 +  method. Returning to the first-order logic example, the following method
  24.217 +  definition applies various rules with their canonical methods.
  24.218 +\<close>
  24.219 +
  24.220 +    named_theorems subst
  24.221 +
  24.222 +    method prop_solver declares intros elims subst =
  24.223 +      (assumption |
  24.224 +        (rule intros) | erule elims |
  24.225 +        subst subst | subst (asm) subst |
  24.226 +        (erule notE ; solve \<open>prop_solver\<close>))+
  24.227 +
  24.228 +text \<open>
  24.229 +  The only non-trivial part above is the final alternative @{text "(erule notE
  24.230 +  ; solve \<open>prop_solver\<close>)"}. Here, in the case that all other alternatives
  24.231 +  fail, the method takes one of the assumptions @{term "\<not> P"} of the current
  24.232 +  goal and eliminates it with the rule @{text notE}, causing the goal to be
  24.233 +  proved to become @{term P}. The method then recursively invokes itself on
  24.234 +  the remaining goals. The job of the recursive call is to demonstrate that
  24.235 +  there is a contradiction in the original assumptions (i.e.\ that @{term P}
  24.236 +  can be derived from them). Note this recursive invocation is applied with
  24.237 +  the @{method solve} method combinator to ensure that a contradiction will
  24.238 +  indeed be shown. In the case where a contradiction cannot be found,
  24.239 +  backtracking will occur and a different assumption @{term "\<not> Q"} will be
  24.240 +  chosen for elimination.
  24.241 +
  24.242 +  Note that the recursive call to @{method prop_solver} does not have any
  24.243 +  parameters passed to it. Recall that fact parameters, e.g.\ @{text
  24.244 +  "intros"}, @{text "elims"}, and @{text "subst"}, are managed by declarations
  24.245 +  in the current proof context. They will therefore be passed to any recursive
  24.246 +  call to @{method prop_solver} and, more generally, any invocation of a
  24.247 +  method which declares these named theorems.
  24.248 +
  24.249 +  \medskip After declaring some standard rules to the context, the @{method
  24.250 +  prop_solver} becomes capable of solving non-trivial propositional
  24.251 +  tautologies.\<close>
  24.252 +
  24.253 +    lemmas [intros] =
  24.254 +      conjI  --  \<open>@{thm conjI}\<close>
  24.255 +      impI  --  \<open>@{thm impI}\<close>
  24.256 +      disjCI  --  \<open>@{thm disjCI}\<close>
  24.257 +      iffI  --  \<open>@{thm iffI}\<close>
  24.258 +      notI  --  \<open>@{thm notI}\<close>
  24.259 +
  24.260 +    lemmas [elims] =
  24.261 +      impCE  --  \<open>@{thm impCE}\<close>
  24.262 +      conjE  --  \<open>@{thm conjE}\<close>
  24.263 +      disjE  --  \<open>@{thm disjE}\<close>
  24.264 +
  24.265 +    lemma "(A \<or> B) \<and> (A \<longrightarrow> C) \<and> (B \<longrightarrow> C) \<longrightarrow> C"
  24.266 +      by prop_solver
  24.267 +
  24.268 +
  24.269 +chapter \<open>The match method \label{s:matching}\<close>
  24.270 +
  24.271 +text \<open>
  24.272 +  So far we have seen methods defined as simple combinations of other methods.
  24.273 +  Some familiar programming language concepts have been introduced (i.e.\
  24.274 +  abstraction and recursion). The only control flow has been implicitly the
  24.275 +  result of backtracking. When designing more sophisticated proof methods this
  24.276 +  proves too restrictive and difficult to manage conceptually.
  24.277 +
  24.278 +  To address this, we introduce the @{method_def "match"} method, which
  24.279 +  provides more direct access to the higher-order matching facility at the
  24.280 +  core of Isabelle. It is implemented as a separate proof method (in
  24.281 +  Isabelle/ML), and thus can be directly applied to proofs, however it is most
  24.282 +  useful when applied in the context of writing Eisbach method definitions.
  24.283 +
  24.284 +  \medskip The syntax diagram below refers to some syntactic categories that
  24.285 +  are further defined in @{cite "isabelle-isar-ref"}.
  24.286 +
  24.287 +  @{rail \<open>
  24.288 +    @@{method match} kind @'in' (pattern '\<Rightarrow>' cartouche + '\<bar>')
  24.289 +    ;
  24.290 +    kind:
  24.291 +      (@'conclusion' | @'premises' ('(' 'local' ')')? |
  24.292 +       '(' term ')' | @{syntax thmrefs})
  24.293 +    ;
  24.294 +    pattern: fact_name? term args? \<newline> (@'for' fixes)?
  24.295 +    ;
  24.296 +    fact_name: @{syntax name} @{syntax attributes}? ':'
  24.297 +    ;
  24.298 +    args: '(' (('multi' | 'cut' nat?) + ',') ')'
  24.299 +  \<close>}
  24.300 +
  24.301 +  Matching allows methods to introspect the goal state, and to implement more
  24.302 +  explicit control flow. In the basic case, a term or fact @{text ts} is given
  24.303 +  to match against as a \emph{match target}, along with a collection of
  24.304 +  pattern-method pairs @{text "(p, m)"}: roughly speaking, when the pattern
  24.305 +  @{text p} matches any member of @{text ts}, the \emph{inner} method @{text
  24.306 +  m} will be executed.
  24.307 +\<close>
  24.308 +
  24.309 +    lemma
  24.310 +      assumes X:
  24.311 +        "Q \<longrightarrow> P"
  24.312 +        "Q"
  24.313 +      shows P
  24.314 +        by (match X in I: "Q \<longrightarrow> P" and I': "Q" \<Rightarrow> \<open>insert mp [OF I I']\<close>)
  24.315 +
  24.316 +text \<open>
  24.317 +  In this example we have a structured Isar proof, with the named
  24.318 +  assumption @{text "X"} and a conclusion @{term "P"}. With the match method
  24.319 +  we can find the local facts @{term "Q \<longrightarrow> P"} and @{term "Q"}, binding them to
  24.320 +  separately as @{text "I"} and @{text "I'"}. We then specialize the
  24.321 +  modus-ponens rule @{thm mp [of Q P]} to these facts to solve the goal.
  24.322 +\<close>
  24.323 +
  24.324 +
  24.325 +section \<open>Subgoal focus\<close>
  24.326 +
  24.327 +text\<open>
  24.328 +  In the previous example we were able to match against an assumption out of
  24.329 +  the Isar proof state. In general, however, proof subgoals can be
  24.330 +  \emph{unstructured}, with goal parameters and premises arising from rule
  24.331 +  application. To address this, @{method match} uses \emph{subgoal focusing}
  24.332 +  to produce structured goals out of
  24.333 +  unstructured ones. In place of fact or term, we may give the
  24.334 +  keyword @{keyword_def "premises"} as the match target. This causes a subgoal
  24.335 +  focus on the first subgoal, lifting local goal parameters to fixed term
  24.336 +  variables and premises into hypothetical theorems. The match is performed
  24.337 +  against these theorems, naming them and binding them as appropriate.
  24.338 +  Similarly giving the keyword @{keyword_def "conclusion"} matches against the
  24.339 +  conclusion of the first subgoal.
  24.340 +
  24.341 +  An unstructured version of the previous example can then be similarly solved
  24.342 +  through focusing.
  24.343 +\<close>
  24.344 +
  24.345 +    lemma "Q \<longrightarrow> P \<Longrightarrow> Q \<Longrightarrow> P"
  24.346 +      by (match premises in
  24.347 +                I: "Q \<longrightarrow> P" and I': "Q" \<Rightarrow> \<open>insert mp [OF I I']\<close>)
  24.348 +
  24.349 +text \<open>
  24.350 +  Match variables may be specified by giving a list of @{keyword_ref
  24.351 +  "for"}-fixes after the pattern description. This marks those terms as bound
  24.352 +  variables, which may be used in the method body.
  24.353 +\<close>
  24.354 +
  24.355 +    lemma "Q \<longrightarrow> P \<Longrightarrow> Q \<Longrightarrow> P"
  24.356 +      by (match premises in I: "Q \<longrightarrow> A" and I': "Q" for A \<Rightarrow>
  24.357 +            \<open>match conclusion in A \<Rightarrow> \<open>insert mp [OF I I']\<close>\<close>)
  24.358 +
  24.359 +text \<open>
  24.360 +  In this example @{term A} is a match variable which is bound to @{term P}
  24.361 +  upon a successful match. The inner @{method match} then matches the
  24.362 +  now-bound @{term A} (bound to @{term P}) against the conclusion (also @{term
  24.363 +  P}), finally applying the specialized rule to solve the goal.
  24.364 +
  24.365 +  Schematic terms like @{text "?P"} may also be used to specify match
  24.366 +  variables, but the result of the match is not bound, and thus cannot be used
  24.367 +  in the inner method body.
  24.368 +
  24.369 +  \medskip In the following example we extract the predicate of an
  24.370 +  existentially quantified conclusion in the current subgoal and search the
  24.371 +  current premises for a matching fact. If both matches are successful, we
  24.372 +  then instantiate the existential introduction rule with both the witness and
  24.373 +  predicate, solving with the matched premise.
  24.374 +\<close>
  24.375 +
  24.376 +    method solve_ex =
  24.377 +      (match conclusion in "\<exists>x. Q x" for Q \<Rightarrow>
  24.378 +        \<open>match premises in U: "Q y" for y \<Rightarrow>
  24.379 +          \<open>rule exI [where P = Q and x = y, OF U]\<close>\<close>)
  24.380 +
  24.381 +text \<open>
  24.382 +  The first @{method match} matches the pattern @{term "\<exists>x. Q x"} against the
  24.383 +  current conclusion, binding the term @{term "Q"} in the inner match. Next
  24.384 +  the pattern @{text "Q y"} is matched against all premises of the current
  24.385 +  subgoal. In this case @{term "Q"} is fixed and @{term "y"} may be
  24.386 +  instantiated. Once a match is found, the local fact @{text U} is bound to
  24.387 +  the matching premise and the variable @{term "y"} is bound to the matching
  24.388 +  witness. The existential introduction rule @{text "exI:"}~@{thm exI} is then
  24.389 +  instantiated with @{term "y"} as the witness and @{term "Q"} as the
  24.390 +  predicate, with its proof obligation solved by the local fact U (using the
  24.391 +  Isar attribute @{attribute OF}). The following example is a trivial use of
  24.392 +  this method.
  24.393 +\<close>
  24.394 +
  24.395 +    lemma "halts p \<Longrightarrow> \<exists>x. halts x"
  24.396 +      by solve_ex
  24.397 +
  24.398 +
  24.399 +subsection \<open>Operating within a focus\<close>
  24.400 +
  24.401 +text \<open>
  24.402 +  Subgoal focusing provides a structured form of a subgoal, allowing for more
  24.403 +  expressive introspection of the goal state. This requires some consideration
  24.404 +  in order to be used effectively. When the keyword @{keyword "premises"} is
  24.405 +  given as the match target, the premises of the subgoal are lifted into
  24.406 +  hypothetical theorems, which can be found and named via match patterns.
  24.407 +  Additionally these premises are stripped from the subgoal, leaving only the
  24.408 +  conclusion. This renders them inaccessible to standard proof methods which
  24.409 +  operate on the premises, such as @{method frule} or @{method erule}. Naive
  24.410 +  usage of these methods within a match will most likely not function as the
  24.411 +  method author intended.
  24.412 +\<close>
  24.413 +
  24.414 +    method my_allE_bad for y :: 'a =
  24.415 +      (match premises in I: "\<forall>x :: 'a. ?Q x" \<Rightarrow>
  24.416 +        \<open>erule allE [where x = y]\<close>)
  24.417 +
  24.418 +text \<open>
  24.419 +  Here we take a single parameter @{term y} and specialize the universal
  24.420 +  elimination rule (@{thm allE}) to it, then attempt to apply this specialized
  24.421 +  rule with @{method erule}. The method @{method erule} will attempt to unify
  24.422 +  with a universal quantifier in the premises that matches the type of @{term
  24.423 +  y}. Since @{keyword "premises"} causes a focus, however, there are no
  24.424 +  subgoal premises to be found and thus @{method my_allE_bad} will always
  24.425 +  fail. If focusing instead left the premises in place, using methods
  24.426 +  like @{method erule} would lead to unintended behaviour, specifically during
  24.427 +  backtracking. In our example, @{method erule} could choose an alternate
  24.428 +  premise while backtracking, while leaving @{text I} bound to the original
  24.429 +  match. In the case of more complex inner methods, where either @{text I} or
  24.430 +  bound terms are used, this would almost certainly not be the intended
  24.431 +  behaviour.
  24.432 +
  24.433 +  An alternative implementation would be to specialize the elimination rule to
  24.434 +  the bound term and apply it directly.
  24.435 +\<close>
  24.436 +
  24.437 +    method my_allE_almost for y :: 'a =
  24.438 +      (match premises in I: "\<forall>x :: 'a. ?Q x" \<Rightarrow>
  24.439 +        \<open>rule allE [where x = y, OF I]\<close>)
  24.440 +
  24.441 +    lemma "\<forall>x. P x \<Longrightarrow> P y"
  24.442 +      by (my_allE_almost y)
  24.443 +
  24.444 +text \<open>
  24.445 +  This method will insert a specialized duplicate of a universally quantified
  24.446 +  premise. Although this will successfully apply in the presence of such a
  24.447 +  premise, it is not likely the intended behaviour. Repeated application of
  24.448 +  this method will produce an infinite stream of duplicate specialized
  24.449 +  premises, due to the original premise never being removed. To address this,
  24.450 +  matched premises may be declared with the @{attribute "thin"} attribute.
  24.451 +  This will hide the premise from subsequent inner matches, and remove it from
  24.452 +  the list of premises when the inner method has finished and the subgoal is
  24.453 +  unfocused. It can be considered analogous to the existing @{text thin_tac}.
  24.454 +
  24.455 +  To complete our example, the correct implementation of the method
  24.456 +  will @{attribute "thin"} the premise from the match and then apply it to the
  24.457 +  specialized elimination rule.\<close>
  24.458 +
  24.459 +    method my_allE for y :: 'a =
  24.460 +      (match premises in I [thin]: "\<forall>x :: 'a. ?Q x" \<Rightarrow>
  24.461 +         \<open>rule allE [where x = y, OF I]\<close>)
  24.462 +
  24.463 +    lemma "\<forall>x. P x \<Longrightarrow> \<forall>x. Q x \<Longrightarrow> P y \<and> Q y"
  24.464 +      by (my_allE y)+ (rule conjI)
  24.465 +
  24.466 +subsubsection \<open>Inner focusing\<close>
  24.467 +
  24.468 +text \<open>
  24.469 +  Premises are \emph{accumulated} for the purposes of subgoal focusing.
  24.470 +  In contrast to using standard methods like @{method frule} within
  24.471 +  focused match, another @{method match} will have access to all the premises
  24.472 +  of the outer focus.
  24.473 +  \<close>
  24.474 +
  24.475 +    lemma "A \<Longrightarrow> B \<Longrightarrow> A \<and> B"
  24.476 +      by (match premises in H: A \<Rightarrow> \<open>intro conjI, rule H,
  24.477 +            match premises in H': B \<Rightarrow> \<open>rule H'\<close>\<close>)
  24.478 +
  24.479 +text \<open>
  24.480 +  In this example, the inner @{method match} can find the focused premise
  24.481 +  @{term B}. In contrast, the @{method assumption} method would fail here
  24.482 +  due to @{term B} not being logically accessible.
  24.483 +\<close>
  24.484 +
  24.485 +    lemma
  24.486 +    "A \<Longrightarrow> A \<and> (B \<longrightarrow> B)"
  24.487 +      by (match premises in H: A \<Rightarrow> \<open>intro conjI, rule H, rule impI,
  24.488 +            match premises (local) in A \<Rightarrow> \<open>fail\<close>
  24.489 +                                 \<bar> H': B \<Rightarrow> \<open>rule H'\<close>\<close>)
  24.490 +
  24.491 +text \<open>
  24.492 +  In this example, the only premise that exists in the first focus is
  24.493 +  @{term "A"}. Prior to the inner match, the rule @{text impI} changes
  24.494 +  the goal @{term "B \<longrightarrow> B"} into @{term "B \<Longrightarrow> B"}. A standard premise
  24.495 +  match would also include @{term A} as an original premise of the outer
  24.496 +  match. The @{text local} argument limits the match to
  24.497 +  newly focused premises.
  24.498 +
  24.499 +\<close>
  24.500 +
  24.501 +section \<open>Attributes\<close>
  24.502 +
  24.503 +text \<open>
  24.504 +  Attributes may throw errors when applied to a given fact. For example, rule
  24.505 +  instantiation will fail of there is a type mismatch or if a given variable
  24.506 +  doesn't exist. Within a match or a method definition, it isn't generally
  24.507 +  possible to guarantee that applied attributes won't fail. For example, in
  24.508 +  the following method there is no guarantee that the two provided facts will
  24.509 +  necessarily compose.
  24.510 +\<close>
  24.511 +
  24.512 +    method my_compose uses rule1 rule2 =
  24.513 +      (rule rule1 [OF rule2])
  24.514 +
  24.515 +text \<open>
  24.516 +  Some attributes (like @{attribute OF}) have been made partially
  24.517 +  Eisbach-aware. This means that they are able to form a closure despite not
  24.518 +  necessarily always being applicable. In the case of @{attribute OF}, it is
  24.519 +  up to the proof author to guard attribute application with an appropriate
  24.520 +  @{method match}, but there are still no static guarantees.
  24.521 +
  24.522 +  In contrast to @{attribute OF}, the @{attribute "where"} and @{attribute of}
  24.523 +  attributes attempt to provide static guarantees that they will apply
  24.524 +  whenever possible.
  24.525 +
  24.526 +  Within a match pattern for a fact, each outermost quantifier specifies the
  24.527 +  requirement that a matching fact must have a schematic variable at that
  24.528 +  point. This gives a corresponding name to this ``slot'' for the purposes of
  24.529 +  forming a static closure, allowing the @{attribute "where"} attribute to
  24.530 +  perform an instantiation at run-time.
  24.531 +\<close>
  24.532 +text_raw\<open>\vbox{\<close>
  24.533 +    lemma
  24.534 +      assumes A: "Q \<Longrightarrow> False"
  24.535 +      shows "\<not> Q"
  24.536 +      by (match intros in X: "\<And>P. (P \<Longrightarrow> False) \<Longrightarrow> \<not> P" \<Rightarrow>
  24.537 +            \<open>rule X [where P = Q, OF A]\<close>)
  24.538 +text_raw\<open>}\<close>
  24.539 +text \<open>
  24.540 +  Subgoal focusing converts the outermost quantifiers of premises into
  24.541 +  schematics when lifting them to hypothetical facts. This allows us to
  24.542 +  instantiate them with @{attribute "where"} when using an appropriate match
  24.543 +  pattern.
  24.544 +\<close>
  24.545 +
  24.546 +    lemma "(\<And>x :: 'a. A x \<Longrightarrow> B x) \<Longrightarrow> A y \<Longrightarrow> B y"
  24.547 +      by (match premises in I: "\<And>x :: 'a. ?P x \<Longrightarrow> ?Q x" \<Rightarrow>
  24.548 +            \<open>rule I [where x = y]\<close>)
  24.549 +
  24.550 +text \<open>
  24.551 +  The @{attribute of} attribute behaves similarly. It is worth noting,
  24.552 +  however, that the positional instantiation of @{attribute of} occurs against
  24.553 +  the position of the variables as they are declared \emph{in the match
  24.554 +  pattern}.
  24.555 +\<close>
  24.556 +
  24.557 +    lemma
  24.558 +      fixes A B and x :: 'a and y :: 'b
  24.559 +      assumes asm: "(\<And>x y. A y x \<Longrightarrow> B x y )"
  24.560 +      shows "A y x \<Longrightarrow> B x y"
  24.561 +      by (match asm in I: "\<And>(x :: 'a) (y :: 'b). ?P x y \<Longrightarrow> ?Q x y" \<Rightarrow>
  24.562 +            \<open>rule I [of x y]\<close>)
  24.563 +
  24.564 +text \<open>
  24.565 +  In this example, the order of schematics in @{text asm} is actually @{text
  24.566 +  "?y ?x"}, but we instantiate our matched rule in the opposite order. This is
  24.567 +  because the effective rule @{term I} was bound from the match, which
  24.568 +  declared the @{typ 'a} slot first and the @{typ 'b} slot second.
  24.569 +
  24.570 +  To get the dynamic behaviour of @{attribute of} we can choose to invoke it
  24.571 +  \emph{unchecked}. This avoids trying to do any type inference for the
  24.572 +  provided parameters, instead storing them as their most general type and
  24.573 +  doing type matching at run-time. This, like @{attribute OF}, will throw
  24.574 +  errors if the expected slots don't exist or there is a type mismatch.
  24.575 +\<close>
  24.576 +
  24.577 +    lemma
  24.578 +      fixes A B and x :: 'a and y :: 'b
  24.579 +      assumes asm: "\<And>x y. A y x \<Longrightarrow> B x y"
  24.580 +      shows "A y x \<Longrightarrow> B x y"
  24.581 +      by (match asm in I: "PROP ?P" \<Rightarrow> \<open>rule I [of (unchecked) y x]\<close>)
  24.582 +
  24.583 +text \<open>
  24.584 +  Attributes may be applied to matched facts directly as they are matched. Any
  24.585 +  declarations will therefore be applied in the context of the inner method,
  24.586 +  as well as any transformations to the rule.
  24.587 +\<close>
  24.588 +
  24.589 +    lemma "(\<And>x :: 'a. A x \<Longrightarrow> B x) \<Longrightarrow> A y \<longrightarrow> B y"
  24.590 +      by (match premises in I [of y, intros]: "\<And>x :: 'a. ?P x \<Longrightarrow> ?Q x" \<Rightarrow>
  24.591 +            \<open>prop_solver\<close>)
  24.592 +
  24.593 +text \<open>
  24.594 +  In this example, the pattern @{text "\<And>x :: 'a. ?P x \<Longrightarrow> ?Q x"} matches against
  24.595 +  the only premise, giving an appropriately typed slot for @{term y}. After
  24.596 +  the match, the resulting rule is instantiated to @{term y} and then declared
  24.597 +  as an @{attribute intros} rule. This is then picked up by @{method
  24.598 +  prop_solver} to solve the goal.
  24.599 +\<close>
  24.600 +
  24.601 +
  24.602 +section \<open>Multi-match \label{sec:multi}\<close>
  24.603 +
  24.604 +text \<open>
  24.605 +  In all previous examples, @{method match} was only ever searching for a
  24.606 +  single rule or premise. Each local fact would therefore always have a length
  24.607 +  of exactly one. We may, however, wish to find \emph{all} matching results.
  24.608 +  To achieve this, we can simply mark a given pattern with the @{text
  24.609 +  "(multi)"} argument.
  24.610 +\<close>
  24.611 +
  24.612 +    lemma
  24.613 +      assumes asms: "A \<Longrightarrow> B"  "A \<Longrightarrow> D"
  24.614 +      shows "(A \<longrightarrow> B) \<and> (A \<longrightarrow> D)"
  24.615 +      apply (match asms in I [intros]: "?P \<Longrightarrow> ?Q"  \<Rightarrow> \<open>solves \<open>prop_solver\<close>\<close>)?
  24.616 +      apply (match asms in I [intros]: "?P \<Longrightarrow> ?Q" (multi) \<Rightarrow> \<open>prop_solver\<close>)
  24.617 +      done
  24.618 +
  24.619 +text \<open>
  24.620 +  In the first @{method match}, without the @{text "(multi)"} argument, @{term
  24.621 +  I} is only ever be bound to one of the members of @{text asms}. This
  24.622 +  backtracks over both possibilities (see next section), however neither
  24.623 +  assumption in isolation is sufficient to solve to goal. The use of the
  24.624 +  @{method solves} combinator ensures that @{method prop_solver} has no effect
  24.625 +  on the goal when it doesn't solve it, and so the first match leaves the goal
  24.626 +  unchanged. In the second @{method match}, @{text I} is bound to all of
  24.627 +  @{text asms}, declaring both results as @{text intros}. With these rules
  24.628 +  @{method prop_solver} is capable of solving the goal.
  24.629 +
  24.630 +  Using for-fixed variables in patterns imposes additional constraints on the
  24.631 +  results. In all previous examples, the choice of using @{text ?P} or a
  24.632 +  for-fixed @{term P} only depended on whether or not @{term P} was mentioned
  24.633 +  in another pattern or the inner method. When using a multi-match, however,
  24.634 +  all for-fixed terms must agree in the results.
  24.635 +\<close>
  24.636 +
  24.637 +    lemma
  24.638 +      assumes asms: "A \<Longrightarrow> B"  "A \<Longrightarrow> D"  "D \<Longrightarrow> B"
  24.639 +      shows "(A \<longrightarrow> B) \<and> (A \<longrightarrow> D)"
  24.640 +      apply (match asms in I [intros]: "?P \<Longrightarrow> Q" (multi) for Q \<Rightarrow>
  24.641 +              \<open>solves \<open>prop_solver\<close>\<close>)?
  24.642 +      apply (match asms in I [intros]: "P \<Longrightarrow> ?Q" (multi) for P \<Rightarrow>
  24.643 +              \<open>prop_solver\<close>)
  24.644 +      done
  24.645 +
  24.646 +text \<open>
  24.647 +  Here we have two seemingly-equivalent applications of @{method match},
  24.648 +  however only the second one is capable of solving the goal. The first
  24.649 +  @{method match} selects the first and third members of @{text asms} (those
  24.650 +  that agree on their conclusion), which is not sufficient. The second
  24.651 +  @{method match} selects the first and second members of @{text asms} (those
  24.652 +  that agree on their assumption), which is enough for @{method prop_solver}
  24.653 +  to solve the goal.
  24.654 +\<close>
  24.655 +
  24.656 +
  24.657 +section \<open>Dummy patterns\<close>
  24.658 +
  24.659 +text \<open>
  24.660 +  Dummy patterns may be given as placeholders for unique schematics in
  24.661 +  patterns. They implicitly receive all currently bound variables as
  24.662 +  arguments, and are coerced into the @{typ prop} type whenever possible. For
  24.663 +  example, the trivial dummy pattern @{text "_"} will match any proposition.
  24.664 +  In contrast, by default the pattern @{text "?P"} is considered to have type
  24.665 +  @{typ bool}. It will not bind anything with meta-logical connectives (e.g.
  24.666 +  @{text "_ \<Longrightarrow> _"} or @{text "_ &&& _"}).
  24.667 +\<close>
  24.668 +
  24.669 +    lemma
  24.670 +      assumes asms: "A &&& B \<Longrightarrow> D"
  24.671 +      shows "(A \<and> B \<longrightarrow> D)"
  24.672 +      by (match asms in I: _ \<Rightarrow> \<open>prop_solver intros: I conjunctionI\<close>)
  24.673 +
  24.674 +
  24.675 +section \<open>Backtracking\<close>
  24.676 +
  24.677 +text \<open>
  24.678 +  Patterns are considered top-down, executing the inner method @{text m} of
  24.679 +  the first pattern which is satisfied by the current match target. By
  24.680 +  default, matching performs extensive backtracking by attempting all valid
  24.681 +  variable and fact bindings according to the given pattern. In particular,
  24.682 +  all unifiers for a given pattern will be explored, as well as each matching
  24.683 +  fact. The inner method @{text m} will be re-executed for each different
  24.684 +  variable/fact binding during backtracking. A successful match is considered
  24.685 +  a cut-point for backtracking. Specifically, once a match is made no other
  24.686 +  pattern-method pairs will be considered.
  24.687 +
  24.688 +  The method @{text foo} below fails for all goals that are conjunctions. Any
  24.689 +  such goal will match the first pattern, causing the second pattern (that
  24.690 +  would otherwise match all goals) to never be considered.
  24.691 +\<close>
  24.692 +
  24.693 +    method foo =
  24.694 +      (match conclusion in "?P \<and> ?Q" \<Rightarrow> \<open>fail\<close> \<bar> "?R" \<Rightarrow> \<open>prop_solver\<close>)
  24.695 +
  24.696 +text \<open>
  24.697 +  The failure of an inner method that is executed after a successful match
  24.698 +  will cause the entire match to fail. This distinction is important
  24.699 +  due to the pervasive use of backtracking. When a method is used in a
  24.700 +  combinator chain, its failure
  24.701 +  becomes significant because it signals previously applied methods to move to
  24.702 +  the next result. Therefore, it is necessary for @{method match} to not mask
  24.703 +  such failure. One can always rewrite a match using the combinators ``@{text
  24.704 +  "?"}'' and ``@{text "|"}'' to try subsequent patterns in the case of an
  24.705 +  inner-method failure. The following proof method, for example, always
  24.706 +  invokes @{method prop_solver} for all goals because its first alternative
  24.707 +  either never matches or (if it does match) always fails.
  24.708 +\<close>
  24.709 +
  24.710 +    method foo\<^sub>1 =
  24.711 +      (match conclusion in "?P \<and> ?Q" \<Rightarrow> \<open>fail\<close>) |
  24.712 +      (match conclusion in "?R" \<Rightarrow> \<open>prop_solver\<close>)
  24.713 +
  24.714 +
  24.715 +subsection \<open>Cut\<close>
  24.716 +
  24.717 +text \<open>
  24.718 +  Backtracking may be controlled more precisely by marking individual patterns
  24.719 +  as \emph{cut}. This causes backtracking to not progress beyond this pattern:
  24.720 +  once a match is found no others will be considered.
  24.721 +\<close>
  24.722 +
  24.723 +    method foo\<^sub>2 =
  24.724 +      (match premises in I: "P \<and> Q" (cut) and I': "P \<longrightarrow> ?U" for P Q \<Rightarrow>
  24.725 +        \<open>rule mp [OF I' I [THEN conjunct1]]\<close>)
  24.726 +
  24.727 +text \<open>
  24.728 +  In this example, once a conjunction is found (@{term "P \<and> Q"}), all possible
  24.729 +  implications of @{term "P"} in the premises are considered, evaluating the
  24.730 +  inner @{method rule} with each consequent. No other conjunctions will be
  24.731 +  considered, with method failure occurring once all implications of the
  24.732 +  form @{text "P \<longrightarrow> ?U"} have been explored. Here the left-right processing of
  24.733 +  individual patterns is important, as all patterns after of the cut will
  24.734 +  maintain their usual backtracking behaviour.
  24.735 +\<close>
  24.736 +
  24.737 +    lemma "A \<and> B \<Longrightarrow> A \<longrightarrow> D \<Longrightarrow> A \<longrightarrow> C \<Longrightarrow> C"
  24.738 +      by foo\<^sub>2
  24.739 +
  24.740 +    lemma "C \<and> D \<Longrightarrow> A \<and> B \<Longrightarrow> A \<longrightarrow> C  \<Longrightarrow> C"
  24.741 +      by (foo\<^sub>2 | prop_solver)
  24.742 +
  24.743 +text \<open>
  24.744 +  In this example, the first lemma is solved by @{text foo\<^sub>2}, by first
  24.745 +  picking @{term "A \<longrightarrow> D"} for @{text I'}, then backtracking and ultimately
  24.746 +  succeeding after picking @{term "A \<longrightarrow> C"}. In the second lemma, however,
  24.747 +  @{term "C \<and> D"} is matched first, the second pattern in the match cannot be
  24.748 +  found and so the method fails, falling through to @{method prop_solver}.
  24.749 +
  24.750 +  More precise control is also possible by giving a positive
  24.751 +  number @{text n} as an argument to @{text cut}. This will limit the number
  24.752 +  of backtracking results of that match to be at most @{text n}.
  24.753 +  The match argument @{text "(cut 1)"} is the same as simply @{text "(cut)"}.
  24.754 +\<close>
  24.755 +
  24.756 +
  24.757 +subsection \<open>Multi-match revisited\<close>
  24.758 +
  24.759 +text \<open>
  24.760 +  A multi-match will produce a sequence of potential bindings for for-fixed
  24.761 +  variables, where each binding environment is the result of matching against
  24.762 +  at least one element from the match target. For each environment, the match
  24.763 +  result will be all elements of the match target which agree with the pattern
  24.764 +  under that environment. This can result in unexpected behaviour when giving
  24.765 +  very general patterns.
  24.766 +\<close>
  24.767 +
  24.768 +    lemma
  24.769 +      assumes asms: "\<And>x. A x \<and> B x"  "\<And>y. A y \<and> C y"  "\<And>z. B z \<and> C z"
  24.770 +      shows "A x \<and> C x"
  24.771 +      by (match asms in I: "\<And>x. P x \<and> ?Q x" (multi) for P \<Rightarrow>
  24.772 +         \<open>match (P) in "A" \<Rightarrow> \<open>fail\<close>
  24.773 +                       \<bar> _ \<Rightarrow> \<open>match I in "\<And>x. A x \<and> B x" \<Rightarrow> \<open>fail\<close>
  24.774 +                                                      \<bar> _ \<Rightarrow> \<open>rule I\<close>\<close>\<close>)
  24.775 +
  24.776 +text \<open>
  24.777 +  Intuitively it seems like this proof should fail to check. The first match
  24.778 +  result, which binds @{term I} to the first two members of @{text asms},
  24.779 +  fails the second inner match due to binding @{term P} to @{term A}.
  24.780 +  Backtracking then attempts to bind @{term I} to the third member of @{text
  24.781 +  asms}. This passes all inner matches, but fails when @{method rule} cannot
  24.782 +  successfully apply this to the current goal. After this, a valid match that
  24.783 +  is produced by the unifier is one which binds @{term P} to simply @{text
  24.784 +  "\<lambda>a. A ?x"}. The first inner match succeeds because @{text "\<lambda>a. A ?x"} does
  24.785 +  not match @{term A}. The next inner match succeeds because @{term I} has
  24.786 +  only been bound to the first member of @{text asms}. This is due to @{method
  24.787 +  match} considering @{text "\<lambda>a. A ?x"} and @{text "\<lambda>a. A ?y"} as distinct
  24.788 +  terms.
  24.789 +
  24.790 +  The simplest way to address this is to explicitly disallow term bindings
  24.791 +  which we would consider invalid.
  24.792 +\<close>
  24.793 +
  24.794 +    method abs_used for P =
  24.795 +      (match (P) in "\<lambda>a. ?P" \<Rightarrow> \<open>fail\<close> \<bar> _ \<Rightarrow> \<open>-\<close>)
  24.796 +
  24.797 +text \<open>
  24.798 +  This method has no effect on the goal state, but instead serves as a filter
  24.799 +  on the environment produced from match.
  24.800 +\<close>
  24.801 +
  24.802 +
  24.803 +section \<open>Uncurrying\<close>
  24.804 +
  24.805 +text \<open>
  24.806 +  The @{method match} method is not aware of the logical content of match
  24.807 +  targets. Each pattern is simply matched against the shallow structure of a
  24.808 +  fact or term. Most facts are in \emph{normal form}, which curries premises
  24.809 +  via meta-implication @{text "_ \<Longrightarrow> _"}.
  24.810 +\<close>
  24.811 +
  24.812 +text_raw \<open>\vbox{\<close>
  24.813 +    lemma
  24.814 +      assumes asms: "D \<Longrightarrow> B \<Longrightarrow> C"  "D \<Longrightarrow> A"
  24.815 +      shows "D \<Longrightarrow> B \<Longrightarrow> C \<and> A"
  24.816 +      by (match asms in H: "D \<Longrightarrow> _" (multi) \<Rightarrow> \<open>prop_solver elims: H\<close>)
  24.817 +text_raw \<open>}\<close>
  24.818 +text \<open>
  24.819 +  For the first member of @{text asms} the dummy pattern successfully matches
  24.820 +  against @{term "B \<Longrightarrow> C"} and so the proof is successful.
  24.821 +\<close>
  24.822 +
  24.823 +    lemma
  24.824 +      assumes asms: "A \<Longrightarrow> B \<Longrightarrow> C"  "D \<Longrightarrow> C"
  24.825 +      shows "D \<or> (A \<and> B) \<Longrightarrow> C"
  24.826 +      apply (match asms in H: "_ \<Longrightarrow> C" (multi) \<Rightarrow> \<open>prop_solver elims: H\<close>)(*<*)?
  24.827 +      apply (prop_solver elims: asms)
  24.828 +      done(*>*)
  24.829 +
  24.830 +text \<open>
  24.831 +  This proof will fail to solve the goal. Our match pattern will only match
  24.832 +  rules which have a single premise, and conclusion @{term C}, so the first
  24.833 +  member of @{text asms} is not bound and thus the proof fails. Matching a
  24.834 +  pattern of the form @{term "P \<Longrightarrow> Q"} against this fact will bind @{term "P"}
  24.835 +  to @{term "A"} and @{term Q} to @{term "B \<Longrightarrow> C"}. Our pattern, with a
  24.836 +  concrete @{term "C"} in the conclusion, will fail to match this fact.
  24.837 +
  24.838 +  To express our desired match, we may \emph{uncurry} our rules before
  24.839 +  matching against them. This forms a meta-conjunction of all premises in a
  24.840 +  fact, so that only one implication remains. For example the uncurried
  24.841 +  version of @{term "A \<Longrightarrow> B \<Longrightarrow> C"} is @{term "A &&& B \<Longrightarrow> C"}. This will now match
  24.842 +  our desired pattern @{text "_ \<Longrightarrow> C"}, and can be \emph{curried} after the
  24.843 +  match to put it back into normal form.
  24.844 +\<close>
  24.845 +
  24.846 +    lemma
  24.847 +      assumes asms: "A \<Longrightarrow> B \<Longrightarrow> C"  "D \<Longrightarrow> C"
  24.848 +      shows "D \<or> (A \<and> B) \<Longrightarrow> C"
  24.849 +      by (match asms [uncurry] in H [curry]: "_ \<Longrightarrow> C" (multi) \<Rightarrow>
  24.850 +          \<open>prop_solver elims: H\<close>)
  24.851 +
  24.852 +
  24.853 +section \<open>Reverse matching\<close>
  24.854 +
  24.855 +text \<open>
  24.856 +  The @{method match} method only attempts to perform matching of the pattern
  24.857 +  against the match target. Specifically this means that it will not
  24.858 +  instantiate schematic terms in the match target.
  24.859 +\<close>
  24.860 +
  24.861 +    lemma
  24.862 +      assumes asms: "\<And>x :: 'a. A x"
  24.863 +      shows "A y"
  24.864 +      apply (match asms in H: "A y" \<Rightarrow> \<open>rule H\<close>)?
  24.865 +      apply (match asms in H: P for P \<Rightarrow>
  24.866 +          \<open>match ("A y") in P \<Rightarrow> \<open>rule H\<close>\<close>)
  24.867 +      done
  24.868 +
  24.869 +text \<open>
  24.870 +  In the first @{method match} we attempt to find a member of @{text asms}
  24.871 +  which matches our goal precisely. This fails due to no such member existing.
  24.872 +  The second match reverses the role of the fact in the match, by first giving
  24.873 +  a general pattern @{term P}. This bound pattern is then matched against
  24.874 +  @{term "A y"}. In this case, @{term P} is bound to @{text "A ?x"} and so it
  24.875 +  successfully matches.
  24.876 +\<close>
  24.877 +
  24.878 +
  24.879 +section \<open>Type matching\<close>
  24.880 +
  24.881 +text \<open>
  24.882 +  The rule instantiation attributes @{attribute "where"} and @{attribute "of"}
  24.883 +  attempt to guarantee type-correctness wherever possible. This can require
  24.884 +  additional invocations of @{method match} in order to statically ensure that
  24.885 +  instantiation will succeed.
  24.886 +\<close>
  24.887 +
  24.888 +    lemma
  24.889 +      assumes asms: "\<And>x :: 'a. A x"
  24.890 +      shows "A y"
  24.891 +      by (match asms in H: "\<And>z :: 'b. P z" for P \<Rightarrow>
  24.892 +          \<open>match (y) in "y :: 'b" for y \<Rightarrow> \<open>rule H [where z = y]\<close>\<close>)
  24.893 +
  24.894 +text \<open>
  24.895 +  In this example the type @{text 'b} is matched to @{text 'a}, however
  24.896 +  statically they are formally distinct types. The first match binds @{text
  24.897 +  'b} while the inner match serves to coerce @{term y} into having the type
  24.898 +  @{text 'b}. This allows the rule instantiation to successfully apply.
  24.899 +\<close>
  24.900 +
  24.901 +
  24.902 +chapter \<open>Method development\<close>
  24.903 +
  24.904 +section \<open>Tracing methods\<close>
  24.905 +
  24.906 +text \<open>
  24.907 +  Method tracing is supported by auxiliary print methods provided by @{theory
  24.908 +  Eisbach_Tools}. These include @{method print_fact}, @{method print_term} and
  24.909 +  @{method print_type}. Whenever a print method is evaluated it leaves the
  24.910 +  goal unchanged and writes its argument as tracing output.
  24.911 +
  24.912 +  Print methods can be combined with the @{method fail} method to investigate
  24.913 +  the backtracking behaviour of a method.
  24.914 +\<close>
  24.915 +
  24.916 +    lemma
  24.917 +      assumes asms: A B C D
  24.918 +      shows D
  24.919 +      apply (match asms in H: _ \<Rightarrow> \<open>print_fact H, fail\<close>)(*<*)?
  24.920 +      apply (simp add: asms)
  24.921 +      done(*>*)
  24.922 +
  24.923 +text \<open>
  24.924 +  This proof will fail, but the tracing output will show the order that the
  24.925 +  assumptions are attempted.
  24.926 +\<close>
  24.927 +
  24.928 +
  24.929 +section \<open>Integrating with Isabelle/ML\<close>
  24.930 +
  24.931 +subsubsection \<open>Attributes\<close>
  24.932 +
  24.933 +text \<open>
  24.934 +  A custom rule attribute is a simple way to extend the functionality of
  24.935 +  Eisbach methods. The dummy rule attribute notation (@{text "[[ _ ]]"})
  24.936 +  invokes the given attribute against a dummy fact and evaluates to the result
  24.937 +  of that attribute. When used as a match target, this can serve as an
  24.938 +  effective auxiliary function.
  24.939 +\<close>
  24.940 +
  24.941 +    attribute_setup get_split_rule =
  24.942 +      \<open>Args.term >> (fn t =>
  24.943 +        Thm.rule_attribute (fn context => fn _ =>
  24.944 +          (case get_split_rule (Context.proof_of context) t of
  24.945 +            SOME thm => thm
  24.946 +          | NONE => Drule.dummy_thm)))\<close>
  24.947 +
  24.948 +text \<open>
  24.949 +  In this example, the new attribute @{attribute get_split_rule} lifts the ML
  24.950 +  function of the same name into an attribute. When applied to a case
  24.951 +  distinction over a datatype, it retrieves its corresponding split rule.
  24.952 +
  24.953 +  We can then integrate this intro a method that applies the split rule, first
  24.954 +  matching to ensure that fetching the rule was successful.
  24.955 +\<close>
  24.956 +(*<*)declare TrueI [intros](*>*)
  24.957 +    method splits =
  24.958 +      (match conclusion in "?P f" for f \<Rightarrow>
  24.959 +        \<open>match [[get_split_rule f]] in U: "(_ :: bool) = _" \<Rightarrow>
  24.960 +          \<open>rule U [THEN iffD2]\<close>\<close>)
  24.961 +
  24.962 +    lemma "L \<noteq> [] \<Longrightarrow> case L of [] \<Rightarrow> False | _ \<Rightarrow> True"
  24.963 +      apply splits
  24.964 +      apply (prop_solver intros: allI)
  24.965 +      done
  24.966 +
  24.967 +text \<open>
  24.968 +  Here the new @{method splits} method transforms the goal to use only logical
  24.969 +  connectives: @{term "L = [] \<longrightarrow> False \<and> (\<forall>x y. L = x # y \<longrightarrow> True)"}. This goal
  24.970 +  is then in a form solvable by @{method prop_solver} when given the universal
  24.971 +  quantifier introduction rule @{text allI}.
  24.972 +\<close>
  24.973 +
  24.974 +end
    25.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.2 +++ b/src/Doc/Eisbach/Preface.thy	Mon May 25 22:11:43 2015 +0200
    25.3 @@ -0,0 +1,35 @@
    25.4 +(*:wrap=hard:maxLineLen=78:*)
    25.5 +
    25.6 +theory Preface
    25.7 +imports Base "../Eisbach_Tools"
    25.8 +begin
    25.9 +
   25.10 +text \<open>
   25.11 +  \emph{Eisbach} is a collection of tools which form the basis for defining
   25.12 +  new proof methods in Isabelle/Isar~@{cite "Wenzel-PhD"}. It can be thought
   25.13 +  of as a ``proof method language'', but is more precisely an infrastructure
   25.14 +  for defining new proof methods out of existing ones.
   25.15 +
   25.16 +  The core functionality of Eisbach is provided by the Isar @{command method}
   25.17 +  command. Here users may define new methods by combining existing ones with
   25.18 +  the usual Isar syntax. These methods can be abstracted over terms, facts and
   25.19 +  other methods, as one might expect in any higher-order functional language.
   25.20 +
   25.21 +  Additional functionality is provided by extending the space of methods and
   25.22 +  attributes. The new @{method match} method allows for explicit control-flow,
   25.23 +  by taking a match target and a list of pattern-method pairs. By using the
   25.24 +  functionality provided by Eisbach, additional support methods can be easily
   25.25 +  written. For example, the @{method catch} method, which provides basic
   25.26 +  try-catch functionality, only requires a few lines of ML.
   25.27 +
   25.28 +  Eisbach is meant to allow users to write automation using only Isar syntax.
   25.29 +  Traditionally proof methods have been written in Isabelle/ML, which poses a
   25.30 +  high barrier-to-entry for many users.
   25.31 +
   25.32 +  \medskip This manual is written for users familiar with Isabelle/Isar, but
   25.33 +  not necessarily Isabelle/ML. It covers the usage of the @{command method} as
   25.34 +  well as the @{method match} method, as well as discussing their integration
   25.35 +  with existing Isar concepts such as @{command named_theorems}.
   25.36 +\<close>
   25.37 +
   25.38 +end
   25.39 \ No newline at end of file
    26.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.2 +++ b/src/Doc/Eisbach/document/build	Mon May 25 22:11:43 2015 +0200
    26.3 @@ -0,0 +1,10 @@
    26.4 +#!/usr/bin/env bash
    26.5 +
    26.6 +set -e
    26.7 +
    26.8 +FORMAT="$1"
    26.9 +VARIANT="$2"
   26.10 +
   26.11 +"$ISABELLE_TOOL" logo Eisbach
   26.12 +"$ISABELLE_HOME/src/Doc/prepare_document" "$FORMAT"
   26.13 +
    27.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.2 +++ b/src/Doc/Eisbach/document/root.tex	Mon May 25 22:11:43 2015 +0200
    27.3 @@ -0,0 +1,88 @@
    27.4 +\documentclass[12pt,a4paper,fleqn]{report}
    27.5 +\usepackage[T1]{fontenc}
    27.6 +\usepackage{latexsym,graphicx}
    27.7 +\usepackage[refpage]{nomencl}
    27.8 +\usepackage{iman,extra,isar,proof}
    27.9 +\usepackage[nohyphen,strings]{underscore}
   27.10 +\usepackage{isabelle}
   27.11 +\usepackage{isabellesym}
   27.12 +\usepackage{railsetup}
   27.13 +\usepackage{ttbox}
   27.14 +\usepackage{supertabular}
   27.15 +\usepackage{style}
   27.16 +\usepackage{pdfsetup}
   27.17 +
   27.18 +
   27.19 +\hyphenation{Isabelle}
   27.20 +\hyphenation{Eisbach}
   27.21 +
   27.22 +\isadroptag{theory}
   27.23 +\title{\includegraphics[scale=0.5]{isabelle_eisbach}
   27.24 +  \\[4ex] The Eisbach User Manual}
   27.25 +\author{Daniel Matichuk \\
   27.26 +  Makarius Wenzel \\
   27.27 +  Toby Murray
   27.28 +}
   27.29 +
   27.30 +
   27.31 +% Control fixmes etc.
   27.32 +\newif\ifDraft \newif\ifFinal
   27.33 +%\Drafttrue\Finalfalse
   27.34 +\Draftfalse\Finaltrue
   27.35 +
   27.36 +
   27.37 +\ifDraft
   27.38 +  \usepackage{draftcopy}
   27.39 +  \newcommand{\Comment}[1]{\textbf{\textsl{#1}}}
   27.40 +  \newenvironment{LongComment}[1] % multi-paragraph comment, argument is owner
   27.41 +    {\begingroup\par\noindent\slshape \textbf{Begin Comment[#1]}\par}
   27.42 +    {\par\noindent\textbf{End Comment}\endgroup\par}
   27.43 +  \newcommand{\FIXME}[1]{\textbf{\textsl{FIXME: #1}}}
   27.44 +  \newcommand{\TODO}[1]{\textbf{\textsl{TODO: #1}}}
   27.45 +\else
   27.46 +  \newcommand{\Comment}[1]{\relax}
   27.47 +  \newenvironment{LongComment}[1]{\expandafter\comment}{\expandafter\endcomment}
   27.48 +  \newcommand{\FIXME}[1]{\relax}
   27.49 +  \newcommand{\TODO}[1]{\relax}
   27.50 +\fi
   27.51 +
   27.52 +% This sort of command for each active author can be convenient
   27.53 +\newcommand{\dan}[1]{\Comment{#1 [dan]}}
   27.54 +\newcommand{\toby}[1]{\Comment{#1 [toby]}}
   27.55 +\newcommand{\makarius}[1]{\Comment{#1 [makarius]}}
   27.56 +
   27.57 +
   27.58 +\makeindex
   27.59 +
   27.60 +\chardef\charbackquote=`\`
   27.61 +\newcommand{\backquote}{\mbox{\tt\charbackquote}}
   27.62 +
   27.63 +
   27.64 +\begin{document}
   27.65 +
   27.66 +\maketitle
   27.67 +
   27.68 +\pagenumbering{roman}
   27.69 +\chapter*{Preface}
   27.70 +\input{Preface.tex}
   27.71 +\tableofcontents
   27.72 +\clearfirst
   27.73 +
   27.74 +\input{Manual.tex}
   27.75 +
   27.76 +\begingroup
   27.77 +\tocentry{\bibname}
   27.78 +\bibliographystyle{abbrv} \small\raggedright\frenchspacing
   27.79 +\bibliography{manual}
   27.80 +\endgroup
   27.81 +
   27.82 +\tocentry{\indexname}
   27.83 +\printindex
   27.84 +
   27.85 +\end{document}
   27.86 +
   27.87 +
   27.88 +%%% Local Variables:
   27.89 +%%% mode: latex
   27.90 +%%% TeX-master: t
   27.91 +%%% End:
    28.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.2 +++ b/src/Doc/Eisbach/document/style.sty	Mon May 25 22:11:43 2015 +0200
    28.3 @@ -0,0 +1,68 @@
    28.4 +%% toc
    28.5 +\newcommand{\tocentry}[1]{\cleardoublepage\phantomsection\addcontentsline{toc}{chapter}{#1}
    28.6 +\@mkboth{\MakeUppercase{#1}}{\MakeUppercase{#1}}}
    28.7 +
    28.8 +%% references
    28.9 +\newcommand{\secref}[1]{\S\ref{#1}}
   28.10 +\newcommand{\chref}[1]{chapter~\ref{#1}}
   28.11 +\newcommand{\figref}[1]{figure~\ref{#1}}
   28.12 +
   28.13 +%% math
   28.14 +\newcommand{\text}[1]{\mbox{#1}}
   28.15 +\newcommand{\isasymvartheta}{\isamath{\theta}}
   28.16 +\newcommand{\isactrlvec}[1]{\emph{$\vec{#1}$}}
   28.17 +\newcommand{\isactrlBG}{\isacharbackquoteopen}
   28.18 +\newcommand{\isactrlEN}{\isacharbackquoteclose}
   28.19 +
   28.20 +\setcounter{secnumdepth}{2} \setcounter{tocdepth}{2}
   28.21 +
   28.22 +\pagestyle{headings}
   28.23 +\sloppy
   28.24 +\binperiod
   28.25 +
   28.26 +\parindent 0pt\parskip 0.5ex
   28.27 +
   28.28 +\renewcommand{\isadigit}[1]{\isamath{#1}}
   28.29 +
   28.30 +\newenvironment{mldecls}{\par\noindent\begingroup\footnotesize\def\isanewline{\\}\begin{tabular}{l}}{\end{tabular}\smallskip\endgroup}
   28.31 +
   28.32 +\isafoldtag{FIXME}
   28.33 +
   28.34 +\isakeeptag{mlref}
   28.35 +\renewcommand{\isatagmlref}{\subsection*{\makebox[0pt][r]{\fbox{ML}~~}Reference}}
   28.36 +\renewcommand{\endisatagmlref}{}
   28.37 +
   28.38 +\isakeeptag{mlantiq}
   28.39 +\renewcommand{\isatagmlantiq}{\subsection*{\makebox[0pt][r]{\fbox{ML}~~}Antiquotations}}
   28.40 +\renewcommand{\endisatagmlantiq}{}
   28.41 +
   28.42 +\isakeeptag{mlex}
   28.43 +\renewcommand{\isatagmlex}{\subsection*{\makebox[0pt][r]{\fbox{ML}~~}Examples}}
   28.44 +\renewcommand{\endisatagmlex}{}
   28.45 +
   28.46 +\renewcommand{\isatagML}{\begingroup\isabellestyle{default}\isastyle\def\isadigit##1{##1}}
   28.47 +\renewcommand{\endisatagML}{\endgroup}
   28.48 +
   28.49 +\newcommand{\minorcmd}[1]{{\sf #1}}
   28.50 +\newcommand{\isasymtype}{\minorcmd{type}}
   28.51 +\newcommand{\isasymval}{\minorcmd{val}}
   28.52 +
   28.53 +\newcommand{\isasymFIX}{\isakeyword{fix}}
   28.54 +\newcommand{\isasymASSUME}{\isakeyword{assume}}
   28.55 +\newcommand{\isasymDEFINE}{\isakeyword{define}}
   28.56 +\newcommand{\isasymNOTE}{\isakeyword{note}}
   28.57 +\newcommand{\isasymGUESS}{\isakeyword{guess}}
   28.58 +\newcommand{\isasymOBTAIN}{\isakeyword{obtain}}
   28.59 +\newcommand{\isasymTHEORY}{\isakeyword{theory}}
   28.60 +\newcommand{\isasymUSES}{\isakeyword{uses}}
   28.61 +\newcommand{\isasymEND}{\isakeyword{end}}
   28.62 +\newcommand{\isasymCONSTS}{\isakeyword{consts}}
   28.63 +\newcommand{\isasymDEFS}{\isakeyword{defs}}
   28.64 +\newcommand{\isasymTHEOREM}{\isakeyword{theorem}}
   28.65 +\newcommand{\isasymDEFINITION}{\isakeyword{definition}}
   28.66 +
   28.67 +\isabellestyle{literal}
   28.68 +
   28.69 +\railtermfont{\isabellestyle{tt}}
   28.70 +\railnontermfont{\isabellestyle{itunderscore}}
   28.71 +\railnamefont{\isabellestyle{itunderscore}}
    29.1 --- a/src/Doc/Implementation/Integration.thy	Sat May 23 22:13:24 2015 +0200
    29.2 +++ b/src/Doc/Implementation/Integration.thy	Mon May 25 22:11:43 2015 +0200
    29.3 @@ -187,7 +187,7 @@
    29.4    sub-graph of theories, the intrinsic parallelism can be exploited by the
    29.5    system to speedup loading.
    29.6  
    29.7 -  This variant is used by default in @{tool build} @{cite "isabelle-sys"}.
    29.8 +  This variant is used by default in @{tool build} @{cite "isabelle-system"}.
    29.9  
   29.10    \item @{ML Thy_Info.get_theory}~@{text A} retrieves the theory value
   29.11    presently associated with name @{text A}. Note that the result might be
    30.1 --- a/src/Doc/Implementation/ML.thy	Sat May 23 22:13:24 2015 +0200
    30.2 +++ b/src/Doc/Implementation/ML.thy	Mon May 25 22:11:43 2015 +0200
    30.3 @@ -1418,7 +1418,7 @@
    30.4    \item sequence of Isabelle symbols (see also \secref{sec:symbols}),
    30.5    with @{ML Symbol.explode} as key operation;
    30.6  
    30.7 -  \item XML tree structure via YXML (see also @{cite "isabelle-sys"}),
    30.8 +  \item XML tree structure via YXML (see also @{cite "isabelle-system"}),
    30.9    with @{ML YXML.parse_body} as key operation.
   30.10  
   30.11    \end{enumerate}
    31.1 --- a/src/Doc/Isar_Ref/Document_Preparation.thy	Sat May 23 22:13:24 2015 +0200
    31.2 +++ b/src/Doc/Isar_Ref/Document_Preparation.thy	Mon May 25 22:11:43 2015 +0200
    31.3 @@ -11,7 +11,7 @@
    31.4  
    31.5    {\LaTeX} output is generated while processing a \emph{session} in
    31.6    batch mode, as explained in the \emph{The Isabelle System Manual}
    31.7 -  @{cite "isabelle-sys"}.  The main Isabelle tools to get started with
    31.8 +  @{cite "isabelle-system"}.  The main Isabelle tools to get started with
    31.9    document preparation are @{tool_ref mkroot} and @{tool_ref build}.
   31.10  
   31.11    The classic Isabelle/HOL tutorial @{cite "isabelle-hol-book"} also
   31.12 @@ -81,7 +81,7 @@
   31.13  \<close>
   31.14  
   31.15  
   31.16 -section \<open>Document Antiquotations \label{sec:antiq}\<close>
   31.17 +section \<open>Document antiquotations \label{sec:antiq}\<close>
   31.18  
   31.19  text \<open>
   31.20    \begin{matharray}{rcl}
   31.21 @@ -434,7 +434,7 @@
   31.22    \end{tabular}
   31.23  
   31.24    \medskip The Isabelle document preparation system
   31.25 -  @{cite "isabelle-sys"} allows tagged command regions to be presented
   31.26 +  @{cite "isabelle-system"} allows tagged command regions to be presented
   31.27    specifically, e.g.\ to fold proof texts, or drop parts of the text
   31.28    completely.
   31.29  
   31.30 @@ -459,7 +459,7 @@
   31.31    arbitrary tags to ``keep'', ``drop'', or ``fold'' the corresponding
   31.32    parts of the text.  Logic sessions may also specify ``document
   31.33    versions'', where given tags are interpreted in some particular way.
   31.34 -  Again see @{cite "isabelle-sys"} for further details.
   31.35 +  Again see @{cite "isabelle-system"} for further details.
   31.36  \<close>
   31.37  
   31.38  
    32.1 --- a/src/Doc/Isar_Ref/HOL_Specific.thy	Sat May 23 22:13:24 2015 +0200
    32.2 +++ b/src/Doc/Isar_Ref/HOL_Specific.thy	Mon May 25 22:11:43 2015 +0200
    32.3 @@ -1,6 +1,6 @@
    32.4  theory HOL_Specific
    32.5  imports Base "~~/src/HOL/Library/Old_Datatype" "~~/src/HOL/Library/Old_Recdef"
    32.6 -  "~~/src/Tools/Adhoc_Overloading"
    32.7 +  "~~/src/Tools/Adhoc_Overloading" "~~/src/HOL/Library/Dlist"  "~~/src/HOL/Library/FSet"
    32.8  begin
    32.9  
   32.10  chapter \<open>Higher-Order Logic\<close>
   32.11 @@ -1616,8 +1616,8 @@
   32.12    \<close>}
   32.13  
   32.14    @{rail \<open>
   32.15 -    @@{command (HOL) lift_definition} @{syntax name} '::' @{syntax type}  @{syntax mixfix}? \<newline>
   32.16 -      'is' @{syntax term} (@'parametric' (@{syntax thmref}+))?
   32.17 +    @@{command (HOL) lift_definition} ('(' 'code_dt' ')')? @{syntax name} '::' @{syntax type}  \<newline>  
   32.18 +      @{syntax mixfix}? 'is' @{syntax term} (@'parametric' (@{syntax thmref}+))?
   32.19    \<close>}
   32.20  
   32.21    @{rail \<open>
   32.22 @@ -1695,9 +1695,24 @@
   32.23      the abstraction function.
   32.24  
   32.25      Integration with [@{attribute code} abstract]: For subtypes (e.g.,
   32.26 -    corresponding to a datatype invariant, such as dlist), @{command
   32.27 +    corresponding to a datatype invariant, such as @{typ "'a dlist"}), @{command
   32.28      (HOL) "lift_definition"} uses a code certificate theorem
   32.29 -    @{text f.rep_eq} as a code equation.
   32.30 +    @{text f.rep_eq} as a code equation. Because of the limitation of the code generator,
   32.31 +    @{text f.rep_eq} cannot be used as a code equation if the subtype occurs inside the result
   32.32 +    type rather than at the top level (e.g., function returning @{typ "'a dlist option"} vs. 
   32.33 +    @{typ "'a dlist"}). In this case, an extension of @{command
   32.34 +    (HOL) "lift_definition"} can be invoked by specifying the flag @{text "code_dt"}. This
   32.35 +    extension enables code execution through series of internal type and lifting definitions 
   32.36 +    if the return type @{text "\<tau>"} meets the following inductive conditions:
   32.37 +    \begin{description}
   32.38 +      \item  @{text "\<tau>"} is a type variable
   32.39 +      \item @{text "\<tau> = \<tau>\<^sub>1 \<dots> \<tau>\<^sub>n \<kappa>"}, where @{text "\<kappa>"} is an abstract type constructor 
   32.40 +        and @{text "\<tau>\<^sub>1 \<dots> \<tau>\<^sub>n"} do not contain abstract types (i.e., @{typ "int dlist"} is allowed 
   32.41 +        whereas @{typ "int dlist dlist"} not)
   32.42 +      \item @{text "\<tau> = \<tau>\<^sub>1 \<dots> \<tau>\<^sub>n \<kappa>"}, @{text "\<kappa>"} is a type constructor that was defined as a 
   32.43 +        (co)datatype whose constructor argument types do not contain either non-free datatypes 
   32.44 +        or the function type.
   32.45 +    \end{description}
   32.46  
   32.47      Integration with [@{attribute code} equation]: For total quotients, @{command
   32.48      (HOL) "lift_definition"} uses @{text f.abs_eq} as a code equation.
   32.49 @@ -1780,7 +1795,7 @@
   32.50      and thus sets up lifting for an abstract type @{text \<tau>} (that is defined by @{text Quotient_thm}).
   32.51      Optional theorems @{text pcr_def} and @{text pcr_cr_eq_thm} can be specified to register 
   32.52      the parametrized
   32.53 -    correspondence relation for @{text \<tau>}. E.g., for @{text "'a dlist"}, @{text pcr_def} is
   32.54 +    correspondence relation for @{text \<tau>}. E.g., for @{typ "'a dlist"}, @{text pcr_def} is
   32.55      @{text "pcr_dlist A \<equiv> list_all2 A \<circ>\<circ> cr_dlist"} and @{text pcr_cr_eq_thm} is 
   32.56      @{text "pcr_dlist op= = op="}.
   32.57      This attribute is rather used for low-level
    33.1 --- a/src/Doc/Isar_Ref/Inner_Syntax.thy	Sat May 23 22:13:24 2015 +0200
    33.2 +++ b/src/Doc/Isar_Ref/Inner_Syntax.thy	Mon May 25 22:11:43 2015 +0200
    33.3 @@ -110,7 +110,7 @@
    33.4    @{command "print_state"}~@{text "(latex xsymbols)"} prints the
    33.5    current proof state with mathematical symbols and special characters
    33.6    represented in {\LaTeX} source, according to the Isabelle style
    33.7 -  @{cite "isabelle-sys"}.
    33.8 +  @{cite "isabelle-system"}.
    33.9  
   33.10    Note that antiquotations (cf.\ \secref{sec:antiq}) provide a more
   33.11    systematic way to include formal items into the printed text
   33.12 @@ -1023,7 +1023,7 @@
   33.13    need to be passed-through carefully by syntax transformations.
   33.14  
   33.15    Pre-terms are further processed by the so-called \emph{check} and
   33.16 -  \emph{unckeck} phases that are intertwined with type-inference (see
   33.17 +  \emph{uncheck} phases that are intertwined with type-inference (see
   33.18    also @{cite "isabelle-implementation"}).  The latter allows to operate
   33.19    on higher-order abstract syntax with proper binding and type
   33.20    information already available.
    34.1 --- a/src/Doc/Isar_Ref/Misc.thy	Sat May 23 22:13:24 2015 +0200
    34.2 +++ b/src/Doc/Isar_Ref/Misc.thy	Mon May 25 22:11:43 2015 +0200
    34.3 @@ -103,7 +103,7 @@
    34.4  
    34.5    \item @{command "thm_deps"}~@{text "a\<^sub>1 \<dots> a\<^sub>n"}
    34.6    visualizes dependencies of facts, using Isabelle's graph browser
    34.7 -  tool (see also @{cite "isabelle-sys"}).
    34.8 +  tool (see also @{cite "isabelle-system"}).
    34.9  
   34.10    \item @{command "unused_thms"}~@{text "A\<^sub>1 \<dots> A\<^sub>m - B\<^sub>1 \<dots> B\<^sub>n"}
   34.11    displays all theorems that are proved in theories @{text "B\<^sub>1 \<dots> B\<^sub>n"}
    35.1 --- a/src/Doc/Isar_Ref/Outer_Syntax.thy	Sat May 23 22:13:24 2015 +0200
    35.2 +++ b/src/Doc/Isar_Ref/Outer_Syntax.thy	Mon May 25 22:11:43 2015 +0200
    35.3 @@ -28,7 +28,7 @@
    35.4  
    35.5    Printed theory documents usually omit quotes to gain readability
    35.6    (this is a matter of {\LaTeX} macro setup, say via @{verbatim
    35.7 -  "\\isabellestyle"}, see also @{cite "isabelle-sys"}).  Experienced
    35.8 +  "\\isabellestyle"}, see also @{cite "isabelle-system"}).  Experienced
    35.9    users of Isabelle/Isar may easily reconstruct the lost technical
   35.10    information, while mere readers need not care about quotes at all.
   35.11  \<close>
    36.1 --- a/src/Doc/Isar_Ref/Preface.thy	Sat May 23 22:13:24 2015 +0200
    36.2 +++ b/src/Doc/Isar_Ref/Preface.thy	Mon May 25 22:11:43 2015 +0200
    36.3 @@ -2,8 +2,6 @@
    36.4  imports Base Main
    36.5  begin
    36.6  
    36.7 -chapter \<open>Preface\<close>
    36.8 -
    36.9  text \<open>
   36.10    The \emph{Isabelle} system essentially provides a generic
   36.11    infrastructure for building deductive systems (programmed in
    37.1 --- a/src/Doc/Isar_Ref/Spec.thy	Sat May 23 22:13:24 2015 +0200
    37.2 +++ b/src/Doc/Isar_Ref/Spec.thy	Mon May 25 22:11:43 2015 +0200
    37.3 @@ -178,7 +178,7 @@
    37.4    accesses to the local scope, as determined by the enclosing @{command
    37.5    "context"}~@{keyword "begin"}~\dots~@{command "end"} block. Outside its
    37.6    scope, a @{keyword "private"} name is inaccessible, and a @{keyword
    37.7 -  "qualified"} name is only accessible with additional qualification.
    37.8 +  "qualified"} name is only accessible with some qualification.
    37.9  
   37.10    Neither a global @{command theory} nor a @{command locale} target provides
   37.11    a local scope by itself: an extra unnamed context is required to use
   37.12 @@ -1541,7 +1541,7 @@
   37.13  
   37.14    \item @{command "hide_class"}~@{text names} fully removes class
   37.15    declarations from a given name space; with the @{text "(open)"}
   37.16 -  option, only the base name is hidden.
   37.17 +  option, only the unqualified base name is hidden.
   37.18  
   37.19    Note that hiding name space accesses has no impact on logical
   37.20    declarations --- they remain valid internally.  Entities that are no
    38.1 --- a/src/Doc/Isar_Ref/document/root.tex	Sat May 23 22:13:24 2015 +0200
    38.2 +++ b/src/Doc/Isar_Ref/document/root.tex	Mon May 25 22:11:43 2015 +0200
    38.3 @@ -60,7 +60,8 @@
    38.4  \maketitle 
    38.5  
    38.6  \pagenumbering{roman}
    38.7 -{\def\isamarkupchapter#1{\chapter*{#1}}\input{Preface.tex}}
    38.8 +\chapter*{Preface}
    38.9 +\input{Preface.tex}
   38.10  \tableofcontents
   38.11  \clearfirst
   38.12  
    39.1 --- a/src/Doc/JEdit/JEdit.thy	Sat May 23 22:13:24 2015 +0200
    39.2 +++ b/src/Doc/JEdit/JEdit.thy	Mon May 25 22:11:43 2015 +0200
    39.3 @@ -82,9 +82,9 @@
    39.4    The options allow to specify a logic session name --- the same selector is
    39.5    accessible in the \emph{Theories} panel (\secref{sec:theories}). On
    39.6    application startup, the selected logic session image is provided
    39.7 -  automatically by the Isabelle build tool @{cite "isabelle-sys"}: if it is
    39.8 +  automatically by the Isabelle build tool @{cite "isabelle-system"}: if it is
    39.9    absent or outdated wrt.\ its sources, the build process updates it before
   39.10 -  entering the Prover IDE.  Changing the logic session within Isabelle/jEdit
   39.11 +  entering the Prover IDE.  Change of the logic session within Isabelle/jEdit
   39.12    requires a restart of the whole application.
   39.13  
   39.14    \medskip The main job of the Prover IDE is to manage sources and their
   39.15 @@ -103,7 +103,8 @@
   39.16  
   39.17    Thus the Prover IDE gives an impression of direct access to formal content
   39.18    of the prover within the editor, but in reality only certain aspects are
   39.19 -  exposed, according to the possibilities of the prover and its many tools.
   39.20 +  exposed, according to the possibilities of the prover and its many add-on
   39.21 +  tools.
   39.22  \<close>
   39.23  
   39.24  
   39.25 @@ -169,7 +170,7 @@
   39.26  
   39.27    Isabelle system options are managed by Isabelle/Scala and changes are stored
   39.28    in @{file_unchecked "$ISABELLE_HOME_USER/etc/preferences"}, independently of
   39.29 -  other jEdit properties. See also @{cite "isabelle-sys"}, especially the
   39.30 +  other jEdit properties. See also @{cite "isabelle-system"}, especially the
   39.31    coverage of sessions and command-line tools like @{tool build} or @{tool
   39.32    options}.
   39.33  
   39.34 @@ -181,7 +182,7 @@
   39.35    Isabelle system options. Note that some of these options affect general
   39.36    parameters that are relevant outside Isabelle/jEdit as well, e.g.\
   39.37    @{system_option threads} or @{system_option parallel_proofs} for the
   39.38 -  Isabelle build tool @{cite "isabelle-sys"}, but it is possible to use the
   39.39 +  Isabelle build tool @{cite "isabelle-system"}, but it is possible to use the
   39.40    settings variable @{setting ISABELLE_BUILD_OPTIONS} to change defaults for
   39.41    batch builds without affecting Isabelle/jEdit.
   39.42  
   39.43 @@ -242,7 +243,7 @@
   39.44    The @{verbatim "-l"} option specifies the session name of the logic
   39.45    image to be used for proof processing.  Additional session root
   39.46    directories may be included via option @{verbatim "-d"} to augment
   39.47 -  that name space of @{tool build} @{cite "isabelle-sys"}.
   39.48 +  that name space of @{tool build} @{cite "isabelle-system"}.
   39.49  
   39.50    By default, the specified image is checked and built on demand. The
   39.51    @{verbatim "-s"} option determines where to store the result session image
   39.52 @@ -256,7 +257,7 @@
   39.53  
   39.54    The @{verbatim "-J"} and @{verbatim "-j"} options allow to pass additional
   39.55    low-level options to the JVM or jEdit, respectively. The defaults are
   39.56 -  provided by the Isabelle settings environment @{cite "isabelle-sys"}, but
   39.57 +  provided by the Isabelle settings environment @{cite "isabelle-system"}, but
   39.58    note that these only work for the command-line tool described here, and not
   39.59    the regular application.
   39.60  
   39.61 @@ -270,12 +271,15 @@
   39.62  
   39.63  chapter \<open>Augmented jEdit functionality\<close>
   39.64  
   39.65 -section \<open>Look-and-feel\<close>
   39.66 +section \<open>GUI rendering\<close>
   39.67 +
   39.68 +subsection \<open>Look-and-feel \label{sec:look-and-feel}\<close>
   39.69  
   39.70 -text \<open>jEdit is a Java/AWT/Swing application with some ambition to
   39.71 -  support ``native'' look-and-feel on all platforms, within the limits
   39.72 -  of what Oracle as Java provider and major operating system
   39.73 -  distributors allow (see also \secref{sec:problems}).
   39.74 +text \<open>
   39.75 +  jEdit is a Java/AWT/Swing application with some ambition to support
   39.76 +  ``native'' look-and-feel on all platforms, within the limits of what Oracle
   39.77 +  as Java provider and major operating system distributors allow (see also
   39.78 +  \secref{sec:problems}).
   39.79  
   39.80    Isabelle/jEdit enables platform-specific look-and-feel by default as
   39.81    follows.
   39.82 @@ -285,11 +289,14 @@
   39.83    \item[Linux:] The platform-independent \emph{Nimbus} is used by
   39.84    default.
   39.85  
   39.86 -  \emph{GTK+} works under the side-condition that the overall GTK theme is
   39.87 -  selected in a Swing-friendly way.\footnote{GTK support in Java/Swing was
   39.88 -  once marketed aggressively by Sun, but never quite finished. Today (2013) it
   39.89 +  \emph{GTK+} also works under the side-condition that the overall GTK theme
   39.90 +  is selected in a Swing-friendly way.\footnote{GTK support in Java/Swing was
   39.91 +  once marketed aggressively by Sun, but never quite finished. Today (2015) it
   39.92    is lagging behind further development of Swing and GTK. The graphics
   39.93 -  rendering performance can be worse than for other Swing look-and-feels.}
   39.94 +  rendering performance can be worse than for other Swing look-and-feels.
   39.95 +  Nonetheless it has its uses for displays with very high resolution (such as
   39.96 +  ``4K'' or ``UHD'' models), because the rendering by the external library is
   39.97 +  subject to global system settings for font scaling.}
   39.98  
   39.99    \item[Windows:] Regular \emph{Windows} is used by default, but
  39.100    \emph{Windows Classic} also works.
  39.101 @@ -308,11 +315,78 @@
  39.102    in mind that this extra variance of GUI functionality is unlikely to
  39.103    work in arbitrary combinations.  The platform-independent
  39.104    \emph{Nimbus} and \emph{Metal} should always work.  The historic
  39.105 -  \emph{CDE/Motif} is better avoided.
  39.106 +  \emph{CDE/Motif} should be ignored.
  39.107  
  39.108    After changing the look-and-feel in \emph{Global Options~/
  39.109    Appearance}, it is advisable to restart Isabelle/jEdit in order to
  39.110 -  take full effect.\<close>
  39.111 +  take full effect.
  39.112 +\<close>
  39.113 +
  39.114 +
  39.115 +subsection \<open>Displays with very high resolution \label{sec:hdpi}\<close>
  39.116 +
  39.117 +text \<open>
  39.118 +  Many years ago, displays with $1024 \times 768$ or $1280 \times 1024$ pixels
  39.119 +  were considered ``high resolution'' and bitmap fonts with 12 or 14 pixels as
  39.120 +  adequate for text rendering. Today (2015), we routinely see ``Full HD''
  39.121 +  monitors at $1920 \times 1080$ pixels, and occasionally ``Ultra HD'' at
  39.122 +  $3840 \times 2160$ or more, but GUI rendering did not really progress
  39.123 +  beyond the old standards.
  39.124 +
  39.125 +  Isabelle/jEdit defaults are a compromise for reasonable out-of-the box
  39.126 +  results on common platforms and medium resolution displays (e.g.\ the ``Full
  39.127 +  HD'' category). Subsequently there are further hints to improve on that.
  39.128 +
  39.129 +  \medskip The \textbf{operating-system platform} usually provides some
  39.130 +  configuration for global scaling of text fonts, e.g.\ $120\%$--$250\%$ on
  39.131 +  Windows. Changing that only has a partial effect on GUI rendering;
  39.132 +  satisfactory display quality requires further adjustments.
  39.133 +
  39.134 +  \medskip The Isabelle/jEdit \textbf{application} and its plugins provide
  39.135 +  various font properties that are summarized below.
  39.136 +
  39.137 +  \begin{itemize}
  39.138 +
  39.139 +  \item \emph{Global Options / Text Area / Text font}: the main text area
  39.140 +  font, which is also used as reference point for various derived font sizes,
  39.141 +  e.g.\ the Output panel (\secref{sec:output}).
  39.142 +
  39.143 +  \item \emph{Global Options / Gutter / Gutter font}: the font for the gutter
  39.144 +  area left of the main text area, e.g.\ relevant for display of line numbers
  39.145 +  (disabled by default).
  39.146 +
  39.147 +  \item \emph{Global Options / Appearance / Button, menu and label font} as
  39.148 +  well as \emph{List and text field font}: this specifies the primary and
  39.149 +  secondary font for the old \emph{Metal} look-and-feel
  39.150 +  (\secref{sec:look-and-feel}), which happens to scale better than newer ones
  39.151 +  like \emph{Nimbus}.
  39.152 +
  39.153 +  \item \emph{Plugin Options / Isabelle / General / Reset Font Size}: the main
  39.154 +  text area font size for action @{action_ref "isabelle.reset-font-size"},
  39.155 +  e.g.\ relevant for quick scaling like in major web browsers.
  39.156 +
  39.157 +  \item \emph{Plugin Options / Console / General / Font}: the console window
  39.158 +  font, e.g.\ relevant for Isabelle/Scala command-line.
  39.159 +
  39.160 +  \end{itemize}
  39.161 +
  39.162 +  In \figref{fig:isabelle-jedit-hdpi} the \emph{Metal} look-and-feel is
  39.163 +  configured with custom fonts at 30 pixels, and the main text area and
  39.164 +  console at 36 pixels. Despite the old-fashioned appearance of \emph{Metal},
  39.165 +  this leads to decent rendering quality on all platforms.
  39.166 +
  39.167 +  \begin{figure}[htb]
  39.168 +  \begin{center}
  39.169 +  \includegraphics[width=\textwidth]{isabelle-jedit-hdpi}
  39.170 +  \end{center}
  39.171 +  \caption{Metal look-and-feel with custom fonts for very high resolution}
  39.172 +  \label{fig:isabelle-jedit-hdpi}
  39.173 +  \end{figure}
  39.174 +
  39.175 +  On Linux, it is also possible to use \emph{GTK+} with a suitable theme and
  39.176 +  global font scaling. On Mac OS X, the default setup for ``Retina'' displays
  39.177 +  should work adequately with the native look-and-feel.
  39.178 +\<close>
  39.179  
  39.180  
  39.181  section \<open>Dockable windows \label{sec:dockables}\<close>
  39.182 @@ -333,10 +407,10 @@
  39.183    \emph{HyperSearch Results} or the \emph{File System Browser}. Plugins often
  39.184    provide a central dockable to access their key functionality, which may be
  39.185    opened by the user on demand. The Isabelle/jEdit plugin takes this approach
  39.186 -  to the extreme: its plugin menu merely provides entry-points to panels that
  39.187 -  are managed as dockable windows. Some important panels are docked by
  39.188 +  to the extreme: its plugin menu provides the entry-points to many panels
  39.189 +  that are managed as dockable windows. Some important panels are docked by
  39.190    default, e.g.\ \emph{Documentation}, \emph{Output}, \emph{Query}, but the
  39.191 -  user can change this arrangement easily.
  39.192 +  user can change this arrangement easily and persistently.
  39.193  
  39.194    Compared to plain jEdit, dockable window management in Isabelle/jEdit is
  39.195    slightly augmented according to the the following principles:
  39.196 @@ -398,15 +472,15 @@
  39.197    alphabets in comments.
  39.198  
  39.199    \medskip \paragraph{Encoding.} Technically, the Unicode view on Isabelle
  39.200 -  symbols is an \emph{encoding} in jEdit (not in the underlying JVM) that is
  39.201 -  called @{verbatim "UTF-8-Isabelle"}. It is provided by the Isabelle/jEdit
  39.202 -  plugin and enabled by default for all source files. Sometimes such defaults
  39.203 -  are reset accidentally, or malformed UTF-8 sequences in the text force jEdit
  39.204 -  to fall back on a different encoding like @{verbatim "ISO-8859-15"}. In that
  39.205 -  case, verbatim ``@{verbatim "\<alpha>"}'' will be shown in the text buffer instead
  39.206 -  of its Unicode rendering ``@{text "\<alpha>"}''. The jEdit menu operation
  39.207 -  \emph{File~/ Reload with Encoding~/ UTF-8-Isabelle} helps to resolve such
  39.208 -  problems (after repairing malformed parts of the text).
  39.209 +  symbols is an \emph{encoding} called @{verbatim "UTF-8-Isabelle"} in jEdit
  39.210 +  (not in the underlying JVM). It is provided by the Isabelle/jEdit plugin and
  39.211 +  enabled by default for all source files. Sometimes such defaults are reset
  39.212 +  accidentally, or malformed UTF-8 sequences in the text force jEdit to fall
  39.213 +  back on a different encoding like @{verbatim "ISO-8859-15"}. In that case,
  39.214 +  verbatim ``@{verbatim "\<alpha>"}'' will be shown in the text buffer instead of its
  39.215 +  Unicode rendering ``@{text "\<alpha>"}''. The jEdit menu operation \emph{File~/
  39.216 +  Reload with Encoding~/ UTF-8-Isabelle} helps to resolve such problems (after
  39.217 +  repairing malformed parts of the text).
  39.218  
  39.219    \medskip \paragraph{Font.} Correct rendering via Unicode requires a
  39.220    font that contains glyphs for the corresponding codepoints.  Most
  39.221 @@ -450,11 +524,11 @@
  39.222    some web browser or mail client, as long as the same Unicode view on
  39.223    Isabelle symbols is used.
  39.224  
  39.225 -  \item Copy/paste from prover output within Isabelle/jEdit.  The
  39.226 -  same principles as for text buffers apply, but note that \emph{copy}
  39.227 -  in secondary Isabelle/jEdit windows works via the keyboard shortcut
  39.228 -  @{verbatim "C+c"}, while jEdit menu actions always refer to the
  39.229 -  primary text area!
  39.230 +  \item Copy/paste from prover output within Isabelle/jEdit. The same
  39.231 +  principles as for text buffers apply, but note that \emph{copy} in secondary
  39.232 +  Isabelle/jEdit windows works via the keyboard shortcuts @{verbatim "C+c"} or
  39.233 +  @{verbatim "C+INSERT"}, while jEdit menu actions always refer to the primary
  39.234 +  text area!
  39.235  
  39.236    \item Completion provided by Isabelle plugin (see
  39.237    \secref{sec:completion}).  Isabelle symbols have a canonical name
  39.238 @@ -592,9 +666,9 @@
  39.239    Despite the flexibility of URLs in jEdit, local files are particularly
  39.240    important and are accessible without protocol prefix. Here the path notation
  39.241    is that of the Java Virtual Machine on the underlying platform. On Windows
  39.242 -  the preferred form uses backslashes, but happens to accept forward slashes
  39.243 -  like Unix/POSIX. Further differences arise due to Windows drive letters and
  39.244 -  network shares.
  39.245 +  the preferred form uses backslashes, but happens to accept also forward
  39.246 +  slashes like Unix/POSIX. Further differences arise due to Windows drive
  39.247 +  letters and network shares.
  39.248  
  39.249    The Java notation for files needs to be distinguished from the one of
  39.250    Isabelle, which uses POSIX notation with forward slashes on \emph{all}
  39.251 @@ -611,8 +685,8 @@
  39.252    though, due to the bias of jEdit towards platform-specific notation and of
  39.253    Isabelle towards POSIX. Moreover, the Isabelle settings environment is not
  39.254    yet active when starting Isabelle/jEdit via its standard application
  39.255 -  wrapper, in contrast to @{verbatim "isabelle jedit"} run from the command
  39.256 -  line (\secref{sec:command-line}).
  39.257 +  wrapper, in contrast to @{tool jedit} run from the command line
  39.258 +  (\secref{sec:command-line}).
  39.259  
  39.260    Isabelle/jEdit imitates @{verbatim "$ISABELLE_HOME"} and @{verbatim
  39.261    "$ISABELLE_HOME_USER"} within the Java process environment, in order to
  39.262 @@ -684,7 +758,7 @@
  39.263  
  39.264    In any case, source files are managed by the PIDE infrastructure: the
  39.265    physical file-system only plays a subordinate role. The relevant version of
  39.266 -  source text is passed directly from the editor to the prover, via internal
  39.267 +  source text is passed directly from the editor to the prover, using internal
  39.268    communication channels.
  39.269  \<close>
  39.270  
  39.271 @@ -695,7 +769,7 @@
  39.272    The \emph{Theories} panel (see also \figref{fig:theories}) provides an
  39.273    overview of the status of continuous checking of theory nodes within the
  39.274    document model. Unlike batch sessions of @{tool build} @{cite
  39.275 -  "isabelle-sys"}, theory nodes are identified by full path names; this allows
  39.276 +  "isabelle-system"}, theory nodes are identified by full path names; this allows
  39.277    to work with multiple (disjoint) Isabelle sessions simultaneously within the
  39.278    same editor session.
  39.279  
  39.280 @@ -736,13 +810,14 @@
  39.281    rendering, based on a standard repertoire known from IDEs for programming
  39.282    languages: colors, icons, highlighting, squiggly underlines, tooltips,
  39.283    hyperlinks etc. For outer syntax of Isabelle/Isar there is some traditional
  39.284 -  syntax-highlighting via static keyword tables and tokenization within the
  39.285 -  editor. In contrast, the painting of inner syntax (term language etc.)\ uses
  39.286 -  semantic information that is reported dynamically from the logical context.
  39.287 -  Thus the prover can provide additional markup to help the user to understand
  39.288 -  the meaning of formal text, and to produce more text with some add-on tools
  39.289 -  (e.g.\ information messages with \emph{sendback} markup by automated provers
  39.290 -  or disprovers in the background).
  39.291 +  syntax-highlighting via static keywords and tokenization within the editor;
  39.292 +  this buffer syntax is determined from theory imports. In contrast, the
  39.293 +  painting of inner syntax (term language etc.)\ uses semantic information
  39.294 +  that is reported dynamically from the logical context. Thus the prover can
  39.295 +  provide additional markup to help the user to understand the meaning of
  39.296 +  formal text, and to produce more text with some add-on tools (e.g.\
  39.297 +  information messages with \emph{sendback} markup by automated provers or
  39.298 +  disprovers in the background).
  39.299  
  39.300  \<close>
  39.301  
  39.302 @@ -763,7 +838,7 @@
  39.303    document-model on demand, the first time when opened explicitly in the
  39.304    editor. There are further tricks to manage markup of ML files, such that
  39.305    Isabelle/HOL may be edited conveniently in the Prover IDE on small machines
  39.306 -  with only 4--8\,GB of main memory. Using @{verbatim Pure} as logic session
  39.307 +  with only 8\,GB of main memory. Using @{verbatim Pure} as logic session
  39.308    image, the exploration may start at the top @{file
  39.309    "$ISABELLE_HOME/src/HOL/Main.thy"} or the bottom @{file
  39.310    "$ISABELLE_HOME/src/HOL/HOL.thy"}, for example.
  39.311 @@ -1017,7 +1092,7 @@
  39.312    subject to formal document processing of the editor session and thus
  39.313    prevents further exploration: the chain of hyperlinks may end in
  39.314    some source file of the underlying logic image, or within the
  39.315 -  Isabelle/ML bootstrap sources of Isabelle/Pure.\<close>
  39.316 +  ML bootstrap sources of Isabelle/Pure.\<close>
  39.317  
  39.318  
  39.319  section \<open>Completion \label{sec:completion}\<close>
  39.320 @@ -1092,7 +1167,7 @@
  39.321  text \<open>
  39.322    Syntax completion tables are determined statically from the keywords of the
  39.323    ``outer syntax'' of the underlying edit mode: for theory files this is the
  39.324 -  syntax of Isar commands.
  39.325 +  syntax of Isar commands according to the cumulative theory imports.
  39.326  
  39.327    Keywords are usually plain words, which means the completion mechanism only
  39.328    inserts them directly into the text for explicit completion
  39.329 @@ -1381,7 +1456,7 @@
  39.330    \begin{itemize}
  39.331  
  39.332    \item @{system_option_def completion_limit} specifies the maximum number of
  39.333 -  name-space entries exposed in semantic completion by the prover.
  39.334 +  items for various semantic completion operations (name-space entries etc.)
  39.335  
  39.336    \item @{system_option_def jedit_completion} guards implicit completion via
  39.337    regular jEdit key events (\secref{sec:completion-input}): it allows to
  39.338 @@ -1567,6 +1642,76 @@
  39.339    nonetheless, say to remove earlier proof attempts.\<close>
  39.340  
  39.341  
  39.342 +chapter \<open>Isabelle document preparation\<close>
  39.343 +
  39.344 +text \<open>The ultimate purpose of Isabelle is to produce nicely rendered documents
  39.345 +  with the Isabelle document preparation system, which is based on {\LaTeX};
  39.346 +  see also @{cite "isabelle-system" and "isabelle-isar-ref"}. Isabelle/jEdit
  39.347 +  provides some additional support for document editing.\<close>
  39.348 +
  39.349 +
  39.350 +section \<open>Document outline\<close>
  39.351 +
  39.352 +text \<open>Theory sources may contain document markup commands, such as
  39.353 +  @{command_ref chapter}, @{command_ref section}, @{command subsection}. The
  39.354 +  Isabelle SideKick parser (\secref{sec:sidekick}) represents this document
  39.355 +  outline as structured tree view, with formal statements and proofs nested
  39.356 +  inside; see \figref{fig:sidekick-document}.
  39.357 +
  39.358 +  \begin{figure}[htb]
  39.359 +  \begin{center}
  39.360 +  \includegraphics[scale=0.333]{sidekick-document}
  39.361 +  \end{center}
  39.362 +  \caption{Isabelle document outline via SideKick tree view}
  39.363 +  \label{fig:sidekick-document}
  39.364 +  \end{figure}
  39.365 +
  39.366 +  It is also possible to use text folding according to this structure, by
  39.367 +  adjusting \emph{Utilities / Buffer Options / Folding mode} of jEdit. The
  39.368 +  default mode @{verbatim isabelle} uses the structure of formal definitions,
  39.369 +  statements, and proofs. The alternative mode @{verbatim sidekick} uses the
  39.370 +  document structure of the SideKick parser, as explained above.\<close>
  39.371 +
  39.372 +
  39.373 +section \<open>Citations and Bib{\TeX} entries\<close>
  39.374 +
  39.375 +text \<open>Citations are managed by {\LaTeX} and Bib{\TeX} in @{verbatim ".bib"}
  39.376 +  files. The Isabelle session build process and the @{tool latex} tool @{cite
  39.377 +  "isabelle-system"} are smart enough to assemble the result, based on the
  39.378 +  session directory layout.
  39.379 +
  39.380 +  The document antiquotation @{text "@{cite}"} is described in @{cite
  39.381 +  "isabelle-isar-ref"}. Within the Prover IDE it provides semantic markup for
  39.382 +  tooltips, hyperlinks, and completion for Bib{\TeX} database entries.
  39.383 +  Isabelle/jEdit does \emph{not} know about the actual Bib{\TeX} environment
  39.384 +  used in {\LaTeX} batch-mode, but it can take citations from those @{verbatim
  39.385 +  ".bib"} files that happen to be open in the editor; see
  39.386 +  \figref{fig:cite-completion}.
  39.387 +
  39.388 +  \begin{figure}[htb]
  39.389 +  \begin{center}
  39.390 +  \includegraphics[scale=0.333]{cite-completion}
  39.391 +  \end{center}
  39.392 +  \caption{Semantic completion of citations from open Bib{\TeX} files}
  39.393 +  \label{fig:cite-completion}
  39.394 +  \end{figure}
  39.395 +
  39.396 +  Isabelle/jEdit also provides some support for editing @{verbatim ".bib"}
  39.397 +  files themselves. There is syntax highlighting based on entry types
  39.398 +  (according to standard Bib{\TeX} styles), a context-menu to compose entries
  39.399 +  systematically, and a SideKick tree view of the overall content; see
  39.400 +  \figref{fig:bibtex-mode}.
  39.401 +
  39.402 +  \begin{figure}[htb]
  39.403 +  \begin{center}
  39.404 +  \includegraphics[scale=0.333]{bibtex-mode}
  39.405 +  \end{center}
  39.406 +  \caption{Bib{\TeX} mode with context menu and SideKick tree view}
  39.407 +  \label{fig:bibtex-mode}
  39.408 +  \end{figure}
  39.409 +\<close>
  39.410 +
  39.411 +
  39.412  chapter \<open>Miscellaneous tools\<close>
  39.413  
  39.414  section \<open>Timing\<close>
  39.415 @@ -1618,7 +1763,7 @@
  39.416    \begin{itemize}
  39.417  
  39.418    \item \emph{Protocol} shows internal messages between the
  39.419 -  Isabelle/Scala and Isabelle/ML side of the PIDE editing protocol.
  39.420 +  Isabelle/Scala and Isabelle/ML side of the PIDE document editing protocol.
  39.421    Recording of messages starts with the first activation of the
  39.422    corresponding dockable window; earlier messages are lost.
  39.423  
  39.424 @@ -1640,11 +1785,14 @@
  39.425    Under normal circumstances, prover output always works via managed message
  39.426    channels (corresponding to @{ML writeln}, @{ML warning}, @{ML
  39.427    Output.error_message} in Isabelle/ML), which are displayed by regular means
  39.428 -  within the document model (\secref{sec:output}).
  39.429 +  within the document model (\secref{sec:output}). Unhandled Isabelle/ML
  39.430 +  exceptions are printed by the system via @{ML Output.error_message}.
  39.431  
  39.432 -  \item \emph{Syslog} shows system messages that might be relevant to
  39.433 -  diagnose problems with the startup or shutdown phase of the prover
  39.434 -  process; this also includes raw output on @{verbatim stderr}.
  39.435 +  \item \emph{Syslog} shows system messages that might be relevant to diagnose
  39.436 +  problems with the startup or shutdown phase of the prover process; this also
  39.437 +  includes raw output on @{verbatim stderr}. Isabelle/ML also provides an
  39.438 +  explicit @{ML Output.system_message} operation, which is occasionally useful
  39.439 +  for diagnostic purposes within the system infrastructure itself.
  39.440  
  39.441    A limited amount of syslog messages are buffered, independently of
  39.442    the docking state of the \emph{Syslog} panel.  This allows to
  39.443 @@ -1711,12 +1859,18 @@
  39.444  
  39.445    \textbf{Workaround:} Use a regular re-parenting X11 window manager.
  39.446  
  39.447 -  \item \textbf{Problem:} Recent forks of Linux/X11 window managers
  39.448 -  and desktop environments (variants of Gnome) disrupt the handling of
  39.449 -  menu popups and mouse positions of Java/AWT/Swing.
  39.450 +  \item \textbf{Problem:} Various forks of Linux/X11 window managers and
  39.451 +  desktop environments (like Gnome) disrupt the handling of menu popups and
  39.452 +  mouse positions of Java/AWT/Swing.
  39.453  
  39.454    \textbf{Workaround:} Use mainstream versions of Linux desktops.
  39.455  
  39.456 +  \item \textbf{Problem:} Native Windows look-and-feel with global font
  39.457 +  scaling leads to bad GUI rendering of various tree views.
  39.458 +
  39.459 +  \textbf{Workaround:} Use \emph{Metal} look-and-feel and re-adjust its
  39.460 +  primary and secondary font as explained in \secref{sec:hdpi}.
  39.461 +
  39.462    \item \textbf{Problem:} Full-screen mode via jEdit action @{action_ref
  39.463    "toggle-full-screen"} (default keyboard shortcut @{verbatim F11}) works on
  39.464    Windows, but not on Mac OS X or various Linux/X11 window managers.
    40.1 Binary file src/Doc/JEdit/document/auto-tools.png has changed
    41.1 Binary file src/Doc/JEdit/document/bibtex-mode.png has changed
    42.1 Binary file src/Doc/JEdit/document/cite-completion.png has changed
    43.1 Binary file src/Doc/JEdit/document/isabelle-jedit-hdpi.png has changed
    44.1 Binary file src/Doc/JEdit/document/isabelle-jedit.png has changed
    45.1 Binary file src/Doc/JEdit/document/output.png has changed
    46.1 Binary file src/Doc/JEdit/document/popup1.png has changed
    47.1 Binary file src/Doc/JEdit/document/popup2.png has changed
    48.1 Binary file src/Doc/JEdit/document/query.png has changed
    49.1 Binary file src/Doc/JEdit/document/sidekick-document.png has changed
    50.1 Binary file src/Doc/JEdit/document/sidekick.png has changed
    51.1 Binary file src/Doc/JEdit/document/sledgehammer.png has changed
    52.1 Binary file src/Doc/JEdit/document/theories.png has changed
    53.1 --- a/src/Doc/Nitpick/document/root.tex	Sat May 23 22:13:24 2015 +0200
    53.2 +++ b/src/Doc/Nitpick/document/root.tex	Mon May 25 22:11:43 2015 +0200
    53.3 @@ -27,7 +27,8 @@
    53.4  \def\lparr{\mathopen{(\mkern-4mu\mid}}
    53.5  \def\rparr{\mathclose{\mid\mkern-4mu)}}
    53.6  
    53.7 -\def\unk{{?}}
    53.8 +%\def\unk{{?}}
    53.9 +\def\unk{{\_}}
   53.10  \def\unkef{(\lambda x.\; \unk)}
   53.11  \def\undef{(\lambda x.\; \_)}
   53.12  %\def\unr{\textit{others}}
   53.13 @@ -931,7 +932,7 @@
   53.14  \hbox{}\qquad Free variable: \nopagebreak \\
   53.15  \hbox{}\qquad\qquad $n = 1$ \\
   53.16  \hbox{}\qquad Constants: \nopagebreak \\
   53.17 -\hbox{}\qquad\qquad $\textit{even} = (λx. ?)(0 := True, 1 := False, 2 := True, 3 := False)$ \\
   53.18 +\hbox{}\qquad\qquad $\textit{even} = \unkef(0 := True, 1 := False, 2 := True, 3 := False)$ \\
   53.19  \hbox{}\qquad\qquad $\textit{odd}_{\textsl{base}} = {}$ \\
   53.20  \hbox{}\qquad\qquad\quad $\unkef(0 := \textit{False},\, 1 := \textit{True},\, 2 := \textit{False},\, 3 := \textit{False})$ \\
   53.21  \hbox{}\qquad\qquad $\textit{odd}_{\textsl{step}} = \unkef$\\
    54.1 --- a/src/Doc/ROOT	Sat May 23 22:13:24 2015 +0200
    54.2 +++ b/src/Doc/ROOT	Mon May 25 22:11:43 2015 +0200
    54.3 @@ -59,6 +59,28 @@
    54.4      "root.tex"
    54.5      "style.sty"
    54.6  
    54.7 +session Eisbach (doc) in "Eisbach" = "HOL-Eisbach" +
    54.8 +  options [document_variants = "eisbach", quick_and_dirty,
    54.9 +    print_mode = "no_brackets,iff", show_question_marks = false]
   54.10 +  theories [document = false]
   54.11 +    Base
   54.12 +  theories
   54.13 +    Preface
   54.14 +    Manual
   54.15 +  document_files (in "..")
   54.16 +    "prepare_document"
   54.17 +    "pdfsetup.sty"
   54.18 +    "iman.sty"
   54.19 +    "extra.sty"
   54.20 +    "isar.sty"
   54.21 +    "ttbox.sty"
   54.22 +    "underscore.sty"
   54.23 +    "manual.bib"
   54.24 +  document_files
   54.25 +    "build"
   54.26 +    "root.tex"
   54.27 +    "style.sty"
   54.28 +
   54.29  session Functions (doc) in "Functions" = HOL +
   54.30    options [document_variants = "functions", skip_proofs = false, quick_and_dirty]
   54.31    theories Functions
   54.32 @@ -183,14 +205,18 @@
   54.33      "style.sty"
   54.34    document_files
   54.35      "auto-tools.png"
   54.36 +    "bibtex-mode.png"
   54.37      "build"
   54.38 +    "cite-completion.png"
   54.39      "isabelle-jedit.png"
   54.40 +    "isabelle-jedit-hdpi.png"
   54.41      "output.png"
   54.42      "query.png"
   54.43      "popup1.png"
   54.44      "popup2.png"
   54.45      "root.tex"
   54.46      "sidekick.png"
   54.47 +    "sidekick-document.png"
   54.48      "sledgehammer.png"
   54.49      "theories.png"
   54.50  
    55.1 --- a/src/Doc/Tutorial/Documents/Documents.thy	Sat May 23 22:13:24 2015 +0200
    55.2 +++ b/src/Doc/Tutorial/Documents/Documents.thy	Mon May 25 22:11:43 2015 +0200
    55.3 @@ -345,7 +345,7 @@
    55.4    setup) and \texttt{isabelle build} (to run sessions as specified in
    55.5    the corresponding \texttt{ROOT} file).  These Isabelle tools are
    55.6    described in further detail in the \emph{Isabelle System Manual}
    55.7 -  @{cite "isabelle-sys"}.
    55.8 +  @{cite "isabelle-system"}.
    55.9  
   55.10    For example, a new session \texttt{MySession} (with document
   55.11    preparation) may be produced as follows:
   55.12 @@ -406,7 +406,7 @@
   55.13    \texttt{MySession/document} directory as well.  In particular,
   55.14    adding a file named \texttt{root.bib} causes an automatic run of
   55.15    \texttt{bibtex} to process a bibliographic database; see also
   55.16 -  \texttt{isabelle document} @{cite "isabelle-sys"}.
   55.17 +  \texttt{isabelle document} @{cite "isabelle-system"}.
   55.18  
   55.19    \medskip Any failure of the document preparation phase in an
   55.20    Isabelle batch session leaves the generated sources in their target
   55.21 @@ -694,7 +694,7 @@
   55.22    preparation system allows the user to specify how to interpret a
   55.23    tagged region, in order to keep, drop, or fold the corresponding
   55.24    parts of the document.  See the \emph{Isabelle System Manual}
   55.25 -  @{cite "isabelle-sys"} for further details, especially on
   55.26 +  @{cite "isabelle-system"} for further details, especially on
   55.27    \texttt{isabelle build} and \texttt{isabelle document}.
   55.28  
   55.29    Ignored material is specified by delimiting the original formal
    56.1 --- a/src/Doc/manual.bib	Sat May 23 22:13:24 2015 +0200
    56.2 +++ b/src/Doc/manual.bib	Mon May 25 22:11:43 2015 +0200
    56.3 @@ -1834,8 +1834,8 @@
    56.4    title = "{SPASS} Version 3.5",
    56.5    note = {\url{http://www.spass-prover.org/publications/spass.pdf}}}
    56.6  
    56.7 -@manual{isabelle-sys,
    56.8 -  author	= {Markus Wenzel and Stefan Berghofer},
    56.9 +@manual{isabelle-system,
   56.10 +  author	= {Makarius Wenzel and Stefan Berghofer},
   56.11    title		= {The {Isabelle} System Manual},
   56.12    institution	= {TU Munich},
   56.13    note          = {\url{http://isabelle.in.tum.de/doc/system.pdf}}}
   56.14 @@ -1965,7 +1965,7 @@
   56.15  @inproceedings{Wenzel:2013:ITP,
   56.16    author    = {Makarius Wenzel},
   56.17    title     = {Shared-Memory Multiprocessing for Interactive Theorem Proving},
   56.18 -  booktitle = {Interactive Theorem Proving - 4th International Conference,
   56.19 +  booktitle = {Interactive Theorem Proving --- 4th International Conference,
   56.20                 ITP 2013, Rennes, France, July 22-26, 2013. Proceedings},
   56.21    editor    = {Sandrine Blazy and
   56.22                 Christine Paulin-Mohring and
   56.23 @@ -1997,7 +1997,7 @@
   56.24    year = 2014,
   56.25    series = {EPTCS},
   56.26    month = {July},
   56.27 -  note = {To appear, \url{http://eptcs.web.cse.unsw.edu.au/paper.cgi?UITP2014:11}}
   56.28 +  note = {\url{http://eptcs.web.cse.unsw.edu.au/paper.cgi?UITP2014:11}}
   56.29  }
   56.30  
   56.31  @book{principia,
    57.1 --- a/src/HOL/Binomial.thy	Sat May 23 22:13:24 2015 +0200
    57.2 +++ b/src/HOL/Binomial.thy	Mon May 25 22:11:43 2015 +0200
    57.3 @@ -39,7 +39,7 @@
    57.4    by (induct n) (auto simp: le_Suc_eq)
    57.5  
    57.6  context
    57.7 -  fixes XXX :: "'a :: {semiring_char_0,linordered_semidom,semiring_no_zero_divisors}"
    57.8 +  assumes "SORT_CONSTRAINT('a::linordered_semidom)"
    57.9  begin
   57.10    
   57.11    lemma fact_mono: "m \<le> n \<Longrightarrow> fact m \<le> (fact n :: 'a)"
   57.12 @@ -79,8 +79,7 @@
   57.13    by (induct n) (auto simp: less_Suc_eq)
   57.14  
   57.15  lemma fact_less_mono:
   57.16 -  fixes XXX :: "'a :: {semiring_char_0,linordered_semidom,semiring_no_zero_divisors}"
   57.17 -  shows "\<lbrakk>0 < m; m < n\<rbrakk> \<Longrightarrow> fact m < (fact n :: 'a)"
   57.18 +  "\<lbrakk>0 < m; m < n\<rbrakk> \<Longrightarrow> fact m < (fact n :: 'a::linordered_semidom)"
   57.19    by (metis of_nat_fact of_nat_less_iff fact_less_mono_nat)
   57.20  
   57.21  lemma fact_ge_Suc_0_nat [simp]: "fact n \<ge> Suc 0"
    58.1 --- a/src/HOL/Cardinals/Bounded_Set.thy	Sat May 23 22:13:24 2015 +0200
    58.2 +++ b/src/HOL/Cardinals/Bounded_Set.thy	Mon May 25 22:11:43 2015 +0200
    58.3 @@ -1,4 +1,4 @@
    58.4 -(*  Title:      HOL/Cardinals/Boundes_Set.thy
    58.5 +(*  Title:      HOL/Cardinals/Bounded_Set.thy
    58.6      Author:     Dmitriy Traytel, TU Muenchen
    58.7      Copyright   2015
    58.8  
    59.1 --- a/src/HOL/Eisbach/Eisbach.thy	Sat May 23 22:13:24 2015 +0200
    59.2 +++ b/src/HOL/Eisbach/Eisbach.thy	Mon May 25 22:11:43 2015 +0200
    59.3 @@ -1,15 +1,15 @@
    59.4 -(*  Title:      Eisbach.thy
    59.5 +(*  Title:      HOL/Eisbach/Eisbach.thy
    59.6      Author:     Daniel Matichuk, NICTA/UNSW
    59.7  
    59.8  Main entry point for Eisbach proof method language.
    59.9  *)
   59.10  
   59.11  theory Eisbach
   59.12 -imports Pure
   59.13 +imports Main
   59.14  keywords
   59.15    "method" :: thy_decl and
   59.16 -  "concl"
   59.17 -  "prems"  (* FIXME conflict with "prems" in Isar, which is presently dormant *)
   59.18 +  "conclusion"
   59.19 +  "premises"
   59.20    "declares"
   59.21    "methods"
   59.22    "\<bar>" "\<Rightarrow>"
   59.23 @@ -17,27 +17,19 @@
   59.24  begin
   59.25  
   59.26  ML_file "parse_tools.ML"
   59.27 +ML_file "method_closure.ML"
   59.28  ML_file "eisbach_rule_insts.ML"
   59.29 -ML_file "method_closure.ML"
   59.30  ML_file "match_method.ML"
   59.31  ML_file "eisbach_antiquotations.ML"
   59.32  
   59.33  (* FIXME reform Isabelle/Pure attributes to make this work by default *)
   59.34 -attribute_setup THEN =
   59.35 -  \<open>Scan.lift (Scan.optional (Args.bracks Parse.nat) 1) -- Attrib.thm >> (fn (i, B) =>
   59.36 -    Method_Closure.free_aware_rule_attribute [B] (fn _ => fn A => A RSN (i, B)))\<close>
   59.37 -  "resolution with rule"
   59.38 +setup \<open>
   59.39 +  fold (Method_Closure.wrap_attribute {handle_all_errs = true, declaration = true})
   59.40 +    [@{binding intro}, @{binding elim}, @{binding dest}, @{binding simp}] #>
   59.41 +  fold (Method_Closure.wrap_attribute {handle_all_errs = false, declaration = false})
   59.42 +    [@{binding THEN}, @{binding OF}, @{binding rotated}, @{binding simplified}]
   59.43 +\<close>
   59.44  
   59.45 -attribute_setup OF =
   59.46 -  \<open>Attrib.thms >> (fn Bs =>
   59.47 -    Method_Closure.free_aware_rule_attribute Bs (fn _ => fn A => A OF Bs))\<close>
   59.48 -  "rule resolved with facts"
   59.49 -
   59.50 -attribute_setup rotated =
   59.51 -  \<open>Scan.lift (Scan.optional Parse.int 1 >> (fn n =>
   59.52 -    Method_Closure.free_aware_rule_attribute [] (fn _ => rotate_prems n)))\<close>
   59.53 -  "rotated theorem premises"
   59.54 -
   59.55 -method solves methods m = \<open>m; fail\<close>
   59.56 +method solves methods m = (m; fail)
   59.57  
   59.58  end
    60.1 --- a/src/HOL/Eisbach/Eisbach_Tools.thy	Sat May 23 22:13:24 2015 +0200
    60.2 +++ b/src/HOL/Eisbach/Eisbach_Tools.thy	Mon May 25 22:11:43 2015 +0200
    60.3 @@ -1,4 +1,4 @@
    60.4 -(*  Title:      Eisbach_Tools.thy
    60.5 +(*  Title:      HOL/Eisbach/Eisbach_Tools.thy
    60.6      Author:     Daniel Matichuk, NICTA/UNSW
    60.7  
    60.8  Usability tools for Eisbach.
    60.9 @@ -35,9 +35,47 @@
   60.10        (Scan.lift (Scan.ahead Parse.not_eof) -- Args.term)
   60.11        (fn ctxt => fn (tok, t) =>
   60.12          (* FIXME proper formatting!? *)
   60.13 -        Token.unparse tok ^ ": " ^ Syntax.string_of_term ctxt t));
   60.14 +        Token.unparse tok ^ ": " ^ Syntax.string_of_term ctxt t) #>
   60.15 +    setup_trace_method @{binding print_type}
   60.16 +      (Scan.lift (Scan.ahead Parse.not_eof) -- Args.typ)
   60.17 +      (fn ctxt => fn (tok, t) =>
   60.18 +        (* FIXME proper formatting!? *)
   60.19 +        Token.unparse tok ^ ": " ^ Syntax.string_of_typ ctxt t));
   60.20  
   60.21  end
   60.22  \<close>
   60.23  
   60.24 +ML \<open>
   60.25 +  fun try_map v seq =
   60.26 +    (case try Seq.pull seq of
   60.27 +      SOME (SOME (x, seq')) => Seq.make (fn () => SOME(x, try_map v seq'))
   60.28 +    | SOME NONE => Seq.empty
   60.29 +    | NONE => v);
   60.30 +\<close>
   60.31 +
   60.32 +method_setup catch = \<open>
   60.33 +  Method_Closure.parse_method -- Method_Closure.parse_method >>
   60.34 +    (fn (text, text') => fn ctxt => fn using => fn st =>
   60.35 +      let
   60.36 +        val method = Method_Closure.method_evaluate text ctxt using;
   60.37 +        val backup_results = Method_Closure.method_evaluate text' ctxt using st;
   60.38 +      in
   60.39 +        (case try method st of
   60.40 +          SOME seq => try_map backup_results seq
   60.41 +        | NONE => backup_results)
   60.42 +      end)
   60.43 +\<close>
   60.44 +
   60.45 +ML \<open>
   60.46 +  fun uncurry_rule thm = Conjunction.uncurry_balanced (Thm.nprems_of thm) thm;
   60.47 +  fun curry_rule thm =
   60.48 +    if Thm.no_prems thm then thm
   60.49 +    else
   60.50 +      let val conjs = Logic.dest_conjunctions (Thm.major_prem_of thm);
   60.51 +      in Conjunction.curry_balanced (length conjs) thm end;
   60.52 +\<close>
   60.53 +
   60.54 +attribute_setup uncurry = \<open>Scan.succeed (Thm.rule_attribute (K uncurry_rule))\<close>
   60.55 +attribute_setup curry = \<open>Scan.succeed (Thm.rule_attribute (K curry_rule))\<close>
   60.56 +
   60.57  end
    61.1 --- a/src/HOL/Eisbach/Examples.thy	Sat May 23 22:13:24 2015 +0200
    61.2 +++ b/src/HOL/Eisbach/Examples.thy	Mon May 25 22:11:43 2015 +0200
    61.3 @@ -1,4 +1,4 @@
    61.4 -(*  Title:      Examples.thy
    61.5 +(*  Title:      HOL/Eisbach/Examples.thy
    61.6      Author:     Daniel Matichuk, NICTA/UNSW
    61.7  *)
    61.8  
    61.9 @@ -11,19 +11,19 @@
   61.10  
   61.11  subsection \<open>Basic methods\<close>
   61.12  
   61.13 -method my_intros = \<open>rule conjI | rule impI\<close>
   61.14 +method my_intros = (rule conjI | rule impI)
   61.15  
   61.16  lemma "P \<and> Q \<longrightarrow> Z \<and> X"
   61.17    apply my_intros+
   61.18    oops
   61.19  
   61.20 -method my_intros' uses intros = \<open>rule conjI | rule impI | rule intros\<close>
   61.21 +method my_intros' uses intros = (rule conjI | rule impI | rule intros)
   61.22  
   61.23  lemma "P \<and> Q \<longrightarrow> Z \<or> X"
   61.24    apply (my_intros' intros: disjI1)+
   61.25    oops
   61.26  
   61.27 -method my_spec for x :: 'a = \<open>drule spec[where x="x"]\<close>
   61.28 +method my_spec for x :: 'a = (drule spec[where x="x"])
   61.29  
   61.30  lemma "\<forall>x. P x \<Longrightarrow> P x"
   61.31    apply (my_spec x)
   61.32 @@ -34,11 +34,11 @@
   61.33  subsection \<open>Focusing and matching\<close>
   61.34  
   61.35  method match_test =
   61.36 -  \<open>match prems in U: "P x \<and> Q x" for P Q x \<Rightarrow>
   61.37 +  (match premises in U: "P x \<and> Q x" for P Q x \<Rightarrow>
   61.38      \<open>print_term P,
   61.39       print_term Q,
   61.40       print_term x,
   61.41 -     print_fact U\<close>\<close>
   61.42 +     print_fact U\<close>)
   61.43  
   61.44  lemma "\<And>x. P x \<and> Q x \<Longrightarrow> A x \<and> B x \<Longrightarrow> R x y \<Longrightarrow> True"
   61.45    apply match_test  -- \<open>Valid match, but not quite what we were expecting..\<close>
   61.46 @@ -51,8 +51,6 @@
   61.47    back
   61.48    back
   61.49    back
   61.50 -  back
   61.51 -  back
   61.52    oops
   61.53  
   61.54  text \<open>Use matching to avoid "improper" methods\<close>
   61.55 @@ -60,18 +58,17 @@
   61.56  lemma focus_test:
   61.57    shows "\<And>x. \<forall>x. P x \<Longrightarrow> P x"
   61.58    apply (my_spec "x :: 'a", assumption)?  -- \<open>Wrong x\<close>
   61.59 -  apply (match concl in "P x" for x \<Rightarrow> \<open>my_spec x, assumption\<close>)
   61.60 +  apply (match conclusion in "P x" for x \<Rightarrow> \<open>my_spec x, assumption\<close>)
   61.61    done
   61.62  
   61.63  
   61.64  text \<open>Matches are exclusive. Backtracking will not occur past a match\<close>
   61.65  
   61.66  method match_test' =
   61.67 -  \<open>match concl in
   61.68 +  (match conclusion in
   61.69      "P \<and> Q" for P Q \<Rightarrow>
   61.70        \<open>print_term P, print_term Q, rule conjI[where P="P" and Q="Q"]; assumption\<close>
   61.71 -    \<bar> "H" for H \<Rightarrow> \<open>print_term H\<close>
   61.72 -  \<close>
   61.73 +    \<bar> "H" for H \<Rightarrow> \<open>print_term H\<close>)
   61.74  
   61.75  text \<open>Solves goal\<close>
   61.76  lemma "P \<Longrightarrow> Q \<Longrightarrow> P \<and> Q"
   61.77 @@ -89,20 +86,20 @@
   61.78  
   61.79  
   61.80  method my_spec_guess =
   61.81 -  \<open>match concl in "P (x :: 'a)" for P x \<Rightarrow>
   61.82 +  (match conclusion in "P (x :: 'a)" for P x \<Rightarrow>
   61.83      \<open>drule spec[where x=x],
   61.84       print_term P,
   61.85 -     print_term x\<close>\<close>
   61.86 +     print_term x\<close>)
   61.87  
   61.88  lemma "\<forall>x. P (x :: nat) \<Longrightarrow> Q (x :: nat)"
   61.89    apply my_spec_guess
   61.90    oops
   61.91  
   61.92  method my_spec_guess2 =
   61.93 -  \<open>match prems in U[thin]:"\<forall>x. P x \<longrightarrow> Q x" and U':"P x" for P Q x \<Rightarrow>
   61.94 +  (match premises in U[thin]:"\<forall>x. P x \<longrightarrow> Q x" and U':"P x" for P Q x \<Rightarrow>
   61.95      \<open>insert spec[where x=x, OF U],
   61.96       print_term P,
   61.97 -     print_term Q\<close>\<close>
   61.98 +     print_term Q\<close>)
   61.99  
  61.100  lemma "\<forall>x. P x \<longrightarrow> Q x \<Longrightarrow> Q x \<Longrightarrow> Q x"
  61.101    apply my_spec_guess2?  -- \<open>Fails. Note that both "P"s must match\<close>
  61.102 @@ -118,7 +115,7 @@
  61.103  subsection \<open>Higher-order methods\<close>
  61.104  
  61.105  method higher_order_example for x methods meth =
  61.106 -  \<open>cases x, meth, meth\<close>
  61.107 +  (cases x, meth, meth)
  61.108  
  61.109  lemma
  61.110    assumes A: "x = Some a"
  61.111 @@ -129,12 +126,12 @@
  61.112  subsection \<open>Recursion\<close>
  61.113  
  61.114  method recursion_example for x :: bool =
  61.115 -  \<open>print_term x,
  61.116 +  (print_term x,
  61.117       match (x) in "A \<and> B" for A B \<Rightarrow>
  61.118 -    \<open>(print_term A,
  61.119 +    \<open>print_term A,
  61.120       print_term B,
  61.121       recursion_example A,
  61.122 -     recursion_example B) | -\<close>\<close>
  61.123 +     recursion_example B | -\<close>)
  61.124  
  61.125  lemma "P"
  61.126    apply (recursion_example "(A \<and> D) \<and> (B \<and> C)")
  61.127 @@ -151,15 +148,13 @@
  61.128  
  61.129  subsection \<open>Demo\<close>
  61.130  
  61.131 -method solve methods m = \<open>m;fail\<close>
  61.132 -
  61.133  named_theorems intros and elims and subst
  61.134  
  61.135  method prop_solver declares intros elims subst =
  61.136 -  \<open>(assumption |
  61.137 +  (assumption |
  61.138      rule intros | erule elims |
  61.139      subst subst | subst (asm) subst |
  61.140 -    (erule notE; solve \<open>prop_solver\<close>))+\<close>
  61.141 +    (erule notE; solves \<open>prop_solver\<close>))+
  61.142  
  61.143  lemmas [intros] =
  61.144    conjI
  61.145 @@ -177,11 +172,11 @@
  61.146    done
  61.147  
  61.148  method guess_all =
  61.149 -  \<open>match prems in U[thin]:"\<forall>x. P (x :: 'a)" for P \<Rightarrow>
  61.150 -    \<open>match prems in "?H (y :: 'a)" for y \<Rightarrow>
  61.151 +  (match premises in U[thin]:"\<forall>x. P (x :: 'a)" for P \<Rightarrow>
  61.152 +    \<open>match premises in "?H (y :: 'a)" for y \<Rightarrow>
  61.153         \<open>rule allE[where P = P and x = y, OF U]\<close>
  61.154 -   | match concl in "?H (y :: 'a)" for y \<Rightarrow>
  61.155 -       \<open>rule allE[where P = P and x = y, OF U]\<close>\<close>\<close>
  61.156 +   | match conclusion in "?H (y :: 'a)" for y \<Rightarrow>
  61.157 +       \<open>rule allE[where P = P and x = y, OF U]\<close>\<close>)
  61.158  
  61.159  lemma "(\<forall>x. P x \<longrightarrow> Q x) \<Longrightarrow> P y \<Longrightarrow> Q y"
  61.160    apply guess_all
  61.161 @@ -189,14 +184,14 @@
  61.162    done
  61.163  
  61.164  lemma "(\<forall>x. P x \<longrightarrow> Q x) \<Longrightarrow>  P z \<Longrightarrow> P y \<Longrightarrow> Q y"
  61.165 -  apply (solve \<open>guess_all, prop_solver\<close>)  -- \<open>Try it without solve\<close>
  61.166 +  apply (solves \<open>guess_all, prop_solver\<close>)  -- \<open>Try it without solve\<close>
  61.167    done
  61.168  
  61.169  method guess_ex =
  61.170 -  \<open>match concl in
  61.171 +  (match conclusion in
  61.172      "\<exists>x. P (x :: 'a)" for P \<Rightarrow>
  61.173 -      \<open>match prems in "?H (x :: 'a)" for x \<Rightarrow>
  61.174 -              \<open>rule exI[where x=x]\<close>\<close>\<close>
  61.175 +      \<open>match premises in "?H (x :: 'a)" for x \<Rightarrow>
  61.176 +              \<open>rule exI[where x=x]\<close>\<close>)
  61.177  
  61.178  lemma "P x \<Longrightarrow> \<exists>x. P x"
  61.179    apply guess_ex
  61.180 @@ -204,7 +199,7 @@
  61.181    done
  61.182  
  61.183  method fol_solver =
  61.184 -  \<open>(guess_ex | guess_all | prop_solver) ; solve \<open>fol_solver\<close>\<close>
  61.185 +  ((guess_ex | guess_all | prop_solver) ; solves \<open>fol_solver\<close>)
  61.186  
  61.187  declare
  61.188    allI [intros]
  61.189 @@ -217,4 +212,36 @@
  61.190    and "(\<exists>x. \<forall>y. R x y) \<longrightarrow> (\<forall>y. \<exists>x. R x y)"
  61.191    by fol_solver+
  61.192  
  61.193 +
  61.194 +text \<open>
  61.195 +  Eisbach_Tools provides the catch method, which catches run-time method
  61.196 +  errors. In this example the OF attribute throws an error when it can't
  61.197 +  compose H with A, forcing H to be re-bound to different members of imps
  61.198 +  until it succeeds.
  61.199 +\<close>
  61.200 +
  61.201 +lemma
  61.202 +  assumes imps:  "A \<Longrightarrow> B" "A \<Longrightarrow> C" "B \<Longrightarrow> D"
  61.203 +  assumes A: "A"
  61.204 +  shows "B \<and> C"
  61.205 +  apply (rule conjI)
  61.206 +  apply ((match imps in H:"_ \<Longrightarrow> _" \<Rightarrow> \<open>catch \<open>rule H[OF A], print_fact H\<close> \<open>print_fact H, fail\<close>\<close>)+)
  61.207 +  done
  61.208 +
  61.209 +text \<open>
  61.210 +  Eisbach_Tools provides the curry and uncurry attributes. This is useful
  61.211 +  when the number of premises of a thm isn't known statically. The pattern
  61.212 +  @{term "P \<Longrightarrow> Q"} matches P against the major premise of a thm, and Q is the
  61.213 +  rest of the premises with the conclusion. If we first uncurry, then @{term
  61.214 +  "P \<Longrightarrow> Q"} will match P with the conjunction of all the premises, and Q with
  61.215 +  the final conclusion of the rule.
  61.216 +\<close>
  61.217 +
  61.218 +lemma
  61.219 +  assumes imps: "A \<Longrightarrow> B \<Longrightarrow> C" "D \<Longrightarrow> C" "E \<Longrightarrow> D \<Longrightarrow> A"
  61.220 +  shows "(A \<longrightarrow> B \<longrightarrow> C) \<and> (D \<longrightarrow> C)"
  61.221 +    by (match imps[uncurry] in H[curry]:"_ \<Longrightarrow> C" (cut, multi) \<Rightarrow>
  61.222 +                    \<open>match H in "E \<Longrightarrow> _" \<Rightarrow> \<open>fail\<close>
  61.223 +                                      \<bar> _ \<Rightarrow> \<open>simp add: H\<close>\<close>)
  61.224 +
  61.225  end
    62.1 --- a/src/HOL/Eisbach/Tests.thy	Sat May 23 22:13:24 2015 +0200
    62.2 +++ b/src/HOL/Eisbach/Tests.thy	Mon May 25 22:11:43 2015 +0200
    62.3 @@ -1,4 +1,4 @@
    62.4 -(*  Title:      Tests.thy
    62.5 +(*  Title:      HOL/Eisbach/Tests.thy
    62.6      Author:     Daniel Matichuk, NICTA/UNSW
    62.7  *)
    62.8  
    62.9 @@ -8,12 +8,12 @@
   62.10  imports Main Eisbach_Tools
   62.11  begin
   62.12  
   62.13 -section \<open>Named Theorems Tests\<close>
   62.14 +
   62.15 +subsection \<open>Named Theorems Tests\<close>
   62.16  
   62.17  named_theorems foo
   62.18  
   62.19 -method foo declares foo =
   62.20 -  \<open>rule foo\<close>
   62.21 +method foo declares foo = (rule foo)
   62.22  
   62.23  lemma
   62.24    assumes A [foo]: A
   62.25 @@ -21,8 +21,10 @@
   62.26    apply foo
   62.27    done
   62.28  
   62.29 +method abs_used for P = (match (P) in "\<lambda>a. ?Q" \<Rightarrow> \<open>fail\<close> \<bar> _ \<Rightarrow> \<open>-\<close>)
   62.30  
   62.31 -section \<open>Match Tests\<close>
   62.32 +
   62.33 +subsection \<open>Match Tests\<close>
   62.34  
   62.35  notepad
   62.36  begin
   62.37 @@ -30,12 +32,12 @@
   62.38  
   62.39    fix A y
   62.40    have "(\<And>x. A x) \<Longrightarrow> A y"
   62.41 -    apply (rule dup, match prems in Y: "\<And>B. P B" for P \<Rightarrow> \<open>match (P) in A \<Rightarrow> \<open>print_fact Y, rule Y\<close>\<close>)
   62.42 -    apply (rule dup, match prems in Y: "\<And>B :: 'a. P B" for P \<Rightarrow> \<open>match (P) in A \<Rightarrow> \<open>print_fact Y, rule Y\<close>\<close>)
   62.43 -    apply (rule dup, match prems in Y: "\<And>B :: 'a. P B" for P \<Rightarrow> \<open>match concl in "P y" for y \<Rightarrow> \<open>print_fact Y, print_term y, rule Y[where B=y]\<close>\<close>)
   62.44 -    apply (rule dup, match prems in Y: "\<And>B :: 'a. P B" for P \<Rightarrow> \<open>match concl in "P z" for z \<Rightarrow> \<open>print_fact Y, print_term y, rule Y[where B=z]\<close>\<close>)
   62.45 -    apply (rule dup, match concl in "P y" for P \<Rightarrow> \<open>match prems in Y: "\<And>z. P z" \<Rightarrow> \<open>print_fact Y, rule Y[where z=y]\<close>\<close>)
   62.46 -    apply (match prems in Y: "\<And>z :: 'a. P z" for P \<Rightarrow> \<open>match concl in "P y" \<Rightarrow> \<open>print_fact Y, rule Y[where z=y]\<close>\<close>)
   62.47 +    apply (rule dup, match premises in Y: "\<And>B. P B" for P \<Rightarrow> \<open>match (P) in A \<Rightarrow> \<open>print_fact Y, rule Y\<close>\<close>)
   62.48 +    apply (rule dup, match premises in Y: "\<And>B :: 'a. P B" for P \<Rightarrow> \<open>match (P) in A \<Rightarrow> \<open>print_fact Y, rule Y\<close>\<close>)
   62.49 +    apply (rule dup, match premises in Y: "\<And>B :: 'a. P B" for P \<Rightarrow> \<open>match conclusion in "P y" for y \<Rightarrow> \<open>print_fact Y, print_term y, rule Y[where B=y]\<close>\<close>)
   62.50 +    apply (rule dup, match premises in Y: "\<And>B :: 'a. P B" for P \<Rightarrow> \<open>match conclusion in "P z" for z \<Rightarrow> \<open>print_fact Y, print_term y, rule Y[where B=z]\<close>\<close>)
   62.51 +    apply (rule dup, match conclusion in "P y" for P \<Rightarrow> \<open>match premises in Y: "\<And>z. P z" \<Rightarrow> \<open>print_fact Y, rule Y[where z=y]\<close>\<close>)
   62.52 +    apply (match premises in Y: "\<And>z :: 'a. P z" for P \<Rightarrow> \<open>match conclusion in "P y" \<Rightarrow> \<open>print_fact Y, rule Y[where z=y]\<close>\<close>)
   62.53      done
   62.54  
   62.55    assume X: "\<And>x. A x" "A y"
   62.56 @@ -44,37 +46,49 @@
   62.57      apply (match X in Y:"B ?x" and Y':"B ?x" for B \<Rightarrow> \<open>print_fact Y, print_term B\<close>)
   62.58      apply (match X in Y:"B x" and Y':"B x" for B x \<Rightarrow> \<open>print_fact Y, print_term B, print_term x\<close>)
   62.59      apply (insert X)
   62.60 -    apply (match prems in Y:"\<And>B. A B" and Y':"B y" for B and y :: 'a \<Rightarrow> \<open>print_fact Y[where B=y], print_term B\<close>)
   62.61 -    apply (match prems in Y:"B ?x" and Y':"B ?x" for B \<Rightarrow> \<open>print_fact Y, print_term B\<close>)
   62.62 -    apply (match prems in Y:"B x" and Y':"B x" for B x \<Rightarrow> \<open>print_fact Y, print_term B\<close>)
   62.63 -    apply (match concl in "P x" and "P y" for P x \<Rightarrow> \<open>print_term P, print_term x\<close>)
   62.64 +    apply (match premises in Y:"\<And>B. A B" and Y':"B y" for B and y :: 'a \<Rightarrow> \<open>print_fact Y[where B=y], print_term B\<close>)
   62.65 +    apply (match premises in Y:"B ?x" and Y':"B ?x" for B \<Rightarrow> \<open>print_fact Y, print_term B\<close>)
   62.66 +    apply (match premises in Y:"B x" and Y':"B x" for B x \<Rightarrow> \<open>print_fact Y, print_term B\<close>)
   62.67 +    apply (match conclusion in "P x" and "P y" for P x \<Rightarrow> \<open>print_term P, print_term x\<close>)
   62.68      apply assumption
   62.69      done
   62.70  
   62.71 +  {
   62.72 +   fix B x y
   62.73 +   assume X: "\<And>x y. B x x y"
   62.74 +   have "B x x y"
   62.75 +     by (match X in Y:"\<And>y. B y y z" for z \<Rightarrow> \<open>rule Y[where y=x]\<close>)
   62.76 +
   62.77 +   fix A B
   62.78 +   have "(\<And>x y. A (B x) y) \<Longrightarrow> A (B x) y"
   62.79 +     by (match premises in Y: "\<And>xx. ?H (B xx)" \<Rightarrow> \<open>rule Y\<close>)
   62.80 +  }
   62.81 +
   62.82    (* match focusing retains prems *)
   62.83    fix B x
   62.84    have "(\<And>x. A x) \<Longrightarrow> (\<And>z. B z) \<Longrightarrow> A y \<Longrightarrow> B x"
   62.85 -    apply (match prems in Y: "\<And>z :: 'a. A z"  \<Rightarrow> \<open>match prems in Y': "\<And>z :: 'b. B z" \<Rightarrow> \<open>print_fact Y, print_fact Y', rule Y'[where z=x]\<close>\<close>)
   62.86 +    apply (match premises in Y: "\<And>z :: 'a. A z"  \<Rightarrow> \<open>match premises in Y': "\<And>z :: 'b. B z" \<Rightarrow> \<open>print_fact Y, print_fact Y', rule Y'[where z=x]\<close>\<close>)
   62.87      done
   62.88  
   62.89    (*Attributes *)
   62.90    fix C
   62.91    have "(\<And>x :: 'a. A x)  \<Longrightarrow> (\<And>z. B z) \<Longrightarrow> A y \<Longrightarrow> B x \<and> B x \<and> A y"
   62.92      apply (intro conjI)
   62.93 -    apply (match prems in Y: "\<And>z :: 'a. A z" and Y'[intro]:"\<And>z :: 'b. B z" \<Rightarrow> \<open>fastforce\<close>)
   62.94 -    apply (match prems in Y: "\<And>z :: 'a. A z"  \<Rightarrow> \<open>match prems in Y'[intro]:"\<And>z :: 'b. B z" \<Rightarrow> \<open>fastforce\<close>\<close>)
   62.95 -    apply (match prems in Y[thin]: "\<And>z :: 'a. A z"  \<Rightarrow> \<open>(match prems in Y':"\<And>z :: 'a. A z" \<Rightarrow> \<open>fail\<close> \<bar> Y': "?H" \<Rightarrow> \<open>-\<close>)\<close>)
   62.96 +    apply (match premises in Y: "\<And>z :: 'a. A z" and Y'[intro]:"\<And>z :: 'b. B z" \<Rightarrow> \<open>fastforce\<close>)
   62.97 +    apply (match premises in Y: "\<And>z :: 'a. A z"  \<Rightarrow> \<open>match premises in Y'[intro]:"\<And>z :: 'b. B z" \<Rightarrow> \<open>fastforce\<close>\<close>)
   62.98 +    apply (match premises in Y[thin]: "\<And>z :: 'a. A z"  \<Rightarrow> \<open>(match premises in Y':"\<And>z :: 'a. A z" \<Rightarrow> \<open>print_fact Y,fail\<close> \<bar> _ \<Rightarrow> \<open>print_fact Y\<close>)\<close>)
   62.99 +    (*apply (match premises in Y: "\<And>z :: 'b. B z"  \<Rightarrow> \<open>(match premises in Y'[thin]:"\<And>z :: 'b. B z" \<Rightarrow> \<open>(match premises in Y':"\<And>z :: 'a. A z" \<Rightarrow> \<open>fail\<close> \<bar> Y': _ \<Rightarrow> \<open>-\<close>)\<close>)\<close>)*)
  62.100      apply assumption
  62.101      done
  62.102  
  62.103    fix A B C D
  62.104    have "\<And>uu'' uu''' uu uu'. (\<And>x :: 'a. A uu' x)  \<Longrightarrow> D uu y \<Longrightarrow> (\<And>z. B uu z) \<Longrightarrow> C uu y \<Longrightarrow> (\<And>z y. C uu z)  \<Longrightarrow> B uu x \<and> B uu x \<and> C uu y"
  62.105 -    apply (match prems in Y[thin]: "\<And>z :: 'a. A ?zz' z" and
  62.106 +    apply (match premises in Y[thin]: "\<And>z :: 'a. A ?zz' z" and
  62.107                            Y'[thin]: "\<And>rr :: 'b. B ?zz rr" \<Rightarrow>
  62.108            \<open>print_fact Y, print_fact Y', intro conjI, rule Y', insert Y', insert Y'[where rr=x]\<close>)
  62.109 -    apply (match prems in Y:"B ?u ?x" \<Rightarrow> \<open>rule Y\<close>)
  62.110 +    apply (match premises in Y:"B ?u ?x" \<Rightarrow> \<open>rule Y\<close>)
  62.111      apply (insert TrueI)
  62.112 -    apply (match prems in Y'[thin]: "\<And>ff. B uu ff" for uu \<Rightarrow> \<open>insert Y', drule meta_spec[where x=x]\<close>)
  62.113 +    apply (match premises in Y'[thin]: "\<And>ff. B uu ff" for uu \<Rightarrow> \<open>insert Y', drule meta_spec[where x=x]\<close>)
  62.114      apply assumption
  62.115      done
  62.116  
  62.117 @@ -82,33 +96,58 @@
  62.118    (* Multi-matches. As many facts as match are bound. *)
  62.119    fix A B C x
  62.120    have "(\<And>x :: 'a. A x) \<Longrightarrow> (\<And>y :: 'a. B y) \<Longrightarrow> C y \<Longrightarrow> (A x \<and> B y \<and> C y)"
  62.121 -    apply (match prems in Y[thin]: "\<And>z :: 'a. ?A z" (multi) \<Rightarrow> \<open>intro conjI, (rule Y)+\<close>)
  62.122 -    apply (match prems in Y[thin]: "\<And>z :: 'a. ?A z" (multi) \<Rightarrow> \<open>fail\<close> \<bar> "C y" \<Rightarrow> \<open>-\<close>) (* multi-match must bind something *)
  62.123 -    apply (match prems in Y: "C y" \<Rightarrow> \<open>rule Y\<close>)
  62.124 +    apply (match premises in Y[thin]: "\<And>z :: 'a. ?A z" (multi) \<Rightarrow> \<open>intro conjI, (rule Y)+\<close>)
  62.125 +    apply (match premises in Y[thin]: "\<And>z :: 'a. ?A z" (multi) \<Rightarrow> \<open>fail\<close> \<bar> "C y" \<Rightarrow> \<open>-\<close>) (* multi-match must bind something *)
  62.126 +    apply (match premises in Y: "C y" \<Rightarrow> \<open>rule Y\<close>)
  62.127      done
  62.128  
  62.129    fix A B C x
  62.130    have "(\<And>x :: 'a. A x) \<Longrightarrow> (\<And>y :: 'a. B y) \<Longrightarrow> C y \<Longrightarrow> (A x \<and> B y \<and> C y)"
  62.131 -    apply (match prems in Y[thin]: "\<And>z. ?A z" (multi) \<Rightarrow> \<open>intro conjI, (rule Y)+\<close>)
  62.132 -    apply (match prems in Y[thin]: "\<And>z. ?A z" (multi) \<Rightarrow> \<open>fail\<close> \<bar> "C y" \<Rightarrow> \<open>-\<close>) (* multi-match must bind something *)
  62.133 -    apply (match prems in Y: "C y" \<Rightarrow> \<open>rule Y\<close>)
  62.134 +    apply (match premises in Y[thin]: "\<And>z. ?A z" (multi) \<Rightarrow> \<open>intro conjI, (rule Y)+\<close>)
  62.135 +    apply (match premises in Y[thin]: "\<And>z. ?A z" (multi) \<Rightarrow> \<open>fail\<close> \<bar> "C y" \<Rightarrow> \<open>-\<close>) (* multi-match must bind something *)
  62.136 +    apply (match premises in Y: "C y" \<Rightarrow> \<open>rule Y\<close>)
  62.137      done
  62.138  
  62.139 +  fix A B C P Q and x :: 'a and y :: 'a
  62.140 +  have "(\<And>x y :: 'a. A x y \<and> Q) \<Longrightarrow> (\<And>a b. B (a :: 'a) (b :: 'a) \<and> Q) \<Longrightarrow> (\<And>x y. C (x :: 'a) (y :: 'a) \<and> P) \<Longrightarrow> A y x \<and> B y x"
  62.141 +    by (match premises in Y: "\<And>z a. ?A (z :: 'a) (a :: 'a) \<and> R" (multi) for R \<Rightarrow> \<open>rule conjI, rule Y[where z=x,THEN conjunct1], rule Y[THEN conjunct1]\<close>)
  62.142 +
  62.143  
  62.144    (*We may use for-fixes in multi-matches too. All bound facts must agree on the fixed term *)
  62.145    fix A B C x
  62.146    have "(\<And>y :: 'a. B y \<and> C y) \<Longrightarrow> (\<And>x :: 'a. A x \<and> B x) \<Longrightarrow> (\<And>y :: 'a. A y \<and> C y) \<Longrightarrow> C y \<Longrightarrow> (A x \<and> B y \<and> C y)"
  62.147 -    apply (match prems in Y: "\<And>x :: 'a. P x \<and> ?U x" (multi) for P \<Rightarrow> \<open>intro conjI Y[THEN conjunct1]\<close>)
  62.148 -    apply (match prems in Y: "\<And>z :: 'a. ?A z \<longrightarrow> False" (multi) \<Rightarrow> \<open>print_fact Y, fail\<close> \<bar> "C y" \<Rightarrow> \<open>print_term C\<close>) (* multi-match must bind something *)
  62.149 -    apply (match prems in Y: "\<And>x. B x \<and> C x" \<Rightarrow> \<open>intro conjI Y[THEN conjunct1]\<close>)
  62.150 -    apply (match prems in Y: "C ?x" \<Rightarrow> \<open>rule Y\<close>)
  62.151 +    apply (match premises in Y: "\<And>x :: 'a. P x \<and> ?U x" (multi) for P \<Rightarrow>
  62.152 +                                  \<open>match (P) in B \<Rightarrow> \<open>fail\<close>
  62.153 +                                        \<bar> "\<lambda>a. B" \<Rightarrow> \<open>fail\<close>
  62.154 +                                        \<bar> _ \<Rightarrow> \<open>-\<close>,
  62.155 +                                  intro conjI, (rule Y[THEN conjunct1])\<close>)
  62.156 +    apply (rule dup)
  62.157 +    apply (match premises in Y':"\<And>x :: 'a. ?U x \<and> Q x" and Y: "\<And>x :: 'a. Q x \<and> ?U x" (multi)  for Q \<Rightarrow> \<open>insert Y[THEN conjunct1]\<close>)
  62.158 +    apply assumption (* Previous match requires that Q is consistent *)
  62.159 +    apply (match premises in Y: "\<And>z :: 'a. ?A z \<longrightarrow> False" (multi) \<Rightarrow> \<open>print_fact Y, fail\<close> \<bar> "C y" \<Rightarrow> \<open>print_term C\<close>) (* multi-match must bind something *)
  62.160 +    apply (match premises in Y: "\<And>x. B x \<and> C x" \<Rightarrow> \<open>intro conjI Y[THEN conjunct1]\<close>)
  62.161 +    apply (match premises in Y: "C ?x" \<Rightarrow> \<open>rule Y\<close>)
  62.162 +    done
  62.163 +
  62.164 +  (* All bindings must be tried for a particular theorem.
  62.165 +     However all combinations are NOT explored. *)
  62.166 +  fix B A C
  62.167 +  assume asms:"\<And>a b. B (a :: 'a) (b :: 'a) \<and> Q" "\<And>x :: 'a. A x x \<and> Q" "\<And>a b. C (a :: 'a) (b :: 'a) \<and> Q"
  62.168 +  have "B y x \<and> C x y \<and> B x y \<and> C y x \<and> A x x"
  62.169 +    apply (intro conjI)
  62.170 +    apply (match asms in Y: "\<And>z a. ?A (z :: 'a) (a :: 'a) \<and> R" (multi) for R \<Rightarrow> \<open>rule Y[where z=x,THEN conjunct1]\<close>)
  62.171 +    apply (match asms in Y: "\<And>z a. ?A (z :: 'a) (a :: 'a) \<and> R" (multi) for R \<Rightarrow> \<open>rule Y[where a=x,THEN conjunct1]\<close>)
  62.172 +    apply (match asms in Y: "\<And>z a. ?A (z :: 'a) (a :: 'a) \<and> R" (multi) for R \<Rightarrow> \<open>rule Y[where a=x,THEN conjunct1]\<close>)
  62.173 +    apply (match asms in Y: "\<And>z a. ?A (z :: 'a) (a :: 'a) \<and> R" (multi) for R \<Rightarrow> \<open>rule Y[where z=x,THEN conjunct1]\<close>)
  62.174 +    apply (match asms in Y: "\<And>z a. A (z :: 'a) (a :: 'a) \<and> R"  for R \<Rightarrow> \<open>fail\<close> \<bar> _ \<Rightarrow> \<open>-\<close>)
  62.175 +    apply (rule asms[THEN conjunct1])
  62.176      done
  62.177  
  62.178    (* Attributes *)
  62.179    fix A B C x
  62.180    have "(\<And>x :: 'a. A x \<and> B x) \<Longrightarrow> (\<And>y :: 'a. A y \<and> C y) \<Longrightarrow> (\<And>y :: 'a. B y \<and> C y) \<Longrightarrow> C y \<Longrightarrow> (A x \<and> B y \<and> C y)"
  62.181 -    apply (match prems in Y: "\<And>x :: 'a. P x \<and> ?U x" (multi) for P \<Rightarrow> \<open>match Y[THEN conjunct1]  in Y':"?H"  (multi) \<Rightarrow> \<open>intro conjI,rule Y'\<close>\<close>)
  62.182 -    apply (match prems in Y: "\<And>x :: 'a. P x \<and> ?U x" (multi) for P \<Rightarrow> \<open>match Y[THEN conjunct2]  in Y':"?H"  (multi) \<Rightarrow> \<open>rule Y'\<close>\<close>)
  62.183 +    apply (match premises in Y: "\<And>x :: 'a. P x \<and> ?U x" (multi) for P \<Rightarrow> \<open>match Y[THEN conjunct1]  in Y':"?H"  (multi) \<Rightarrow> \<open>intro conjI,rule Y'\<close>\<close>)
  62.184 +    apply (match premises in Y: "\<And>x :: 'a. P x \<and> ?U x" (multi) for P \<Rightarrow> \<open>match Y[THEN conjunct2]  in Y':"?H"  (multi) \<Rightarrow> \<open>rule Y'\<close>\<close>)
  62.185      apply assumption
  62.186      done
  62.187  
  62.188 @@ -123,28 +162,70 @@
  62.189    (* Testing THEN_ALL_NEW within match *)
  62.190    fix A B C x
  62.191    have "(\<And>x :: 'a. A x \<and> B x) \<Longrightarrow> (\<And>y :: 'a. A y \<and> C y) \<Longrightarrow> (\<And>y :: 'a. B y \<and> C y) \<Longrightarrow> C y \<Longrightarrow> (A x \<and> B y \<and> C y)"
  62.192 -    apply (match prems in Y: "\<And>x :: 'a. P x \<and> ?U x" (multi) for P \<Rightarrow> \<open>intro conjI ; ((rule Y[THEN conjunct1])?); rule Y[THEN conjunct2] \<close>)
  62.193 +    apply (match premises in Y: "\<And>x :: 'a. P x \<and> ?U x" (multi) for P \<Rightarrow> \<open>intro conjI ; ((rule Y[THEN conjunct1])?); rule Y[THEN conjunct2] \<close>)
  62.194      done
  62.195  
  62.196    (* Cut tests *)
  62.197    fix A B C
  62.198  
  62.199    have "D \<and> C  \<Longrightarrow> A \<and> B  \<Longrightarrow> A \<longrightarrow> C \<Longrightarrow> D \<longrightarrow> True \<Longrightarrow> C"
  62.200 -    by (((match prems in I: "P \<and> Q" (cut)
  62.201 +    by (((match premises in I: "P \<and> Q" (cut)
  62.202                and I': "P \<longrightarrow> ?U" for P Q \<Rightarrow> \<open>rule mp [OF I' I[THEN conjunct1]]\<close>)?), simp)
  62.203  
  62.204 +  have "D \<and> C  \<Longrightarrow> A \<and> B  \<Longrightarrow> A \<longrightarrow> C \<Longrightarrow> D \<longrightarrow> True \<Longrightarrow> C"
  62.205 +    by (match premises in I: "P \<and> Q" (cut 2)
  62.206 +              and I': "P \<longrightarrow> ?U" for P Q \<Rightarrow> \<open>rule mp [OF I' I[THEN conjunct1]]\<close>)
  62.207 +
  62.208    have "A \<and> B \<Longrightarrow> A \<longrightarrow> C \<Longrightarrow> C"
  62.209 -    by (((match prems in I: "P \<and> Q" (cut)
  62.210 +    by (((match premises in I: "P \<and> Q" (cut)
  62.211                and I': "P \<longrightarrow> ?U" for P Q \<Rightarrow> \<open>rule mp [OF I' I[THEN conjunct1]]\<close>)?, simp) | simp)
  62.212  
  62.213 +  fix f x y
  62.214 +  have "f x y \<Longrightarrow> f x y"
  62.215 +    by (match conclusion in "f x y" for f x y  \<Rightarrow> \<open>print_term f\<close>)
  62.216 +
  62.217 +  fix A B C
  62.218 +  assume X: "A \<and> B" "A \<and> C" C
  62.219 +  have "A \<and> B \<and> C"
  62.220 +    by (match X in H: "A \<and> ?H" (multi, cut) \<Rightarrow>
  62.221 +          \<open>match H in "A \<and> C" and "A \<and> B" \<Rightarrow> \<open>fail\<close>\<close>
  62.222 +        | simp add: X)
  62.223 +
  62.224 +
  62.225 +  (* Thinning an inner focus *)
  62.226 +  (* Thinning should persist within a match, even when on an external premise *)
  62.227 +
  62.228 +  fix A
  62.229 +  have "(\<And>x. A x \<and> B) \<Longrightarrow> B \<and> C \<Longrightarrow> C"
  62.230 +    apply (match premises in H:"\<And>x. A x \<and> B" \<Rightarrow>
  62.231 +                     \<open>match premises in H'[thin]: "\<And>x. A x \<and> B" \<Rightarrow>
  62.232 +                      \<open>match premises in H'':"\<And>x. A x \<and> B" \<Rightarrow> \<open>fail\<close>
  62.233 +                                         \<bar> _ \<Rightarrow> \<open>-\<close>\<close>
  62.234 +                      ,match premises in H'':"\<And>x. A x \<and> B" \<Rightarrow> \<open>fail\<close> \<bar> _ \<Rightarrow> \<open>-\<close>\<close>)
  62.235 +    apply (match premises in H:"\<And>x. A x \<and> B" \<Rightarrow> \<open>fail\<close>
  62.236 +                              \<bar> H':_ \<Rightarrow> \<open>rule H'[THEN conjunct2]\<close>)
  62.237 +    done
  62.238 +
  62.239 +
  62.240 +  (* Local premises *)
  62.241 +  (* Only match premises which actually existed in the goal we just focused.*)
  62.242 +
  62.243 +  fix A
  62.244 +  assume asms: "C \<and> D"
  62.245 +  have "B \<and> C \<Longrightarrow> C"
  62.246 +    by (match premises in _ \<Rightarrow> \<open>insert asms,
  62.247 +            match premises (local) in "B \<and> C" \<Rightarrow> \<open>fail\<close>
  62.248 +                                  \<bar> H:"C \<and> D" \<Rightarrow> \<open>rule H[THEN conjunct1]\<close>\<close>)
  62.249  end
  62.250  
  62.251 +
  62.252 +
  62.253  (* Testing inner focusing. This fails if we don't smash flex-flex pairs produced
  62.254     by retrofitting. This needs to be done more carefully to avoid smashing
  62.255     legitimate pairs.*)
  62.256  
  62.257  schematic_lemma "?A x \<Longrightarrow> A x"
  62.258 -  apply (match concl in "H" for H \<Rightarrow> \<open>match concl in Y for Y \<Rightarrow> \<open>print_term Y\<close>\<close>)
  62.259 +  apply (match conclusion in "H" for H \<Rightarrow> \<open>match conclusion in Y for Y \<Rightarrow> \<open>print_term Y\<close>\<close>)
  62.260    apply assumption
  62.261    done
  62.262  
  62.263 @@ -169,9 +250,10 @@
  62.264    fun test_internal_fact ctxt factnm =
  62.265      (case try (Proof_Context.get_thms ctxt) factnm of
  62.266        NONE => ()
  62.267 -    | SOME _ => error "Found internal fact")\<close>
  62.268 +    | SOME _ => error "Found internal fact");
  62.269 +\<close>
  62.270  
  62.271 -method uses_test\<^sub>1 uses uses_test\<^sub>1_uses = \<open>rule uses_test\<^sub>1_uses\<close>
  62.272 +method uses_test\<^sub>1 uses uses_test\<^sub>1_uses = (rule uses_test\<^sub>1_uses)
  62.273  
  62.274  lemma assumes A shows A by (uses_test\<^sub>1 uses_test\<^sub>1_uses: assms)
  62.275  
  62.276 @@ -181,12 +263,12 @@
  62.277  ML \<open>test_internal_fact @{context} "Tests.uses_test\<^sub>1.uses_test\<^sub>1_uses"\<close>
  62.278  
  62.279  
  62.280 -(* Testing term and fact passing in recursion *)
  62.281 +subsection \<open>Testing term and fact passing in recursion\<close>
  62.282  
  62.283  method recursion_example for x :: bool uses facts =
  62.284 -  \<open>match (x) in
  62.285 +  (match (x) in
  62.286      "A \<and> B" for A B \<Rightarrow> \<open>(recursion_example A facts: facts, recursion_example B facts: facts)\<close>
  62.287 -  \<bar> "?H" \<Rightarrow> \<open>match facts in U: "x" \<Rightarrow> \<open>insert U\<close>\<close>\<close>
  62.288 +  \<bar> "?H" \<Rightarrow> \<open>match facts in U: "x" \<Rightarrow> \<open>insert U\<close>\<close>)
  62.289  
  62.290  lemma
  62.291    assumes asms: "A" "B" "C" "D"
  62.292 @@ -195,12 +277,29 @@
  62.293    apply simp
  62.294    done
  62.295  
  62.296 +(* uses facts are not accumulated *)
  62.297 +
  62.298 +method recursion_example' for A :: bool and B :: bool uses facts =
  62.299 +  (match facts in
  62.300 +    H: "A" and H': "B" \<Rightarrow> \<open>recursion_example' "A" "B" facts: H TrueI\<close>
  62.301 +  \<bar> "A" and "True" \<Rightarrow> \<open>recursion_example' "A" "B" facts: TrueI\<close>
  62.302 +  \<bar> "True" \<Rightarrow> \<open>-\<close>
  62.303 +  \<bar> "PROP ?P" \<Rightarrow> \<open>fail\<close>)
  62.304 +
  62.305 +lemma
  62.306 +  assumes asms: "A" "B"
  62.307 +  shows "True"
  62.308 +  apply (recursion_example' "A" "B" facts: asms)
  62.309 +  apply simp
  62.310 +  done
  62.311 +
  62.312 +
  62.313  (*Method.sections in existing method*)
  62.314 -method my_simp\<^sub>1 uses my_simp\<^sub>1_facts = \<open>simp add: my_simp\<^sub>1_facts\<close>
  62.315 +method my_simp\<^sub>1 uses my_simp\<^sub>1_facts = (simp add: my_simp\<^sub>1_facts)
  62.316  lemma assumes A shows A by (my_simp\<^sub>1 my_simp\<^sub>1_facts: assms)
  62.317  
  62.318  (*Method.sections via Eisbach argument parser*)
  62.319 -method uses_test\<^sub>2 uses uses_test\<^sub>2_uses = \<open>uses_test\<^sub>1 uses_test\<^sub>1_uses: uses_test\<^sub>2_uses\<close>
  62.320 +method uses_test\<^sub>2 uses uses_test\<^sub>2_uses = (uses_test\<^sub>1 uses_test\<^sub>1_uses: uses_test\<^sub>2_uses)
  62.321  lemma assumes A shows A by (uses_test\<^sub>2 uses_test\<^sub>2_uses: assms)
  62.322  
  62.323  
  62.324 @@ -208,7 +307,7 @@
  62.325  
  62.326  named_theorems declare_facts\<^sub>1
  62.327  
  62.328 -method declares_test\<^sub>1 declares declare_facts\<^sub>1 = \<open>rule declare_facts\<^sub>1\<close>
  62.329 +method declares_test\<^sub>1 declares declare_facts\<^sub>1 = (rule declare_facts\<^sub>1)
  62.330  
  62.331  lemma assumes A shows A by (declares_test\<^sub>1 declare_facts\<^sub>1: assms)
  62.332  
  62.333 @@ -218,29 +317,90 @@
  62.334  subsection \<open>Rule Instantiation Tests\<close>
  62.335  
  62.336  method my_allE\<^sub>1 for x :: 'a and P :: "'a \<Rightarrow> bool" =
  62.337 -  \<open>erule allE [where x = x and P = P]\<close>
  62.338 +  (erule allE [where x = x and P = P])
  62.339  
  62.340  lemma "\<forall>x. Q x \<Longrightarrow> Q x" by (my_allE\<^sub>1 x Q)
  62.341  
  62.342  method my_allE\<^sub>2 for x :: 'a and P :: "'a \<Rightarrow> bool" =
  62.343 -  \<open>erule allE [of P x]\<close>
  62.344 +  (erule allE [of P x])
  62.345  
  62.346  lemma "\<forall>x. Q x \<Longrightarrow> Q x" by (my_allE\<^sub>2 x Q)
  62.347  
  62.348  method my_allE\<^sub>3 for x :: 'a and P :: "'a \<Rightarrow> bool" =
  62.349 -  \<open>match allE [where 'a = 'a] in X: "\<And>(x :: 'a) P R. \<forall>x. P x \<Longrightarrow> (P x \<Longrightarrow> R) \<Longrightarrow> R" \<Rightarrow>
  62.350 -    \<open>erule X [where x = x and P = P]\<close>\<close>
  62.351 +  (match allE [where 'a = 'a] in X: "\<And>(x :: 'a) P R. \<forall>x. P x \<Longrightarrow> (P x \<Longrightarrow> R) \<Longrightarrow> R" \<Rightarrow>
  62.352 +    \<open>erule X [where x = x and P = P]\<close>)
  62.353  
  62.354  lemma "\<forall>x. Q x \<Longrightarrow> Q x" by (my_allE\<^sub>3 x Q)
  62.355  
  62.356  method my_allE\<^sub>4 for x :: 'a and P :: "'a \<Rightarrow> bool" =
  62.357 -  \<open>match allE [where 'a = 'a] in X: "\<And>(x :: 'a) P R. \<forall>x. P x \<Longrightarrow> (P x \<Longrightarrow> R) \<Longrightarrow> R" \<Rightarrow>
  62.358 -    \<open>erule X [of x P]\<close>\<close>
  62.359 +  (match allE [where 'a = 'a] in X: "\<And>(x :: 'a) P R. \<forall>x. P x \<Longrightarrow> (P x \<Longrightarrow> R) \<Longrightarrow> R" \<Rightarrow>
  62.360 +    \<open>erule X [of x P]\<close>)
  62.361  
  62.362  lemma "\<forall>x. Q x \<Longrightarrow> Q x" by (my_allE\<^sub>4 x Q)
  62.363  
  62.364  
  62.365 -ML {*
  62.366 +
  62.367 +subsection \<open>Polymorphism test\<close>
  62.368 +
  62.369 +axiomatization foo' :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool"
  62.370 +axiomatization where foo'_ax1: "foo' x y z \<Longrightarrow> z \<and> y"
  62.371 +axiomatization where foo'_ax2: "foo' x y y \<Longrightarrow> x \<and> z"
  62.372 +axiomatization where foo'_ax3: "foo' (x :: int) y y \<Longrightarrow> y \<and> y"
  62.373 +
  62.374 +lemmas my_thms = foo'_ax1 foo'_ax2 foo'_ax3
  62.375 +
  62.376 +definition first_id where "first_id x = x"
  62.377 +
  62.378 +lemmas my_thms' = my_thms[of "first_id x" for x]
  62.379 +
  62.380 +method print_conclusion = (match conclusion in concl for concl \<Rightarrow> \<open>print_term concl\<close>)
  62.381 +
  62.382 +lemma
  62.383 +  assumes foo: "\<And>x (y :: bool). foo' (A x) B (A x)"
  62.384 +  shows "\<And>z. A z \<and> B"
  62.385 +  apply
  62.386 +    (match conclusion in "f x y" for f y and x :: "'d :: type" \<Rightarrow> \<open>
  62.387 +      match my_thms' in R:"\<And>(x :: 'f :: type). ?P (first_id x) \<Longrightarrow> ?R"
  62.388 +                     and R':"\<And>(x :: 'f :: type). ?P' (first_id x) \<Longrightarrow> ?R'" \<Rightarrow> \<open>
  62.389 +        match (x) in "q :: 'f" for q \<Rightarrow> \<open>
  62.390 +          rule R[of q,simplified first_id_def],
  62.391 +          print_conclusion,
  62.392 +          rule foo
  62.393 +      \<close>\<close>\<close>)
  62.394 +  done
  62.395 +
  62.396 +
  62.397 +subsection \<open>Unchecked rule instantiation, with the possibility of runtime errors\<close>
  62.398 +
  62.399 +named_theorems my_thms_named
  62.400 +
  62.401 +declare foo'_ax3[my_thms_named]
  62.402 +
  62.403 +method foo_method3 declares my_thms_named =
  62.404 +  (match my_thms_named[of (unchecked) z for z] in R:"PROP ?H" \<Rightarrow> \<open>rule R\<close>)
  62.405 +
  62.406 +notepad
  62.407 +begin
  62.408 +
  62.409 +  (*FIXME: Shouldn't need unchecked keyword here. See Tests_Failing.thy *)
  62.410 +  fix A B x
  62.411 +  have "foo' x B A \<Longrightarrow> A \<and> B"
  62.412 +    by (match my_thms[of (unchecked) z for z] in R:"PROP ?H" \<Rightarrow> \<open>rule R\<close>)
  62.413 +
  62.414 +  fix A B x
  62.415 +  note foo'_ax1[my_thms_named]
  62.416 +  have "foo' x B A \<Longrightarrow> A \<and> B"
  62.417 +    by (match my_thms_named[where x=z for z] in R:"PROP ?H" \<Rightarrow> \<open>rule R\<close>)
  62.418 +
  62.419 +  fix A B x
  62.420 +  note foo'_ax1[my_thms_named] foo'_ax2[my_thms_named] foo'_ax3[my_thms_named]
  62.421 +  have "foo' x B A \<Longrightarrow> A \<and> B"
  62.422 +   by foo_method3
  62.423 +
  62.424 +end
  62.425 +
  62.426 +
  62.427 +ML \<open>
  62.428  structure Data = Generic_Data
  62.429  (
  62.430    type T = thm list;
  62.431 @@ -248,13 +408,13 @@
  62.432    val extend = I;
  62.433    fun merge data : T = Thm.merge_thms data;
  62.434  );
  62.435 -*}
  62.436 +\<close>
  62.437  
  62.438  local_setup \<open>Local_Theory.add_thms_dynamic (@{binding test_dyn}, Data.get)\<close>
  62.439  
  62.440  setup \<open>Context.theory_map (Data.put @{thms TrueI})\<close>
  62.441  
  62.442 -method dynamic_thms_test = \<open>rule test_dyn\<close>
  62.443 +method dynamic_thms_test = (rule test_dyn)
  62.444  
  62.445  locale foo =
  62.446    fixes A
  62.447 @@ -269,4 +429,69 @@
  62.448  
  62.449  end
  62.450  
  62.451 +
  62.452 +notepad
  62.453 +begin
  62.454 +  fix A x
  62.455 +  assume X: "\<And>x. A x"
  62.456 +  have "A x"
  62.457 +    by (match X in H[of x]:"\<And>x. A x" \<Rightarrow> \<open>print_fact H,match H in "A x" \<Rightarrow> \<open>rule H\<close>\<close>)
  62.458 +
  62.459 +  fix A x B
  62.460 +  assume X: "\<And>x :: bool. A x \<Longrightarrow> B" "\<And>x. A x"
  62.461 +  assume Y: "A B"
  62.462 +  have "B \<and> B \<and> B \<and> B \<and> B \<and> B"
  62.463 +    apply (intro conjI)
  62.464 +    apply (match X in H[OF X(2)]:"\<And>x. A x \<Longrightarrow> B" \<Rightarrow> \<open>print_fact H,rule H\<close>)
  62.465 +    apply (match X in H':"\<And>x. A x" and H[OF H']:"\<And>x. A x \<Longrightarrow> B" \<Rightarrow> \<open>print_fact H',print_fact H,rule H\<close>)
  62.466 +    apply (match X in H[of Q]:"\<And>x. A x \<Longrightarrow> ?R" and "?P \<Longrightarrow> Q" for Q \<Rightarrow> \<open>print_fact H,rule H, rule Y\<close>)
  62.467 +    apply (match X in H[of Q,OF Y]:"\<And>x. A x \<Longrightarrow> ?R" and "?P \<Longrightarrow> Q" for Q \<Rightarrow> \<open>print_fact H,rule H\<close>)
  62.468 +    apply (match X in H[OF Y,intro]:"\<And>x. A x \<Longrightarrow> ?R" \<Rightarrow> \<open>print_fact H,fastforce\<close>)
  62.469 +    apply (match X in H[intro]:"\<And>x. A x \<Longrightarrow> ?R" \<Rightarrow> \<open>rule H[where x=B], rule Y\<close>)
  62.470 +    done
  62.471 +
  62.472 +  fix x :: "prop" and A
  62.473 +  assume X: "TERM x"
  62.474 +  assume Y: "\<And>x :: prop. A x"
  62.475 +  have "A TERM x"
  62.476 +    apply (match X in "PROP y" for y \<Rightarrow> \<open>rule Y[where x="PROP y"]\<close>)
  62.477 +    done
  62.478  end
  62.479 +
  62.480 +subsection \<open>Proper context for method parameters\<close>
  62.481 +
  62.482 +method add_simp methods m uses f = (match f in H[simp]:_ \<Rightarrow> \<open>m\<close>)
  62.483 +
  62.484 +method add_my_thms methods m uses f = (match f in H[my_thms_named]:_ \<Rightarrow> \<open>m\<close>)
  62.485 +
  62.486 +method rule_my_thms = (rule my_thms_named)
  62.487 +method rule_my_thms' declares my_thms_named = (rule my_thms_named)
  62.488 +
  62.489 +lemma
  62.490 +  assumes A: A and B: B
  62.491 +  shows
  62.492 +  "(A \<or> B) \<and> A \<and> A \<and> A"
  62.493 +  apply (intro conjI)
  62.494 +  apply (add_simp \<open>add_simp \<open>simp\<close> f: B\<close> f: A)
  62.495 +  apply (add_my_thms \<open>rule_my_thms\<close> f:A)
  62.496 +  apply (add_my_thms \<open>rule_my_thms'\<close> f:A)
  62.497 +  apply (add_my_thms \<open>rule my_thms_named\<close> f:A)
  62.498 +  done
  62.499 +
  62.500 +subsection \<open>Shallow parser tests\<close>
  62.501 +
  62.502 +method all_args for A B methods m1 m2 uses f1 f2 declares my_thms_named = (fail)
  62.503 +
  62.504 +lemma True
  62.505 +  by (all_args True False \<open>-\<close> \<open>fail\<close> f1: TrueI f2: TrueI my_thms_named: TrueI | rule TrueI)
  62.506 +
  62.507 +subsection \<open>Method name internalization test\<close>
  62.508 +
  62.509 +
  62.510 +method test2 = (simp)
  62.511 +
  62.512 +method simp = fail
  62.513 +
  62.514 +lemma "A \<Longrightarrow> A" by test2
  62.515 +
  62.516 +end
    63.1 --- a/src/HOL/Eisbach/eisbach_antiquotations.ML	Sat May 23 22:13:24 2015 +0200
    63.2 +++ b/src/HOL/Eisbach/eisbach_antiquotations.ML	Mon May 25 22:11:43 2015 +0200
    63.3 @@ -1,4 +1,4 @@
    63.4 -(*  Title:      eisbach_antiquotations.ML
    63.5 +(*  Title:      HOL/Eisbach/eisbach_antiquotations.ML
    63.6      Author:     Daniel Matichuk, NICTA/UNSW
    63.7  
    63.8  ML antiquotations for Eisbach.
    64.1 --- a/src/HOL/Eisbach/eisbach_rule_insts.ML	Sat May 23 22:13:24 2015 +0200
    64.2 +++ b/src/HOL/Eisbach/eisbach_rule_insts.ML	Mon May 25 22:11:43 2015 +0200
    64.3 @@ -1,4 +1,4 @@
    64.4 -(*  Title:      eisbach_rule_insts.ML
    64.5 +(*  Title:      HOL/Eisbach/eisbach_rule_insts.ML
    64.6      Author:     Daniel Matichuk, NICTA/UNSW
    64.7  
    64.8  Eisbach-aware variants of the "where" and "of" attributes.
    64.9 @@ -72,38 +72,59 @@
   64.10      |> restore_tags thm
   64.11    end;
   64.12  
   64.13 +(* FIXME unused *)
   64.14 +fun read_instantiate_no_thm ctxt insts fixes =
   64.15 +  let
   64.16 +    val (type_insts, term_insts) =
   64.17 +      List.partition (fn (((x, _) : indexname), _) => String.isPrefix "'" x) insts;
   64.18 +
   64.19 +    val ctxt1 =
   64.20 +      ctxt
   64.21 +      |> Context_Position.not_really
   64.22 +      |> Proof_Context.read_vars fixes |-> Proof_Context.add_fixes |> #2;
   64.23 +
   64.24 +    val typs =
   64.25 +      map snd type_insts
   64.26 +      |> Syntax.read_typs ctxt1
   64.27 +      |> Syntax.check_typs ctxt1;
   64.28 +
   64.29 +    val typ_insts' = map2 (fn (xi, _) => fn T => (xi,T)) type_insts typs;
   64.30 +
   64.31 +    val terms =
   64.32 +      map snd term_insts
   64.33 +      |> Syntax.read_terms ctxt1
   64.34 +      |> Syntax.check_terms ctxt1;
   64.35 +
   64.36 +    val term_insts' = map2 (fn (xi, _) => fn t => (xi, t)) term_insts terms;
   64.37 +
   64.38 +  in (typ_insts',term_insts') end;
   64.39 +
   64.40  
   64.41  datatype rule_inst =
   64.42 -  Named_Insts of ((indexname * string) * (term -> unit)) list
   64.43 -| Term_Insts of (indexname * term) list;
   64.44 +  Named_Insts of ((indexname * string) * (term -> unit)) list * (binding * string option * mixfix) list
   64.45 +(*| Unchecked_Of_Insts of (string option list * string option list) * (binding * string option * mixfix) list*)
   64.46 +| Term_Insts of (indexname * term) list
   64.47 +| Unchecked_Term_Insts of term option list * term option list;
   64.48 +
   64.49 +fun mk_pair (t, t') = Logic.mk_conjunction (Logic.mk_term t, Logic.mk_term t');
   64.50  
   64.51 -fun embed_indexname ((xi,s),f) =
   64.52 -  let
   64.53 -    fun wrap_xi xi t = Logic.mk_conjunction (Logic.mk_term (Var (xi,fastype_of t)),Logic.mk_term t);
   64.54 -  in ((xi,s),f o wrap_xi xi) end;
   64.55 +fun dest_pair t = apply2 Logic.dest_term (Logic.dest_conjunction t);
   64.56  
   64.57 -fun unembed_indexname t =
   64.58 +fun embed_indexname ((xi, s), f) =
   64.59 +  let fun wrap_xi xi t = mk_pair (Var (xi, fastype_of t), t);
   64.60 +  in ((xi, s), f o wrap_xi xi) end;
   64.61 +
   64.62 +fun unembed_indexname t = dest_pair t |> apfst (Term.dest_Var #> fst);
   64.63 +
   64.64 +fun read_where_insts (insts, fixes) =
   64.65    let
   64.66 -    val (t, t') = apply2 Logic.dest_term (Logic.dest_conjunction t);
   64.67 -    val (xi, _) = Term.dest_Var t;
   64.68 -  in (xi, t') end;
   64.69 -
   64.70 -fun read_where_insts toks =
   64.71 -  let
   64.72 -    val parser =
   64.73 -      Parse.!!!
   64.74 -        (Parse.and_list1 (Args.var -- (Args.$$$ "=" |-- Parse_Tools.name_term)) -- Parse.for_fixes)
   64.75 -          --| Scan.ahead Parse.eof;
   64.76 -    val (insts, fixes) = the (Scan.read Token.stopper parser toks);
   64.77 -
   64.78      val insts' =
   64.79        if forall (fn (_, v) => Parse_Tools.is_real_val v) insts
   64.80 -      then Term_Insts (map (fn (_,t) => unembed_indexname (Parse_Tools.the_real_val t)) insts)
   64.81 -      else Named_Insts (map (fn (xi, p) => embed_indexname
   64.82 -            ((xi,Parse_Tools.the_parse_val p),Parse_Tools.the_parse_fun p)) insts);
   64.83 -  in
   64.84 -    (insts', fixes)
   64.85 -  end;
   64.86 +      then Term_Insts (map (unembed_indexname o Parse_Tools.the_real_val o snd) insts)
   64.87 +      else
   64.88 +        Named_Insts (map (fn (xi, p) => embed_indexname
   64.89 +          ((xi, Parse_Tools.the_parse_val p), Parse_Tools.the_parse_fun p)) insts, fixes);
   64.90 +  in insts' end;
   64.91  
   64.92  fun of_rule thm  (args, concl_args) =
   64.93    let
   64.94 @@ -119,31 +140,55 @@
   64.95  val inst =  Args.maybe Parse_Tools.name_term;
   64.96  val concl = Args.$$$ "concl" -- Args.colon;
   64.97  
   64.98 -fun read_of_insts toks thm =
   64.99 +fun close_unchecked_insts context ((insts,concl_inst), fixes) =
  64.100    let
  64.101 -    val parser =
  64.102 -      Parse.!!!
  64.103 -        ((Scan.repeat (Scan.unless concl inst) -- Scan.optional (concl |-- Scan.repeat inst) [])
  64.104 -          -- Parse.for_fixes) --| Scan.ahead Parse.eof;
  64.105 -    val ((insts, concl_insts), fixes) =
  64.106 -      the (Scan.read Token.stopper parser toks);
  64.107 +    val ctxt = Context.proof_of context;
  64.108 +    val ctxt1 = ctxt
  64.109 +      |> Proof_Context.read_vars fixes |-> Proof_Context.add_fixes |> #2;
  64.110 +
  64.111 +    val insts' = insts @ concl_inst;
  64.112 +
  64.113 +    val term_insts =
  64.114 +      map (the_list o (Option.map Parse_Tools.the_parse_val)) insts'
  64.115 +      |> burrow (Syntax.read_terms ctxt1
  64.116 +        #> Syntax.check_terms ctxt1
  64.117 +        #> Variable.export_terms ctxt1 ctxt)
  64.118 +      |> map (try the_single);
  64.119 +
  64.120 +    val _ =
  64.121 +      (insts', term_insts)
  64.122 +      |> ListPair.app (fn (SOME p, SOME t) => Parse_Tools.the_parse_fun p t | _ => ());
  64.123 +    val (insts'',concl_insts'') = chop (length insts) term_insts;
  64.124 +   in Unchecked_Term_Insts (insts'', concl_insts'') end;
  64.125  
  64.126 -    val insts' =
  64.127 -      if forall (fn SOME t => Parse_Tools.is_real_val t | NONE => true) (insts @ concl_insts)
  64.128 -      then
  64.129 -        Term_Insts
  64.130 -          (map_filter (Option.map (Parse_Tools.the_real_val #> unembed_indexname)) (insts @ concl_insts))
  64.131 -
  64.132 -      else
  64.133 +fun read_of_insts checked context ((insts, concl_insts), fixes) =
  64.134 +  if forall (fn SOME t => Parse_Tools.is_real_val t | NONE => true) (insts @ concl_insts)
  64.135 +  then
  64.136 +    if checked
  64.137 +    then
  64.138 +      (fn _ =>
  64.139 +       Term_Insts
  64.140 +        (map (unembed_indexname o Parse_Tools.the_real_val) (map_filter I (insts @ concl_insts))))
  64.141 +    else
  64.142 +      (fn _ =>
  64.143 +        Unchecked_Term_Insts
  64.144 +          (map (Option.map Parse_Tools.the_real_val) insts,
  64.145 +            map (Option.map Parse_Tools.the_real_val) concl_insts))
  64.146 +  else
  64.147 +    if checked
  64.148 +    then
  64.149 +      (fn thm =>
  64.150          Named_Insts
  64.151 -          (apply2 (map (Option.map (fn p => (Parse_Tools.the_parse_val p,Parse_Tools.the_parse_fun p))))
  64.152 +          (apply2
  64.153 +            (map (Option.map (fn p => (Parse_Tools.the_parse_val p, Parse_Tools.the_parse_fun p))))
  64.154              (insts, concl_insts)
  64.155 -            |> of_rule thm |> map ((fn (xi, (nm, tok)) => embed_indexname ((xi, nm), tok))));
  64.156 -  in
  64.157 -    (insts', fixes)
  64.158 -  end;
  64.159 +          |> of_rule thm |> map ((fn (xi, (nm, f)) => embed_indexname ((xi, nm), f))), fixes))
  64.160 +    else
  64.161 +      let val result = close_unchecked_insts context ((insts, concl_insts), fixes);
  64.162 +      in fn _ => result end;
  64.163  
  64.164 -fun read_instantiate_closed ctxt ((Named_Insts insts), fixes) thm  =
  64.165 +
  64.166 +fun read_instantiate_closed ctxt (Named_Insts (insts, fixes)) thm  =
  64.167        let
  64.168          val insts' = map (fn ((v, t), _) => ((v, Position.none), t)) insts;
  64.169  
  64.170 @@ -168,22 +213,42 @@
  64.171        in
  64.172          (thm'' |> restore_tags thm)
  64.173        end
  64.174 -  | read_instantiate_closed _ ((Term_Insts insts), _) thm = instantiate_xis insts thm;
  64.175 -
  64.176 -val parse_all : Token.T list context_parser = Scan.lift (Scan.many Token.not_eof);
  64.177 +  | read_instantiate_closed ctxt (Unchecked_Term_Insts insts) thm =
  64.178 +      let
  64.179 +        val (xis, ts) = ListPair.unzip (of_rule thm insts);
  64.180 +        val ctxt' = Variable.declare_maxidx (Thm.maxidx_of thm) ctxt;
  64.181 +        val (ts', ctxt'') = Variable.import_terms false ts ctxt';
  64.182 +        val ts'' = Variable.export_terms ctxt'' ctxt ts';
  64.183 +        val insts' = ListPair.zip (xis, ts'');
  64.184 +      in instantiate_xis insts' thm end
  64.185 +  | read_instantiate_closed _ (Term_Insts insts) thm = instantiate_xis insts thm;
  64.186  
  64.187  val _ =
  64.188    Theory.setup
  64.189 -    (Attrib.setup @{binding "where"} (parse_all >>
  64.190 -      (fn toks => Thm.rule_attribute (fn context =>
  64.191 -        read_instantiate_closed (Context.proof_of context) (read_where_insts toks))))
  64.192 +    (Attrib.setup @{binding "where"}
  64.193 +      (Scan.lift
  64.194 +        (Parse.and_list1 (Args.var -- (Args.$$$ "=" |-- Parse_Tools.name_term)) -- Parse.for_fixes)
  64.195 +        >> (fn args => let val args' = read_where_insts args in Thm.rule_attribute (fn context =>
  64.196 +            read_instantiate_closed (Context.proof_of context) args') end))
  64.197        "named instantiation of theorem");
  64.198  
  64.199  val _ =
  64.200    Theory.setup
  64.201 -    (Attrib.setup @{binding "of"} (parse_all >>
  64.202 -      (fn toks => Thm.rule_attribute (fn context => fn thm =>
  64.203 -        read_instantiate_closed (Context.proof_of context) (read_of_insts toks thm) thm)))
  64.204 +    (Attrib.setup @{binding "of"}
  64.205 +      (Scan.lift
  64.206 +        (Args.mode "unchecked" --
  64.207 +          (Scan.repeat (Scan.unless concl inst) --
  64.208 +            Scan.optional (concl |-- Scan.repeat inst) [] --
  64.209 +            Parse.for_fixes)) -- Scan.state >>
  64.210 +      (fn ((unchecked, args), context) =>
  64.211 +        let
  64.212 +          val read_insts = read_of_insts (not unchecked) context args;
  64.213 +        in
  64.214 +          Thm.rule_attribute (fn context => fn thm =>
  64.215 +            if Method_Closure.is_free_thm thm andalso unchecked
  64.216 +            then Method_Closure.dummy_free_thm
  64.217 +            else read_instantiate_closed (Context.proof_of context) (read_insts thm) thm)
  64.218 +        end))
  64.219        "positional instantiation of theorem");
  64.220  
  64.221  end;
    65.1 --- a/src/HOL/Eisbach/match_method.ML	Sat May 23 22:13:24 2015 +0200
    65.2 +++ b/src/HOL/Eisbach/match_method.ML	Mon May 25 22:11:43 2015 +0200
    65.3 @@ -1,4 +1,4 @@
    65.4 -(*  Title:      match_method.ML
    65.5 +(*  Title:      HOL/Eisbach/match_method.ML
    65.6      Author:     Daniel Matichuk, NICTA/UNSW
    65.7  
    65.8  Setup for "match" proof method. It provides basic fact/term matching in
    65.9 @@ -40,86 +40,79 @@
   65.10      Match_Term of term Item_Net.T
   65.11    | Match_Fact of thm Item_Net.T
   65.12    | Match_Concl
   65.13 -  | Match_Prems;
   65.14 +  | Match_Prems of bool;
   65.15  
   65.16  
   65.17  val aconv_net = Item_Net.init (op aconv) single;
   65.18  
   65.19  val parse_match_kind =
   65.20 -  Scan.lift @{keyword "concl"} >> K Match_Concl ||
   65.21 -  Scan.lift @{keyword "prems"} >> K Match_Prems ||
   65.22 +  Scan.lift @{keyword "conclusion"} >> K Match_Concl ||
   65.23 +  Scan.lift (@{keyword "premises"} |-- Args.mode "local") >> Match_Prems ||
   65.24    Scan.lift (@{keyword "("}) |-- Args.term --| Scan.lift (@{keyword ")"}) >>
   65.25      (fn t => Match_Term (Item_Net.update t aconv_net)) ||
   65.26    Attrib.thms >> (fn thms => Match_Fact (fold Item_Net.update thms Thm.full_rules));
   65.27  
   65.28  
   65.29 -fun nameable_match m = (case m of Match_Fact _ => true | Match_Prems => true | _ => false);
   65.30 +fun nameable_match m = (case m of Match_Fact _ => true | Match_Prems _ => true | _ => false);
   65.31  fun prop_match m = (case m of Match_Term _ => false | _ => true);
   65.32  
   65.33  val bound_term : (term, binding) Parse_Tools.parse_val parser =
   65.34    Parse_Tools.parse_term_val Parse.binding;
   65.35  
   65.36  val fixes =
   65.37 -  Parse.and_list1 (Scan.repeat1 bound_term --
   65.38 -    Scan.option (@{keyword "::"} |-- Parse.!!! Parse.typ) >> (fn (xs, T) => map (rpair T) xs))
   65.39 -  >> flat;
   65.40 +  Parse.and_list1 (Scan.repeat1 (Parse.position bound_term) --
   65.41 +    Scan.option (@{keyword "::"} |-- Parse.!!! Parse.typ)
   65.42 +    >> (fn (xs, T) => map (fn (x, pos) => ((x, T), pos)) xs)) >> flat;
   65.43  
   65.44  val for_fixes = Scan.optional (@{keyword "for"} |-- fixes) [];
   65.45  
   65.46 -fun pos_of dyn =
   65.47 -  (case dyn of
   65.48 -    Parse_Tools.Parse_Val (b, _) => Binding.pos_of b
   65.49 -  | _ => raise Fail "Not a parse value");
   65.50 -
   65.51 +fun pos_of dyn = Parse_Tools.the_parse_val dyn |> Binding.pos_of;
   65.52  
   65.53  (*FIXME: Dynamic facts modify the background theory, so we have to resort
   65.54    to token replacement for matched facts. *)
   65.55  fun dynamic_fact ctxt =
   65.56    bound_term -- Args.opt_attribs (Attrib.check_name ctxt);
   65.57  
   65.58 -type match_args = {unify : bool, multi : bool, cut : bool};
   65.59 +type match_args = {multi : bool, cut : int};
   65.60  
   65.61  val parse_match_args =
   65.62    Scan.optional (Args.parens (Parse.enum1 ","
   65.63 -    (Args.$$$ "unify" || Args.$$$ "multi" || Args.$$$ "cut"))) [] >>
   65.64 +    (Args.$$$ "multi" -- Scan.succeed ~1 || Args.$$$ "cut" -- Scan.optional Parse.nat 1))) [] >>
   65.65      (fn ss =>
   65.66 -      fold (fn s => fn {unify, multi, cut} =>
   65.67 +      fold (fn s => fn {multi, cut} =>
   65.68          (case s of
   65.69 -          "unify" => {unify = true, multi = multi, cut = cut}
   65.70 -        | "multi" => {unify = unify, multi = true, cut = cut}
   65.71 -        | "cut" => {unify = unify, multi = multi, cut = true}))
   65.72 -      ss {unify = false, multi = false, cut = false});
   65.73 +          ("multi", _) => {multi = true, cut = cut}
   65.74 +        | ("cut", n) => {multi = multi, cut = n}))
   65.75 +      ss {multi = false, cut = ~1});
   65.76  
   65.77 -(*TODO: Shape holes in thms *)
   65.78  fun parse_named_pats match_kind =
   65.79    Args.context :|-- (fn ctxt =>
   65.80 -    Scan.lift (Parse.and_list1 (Scan.option (dynamic_fact ctxt --| Args.colon) :--
   65.81 -      (fn opt_dyn =>
   65.82 -        if is_none opt_dyn orelse nameable_match match_kind
   65.83 -        then Parse_Tools.name_term -- parse_match_args
   65.84 -        else
   65.85 -          let val b = #1 (the opt_dyn)
   65.86 -          in error ("Cannot bind fact name in term match" ^ Position.here (pos_of b)) end))
   65.87 -    -- for_fixes -- (@{keyword "\<Rightarrow>"} |-- Parse.token Parse.cartouche))
   65.88 +    Scan.lift (Parse.and_list1
   65.89 +      (Scan.option (dynamic_fact ctxt --| Args.colon) :--
   65.90 +        (fn opt_dyn =>
   65.91 +          if is_none opt_dyn orelse nameable_match match_kind
   65.92 +          then Parse_Tools.name_term -- parse_match_args
   65.93 +          else
   65.94 +            let val b = #1 (the opt_dyn)
   65.95 +            in error ("Cannot bind fact name in term match" ^ Position.here (pos_of b)) end))
   65.96 +        -- for_fixes -- (@{keyword "\<Rightarrow>"} |-- Parse.token Parse.cartouche))
   65.97    >> (fn ((ts, fixes), cartouche) =>
   65.98      (case Token.get_value cartouche of
   65.99        SOME (Token.Source src) =>
  65.100          let
  65.101            val text = Method_Closure.read_inner_method ctxt src
  65.102 -          (*TODO: Correct parse context for attributes?*)
  65.103            val ts' =
  65.104              map
  65.105                (fn (b, (Parse_Tools.Real_Val v, match_args)) =>
  65.106                  ((Option.map (fn (b, att) =>
  65.107 -                  (Parse_Tools.the_real_val b,
  65.108 -                    map (Attrib.attribute ctxt) att)) b, match_args), v)
  65.109 +                  (Parse_Tools.the_real_val b, att)) b, match_args), v)
  65.110                  | _ => raise Fail "Expected closed term") ts
  65.111 -          val fixes' = map (fn (p, _) => Parse_Tools.the_real_val p) fixes
  65.112 +          val fixes' = map (fn ((p, _), _) => Parse_Tools.the_real_val p) fixes
  65.113          in (ts', fixes', text) end
  65.114      | SOME _ => error "Unexpected token value in match cartouche"
  65.115      | NONE =>
  65.116          let
  65.117 -          val fixes' = map (fn (pb, otyp) => (Parse_Tools.the_parse_val pb, otyp, NoSyn)) fixes;
  65.118 +          val fixes' = map (fn ((pb, otyp), _) => (Parse_Tools.the_parse_val pb, otyp, NoSyn)) fixes;
  65.119            val (fixes'', ctxt1) = Proof_Context.read_vars fixes' ctxt;
  65.120            val (fix_nms, ctxt2) = Proof_Context.add_fixes fixes'' ctxt1;
  65.121  
  65.122 @@ -130,10 +123,34 @@
  65.123              then Syntax.parse_prop ctxt3 term
  65.124              else Syntax.parse_term ctxt3 term;
  65.125  
  65.126 +          fun drop_Trueprop_dummy t =
  65.127 +            (case t of
  65.128 +              Const (@{const_name Trueprop}, _) $
  65.129 +                (Const (@{syntax_const "_type_constraint_"}, T) $
  65.130 +                  Const (@{const_name Pure.dummy_pattern}, _)) =>
  65.131 +                    Const (@{syntax_const "_type_constraint_"}, T) $
  65.132 +                      Const (@{const_name Pure.dummy_pattern}, propT)
  65.133 +            | t1 $ t2 => drop_Trueprop_dummy t1 $ drop_Trueprop_dummy t2
  65.134 +            | Abs (a, T, b) => Abs (a, T, drop_Trueprop_dummy b)
  65.135 +            | _ => t);
  65.136 +
  65.137            val pats =
  65.138              map (fn (_, (term, _)) => parse_term (Parse_Tools.the_parse_val term)) ts
  65.139 +            |> map drop_Trueprop_dummy
  65.140 +            |> (fn ts => fold_map Term.replace_dummy_patterns ts (Variable.maxidx_of ctxt3 + 1))
  65.141 +            |> fst
  65.142              |> Syntax.check_terms ctxt3;
  65.143  
  65.144 +          val pat_fixes = fold (Term.add_frees) pats [] |> map fst;
  65.145 +
  65.146 +          val _ =
  65.147 +            map2 (fn nm => fn (_, pos) =>
  65.148 +                member (op =) pat_fixes nm orelse
  65.149 +                error ("For-fixed variable must be bound in some pattern" ^ Position.here pos))
  65.150 +              fix_nms fixes;
  65.151 +
  65.152 +          val _ = map (Term.map_types Type.no_tvars) pats;
  65.153 +
  65.154            val ctxt4 = fold Variable.declare_term pats ctxt3;
  65.155  
  65.156            val (Ts, ctxt5) = ctxt4 |> fold_map Proof_Context.inferred_param fix_nms;
  65.157 @@ -146,12 +163,6 @@
  65.158              | reject_extra_free _ () = ();
  65.159            val _ = (fold o fold_aterms) reject_extra_free pats ();
  65.160  
  65.161 -          (*fun test_multi_bind {multi = multi, ...} pat = multi andalso
  65.162 -           not (null (inter (op =) (map Free (Term.add_frees pat [])) real_fixes)) andalso
  65.163 -           error "Cannot fix terms in multi-match. Use a schematic instead."
  65.164 -
  65.165 -          val _ = map2 (fn pat => fn (_, (_, match_args)) => test_multi_bind match_args pat) pats ts*)
  65.166 -
  65.167            val binds =
  65.168              map (fn (b, _) => Option.map (fn (b, att) => (Parse_Tools.the_parse_val b, att)) b) ts;
  65.169  
  65.170 @@ -163,20 +174,27 @@
  65.171  
  65.172                    val param_thm = map (Drule.mk_term o Thm.cterm_of ctxt' o Free) abs_nms
  65.173                      |> Conjunction.intr_balanced
  65.174 -                    |> Drule.generalize ([], map fst abs_nms);
  65.175 +                    |> Drule.generalize ([], map fst abs_nms)
  65.176 +                    |> Method_Closure.tag_free_thm;
  65.177  
  65.178 -                  val thm =
  65.179 +                  val atts = map (Attrib.attribute ctxt') att;
  65.180 +                  val (param_thm', ctxt'') = Thm.proof_attributes atts param_thm ctxt';
  65.181 +
  65.182 +                  fun label_thm thm =
  65.183                      Thm.cterm_of ctxt' (Free (nm, propT))
  65.184                      |> Drule.mk_term
  65.185 -                    |> not (null abs_nms) ? Conjunction.intr param_thm
  65.186 -                    |> Drule.zero_var_indexes
  65.187 -                    |> Method_Closure.tag_free_thm;
  65.188 +                    |> not (null abs_nms) ? Conjunction.intr thm
  65.189 +
  65.190 +                  val [head_thm, body_thm] =
  65.191 +                    Drule.zero_var_indexes_list (map label_thm [param_thm, param_thm'])
  65.192 +                    |> map Method_Closure.tag_free_thm;
  65.193  
  65.194 -                  (*TODO: Preprocess attributes here?*)
  65.195 -
  65.196 -                  val (_, ctxt'') = Proof_Context.note_thmss "" [((b, []), [([thm], [])])] ctxt';
  65.197 +                  val ctxt''' =
  65.198 +                    Attrib.local_notes "" [((b, []), [([body_thm], [])])] ctxt''
  65.199 +                    |> snd
  65.200 +                    |> Variable.declare_maxidx (Thm.maxidx_of head_thm);
  65.201                  in
  65.202 -                  (SOME (Thm.prop_of thm, map (Attrib.attribute ctxt) att) :: tms, ctxt'')
  65.203 +                  (SOME (Thm.prop_of head_thm, att) :: tms, ctxt''')
  65.204                  end
  65.205              | upd_ctxt NONE _ (tms, ctxt) = (NONE :: tms, ctxt);
  65.206  
  65.207 @@ -184,7 +202,7 @@
  65.208              |> (fn ctxt => fold2 upd_ctxt binds pats ([], ctxt) |> apfst rev)
  65.209              ||> Proof_Context.restore_mode ctxt;
  65.210  
  65.211 -          val (src, text) = Method_Closure.read_text_closure ctxt6 (Token.input_of cartouche);
  65.212 +          val (src, text) = Method_Closure.read_inner_text_closure ctxt6 (Token.input_of cartouche);
  65.213  
  65.214            val morphism =
  65.215              Variable.export_morphism ctxt6
  65.216 @@ -193,20 +211,34 @@
  65.217                  |> Variable.declare_maxidx (Variable.maxidx_of ctxt6));
  65.218  
  65.219            val pats' = map (Term.map_types Type_Infer.paramify_vars #> Morphism.term morphism) pats;
  65.220 -          val _ = ListPair.app (fn ((_, (Parse_Tools.Parse_Val (_, f), _)), t) => f t) (ts, pats');
  65.221 +          val _ = ListPair.app (fn ((_, (v, _)), t) => Parse_Tools.the_parse_fun v t) (ts, pats');
  65.222  
  65.223 -          val binds' = map (Option.map (fn (t, atts) => (Morphism.term morphism t, atts))) binds;
  65.224 +          fun close_src src =
  65.225 +            let
  65.226 +              val src' = Token.closure_src src |> Token.transform_src morphism;
  65.227 +              val _ =
  65.228 +                map2 (fn tok1 => fn tok2 =>
  65.229 +                  (case Token.get_value tok2 of
  65.230 +                    SOME value => Token.assign (SOME value) tok1
  65.231 +                  | NONE => ()))
  65.232 +                  (Token.args_of_src src)
  65.233 +                  (Token.args_of_src src');
  65.234 +            in src' end;
  65.235 +
  65.236 +          val binds' =
  65.237 +            map (Option.map (fn (t, atts) => (Morphism.term morphism t, map close_src atts))) binds;
  65.238  
  65.239            val _ =
  65.240              ListPair.app
  65.241 -              (fn ((SOME ((Parse_Tools.Parse_Val (_, f), _)), _), SOME (t, _)) => f t
  65.242 +              (fn ((SOME ((v, _)), _), SOME (t, _)) => Parse_Tools.the_parse_fun v t
  65.243                  | ((NONE, _), NONE) => ()
  65.244                  | _ => error "Mismatch between real and parsed bound variables")
  65.245                (ts, binds');
  65.246  
  65.247            val real_fixes' = map (Morphism.term morphism) real_fixes;
  65.248            val _ =
  65.249 -            ListPair.app (fn ((Parse_Tools.Parse_Val (_, f), _), t) => f t) (fixes, real_fixes');
  65.250 +            ListPair.app (fn (((v, _) , _), t) => Parse_Tools.the_parse_fun v t)
  65.251 +              (fixes, real_fixes');
  65.252  
  65.253            val match_args = map (fn (_, (_, match_args)) => match_args) ts;
  65.254            val binds'' = (binds' ~~ match_args) ~~ pats';
  65.255 @@ -218,10 +250,6 @@
  65.256          end)));
  65.257  
  65.258  
  65.259 -fun parse_match_bodies match_kind =
  65.260 -  Parse.enum1' "\<bar>" (parse_named_pats match_kind);
  65.261 -
  65.262 -
  65.263  fun dest_internal_fact t =
  65.264    (case try Logic.dest_conjunction t of
  65.265      SOME (params, head) =>
  65.266 @@ -234,19 +262,8 @@
  65.267    let
  65.268      val ts' = map (Envir.norm_term env) ts;
  65.269      val insts = map (Thm.cterm_of ctxt) ts' ~~ map (Thm.cterm_of ctxt) params;
  65.270 -    val tags = Thm.get_tags thm;
  65.271 -
  65.272 -   (*
  65.273 -    val Tinsts = Type.raw_matches ((map (fastype_of) params), (map (fastype_of) ts')) Vartab.empty
  65.274 -    |> Vartab.dest
  65.275 -    |> map (fn (xi, (S, typ)) => (certT (TVar (xi, S)), certT typ))
  65.276 -   *)
  65.277 -
  65.278 -    val thm' = Drule.cterm_instantiate insts thm
  65.279 -    (*|> Thm.instantiate (Tinsts, [])*)
  65.280 -      |> Thm.map_tags (K tags);
  65.281    in
  65.282 -    thm'
  65.283 +    Drule.cterm_instantiate insts thm
  65.284    end;
  65.285  
  65.286  fun do_inst fact_insts' env text ctxt =
  65.287 @@ -256,35 +273,30 @@
  65.288          (fn ((((SOME ((_, head), att), _), _), _), thms) => SOME (head, (thms, att))
  65.289            | _ => NONE) fact_insts';
  65.290  
  65.291 -    fun apply_attribute thm att ctxt =
  65.292 -      let
  65.293 -        val (opt_context', thm') = att (Context.Proof ctxt, thm)
  65.294 -      in
  65.295 -        (case thm' of
  65.296 -          SOME _ => error "Rule attributes cannot be applied here"
  65.297 -        | _ => the_default ctxt (Option.map Context.proof_of opt_context'))
  65.298 -      end;
  65.299 -
  65.300 -    fun apply_attributes atts thm = fold (apply_attribute thm) atts;
  65.301 -
  65.302 -     (*TODO: What to do about attributes that raise errors?*)
  65.303 -    val (fact_insts, ctxt') =
  65.304 -      fold_map (fn (head, (thms, atts : attribute list)) => fn ctxt =>
  65.305 -        ((head, thms), fold (apply_attributes atts) thms ctxt)) fact_insts ctxt;
  65.306 -
  65.307      fun try_dest_term thm = try (Thm.prop_of #> dest_internal_fact #> snd) thm;
  65.308  
  65.309 -    fun expand_fact thm =
  65.310 +    fun expand_fact fact_insts thm =
  65.311        the_default [thm]
  65.312          (case try_dest_term thm of
  65.313            SOME t_ident => AList.lookup (op aconv) fact_insts t_ident
  65.314          | NONE => NONE);
  65.315  
  65.316 -    val morphism =
  65.317 +    fun fact_morphism fact_insts =
  65.318        Morphism.term_morphism "do_inst.term" (Envir.norm_term env) $>
  65.319 -      Morphism.fact_morphism "do_inst.fact" (maps expand_fact);
  65.320 +      Morphism.typ_morphism "do_inst.type" (Envir.norm_type (Envir.type_env env)) $>
  65.321 +      Morphism.fact_morphism "do_inst.fact" (maps (expand_fact fact_insts));
  65.322  
  65.323 -    val text' = Method.map_source (Token.transform_src morphism) text;
  65.324 +    fun apply_attribute (head, (fact, atts)) (fact_insts, ctxt) =
  65.325 +      let
  65.326 +        val morphism = fact_morphism fact_insts;
  65.327 +        val atts' = map (Attrib.attribute ctxt o Token.transform_src morphism) atts;
  65.328 +        val (fact'', ctxt') = fold_map (Thm.proof_attributes atts') fact ctxt;
  65.329 +      in ((head, fact'') :: fact_insts, ctxt') end;
  65.330 +
  65.331 +     (*TODO: What to do about attributes that raise errors?*)
  65.332 +    val (fact_insts', ctxt') = fold_rev (apply_attribute) fact_insts ([], ctxt);
  65.333 +
  65.334 +    val text' = Method.map_source (Token.transform_src (fact_morphism fact_insts')) text;
  65.335    in
  65.336      (text', ctxt')
  65.337    end;
  65.338 @@ -307,28 +319,62 @@
  65.339      ((((Option.map prep_head x, args), params''), pat''), ctxt')
  65.340    end;
  65.341  
  65.342 -fun match_filter_env ctxt fixes (ts, params) thm env =
  65.343 +fun recalculate_maxidx env =
  65.344 +  let
  65.345 +    val tenv = Envir.term_env env;
  65.346 +    val tyenv = Envir.type_env env;
  65.347 +    val max_tidx = Vartab.fold (fn (_, (_, t)) => curry Int.max (maxidx_of_term t)) tenv ~1;
  65.348 +    val max_Tidx = Vartab.fold (fn (_, (_, T)) => curry Int.max (maxidx_of_typ T)) tyenv ~1;
  65.349 +  in
  65.350 +    Envir.Envir
  65.351 +      {maxidx = Int.max (Int.max (max_tidx, max_Tidx), Envir.maxidx_of env),
  65.352 +        tenv = tenv, tyenv = tyenv}
  65.353 +  end
  65.354 +
  65.355 +fun morphism_env morphism env =
  65.356 +  let
  65.357 +    val tenv = Envir.term_env env
  65.358 +      |> Vartab.map (K (fn (T, t) => (Morphism.typ morphism T, Morphism.term morphism t)));
  65.359 +    val tyenv = Envir.type_env env
  65.360 +      |> Vartab.map (K (fn (S, T) => (S, Morphism.typ morphism T)));
  65.361 +   in Envir.Envir {maxidx = Envir.maxidx_of env, tenv = tenv, tyenv = tyenv} end;
  65.362 +
  65.363 +fun export_with_params ctxt morphism (SOME ts, params) thm env =
  65.364 +      let
  65.365 +        val outer_env = morphism_env morphism env;
  65.366 +        val thm' = Morphism.thm morphism thm;
  65.367 +      in inst_thm ctxt outer_env params ts thm' end
  65.368 +  | export_with_params _ morphism (NONE,_) thm _ = Morphism.thm morphism thm;
  65.369 +
  65.370 +fun match_filter_env is_newly_fixed pat_vars fixes params env =
  65.371    let
  65.372      val param_vars = map Term.dest_Var params;
  65.373 -    val params' = map (Envir.lookup env) param_vars;
  65.374 +
  65.375 +    val tenv = Envir.term_env env;
  65.376 +
  65.377 +    val params' = map (fn (xi, _) => Vartab.lookup tenv xi) param_vars;
  65.378  
  65.379      val fixes_vars = map Term.dest_Var fixes;
  65.380  
  65.381 -    val tenv = Envir.term_env env;
  65.382      val all_vars = Vartab.keys tenv;
  65.383  
  65.384      val extra_vars = subtract (fn ((xi, _), xi') => xi = xi') fixes_vars all_vars;
  65.385  
  65.386 -    val tenv' = Envir.term_env env
  65.387 -      |> fold (Vartab.delete_safe) extra_vars;
  65.388 +    val tenv' = tenv |> fold (Vartab.delete_safe) extra_vars;
  65.389  
  65.390      val env' =
  65.391 -      Envir.Envir {maxidx = Envir.maxidx_of env, tenv = tenv', tyenv = Envir.type_env env};
  65.392 +      Envir.Envir {maxidx = Envir.maxidx_of env, tenv = tenv', tyenv = Envir.type_env env}
  65.393 +
  65.394 +    val all_params_bound = forall (fn SOME (_, Free (x,_)) => is_newly_fixed x | _ => false) params';
  65.395 +
  65.396 +    val all_params_distinct = not (has_duplicates (op =) params');
  65.397  
  65.398 -    val all_params_bound = forall (fn SOME (Var _) => true | _ => false) params';
  65.399 +    val pat_fixes = inter (eq_fst (op =)) fixes_vars pat_vars;
  65.400 +
  65.401 +    val all_pat_fixes_bound = forall (fn (xi, _) => is_some (Vartab.lookup tenv' xi)) pat_fixes;
  65.402    in
  65.403 -    if all_params_bound
  65.404 -    then SOME (case ts of SOME ts => inst_thm ctxt env params ts thm | _ => thm, env')
  65.405 +    if all_params_bound andalso all_pat_fixes_bound andalso all_params_distinct
  65.406 +    then SOME env'
  65.407      else NONE
  65.408    end;
  65.409  
  65.410 @@ -339,7 +385,7 @@
  65.411  fun prem_id_eq ((id, _ : thm), (id', _ : thm)) = id = id';
  65.412  
  65.413  val prem_rules : (int * thm) Item_Net.T =
  65.414 -   Item_Net.init prem_id_eq (single o Thm.full_prop_of o snd);
  65.415 +  Item_Net.init prem_id_eq (single o Thm.full_prop_of o snd);
  65.416  
  65.417  fun raw_thm_to_id thm =
  65.418    (case Properties.get (Thm.get_tags thm) prem_idN of NONE => NONE | SOME id => Int.fromString id)
  65.419 @@ -359,13 +405,34 @@
  65.420  
  65.421  val focus_prems = #1 o Focus_Data.get;
  65.422  
  65.423 +fun hyp_from_premid ctxt (ident, prem) =
  65.424 +  let
  65.425 +    val ident = Thm.cterm_of ctxt (HOLogic.mk_number @{typ nat} ident |> Logic.mk_term);
  65.426 +    val hyp =
  65.427 +      (case #hyps (Thm.crep_thm prem) of
  65.428 +        [hyp] => hyp
  65.429 +      | _ => error "Prem should have exactly one hyp");  (* FIXME error vs. raise Fail !? *)
  65.430 +    val ct = Drule.mk_term (hyp) |> Thm.cprop_of;
  65.431 +  in Drule.protect (Conjunction.mk_conjunction (ident, ct)) end;
  65.432 +
  65.433 +fun hyp_from_ctermid ctxt (ident,cterm) =
  65.434 +  let
  65.435 +    val ident = Thm.cterm_of ctxt (HOLogic.mk_number @{typ nat} ident |> Logic.mk_term);
  65.436 +  in Drule.protect (Conjunction.mk_conjunction (ident, cterm)) end;
  65.437 +
  65.438 +fun add_premid_hyp premid ctxt =
  65.439 +  Thm.declare_hyps (hyp_from_premid ctxt premid) ctxt;
  65.440 +
  65.441  fun add_focus_prem prem =
  65.442 +  `(Focus_Data.get #> #1 #> #1) ##>
  65.443    (Focus_Data.map o @{apply 3(1)}) (fn (next, net) =>
  65.444      (next + 1, Item_Net.update (next, Thm.tag_rule (prem_idN, string_of_int next) prem) net));
  65.445  
  65.446 -fun remove_focus_prem thm =
  65.447 +fun remove_focus_prem' (ident, thm) =
  65.448    (Focus_Data.map o @{apply 3(1)} o apsnd)
  65.449 -    (Item_Net.remove (raw_thm_to_id thm, thm));
  65.450 +    (Item_Net.remove (ident, thm));
  65.451 +
  65.452 +fun remove_focus_prem thm = remove_focus_prem' (raw_thm_to_id thm, thm);
  65.453  
  65.454  (*TODO: Preliminary analysis to see if we're trying to clear in a non-focus match?*)
  65.455  val _ =
  65.456 @@ -394,22 +461,48 @@
  65.457    (Focus_Data.map o @{apply 3(3)})
  65.458      (append (map (fn (_, ct) => Thm.term_of ct) params));
  65.459  
  65.460 +fun solve_term ct = Thm.trivial ct OF [Drule.termI];
  65.461 +
  65.462 +fun get_thinned_prems goal =
  65.463 +  let
  65.464 +    val chyps = Thm.crep_thm goal |> #hyps;
  65.465 +
  65.466 +    fun prem_from_hyp hyp goal =
  65.467 +    let
  65.468 +      val asm = Thm.assume hyp;
  65.469 +      val (identt,ct) = asm |> Goal.conclude |> Thm.cprop_of |> Conjunction.dest_conjunction;
  65.470 +      val ident = HOLogic.dest_number (Thm.term_of identt |> Logic.dest_term) |> snd;
  65.471 +      val thm = Conjunction.intr (solve_term identt) (solve_term ct) |> Goal.protect 0
  65.472 +      val goal' = Thm.implies_elim (Thm.implies_intr hyp goal) thm;
  65.473 +    in
  65.474 +      (SOME (ident,ct),goal')
  65.475 +    end handle TERM _ => (NONE,goal) | THM _ => (NONE,goal);
  65.476 +  in
  65.477 +    fold_map prem_from_hyp chyps goal
  65.478 +    |>> map_filter I
  65.479 +  end;
  65.480 +
  65.481  
  65.482  (* Add focus elements as proof data *)
  65.483 -fun augment_focus
  65.484 -    ({context, params, prems, asms, concl, schematics} : Subgoal.focus) : Subgoal.focus =
  65.485 +fun augment_focus (focus: Subgoal.focus) : (int list * Subgoal.focus) =
  65.486    let
  65.487 -    val context' = context
  65.488 +    val {context, params, prems, asms, concl, schematics} = focus;
  65.489 +
  65.490 +    val (prem_ids,ctxt') = context
  65.491        |> add_focus_params params
  65.492        |> add_focus_schematics (snd schematics)
  65.493 -      |> fold add_focus_prem (rev prems);
  65.494 +      |> fold_map add_focus_prem (rev prems)
  65.495 +
  65.496 +    val local_prems = map2 pair prem_ids (rev prems);
  65.497 +
  65.498 +    val ctxt'' = fold add_premid_hyp local_prems ctxt';
  65.499    in
  65.500 -    {context = context',
  65.501 +    (prem_ids,{context = ctxt'',
  65.502       params = params,
  65.503       prems = prems,
  65.504       concl = concl,
  65.505       schematics = schematics,
  65.506 -     asms = asms}
  65.507 +     asms = asms})
  65.508    end;
  65.509  
  65.510  
  65.511 @@ -432,69 +525,154 @@
  65.512        schematics = schematics', asms = asms} : Subgoal.focus, goal'')
  65.513    end;
  65.514  
  65.515 -exception MATCH_CUT;
  65.516 +
  65.517 +fun deduplicate eq prev seq =
  65.518 +  Seq.make (fn () =>
  65.519 +    (case Seq.pull seq of
  65.520 +      SOME (x, seq') =>
  65.521 +        if member eq prev x
  65.522 +        then Seq.pull (deduplicate eq prev seq')
  65.523 +        else SOME (x, deduplicate eq (x :: prev) seq')
  65.524 +    | NONE => NONE));
  65.525 +
  65.526 +
  65.527 +fun consistent_env env =
  65.528 +  let
  65.529 +    val tenv = Envir.term_env env;
  65.530 +    val tyenv = Envir.type_env env;
  65.531 +  in
  65.532 +    forall (fn (_, (T, t)) => Envir.norm_type tyenv T = fastype_of t) (Vartab.dest tenv)
  65.533 +  end;
  65.534 +
  65.535 +fun term_eq_wrt (env1,env2) (t1,t2) =
  65.536 +  Envir.eta_contract (Envir.norm_term env1 t1) aconv
  65.537 +  Envir.eta_contract (Envir.norm_term env2 t2);
  65.538 +
  65.539 +fun type_eq_wrt (env1,env2) (T1,T2) =
  65.540 +  Envir.norm_type (Envir.type_env env1) T1 = Envir.norm_type (Envir.type_env env2) T2
  65.541 +
  65.542  
  65.543 -val raise_match : (thm * Envir.env) Seq.seq = Seq.make (fn () => raise MATCH_CUT);
  65.544 +fun eq_env (env1, env2) =
  65.545 +    Envir.maxidx_of env1 = Envir.maxidx_of env1 andalso
  65.546 +    ListPair.allEq (fn ((var, (_, t)), (var', (_, t'))) =>
  65.547 +        (var = var' andalso term_eq_wrt (env1,env2) (t,t')))
  65.548 +      (apply2 Vartab.dest (Envir.term_env env1, Envir.term_env env2))
  65.549 +    andalso
  65.550 +    ListPair.allEq (fn ((var, (_, T)), (var', (_, T'))) =>
  65.551 +        var = var' andalso type_eq_wrt (env1,env2) (T,T'))
  65.552 +      (apply2 Vartab.dest (Envir.type_env env1, Envir.type_env env2));
  65.553 +
  65.554 +
  65.555 +fun merge_env (env1,env2) =
  65.556 +  let
  65.557 +    val tenv =
  65.558 +      Vartab.merge (eq_snd (term_eq_wrt (env1, env2))) (Envir.term_env env1, Envir.term_env env2);
  65.559 +    val tyenv =
  65.560 +      Vartab.merge (eq_snd (type_eq_wrt (env1, env2)) andf eq_fst (op =))
  65.561 +        (Envir.type_env env1,Envir.type_env env2);
  65.562 +    val maxidx = Int.max (Envir.maxidx_of env1, Envir.maxidx_of env2);
  65.563 +  in Envir.Envir {maxidx = maxidx, tenv = tenv, tyenv = tyenv} end;
  65.564 +
  65.565 +
  65.566 +fun import_with_tags thms ctxt =
  65.567 +  let
  65.568 +    val ((_, thms'), ctxt') = Variable.import false thms ctxt;
  65.569 +    val thms'' = map2 (fn thm => Thm.map_tags (K (Thm.get_tags thm))) thms thms';
  65.570 +  in (thms'', ctxt') end;
  65.571 +
  65.572 +
  65.573 +fun try_merge (env, env') = SOME (merge_env (env, env')) handle Vartab.DUP _ => NONE
  65.574 +
  65.575 +
  65.576 +fun Seq_retrieve seq f =
  65.577 +  let
  65.578 +    fun retrieve' (list, seq) f =
  65.579 +      (case Seq.pull seq of
  65.580 +        SOME (x, seq') =>
  65.581 +          if f x then (SOME x, (list, seq'))
  65.582 +          else retrieve' (list @ [x], seq') f
  65.583 +      | NONE => (NONE, (list, seq)));
  65.584 +
  65.585 +    val (result, (list, seq)) = retrieve' ([], seq) f;
  65.586 +  in (result, Seq.append (Seq.of_list list) seq) end;
  65.587  
  65.588  fun match_facts ctxt fixes prop_pats get =
  65.589    let
  65.590      fun is_multi (((_, x : match_args), _), _) = #multi x;
  65.591 -    fun is_unify (_, x : match_args) = #unify x;
  65.592 -    fun is_cut (_, x : match_args) = #cut x;
  65.593 +    fun get_cut (((_, x : match_args), _), _) = #cut x;
  65.594 +    fun do_cut n = if n = ~1 then I else Seq.take n;
  65.595 +
  65.596 +    val raw_thmss = map (get o snd) prop_pats;
  65.597 +    val (thmss,ctxt') = fold_burrow import_with_tags raw_thmss ctxt;
  65.598  
  65.599 -    fun match_thm (((x, params), pat), thm) env  =
  65.600 +    val newly_fixed = Variable.is_newly_fixed ctxt' ctxt;
  65.601 +
  65.602 +    val morphism = Variable.export_morphism ctxt' ctxt;
  65.603 +
  65.604 +    fun match_thm (((x, params), pat), thm)  =
  65.605        let
  65.606 -        fun try_dest_term term = the_default term (try Logic.dest_term term);
  65.607 -
  65.608 -        val pat' = pat |> Envir.norm_term env |> try_dest_term;
  65.609 +        val pat_vars = Term.add_vars pat [];
  65.610  
  65.611 -        val item' = Thm.prop_of thm |> try_dest_term;
  65.612          val ts = Option.map (fst o fst) (fst x);
  65.613 -        (*FIXME: Do we need to move one of these patterns above the other?*)
  65.614 +
  65.615 +        val item' = Thm.prop_of thm;
  65.616  
  65.617          val matches =
  65.618 -          (if is_unify x
  65.619 -           then Unify.smash_unifiers (Context.Proof ctxt) [(pat', item') ] env
  65.620 -           else Unify.matchers (Context.Proof ctxt) [(pat', item')])
  65.621 +          (Unify.matchers (Context.Proof ctxt) [(pat, item')])
  65.622 +          |> Seq.filter consistent_env
  65.623            |> Seq.map_filter (fn env' =>
  65.624 -              match_filter_env ctxt fixes (ts, params) thm (Envir.merge (env, env')))
  65.625 -          |> is_cut x ? (fn t => Seq.make (fn () =>
  65.626 -            Option.map (fn (x, _) => (x, raise_match)) (Seq.pull t)));
  65.627 -      in
  65.628 -        matches
  65.629 -      end;
  65.630 +              (case match_filter_env newly_fixed pat_vars fixes params env' of
  65.631 +                SOME env'' => SOME (export_with_params ctxt morphism (ts,params) thm env',env'')
  65.632 +              | NONE => NONE))
  65.633 +          |> Seq.map (apfst (Thm.map_tags (K (Thm.get_tags thm))))
  65.634 +          |> deduplicate (eq_pair Thm.eq_thm_prop eq_env) []
  65.635 +      in matches end;
  65.636  
  65.637      val all_matches =
  65.638 -      map (fn pat => (pat, get (snd pat))) prop_pats
  65.639 +      map2 pair prop_pats thmss
  65.640        |> map (fn (pat, matches) => (pat, map (fn thm => match_thm (pat, thm)) matches));
  65.641  
  65.642      fun proc_multi_match (pat, thmenvs) (pats, env) =
  65.643 -      if is_multi pat then
  65.644 -        let
  65.645 -          val empty = ([], Envir.empty ~1);
  65.646 +      do_cut (get_cut pat)
  65.647 +        (if is_multi pat then
  65.648 +          let
  65.649 +            fun maximal_set tail seq envthms =
  65.650 +              Seq.make (fn () =>
  65.651 +                (case Seq.pull seq of
  65.652 +                  SOME ((thm, env'), seq') =>
  65.653 +                    let
  65.654 +                      val (result, envthms') =
  65.655 +                        Seq_retrieve envthms (fn (env, _) => eq_env (env, env'));
  65.656 +                    in
  65.657 +                      (case result of
  65.658 +                        SOME (_,thms) => SOME ((env', thm :: thms), maximal_set tail seq' envthms')
  65.659 +                      | NONE => Seq.pull (maximal_set (tail @ [(env', [thm])]) seq' envthms'))
  65.660 +                    end
  65.661 +                 | NONE => Seq.pull (Seq.append envthms (Seq.of_list tail))));
  65.662  
  65.663 -          val thmenvs' =
  65.664 -            Seq.EVERY (map (fn e => fn (thms, env) =>
  65.665 -              Seq.append (Seq.map (fn (thm, env') => (thm :: thms, env')) (e env))
  65.666 -                (Seq.single (thms, env))) thmenvs) empty;
  65.667 -        in
  65.668 -          Seq.map_filter (fn (fact, env') =>
  65.669 -            if not (null fact) then SOME ((pat, fact) :: pats, env') else NONE) thmenvs'
  65.670 -        end
  65.671 -      else
  65.672 -        fold (fn e => Seq.append (Seq.map (fn (thm, env') =>
  65.673 -          ((pat, [thm]) :: pats, env')) (e env))) thmenvs Seq.empty;
  65.674 +            val maximal_sets = fold (maximal_set []) thmenvs Seq.empty;
  65.675 +          in
  65.676 +            maximal_sets
  65.677 +            |> Seq.map swap
  65.678 +            |> Seq.filter (fn (thms, _) => not (null thms))
  65.679 +            |> Seq.map_filter (fn (thms, env') =>
  65.680 +              (case try_merge (env, env') of
  65.681 +                SOME env'' => SOME ((pat, thms) :: pats, env'')
  65.682 +              | NONE => NONE))
  65.683 +          end
  65.684 +        else
  65.685 +          let
  65.686 +            fun just_one (thm, env') =
  65.687 +              (case try_merge (env,env') of
  65.688 +                SOME env'' => SOME ((pat,[thm]) :: pats, env'')
  65.689 +              | NONE => NONE);
  65.690 +          in fold (fn seq => Seq.append (Seq.map_filter just_one seq)) thmenvs Seq.empty end);
  65.691  
  65.692      val all_matches =
  65.693 -      Seq.EVERY (map proc_multi_match all_matches) ([], Envir.empty ~1)
  65.694 -      |> Seq.filter (fn (_, e) => forall (is_some o Envir.lookup e o Term.dest_Var) fixes);
  65.695 -
  65.696 -    fun map_handle seq = Seq.make (fn () =>
  65.697 -      (case (Seq.pull seq handle MATCH_CUT => NONE) of
  65.698 -        SOME (x, seq') => SOME (x, map_handle seq')
  65.699 -      | NONE => NONE));
  65.700 +      Seq.EVERY (map proc_multi_match all_matches) ([], Envir.empty ~1);
  65.701    in
  65.702 -    map_handle all_matches
  65.703 +    all_matches
  65.704 +    |> Seq.map (apsnd (morphism_env morphism))
  65.705    end;
  65.706  
  65.707  fun real_match using ctxt fixes m text pats goal =
  65.708 @@ -507,7 +685,6 @@
  65.709          |> Seq.map (fn (fact_insts, env) => do_inst fact_insts env text ctxt')
  65.710        end;
  65.711  
  65.712 -    (*TODO: Slightly hacky re-use of fact match implementation in plain term matching *)
  65.713      fun make_term_matches ctxt get =
  65.714        let
  65.715          val pats' =
  65.716 @@ -535,20 +712,24 @@
  65.717            let
  65.718              fun focus_cases f g =
  65.719                (case match_kind of
  65.720 -                Match_Prems => f
  65.721 +                Match_Prems b => f b
  65.722                | Match_Concl => g
  65.723                | _ => raise Fail "Match kind fell through");
  65.724  
  65.725 -            val ({context = focus_ctxt, params, asms, concl, ...}, focused_goal) =
  65.726 -              focus_cases (Subgoal.focus_prems) (focus_concl) ctxt 1 goal
  65.727 +            val (goal_thins,goal) = get_thinned_prems goal;
  65.728 +
  65.729 +            val ((local_premids,{context = focus_ctxt, params, asms, concl, ...}), focused_goal) =
  65.730 +              focus_cases (K Subgoal.focus_prems) (focus_concl) ctxt 1 goal
  65.731                |>> augment_focus;
  65.732  
  65.733              val texts =
  65.734                focus_cases
  65.735 -                (fn _ =>
  65.736 +                (fn is_local => fn _ =>
  65.737                    make_fact_matches focus_ctxt
  65.738 -                    (Item_Net.retrieve (focus_prems focus_ctxt |> snd) #>
  65.739 -                  order_list))
  65.740 +                    (Item_Net.retrieve (focus_prems focus_ctxt |> snd)
  65.741 +                     #> filter_out (member (eq_fst (op =)) goal_thins)
  65.742 +                     #> is_local ? filter (fn (p,_) => exists (fn id' => id' = p) local_premids)
  65.743 +                     #> order_list))
  65.744                  (fn _ =>
  65.745                    make_term_matches focus_ctxt (fn _ => [Logic.strip_imp_concl (Thm.term_of concl)]))
  65.746                  ();
  65.747 @@ -557,13 +738,34 @@
  65.748  
  65.749              fun do_retrofit inner_ctxt goal' =
  65.750                let
  65.751 -                val cleared_prems =
  65.752 -                  subtract (eq_fst (op =))
  65.753 +                val (goal'_thins,goal') = get_thinned_prems goal';
  65.754 +
  65.755 +                val thinned_prems =
  65.756 +                  ((subtract (eq_fst (op =))
  65.757                      (focus_prems inner_ctxt |> snd |> Item_Net.content)
  65.758 -                    (focus_prems focus_ctxt |> snd |> Item_Net.content)
  65.759 -                  |> map (fn (_, thm) =>
  65.760 -                    Thm.hyps_of thm
  65.761 -                    |> (fn [hyp] => hyp | _ => error "Prem should have only one hyp"));
  65.762 +                    (focus_prems focus_ctxt |> snd |> Item_Net.content))
  65.763 +                    |> map (fn (id, thm) =>
  65.764 +                        #hyps (Thm.crep_thm thm)
  65.765 +                        |> (fn [chyp] => (id, (SOME chyp, NONE))
  65.766 +                             | _ => error "Prem should have only one hyp")));
  65.767 +
  65.768 +                val all_thinned_prems =
  65.769 +                  thinned_prems @
  65.770 +                  map (fn (id, prem) => (id, (NONE, SOME prem))) (goal'_thins @ goal_thins);
  65.771 +
  65.772 +                val (thinned_local_prems,thinned_extra_prems) =
  65.773 +                  List.partition (fn (id, _) => member (op =) local_premids id) all_thinned_prems;
  65.774 +
  65.775 +                val local_thins =
  65.776 +                  thinned_local_prems
  65.777 +                  |> map (fn (_, (SOME t, _)) => Thm.term_of t
  65.778 +                           | (_, (_, SOME pt)) => Thm.term_of pt |> Logic.dest_term);
  65.779 +
  65.780 +                val extra_thins =
  65.781 +                  thinned_extra_prems
  65.782 +                  |> map (fn (id, (SOME ct, _)) => (id, Drule.mk_term ct |> Thm.cprop_of)
  65.783 +                           | (id, (_, SOME pt)) => (id, pt))
  65.784 +                  |> map (hyp_from_ctermid inner_ctxt);
  65.785  
  65.786                  val n_subgoals = Thm.nprems_of goal';
  65.787                  fun prep_filter t =
  65.788 @@ -572,12 +774,13 @@
  65.789                    if member (op =) prems t then SOME (remove1 (op aconv) t prems) else NONE;
  65.790                in
  65.791                  Subgoal.retrofit inner_ctxt ctxt params asms 1 goal' goal |>
  65.792 -                (if n_subgoals = 0 orelse null cleared_prems then I
  65.793 +                (if n_subgoals = 0 orelse null local_thins then I
  65.794                   else
  65.795                    Seq.map (Goal.restrict 1 n_subgoals)
  65.796                    #> Seq.maps (ALLGOALS (fn i =>
  65.797 -                      DETERM (filter_prems_tac' ctxt prep_filter filter_test cleared_prems i)))
  65.798 +                      DETERM (filter_prems_tac' ctxt prep_filter filter_test local_thins i)))
  65.799                    #> Seq.map (Goal.unrestrict 1))
  65.800 +                  |> Seq.map (fold Thm.weaken extra_thins)
  65.801                end;
  65.802  
  65.803              fun apply_text (text, ctxt') =
  65.804 @@ -585,7 +788,7 @@
  65.805                  val goal' =
  65.806                    DROP_CASES (Method_Closure.method_evaluate text ctxt' using) focused_goal
  65.807                    |> Seq.maps (DETERM (do_retrofit ctxt'))
  65.808 -                  |> Seq.map (fn goal => ([]: cases, goal))
  65.809 +                  |> Seq.map (fn goal => ([]: cases, goal));
  65.810                in goal' end;
  65.811            in
  65.812              Seq.map apply_text texts
  65.813 @@ -593,22 +796,19 @@
  65.814    end;
  65.815  
  65.816  val match_parser =
  65.817 -  parse_match_kind :-- (fn kind => Scan.lift @{keyword "in"} |-- parse_match_bodies kind) >>
  65.818 +  parse_match_kind :-- (fn kind =>
  65.819 +      Scan.lift @{keyword "in"} |-- Parse.enum1' "\<bar>" (parse_named_pats kind)) >>
  65.820      (fn (matches, bodies) => fn ctxt => fn using => fn goal =>
  65.821        if Method_Closure.is_dummy goal then Seq.empty
  65.822        else
  65.823          let
  65.824            fun exec (pats, fixes, text) goal =
  65.825              let
  65.826 -              val ctxt' = fold Variable.declare_term fixes ctxt
  65.827 -              |> fold (fn (_, t) => Variable.declare_term t) pats; (*Is this a good idea? We really only care about the maxidx*)
  65.828 -            in
  65.829 -              real_match using ctxt' fixes matches text pats goal
  65.830 -            end;
  65.831 -        in
  65.832 -          Seq.FIRST (map exec bodies) goal
  65.833 -          |> Seq.flat
  65.834 -        end);
  65.835 +              val ctxt' =
  65.836 +                fold Variable.declare_term fixes ctxt
  65.837 +                |> fold (fn (_, t) => Variable.declare_term t) pats; (*Is this a good idea? We really only care about the maxidx*)
  65.838 +            in real_match using ctxt' fixes matches text pats goal end;
  65.839 +        in Seq.flat (Seq.FIRST (map exec bodies) goal) end);
  65.840  
  65.841  val _ =
  65.842    Theory.setup
    66.1 --- a/src/HOL/Eisbach/method_closure.ML	Sat May 23 22:13:24 2015 +0200
    66.2 +++ b/src/HOL/Eisbach/method_closure.ML	Mon May 25 22:11:43 2015 +0200
    66.3 @@ -1,4 +1,4 @@
    66.4 -(*  Title:      method_closure.ML
    66.5 +(*  Title:      HOL/Eisbach/method_closure.ML
    66.6      Author:     Daniel Matichuk, NICTA/UNSW
    66.7  
    66.8  Facilities for treating method syntax as a closure, with abstraction
    66.9 @@ -12,19 +12,25 @@
   66.10  sig
   66.11    val is_dummy: thm -> bool
   66.12    val tag_free_thm: thm -> thm
   66.13 +  val is_free_thm: thm -> bool
   66.14 +  val dummy_free_thm: thm
   66.15    val free_aware_rule_attribute: thm list -> (Context.generic -> thm -> thm) -> Thm.attribute
   66.16 +  val wrap_attribute: {handle_all_errs : bool, declaration : bool} ->
   66.17 +    Binding.binding -> theory -> theory
   66.18    val read_inner_method: Proof.context -> Token.src -> Method.text
   66.19 -  val read_text_closure: Proof.context -> Input.source -> Token.src * Method.text
   66.20 +  val read_text_closure: Proof.context -> Token.src -> Token.src * Method.text
   66.21 +  val read_inner_text_closure: Proof.context -> Input.source -> Token.src * Method.text
   66.22 +  val parse_method: Method.text context_parser
   66.23    val method_evaluate: Method.text -> Proof.context -> Method.method
   66.24    val get_inner_method: Proof.context -> string * Position.T ->
   66.25      (term list * (string list * string list)) * Method.text
   66.26    val eval_inner_method: Proof.context -> (term list * string list) * Method.text ->
   66.27 -    term list -> (string * thm list) list -> Method.method list ->
   66.28 +    term list -> (string * thm list) list -> (Proof.context -> Method.method) list ->
   66.29      Proof.context -> Method.method
   66.30    val method_definition: binding -> (binding * typ option * mixfix) list ->
   66.31 -    binding list -> binding list -> binding list -> Input.source -> local_theory -> local_theory
   66.32 +    binding list -> binding list -> binding list -> Token.src -> local_theory -> local_theory
   66.33    val method_definition_cmd: binding -> (binding * string option * mixfix) list ->
   66.34 -    binding list -> binding list -> binding list -> Input.source -> local_theory -> local_theory
   66.35 +    binding list -> binding list -> binding list -> Token.src -> local_theory -> local_theory
   66.36  end;
   66.37  
   66.38  structure Method_Closure: METHOD_CLOSURE =
   66.39 @@ -34,12 +40,10 @@
   66.40  
   66.41  structure Data = Generic_Data
   66.42  (
   66.43 -  type T =
   66.44 -    ((term list * (string list * string list)) * Method.text) Symtab.table;
   66.45 +  type T = ((term list * (string list * string list)) * Method.text) Symtab.table;
   66.46    val empty: T = Symtab.empty;
   66.47    val extend = I;
   66.48 -  fun merge (methods1,methods2) : T =
   66.49 -    (Symtab.merge (K true) (methods1, methods2));
   66.50 +  fun merge data : T = Symtab.merge (K true) data;
   66.51  );
   66.52  
   66.53  val get_methods = Data.get o Context.Proof;
   66.54 @@ -49,12 +53,12 @@
   66.55  structure Local_Data = Proof_Data
   66.56  (
   66.57    type T =
   66.58 -    Method.method Symtab.table *  (*dynamic methods*)
   66.59 +    (Proof.context -> Method.method) Symtab.table *  (*dynamic methods*)
   66.60      (term list -> Proof.context -> Method.method)  (*recursive method*);
   66.61    fun init _ : T = (Symtab.empty, fn _ => fn _ => Method.fail);
   66.62  );
   66.63  
   66.64 -fun lookup_dynamic_method full_name ctxt =
   66.65 +fun lookup_dynamic_method ctxt full_name =
   66.66    (case Symtab.lookup (#1 (Local_Data.get ctxt)) full_name of
   66.67      SOME m => m
   66.68    | NONE => error ("Illegal use of internal Eisbach method: " ^ quote full_name));
   66.69 @@ -87,6 +91,35 @@
   66.70      if exists is_free_thm (thm :: args) then dummy_free_thm
   66.71      else f context thm);
   66.72  
   66.73 +fun free_aware_attribute thy {handle_all_errs,declaration} src (context, thm) =
   66.74 +  let
   66.75 +    val src' = Token.init_assignable_src src;
   66.76 +    fun apply_att thm = (Attrib.attribute_global thy src') (context, thm);
   66.77 +    val _ =
   66.78 +      if handle_all_errs then (try apply_att Drule.dummy_thm; ())
   66.79 +      else (apply_att Drule.dummy_thm; ()) handle THM _ => () | TERM _ => () | TYPE _ => ();
   66.80 +
   66.81 +    val src'' = Token.closure_src src';
   66.82 +    val thms =
   66.83 +      map_filter Token.get_value (Token.args_of_src src'')
   66.84 +      |> map_filter (fn (Token.Fact (_, f)) => SOME f | _ => NONE)
   66.85 +      |> flat;
   66.86 +  in
   66.87 +    if exists is_free_thm (thm :: thms) then
   66.88 +      if declaration then (NONE, NONE)
   66.89 +      else (NONE, SOME dummy_free_thm)
   66.90 +    else apply_att thm
   66.91 +  end;
   66.92 +
   66.93 +fun wrap_attribute args binding thy =
   66.94 +  let
   66.95 +    val name = Binding.name_of binding;
   66.96 +    val name' = Attrib.check_name_generic (Context.Theory thy) (name, Position.none);
   66.97 +    fun get_src src = Token.src (name', Token.range_of_src src) (Token.args_of_src src);
   66.98 +  in
   66.99 +    Attrib.define_global binding (free_aware_attribute thy args o get_src) "" thy
  66.100 +    |> snd
  66.101 +  end;
  66.102  
  66.103  (* thm semantics for combined methods with internal parser. Simulates outer syntax parsing. *)
  66.104  (* Creates closures for each combined method while parsing, based on the parse context *)
  66.105 @@ -97,38 +130,38 @@
  66.106      val parser = Parse.!!! (Method.parser' ctxt 0 --| Scan.ahead Parse.eof);
  66.107    in
  66.108      (case Scan.read Token.stopper parser toks of
  66.109 -      SOME (method_text, _) => method_text
  66.110 +      SOME (method_text, pos) => (Method.report (method_text, pos); method_text)
  66.111      | NONE => error ("Failed to parse method" ^ Position.here (#2 (Token.name_of_src src))))
  66.112    end;
  66.113  
  66.114 -fun read_text_closure ctxt input =
  66.115 +fun read_text_closure ctxt source =
  66.116    let
  66.117 -    (*tokens*)
  66.118 +    val src = Token.init_assignable_src source;
  66.119 +    val method_text = read_inner_method ctxt src;
  66.120 +    val method_text' = Method.map_source (Method.method_closure ctxt) method_text;
  66.121 +    (*FIXME: Does not markup method parameters. Needs to be done by Method.parser' directly. *)
  66.122 +    val _ =
  66.123 +      Method.map_source (fn src => (try (Method.check_name ctxt) (Token.name_of_src src); src))
  66.124 +        method_text;
  66.125 +    val src' = Token.closure_src src;
  66.126 +  in (src', method_text') end;
  66.127 +
  66.128 +fun read_inner_text_closure ctxt input =
  66.129 +  let
  66.130      val keywords = Thy_Header.get_keywords' ctxt;
  66.131      val toks =
  66.132        Input.source_explode input
  66.133        |> Token.read_no_commands keywords (Scan.one Token.not_eof);
  66.134 -    val _ =
  66.135 -      toks |> List.app (fn tok =>
  66.136 -        if Token.keyword_with Symbol.is_ascii_identifier tok then
  66.137 -          Context_Position.report ctxt (Token.pos_of tok) Markup.keyword1
  66.138 -        else ());
  66.139 +  in read_text_closure ctxt (Token.src ("", Input.pos_of input) toks) end;
  66.140  
  66.141 -    (*source closure*)
  66.142 -    val src =
  66.143 -      Token.src ("", Input.pos_of input) toks
  66.144 -      |> Token.init_assignable_src;
  66.145 -    val method_text = read_inner_method ctxt src;
  66.146 -    val method_text' = Method.map_source (Method.method_closure ctxt) method_text;
  66.147 -    val src' = Token.closure_src src;
  66.148 -  in (src', method_text') end;
  66.149  
  66.150  val parse_method =
  66.151    Args.context -- Scan.lift (Parse.token Parse.cartouche) >> (fn (ctxt, tok) =>
  66.152      (case Token.get_value tok of
  66.153        NONE =>
  66.154          let
  66.155 -           val (src, text) = read_text_closure ctxt (Token.input_of tok);
  66.156 +           val input = Token.input_of tok;
  66.157 +           val (src, text) = read_inner_text_closure ctxt input;
  66.158             val _ = Token.assign (SOME (Token.Source src)) tok;
  66.159          in text end
  66.160      | SOME (Token.Source src) => read_inner_method ctxt src
  66.161 @@ -136,26 +169,22 @@
  66.162          error ("Unexpected inner token value for method cartouche" ^
  66.163            Position.here (Token.pos_of tok))));
  66.164  
  66.165 -fun method_evaluate text ctxt : Method.method = fn facts => fn st =>
  66.166 -  if is_dummy st then Seq.empty
  66.167 -  else Method.evaluate text (Config.put Method.closure false ctxt) facts st;
  66.168 -
  66.169  
  66.170  fun parse_term_args args =
  66.171    Args.context :|-- (fn ctxt =>
  66.172      let
  66.173 +      val ctxt' = Proof_Context.set_mode (Proof_Context.mode_schematic) ctxt;
  66.174 +
  66.175        fun parse T =
  66.176 -        (if T = propT then Syntax.parse_prop ctxt else Syntax.parse_term ctxt)
  66.177 +        (if T = propT then Syntax.parse_prop ctxt' else Syntax.parse_term ctxt')
  66.178          #> Type.constraint (Type_Infer.paramify_vars T);
  66.179  
  66.180        fun do_parse' T =
  66.181 -        Parse_Tools.name_term >>
  66.182 -          (fn Parse_Tools.Parse_Val (s, f) => (parse T s, f)
  66.183 -            | Parse_Tools.Real_Val t' => (t', K ()));
  66.184 +        Parse_Tools.name_term >> Parse_Tools.parse_val_cases (parse T);
  66.185  
  66.186        fun do_parse (Var (_, T)) = do_parse' T
  66.187          | do_parse (Free (_, T)) = do_parse' T
  66.188 -        | do_parse t = error ("Unexpected method parameter: " ^ Syntax.string_of_term ctxt t);
  66.189 +        | do_parse t = error ("Unexpected method parameter: " ^ Syntax.string_of_term ctxt' t);
  66.190  
  66.191         fun rep [] x = Scan.succeed [] x
  66.192           | rep (t :: ts) x  = (do_parse t -- rep ts >> op ::) x;
  66.193 @@ -163,7 +192,7 @@
  66.194        fun check ts =
  66.195          let
  66.196            val (ts, fs) = split_list ts;
  66.197 -          val ts' = Syntax.check_terms ctxt ts |> Variable.polymorphic ctxt;
  66.198 +          val ts' = Syntax.check_terms ctxt' ts |> Variable.polymorphic ctxt';
  66.199            val _ = ListPair.app (fn (f, t) => f t) (fs, ts');
  66.200          in ts' end;
  66.201      in Scan.lift (rep args) >> check end);
  66.202 @@ -193,7 +222,7 @@
  66.203    in Method.map_source (Token.transform_src morphism) text end;
  66.204  
  66.205  fun evaluate_dynamic_thm ctxt name =
  66.206 -  (case (try (Named_Theorems.get ctxt) name) of
  66.207 +  (case try (Named_Theorems.get ctxt) name of
  66.208      SOME thms => thms
  66.209    | NONE => Proof_Context.get_thms ctxt name);
  66.210  
  66.211 @@ -204,28 +233,53 @@
  66.212            Token.Fact (SOME name, evaluate_dynamic_thm ctxt name)
  66.213        | x => x);
  66.214  
  66.215 +fun method_evaluate text ctxt : Method.method = fn facts => fn st =>
  66.216 +  let
  66.217 +    val ctxt' = Config.put Method.closure false ctxt;
  66.218 +  in
  66.219 +    if is_dummy st then Seq.empty
  66.220 +    else Method.evaluate (evaluate_named_theorems ctxt' text) ctxt' facts st
  66.221 +  end;
  66.222 +
  66.223  fun evaluate_method_def fix_env raw_text ctxt =
  66.224    let
  66.225      val text = raw_text
  66.226 -      |> instantiate_text fix_env
  66.227 -      |> evaluate_named_theorems ctxt;
  66.228 +      |> instantiate_text fix_env;
  66.229    in method_evaluate text ctxt end;
  66.230  
  66.231  fun setup_local_method binding lthy =
  66.232    let
  66.233      val full_name = Local_Theory.full_name lthy binding;
  66.234 +    fun get_method ctxt = lookup_dynamic_method ctxt full_name ctxt;
  66.235    in
  66.236      lthy
  66.237 -    |> update_dynamic_method (full_name, Method.fail)
  66.238 -    |> Method.local_setup binding (Scan.succeed (lookup_dynamic_method full_name)) "(internal)"
  66.239 +    |> update_dynamic_method (full_name, K Method.fail)
  66.240 +    |> Method.local_setup binding (Scan.succeed get_method) "(internal)"
  66.241    end;
  66.242  
  66.243  fun setup_local_fact binding = Named_Theorems.declare binding "";
  66.244  
  66.245 +(* FIXME: In general we need the ability to override all dynamic facts.
  66.246 +   This is also slow: we need Named_Theorems.only *)
  66.247 +fun empty_named_thm named_thm ctxt =
  66.248 +  let
  66.249 +    val contents = Named_Theorems.get ctxt named_thm;
  66.250 +    val attrib = snd oo Thm.proof_attributes [Named_Theorems.del named_thm];
  66.251 +  in fold attrib contents ctxt end;
  66.252 +
  66.253 +fun dummy_named_thm named_thm ctxt =
  66.254 +  let
  66.255 +    val ctxt' = empty_named_thm named_thm ctxt;
  66.256 +    val (_,ctxt'') = Thm.proof_attributes [Named_Theorems.add named_thm] dummy_free_thm ctxt';
  66.257 +  in ctxt'' end;
  66.258 +
  66.259  fun parse_method_args method_names =
  66.260    let
  66.261 -    fun bind_method (name, text) ctxt =
  66.262 -      update_dynamic_method (name, method_evaluate text ctxt) ctxt;
  66.263 +    fun bind_method (name, text) ctxt = 
  66.264 +    let
  66.265 +      val method = method_evaluate text;
  66.266 +      val inner_update = method o update_dynamic_method (name,K (method ctxt));
  66.267 +    in update_dynamic_method (name,inner_update) ctxt end;
  66.268  
  66.269      fun do_parse t = parse_method >> pair t;
  66.270      fun rep [] x = Scan.succeed [] x
  66.271 @@ -274,7 +328,7 @@
  66.272      fn ctxt => evaluate_method_def (match fixes) text (setup_ctxt ctxt)
  66.273    end;
  66.274  
  66.275 -fun gen_method_definition prep_vars name vars uses attribs methods body lthy =
  66.276 +fun gen_method_definition prep_vars name vars uses attribs methods source lthy =
  66.277    let
  66.278      val (uses_nms, lthy1) = lthy
  66.279        |> Proof_Context.concealed
  66.280 @@ -294,17 +348,19 @@
  66.281  
  66.282      fun parser args eval =
  66.283        apfst (Config.put_generic Method.old_section_parser true) #>
  66.284 -      (parse_term_args args --|
  66.285 -        Method.sections modifiers --
  66.286 -        (*Scan.depend (fn context => Scan.succeed () >> (K (fold XNamed_Theorems.empty uses_nms context, ()))) --*)  (* FIXME *)
  66.287 -        parse_method_args method_names >> eval);
  66.288 +      (parse_term_args args --
  66.289 +        parse_method_args method_names --|
  66.290 +        (Scan.depend (fn context =>
  66.291 +              Scan.succeed (Context.map_proof (fold empty_named_thm uses_nms) context,())) --
  66.292 +         Method.sections modifiers) >> eval);
  66.293  
  66.294      val lthy3 = lthy2
  66.295 +      |> fold dummy_named_thm named_thms
  66.296        |> Method.local_setup (Binding.make (Binding.name_of name, Position.none))
  66.297          (parser term_args
  66.298            (fn (fixes, decl) => fn ctxt => get_recursive_method ctxt fixes (decl ctxt))) "(internal)";
  66.299  
  66.300 -    val (src, text) = read_text_closure lthy3 body;
  66.301 +    val (src, text) = read_text_closure lthy3 source;
  66.302  
  66.303      val morphism =
  66.304        Variable.export_morphism lthy3
  66.305 @@ -335,10 +391,11 @@
  66.306  val _ =
  66.307    Outer_Syntax.local_theory @{command_keyword method} "Eisbach method definition"
  66.308      (Parse.binding -- Parse.for_fixes --
  66.309 -      ((Scan.optional (@{keyword "uses"} |-- Parse.!!! (Scan.repeat1 Parse.binding)) []) --
  66.310 -        (Scan.optional (@{keyword "declares"} |-- Parse.!!! (Scan.repeat1 Parse.binding)) [])) --
  66.311 -      (Scan.optional (@{keyword "methods"} |-- Parse.!!! (Scan.repeat1 Parse.binding)) []) --
  66.312 -      Parse.!!! (@{keyword "="} |-- Parse.token Parse.cartouche)
  66.313 -      >> (fn ((((name, vars), (uses, attribs)), methods), cartouche) =>
  66.314 -        method_definition_cmd name vars uses attribs methods (Token.input_of cartouche)));
  66.315 +      ((Scan.optional (@{keyword "methods"} |-- Parse.!!! (Scan.repeat1 Parse.binding)) []) --
  66.316 +        (Scan.optional (@{keyword "uses"} |-- Parse.!!! (Scan.repeat1 Parse.binding)) [])) --
  66.317 +      (Scan.optional (@{keyword "declares"} |-- Parse.!!! (Scan.repeat1 Parse.binding)) []) --
  66.318 +      Parse.!!! (@{keyword "="}
  66.319 +        |-- (Parse.position (Parse.args1 (K true)) >> (fn (args, pos) => Token.src ("", pos) args)))
  66.320 +      >> (fn ((((name, vars), (methods, uses)), attribs), source) =>
  66.321 +        method_definition_cmd name vars uses attribs methods source));
  66.322  end;
    67.1 --- a/src/HOL/Eisbach/parse_tools.ML	Sat May 23 22:13:24 2015 +0200
    67.2 +++ b/src/HOL/Eisbach/parse_tools.ML	Mon May 25 22:11:43 2015 +0200
    67.3 @@ -1,4 +1,4 @@
    67.4 -(*  Title:      parse_tools.ML
    67.5 +(*  Title:      HOL/Eisbach/parse_tools.ML
    67.6      Author:     Daniel Matichuk, NICTA/UNSW
    67.7  
    67.8  Simple tools for deferred stateful token values.
    67.9 @@ -6,18 +6,21 @@
   67.10  
   67.11  signature PARSE_TOOLS =
   67.12  sig
   67.13 +
   67.14    datatype ('a, 'b) parse_val =
   67.15      Real_Val of 'a
   67.16 -  | Parse_Val of 'b * ('a -> unit)
   67.17 +  | Parse_Val of 'b * ('a -> unit);
   67.18  
   67.19 -  val parse_term_val : 'b parser -> (term, 'b) parse_val parser
   67.20 -
   67.21 -  val name_term : (term, string) parse_val parser
   67.22    val is_real_val : ('a, 'b) parse_val -> bool
   67.23  
   67.24    val the_real_val : ('a, 'b) parse_val -> 'a
   67.25    val the_parse_val : ('a, 'b) parse_val -> 'b
   67.26    val the_parse_fun : ('a, 'b) parse_val -> ('a -> unit)
   67.27 +
   67.28 +  val parse_val_cases: ('b -> 'a) -> ('a, 'b) parse_val -> ('a * ('a -> unit))
   67.29 +
   67.30 +  val parse_term_val : 'b parser -> (term, 'b) parse_val parser
   67.31 +  val name_term : (term, string) parse_val parser
   67.32  end;
   67.33  
   67.34  structure Parse_Tools: PARSE_TOOLS =
   67.35 @@ -46,4 +49,7 @@
   67.36  fun the_parse_fun (Parse_Val (_, f)) = f
   67.37    | the_parse_fun _ = raise Fail "Expected open parsed value";
   67.38  
   67.39 +fun parse_val_cases g (Parse_Val (b, f)) = (g b, f)
   67.40 +  | parse_val_cases _ (Real_Val v) = (v, K ());
   67.41 +
   67.42  end;
    68.1 --- a/src/HOL/Library/FSet.thy	Sat May 23 22:13:24 2015 +0200
    68.2 +++ b/src/HOL/Library/FSet.thy	Mon May 25 22:11:43 2015 +0200
    68.3 @@ -1001,14 +1001,16 @@
    68.4      folded size_fset_overloaded_def]
    68.5  
    68.6  lemma fset_size_o_map: "inj f \<Longrightarrow> size_fset g \<circ> fimage f = size_fset (g \<circ> f)"
    68.7 -  unfolding size_fset_def fimage_def
    68.8 -  by (auto simp: Abs_fset_inverse setsum.reindex_cong[OF subset_inj_on[OF _ top_greatest]])
    68.9 -
   68.10 +  apply (subst fun_eq_iff)
   68.11 +  including fset.lifting by transfer (auto intro: setsum.reindex_cong subset_inj_on)
   68.12 +  
   68.13  setup {*
   68.14  BNF_LFP_Size.register_size_global @{type_name fset} @{const_name size_fset}
   68.15    @{thms size_fset_simps size_fset_overloaded_simps} @{thms fset_size_o_map}
   68.16  *}
   68.17  
   68.18 +lifting_update fset.lifting
   68.19 +lifting_forget fset.lifting
   68.20  
   68.21  subsection {* Advanced relator customization *}
   68.22  
    69.1 --- a/src/HOL/Library/refute.ML	Sat May 23 22:13:24 2015 +0200
    69.2 +++ b/src/HOL/Library/refute.ML	Mon May 25 22:11:43 2015 +0200
    69.3 @@ -2969,7 +2969,7 @@
    69.4      "try to find a model that refutes a given subgoal"
    69.5      (scan_parms -- Scan.optional Parse.nat 1 >>
    69.6        (fn (parms, i) =>
    69.7 -        Toplevel.keep (fn state =>
    69.8 +        Toplevel.keep_proof (fn state =>
    69.9            let
   69.10              val ctxt = Toplevel.context_of state;
   69.11              val {goal = st, ...} = Proof.raw_goal (Toplevel.proof_of state);
    70.1 --- a/src/HOL/Lifting.thy	Sat May 23 22:13:24 2015 +0200
    70.2 +++ b/src/HOL/Lifting.thy	Mon May 25 22:11:43 2015 +0200
    70.3 @@ -265,6 +265,13 @@
    70.4    shows "part_equivp (eq_onp P)"
    70.5    using typedef_to_part_equivp [OF assms] by simp
    70.6  
    70.7 +lemma type_definition_Quotient_not_empty: "Quotient (eq_onp P) Abs Rep T \<Longrightarrow> \<exists>x. P x"
    70.8 +unfolding eq_onp_def by (drule Quotient_rep_reflp) blast
    70.9 +
   70.10 +lemma type_definition_Quotient_not_empty_witness: "Quotient (eq_onp P) Abs Rep T \<Longrightarrow> P (Rep undefined)"
   70.11 +unfolding eq_onp_def by (drule Quotient_rep_reflp) blast
   70.12 +
   70.13 +
   70.14  text {* Generating transfer rules for quotients. *}
   70.15  
   70.16  context
   70.17 @@ -538,6 +545,12 @@
   70.18  
   70.19  end
   70.20  
   70.21 +(* needed for lifting_def_code_dt.ML (moved from Lifting_Set) *)
   70.22 +lemma right_total_UNIV_transfer: 
   70.23 +  assumes "right_total A"
   70.24 +  shows "(rel_set A) (Collect (Domainp A)) UNIV"
   70.25 +  using assms unfolding right_total_def rel_set_def Domainp_iff by blast
   70.26 +
   70.27  subsection {* ML setup *}
   70.28  
   70.29  ML_file "Tools/Lifting/lifting_util.ML"
   70.30 @@ -555,6 +568,7 @@
   70.31  ML_file "Tools/Lifting/lifting_term.ML"
   70.32  ML_file "Tools/Lifting/lifting_def.ML"
   70.33  ML_file "Tools/Lifting/lifting_setup.ML"
   70.34 +ML_file "Tools/Lifting/lifting_def_code_dt.ML"
   70.35  
   70.36  hide_const (open) POS NEG
   70.37  
    71.1 --- a/src/HOL/Lifting_Set.thy	Sat May 23 22:13:24 2015 +0200
    71.2 +++ b/src/HOL/Lifting_Set.thy	Mon May 25 22:11:43 2015 +0200
    71.3 @@ -205,10 +205,7 @@
    71.4    shows "(rel_set A ===> rel_set A ===> op =) (op \<subseteq>) (op \<subseteq>)"
    71.5    unfolding subset_eq [abs_def] by transfer_prover
    71.6  
    71.7 -lemma right_total_UNIV_transfer[transfer_rule]: 
    71.8 -  assumes "right_total A"
    71.9 -  shows "(rel_set A) (Collect (Domainp A)) UNIV"
   71.10 -  using assms unfolding right_total_def rel_set_def Domainp_iff by blast
   71.11 +declare right_total_UNIV_transfer[transfer_rule]
   71.12  
   71.13  lemma UNIV_transfer [transfer_rule]:
   71.14    assumes "bi_total A"
    72.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    72.2 +++ b/src/HOL/Quotient_Examples/Lifting_Code_Dt_Test.thy	Mon May 25 22:11:43 2015 +0200
    72.3 @@ -0,0 +1,101 @@
    72.4 +(*  Title:      HOL/Quotient_Examples/Lifting_Code_Dt_Test.thy
    72.5 +    Author:     Ondrej Kuncar, TU Muenchen
    72.6 +    Copyright   2015
    72.7 +
    72.8 +Miscellaneous lift_definition(code_dt) definitions (for testing purposes).
    72.9 +*)
   72.10 +
   72.11 +theory Lifting_Code_Dt_Test
   72.12 +imports Main
   72.13 +begin
   72.14 +
   72.15 +(* basic examples *)
   72.16 +
   72.17 +typedef bool2 = "{x. x}" by auto
   72.18 +
   72.19 +setup_lifting type_definition_bool2
   72.20 +
   72.21 +lift_definition(code_dt) f1 :: "bool2 option" is "Some True" by simp
   72.22 +
   72.23 +lift_definition(code_dt) f2 :: "bool2 list" is "[True]" by simp
   72.24 +
   72.25 +lift_definition(code_dt) f3 :: "bool2 \<times> int" is "(True, 42)" by simp
   72.26 +
   72.27 +lift_definition(code_dt) f4 :: "int + bool2" is "Inr True" by simp
   72.28 +
   72.29 +lift_definition(code_dt) f5 :: "'a \<Rightarrow> (bool2 \<times> 'a) option" is "\<lambda>x. Some (True, x)" by simp
   72.30 +
   72.31 +(* ugly (i.e., sensitive to rewriting done in my tactics) definition of T *)
   72.32 +
   72.33 +typedef 'a T = "{ x::'a. \<forall>(y::'a) z::'a. \<exists>(w::'a). (z = z) \<and> eq_onp top y y 
   72.34 +  \<or> rel_prod (eq_onp top) (eq_onp top) (x, y) (x, y) \<longrightarrow> pred_prod top top (w, w) }"
   72.35 +  by auto
   72.36 +
   72.37 +setup_lifting type_definition_T
   72.38 +
   72.39 +lift_definition(code_dt) f6 :: "bool T option" is "Some True" by simp
   72.40 +
   72.41 +lift_definition(code_dt) f7 :: "(bool T \<times> int) option" is "Some (True, 42)" by simp
   72.42 +
   72.43 +lift_definition(code_dt) f8 :: "bool T \<Rightarrow> int \<Rightarrow> (bool T \<times> int) option" 
   72.44 +  is "\<lambda>x y. if x then Some (x, y) else None" by simp
   72.45 +
   72.46 +lift_definition(code_dt) f9 :: "nat \<Rightarrow> ((bool T \<times> int) option) list \<times> nat" 
   72.47 +  is "\<lambda>x. ([Some (True, 42)], x)" by simp
   72.48 +
   72.49 +(* complicated nested datatypes *)
   72.50 +
   72.51 +(* stolen from Datatype_Examples *)
   72.52 +datatype 'a tree = Empty | Node 'a "'a tree list"
   72.53 +
   72.54 +datatype 'a ttree = TEmpty | TNode 'a "'a ttree list tree"
   72.55 +
   72.56 +datatype 'a tttree = TEmpty | TNode 'a "'a tttree list ttree list tree"
   72.57 +
   72.58 +lift_definition(code_dt) f10 :: "int \<Rightarrow> int T tree" is "\<lambda>i. Node i [Node i Nil, Empty]" by simp
   72.59 +
   72.60 +lift_definition(code_dt) f11 :: "int \<Rightarrow> int T ttree" 
   72.61 +  is "\<lambda>i. ttree.TNode i (Node [ttree.TNode i Empty] [])" by simp
   72.62 +
   72.63 +lift_definition(code_dt) f12 :: "int \<Rightarrow> int T tttree" is "\<lambda>i. tttree.TNode i Empty" by simp
   72.64 +
   72.65 +(* Phantom type variables *)
   72.66 +
   72.67 +datatype 'a phantom = PH1 | PH2 
   72.68 +
   72.69 +datatype ('a, 'b) phantom2 = PH21 'a | PH22 "'a option"
   72.70 +
   72.71 +lift_definition(code_dt) f13 :: "int \<Rightarrow> int T phantom" is "\<lambda>i. PH1" by auto
   72.72 +
   72.73 +lift_definition(code_dt) f14 :: "int \<Rightarrow> (int T, nat T) phantom2" is "\<lambda>i. PH22 (Some i)" by auto
   72.74 +
   72.75 +(* Mutual datatypes *)
   72.76 +
   72.77 +datatype 'a M1 = Empty 'a | CM "'a M2"
   72.78 +and 'a M2 = CM2 "'a M1"
   72.79 +
   72.80 +lift_definition(code_dt) f15 :: "int \<Rightarrow> int T M1" is "\<lambda>i. Empty i" by auto
   72.81 +
   72.82 +(* Codatatypes *)
   72.83 +
   72.84 +codatatype 'a stream = S 'a "'a stream"
   72.85 +
   72.86 +primcorec 
   72.87 +  sconst :: "'a \<Rightarrow> 'a stream" where
   72.88 +  "sconst a = S a (sconst a)"
   72.89 +
   72.90 +lift_definition(code_dt) f16 :: "int \<Rightarrow> int T stream" is "\<lambda>i. sconst i"  unfolding pred_stream_def
   72.91 +by auto
   72.92 +
   72.93 +(* Sort constraints *)
   72.94 +
   72.95 +datatype ('a::finite, 'b::finite) F = F 'a | F2 'b
   72.96 +
   72.97 +instance T :: (finite) finite by (default, transfer, auto)
   72.98 +
   72.99 +lift_definition(code_dt) f17 :: "bool \<Rightarrow> (bool T, 'b::finite) F" is "\<lambda>b. F b" by auto
  72.100 +
  72.101 +export_code f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 
  72.102 +  checking SML OCaml? Haskell? Scala? 
  72.103 +
  72.104 +end
    73.1 --- a/src/HOL/ROOT	Sat May 23 22:13:24 2015 +0200
    73.2 +++ b/src/HOL/ROOT	Mon May 25 22:11:43 2015 +0200
    73.3 @@ -962,6 +962,7 @@
    73.4      Quotient_Rat
    73.5      Lift_DList
    73.6      Int_Pow
    73.7 +    Lifting_Code_Dt_Test
    73.8  
    73.9  session "HOL-Predicate_Compile_Examples" in Predicate_Compile_Examples = HOL +
   73.10    options [document = false]
    74.1 --- a/src/HOL/SMT.thy	Sat May 23 22:13:24 2015 +0200
    74.2 +++ b/src/HOL/SMT.thy	Mon May 25 22:11:43 2015 +0200
    74.3 @@ -49,7 +49,7 @@
    74.4  *}
    74.5  
    74.6  method_setup moura = {*
    74.7 - Scan.succeed (SIMPLE_METHOD' o moura_tac)
    74.8 +  Scan.succeed (SIMPLE_METHOD' o moura_tac)
    74.9  *} "solve skolemization goals, especially those arising from Z3 proofs"
   74.10  
   74.11  hide_fact (open) choices bchoices
    75.1 --- a/src/HOL/Tools/BNF/bnf_comp.ML	Sat May 23 22:13:24 2015 +0200
    75.2 +++ b/src/HOL/Tools/BNF/bnf_comp.ML	Mon May 25 22:11:43 2015 +0200
    75.3 @@ -149,10 +149,10 @@
    75.4    let
    75.5      val olive = live_of_bnf outer;
    75.6      val onwits = nwits_of_bnf outer;
    75.7 -    val odead = dead_of_bnf outer;
    75.8 +    val odeads = deads_of_bnf outer;
    75.9      val inner = hd inners;
   75.10      val ilive = live_of_bnf inner;
   75.11 -    val ideads = map dead_of_bnf inners;
   75.12 +    val ideadss = map deads_of_bnf inners;
   75.13      val inwitss = map nwits_of_bnf inners;
   75.14  
   75.15      (* TODO: check olive = length inners > 0,
   75.16 @@ -160,9 +160,9 @@
   75.17                     forall inner from inners. idead = dead  *)
   75.18  
   75.19      val (oDs, lthy1) = apfst (map TFree)
   75.20 -      (Variable.invent_types (replicate odead @{sort type}) lthy);
   75.21 +      (Variable.invent_types (map Type.sort_of_atyp odeads) lthy);
   75.22      val (Dss, lthy2) = apfst (map (map TFree))
   75.23 -      (fold_map Variable.invent_types (map (fn n => replicate n @{sort type}) ideads) lthy1);
   75.24 +      (fold_map Variable.invent_types (map (map Type.sort_of_atyp) ideadss) lthy1);
   75.25      val (Ass, lthy3) = apfst (replicate ilive o map TFree)
   75.26        (Variable.invent_types (replicate ilive @{sort type}) lthy2);
   75.27      val As = if ilive > 0 then hd Ass else [];
   75.28 @@ -379,13 +379,13 @@
   75.29    let
   75.30      val b = Binding.suffix_name (mk_killN n) (name_of_bnf bnf);
   75.31      val live = live_of_bnf bnf;
   75.32 -    val dead = dead_of_bnf bnf;
   75.33 +    val deads = deads_of_bnf bnf;
   75.34      val nwits = nwits_of_bnf bnf;
   75.35  
   75.36      (* TODO: check 0 < n <= live *)
   75.37  
   75.38      val (Ds, lthy1) = apfst (map TFree)
   75.39 -      (Variable.invent_types (replicate dead @{sort type}) lthy);
   75.40 +      (Variable.invent_types (map Type.sort_of_atyp deads) lthy);
   75.41      val ((killedAs, As), lthy2) = apfst (`(take n) o map TFree)
   75.42        (Variable.invent_types (replicate live @{sort type}) lthy1);
   75.43      val (Bs, _(*lthy3*)) = apfst (append killedAs o map TFree)
   75.44 @@ -478,13 +478,13 @@
   75.45    let
   75.46      val b = Binding.suffix_name (mk_liftN n) (name_of_bnf bnf);
   75.47      val live = live_of_bnf bnf;
   75.48 -    val dead = dead_of_bnf bnf;
   75.49 +    val deads = deads_of_bnf bnf;
   75.50      val nwits = nwits_of_bnf bnf;
   75.51  
   75.52      (* TODO: check 0 < n *)
   75.53  
   75.54      val (Ds, lthy1) = apfst (map TFree)
   75.55 -      (Variable.invent_types (replicate dead @{sort type}) lthy);
   75.56 +      (Variable.invent_types (map Type.sort_of_atyp deads) lthy);
   75.57      val ((newAs, As), lthy2) = apfst (chop n o map TFree)
   75.58        (Variable.invent_types (replicate (n + live) @{sort type}) lthy1);
   75.59      val ((newBs, Bs), _(*lthy3*)) = apfst (chop n o map TFree)
   75.60 @@ -568,14 +568,14 @@
   75.61    let
   75.62      val b = Binding.suffix_name (mk_permuteN src dest) (name_of_bnf bnf);
   75.63      val live = live_of_bnf bnf;
   75.64 -    val dead = dead_of_bnf bnf;
   75.65 +    val deads = deads_of_bnf bnf;
   75.66      val nwits = nwits_of_bnf bnf;
   75.67  
   75.68      fun permute xs = permute_like_unique (op =) src dest xs;
   75.69      fun unpermute xs = permute_like_unique (op =) dest src xs;
   75.70  
   75.71      val (Ds, lthy1) = apfst (map TFree)
   75.72 -      (Variable.invent_types (replicate dead @{sort type}) lthy);
   75.73 +      (Variable.invent_types (map Type.sort_of_atyp deads) lthy);
   75.74      val (As, lthy2) = apfst (map TFree)
   75.75        (Variable.invent_types (replicate live @{sort type}) lthy1);
   75.76      val (Bs, _(*lthy3*)) = apfst (map TFree)
    76.1 --- a/src/HOL/Tools/BNF/bnf_gfp_rec_sugar_tactics.ML	Sat May 23 22:13:24 2015 +0200
    76.2 +++ b/src/HOL/Tools/BNF/bnf_gfp_rec_sugar_tactics.ML	Mon May 25 22:11:43 2015 +0200
    76.3 @@ -37,6 +37,8 @@
    76.4  val split_connectI = @{thms allI impI conjI};
    76.5  val unfold_lets = @{thms Let_def[abs_def] split_beta}
    76.6  
    76.7 +fun clean_blast_tac ctxt = blast_tac (put_claset (claset_of @{theory_context HOL}) ctxt);
    76.8 +
    76.9  fun exhaust_inst_as_projs ctxt frees thm =
   76.10    let
   76.11      val num_frees = length frees;
    77.1 --- a/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML	Sat May 23 22:13:24 2015 +0200
    77.2 +++ b/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML	Mon May 25 22:11:43 2015 +0200
    77.3 @@ -397,7 +397,13 @@
    77.4  
    77.5      val ctrs0 = map (prep_term no_defs_lthy) raw_ctrs;
    77.6  
    77.7 -    val Type (fcT_name, As0) = body_type (fastype_of (hd ctrs0));
    77.8 +    val (fcT_name, As0) =
    77.9 +      (case body_type (fastype_of (hd ctrs0)) of
   77.10 +        Type T' => T'
   77.11 +      | _ => error "Expected type constructor in body type of constructor");
   77.12 +    val _ = forall ((fn Type (T_name, _) => T_name = fcT_name | _ => false) o body_type
   77.13 +      o fastype_of) (tl ctrs0) orelse error "Constructors not constructing same type";
   77.14 +
   77.15      val fc_b_name = Long_Name.base_name fcT_name;
   77.16      val fc_b = Binding.name fc_b_name;
   77.17  
   77.18 @@ -675,7 +681,7 @@
   77.19  
   77.20      val goalss = [exhaust_goal] :: inject_goalss @ half_distinct_goalss;
   77.21  
   77.22 -    fun after_qed (thmss0 as [exhaust_thm] :: thmss) lthy =
   77.23 +    fun after_qed ([exhaust_thm] :: thmss) lthy =
   77.24        let
   77.25          val ((inject_thms, inject_thmss), half_distinct_thmss) = chop n thmss |>> `flat;
   77.26  
   77.27 @@ -751,7 +757,7 @@
   77.28  
   77.29          fun prove_split selss goal =
   77.30            Goal.prove_sorry lthy [] [] goal (fn _ =>
   77.31 -            mk_split_tac lthy uexhaust_thm case_thms selss inject_thmss distinct_thmsss)
   77.32 +            mk_split_tac lthy ms uexhaust_thm case_thms selss inject_thmss distinct_thmsss)
   77.33            |> singleton (Proof_Context.export names_lthy lthy)
   77.34            |> Thm.close_derivation;
   77.35  
    78.1 --- a/src/HOL/Tools/Ctr_Sugar/ctr_sugar_tactics.ML	Sat May 23 22:13:24 2015 +0200
    78.2 +++ b/src/HOL/Tools/Ctr_Sugar/ctr_sugar_tactics.ML	Mon May 25 22:11:43 2015 +0200
    78.3 @@ -7,7 +7,6 @@
    78.4  
    78.5  signature CTR_SUGAR_GENERAL_TACTICS =
    78.6  sig
    78.7 -  val clean_blast_tac: Proof.context -> int -> tactic
    78.8    val select_prem_tac: int -> (int -> tactic) -> int -> int -> tactic
    78.9    val unfold_thms_tac: Proof.context -> thm list -> tactic
   78.10  end;
   78.11 @@ -32,8 +31,8 @@
   78.12    val mk_half_distinct_disc_tac: Proof.context -> int -> thm -> thm -> tactic
   78.13    val mk_nchotomy_tac: int -> thm -> tactic
   78.14    val mk_other_half_distinct_disc_tac: thm -> tactic
   78.15 -  val mk_split_tac: Proof.context -> thm -> thm list -> thm list list -> thm list list ->
   78.16 -    thm list list list -> tactic
   78.17 +  val mk_split_tac: Proof.context -> int list -> thm -> thm list -> thm list list ->
   78.18 +    thm list list -> thm list list list -> tactic
   78.19    val mk_split_asm_tac: Proof.context -> thm -> tactic
   78.20    val mk_unique_disc_def_tac: int -> thm -> tactic
   78.21  end;
   78.22 @@ -45,8 +44,6 @@
   78.23  
   78.24  val meta_mp = @{thm meta_mp};
   78.25  
   78.26 -fun clean_blast_tac ctxt = blast_tac (put_claset (claset_of @{theory_context HOL}) ctxt);
   78.27 -
   78.28  fun select_prem_tac n tac k = DETERM o (EVERY' [REPEAT_DETERM_N (k - 1) o etac thin_rl,
   78.29    tac, REPEAT_DETERM_N (n - k) o etac thin_rl]);
   78.30  
   78.31 @@ -170,12 +167,17 @@
   78.32            rtac casex])
   78.33        cases (map2 (seq_conds if_P_or_not_P_OF n) (1 upto n) discss') selss));
   78.34  
   78.35 -fun mk_split_tac ctxt uexhaust cases selss injectss distinctsss =
   78.36 -  HEADGOAL (rtac uexhaust) THEN
   78.37 -  ALLGOALS (fn k => (hyp_subst_tac ctxt THEN'
   78.38 -     simp_tac (ss_only (@{thms simp_thms} @ cases @ nth selss (k - 1) @ nth injectss (k - 1) @
   78.39 -       flat (nth distinctsss (k - 1))) ctxt)) k) THEN
   78.40 -  ALLGOALS (clean_blast_tac ctxt);
   78.41 +fun mk_split_tac ctxt ms uexhaust cases selss injectss distinctsss =
   78.42 +  let val depth = fold Integer.max ms 0 in
   78.43 +    HEADGOAL (rtac uexhaust) THEN
   78.44 +    ALLGOALS (fn k => (hyp_subst_tac ctxt THEN'
   78.45 +       simp_tac (ss_only (@{thms simp_thms} @ cases @ nth selss (k - 1) @ nth injectss (k - 1) @
   78.46 +         flat (nth distinctsss (k - 1))) ctxt)) k) THEN
   78.47 +    ALLGOALS (etac thin_rl THEN' rtac iffI THEN'
   78.48 +      REPEAT_DETERM o rtac allI THEN' rtac impI THEN' REPEAT_DETERM o etac conjE THEN'
   78.49 +      hyp_subst_tac ctxt THEN' atac THEN' REPEAT_DETERM o etac allE THEN' etac impE THEN'
   78.50 +      REPEAT_DETERM o (rtac conjI THEN' rtac refl) THEN' rtac refl THEN' atac)
   78.51 +  end;
   78.52  
   78.53  val split_asm_thms = @{thms imp_conv_disj de_Morgan_conj de_Morgan_disj not_not not_ex};
   78.54  
    79.1 --- a/src/HOL/Tools/Lifting/lifting_bnf.ML	Sat May 23 22:13:24 2015 +0200
    79.2 +++ b/src/HOL/Tools/Lifting/lifting_bnf.ML	Mon May 25 22:11:43 2015 +0200
    79.3 @@ -87,9 +87,8 @@
    79.4  
    79.5  fun relator_eq_onp bnf ctxt =
    79.6    let
    79.7 -    val relator_eq_onp_thm = lookup_defined_pred_data ctxt (type_name_of_bnf bnf)
    79.8 -      |> Transfer.rel_eq_onp |> Conv.fconv_rule (HOLogic.Trueprop_conv (Conv.arg1_conv 
    79.9 -          (Raw_Simplifier.rewrite ctxt false @{thms eq_onp_top_eq_eq[THEN eq_reflection]})))
   79.10 +    val relator_eq_onp_thm = lookup_defined_pred_data ctxt (type_name_of_bnf bnf) 
   79.11 +      |> Transfer.rel_eq_onp
   79.12    in
   79.13      [((Binding.empty, []), [([relator_eq_onp_thm], @{attributes [relator_eq_onp]})])]    
   79.14    end
    80.1 --- a/src/HOL/Tools/Lifting/lifting_def.ML	Sat May 23 22:13:24 2015 +0200
    80.2 +++ b/src/HOL/Tools/Lifting/lifting_def.ML	Mon May 25 22:11:43 2015 +0200
    80.3 @@ -6,15 +6,48 @@
    80.4  
    80.5  signature LIFTING_DEF =
    80.6  sig
    80.7 +  datatype code_eq = UNKNOWN_EQ | NONE_EQ | ABS_EQ | REP_EQ
    80.8 +  type lift_def
    80.9 +  val rty_of_lift_def: lift_def -> typ
   80.10 +  val qty_of_lift_def: lift_def -> typ
   80.11 +  val rhs_of_lift_def: lift_def -> term
   80.12 +  val lift_const_of_lift_def: lift_def -> term
   80.13 +  val def_thm_of_lift_def: lift_def -> thm
   80.14 +  val rsp_thm_of_lift_def: lift_def -> thm
   80.15 +  val abs_eq_of_lift_def: lift_def -> thm
   80.16 +  val rep_eq_of_lift_def: lift_def -> thm option
   80.17 +  val code_eq_of_lift_def: lift_def -> code_eq
   80.18 +  val transfer_rules_of_lift_def: lift_def -> thm list
   80.19 +  val morph_lift_def: morphism -> lift_def -> lift_def
   80.20 +  val inst_of_lift_def: Proof.context -> typ -> lift_def -> lift_def
   80.21 +  val mk_lift_const_of_lift_def: typ -> lift_def -> term
   80.22 +
   80.23 +  type config = { notes: bool }
   80.24 +  val map_config: (bool -> bool) -> config -> config
   80.25 +  val default_config: config
   80.26 +
   80.27    val generate_parametric_transfer_rule:
   80.28      Proof.context -> thm -> thm -> thm
   80.29  
   80.30 -  val add_lift_def:
   80.31 -    (binding * mixfix) -> typ -> term -> thm -> thm list -> local_theory -> local_theory
   80.32 +  val add_lift_def: 
   80.33 +    config -> binding * mixfix -> typ -> term -> thm -> thm list -> local_theory -> 
   80.34 +      lift_def * local_theory
   80.35 +  
   80.36 +  val prepare_lift_def:
   80.37 +    (binding * mixfix -> typ -> term -> thm -> thm list -> Proof.context -> 
   80.38 +      lift_def * local_theory) -> 
   80.39 +    binding * mixfix -> typ -> term -> thm list -> local_theory -> 
   80.40 +    term option * (thm -> Proof.context -> lift_def * local_theory)
   80.41  
   80.42 -  val lift_def_cmd:
   80.43 -    (binding * string option * mixfix) * string * (Facts.ref * Token.src list) list ->
   80.44 -    local_theory -> Proof.state
   80.45 +  val gen_lift_def:
   80.46 +    (binding * mixfix -> typ -> term -> thm -> thm list -> local_theory -> 
   80.47 +      lift_def * local_theory) -> 
   80.48 +    binding * mixfix -> typ -> term -> (Proof.context -> tactic) -> thm list -> 
   80.49 +    local_theory -> lift_def * local_theory
   80.50 +
   80.51 +  val lift_def: 
   80.52 +    config -> binding * mixfix -> typ -> term -> (Proof.context -> tactic) -> thm list -> 
   80.53 +    local_theory -> lift_def * local_theory
   80.54  
   80.55    val can_generate_code_cert: thm -> bool
   80.56  end
   80.57 @@ -26,6 +59,70 @@
   80.58  
   80.59  infix 0 MRSL
   80.60  
   80.61 +datatype code_eq = UNKNOWN_EQ | NONE_EQ | ABS_EQ | REP_EQ
   80.62 +
   80.63 +datatype lift_def = LIFT_DEF of {
   80.64 +  rty: typ,
   80.65 +  qty: typ,
   80.66 +  rhs: term,
   80.67 +  lift_const: term,
   80.68 +  def_thm: thm,
   80.69 +  rsp_thm: thm,
   80.70 +  abs_eq: thm,
   80.71 +  rep_eq: thm option,
   80.72 +  code_eq: code_eq,
   80.73 +  transfer_rules: thm list
   80.74 +};
   80.75 +
   80.76 +fun rep_lift_def (LIFT_DEF lift_def) = lift_def;
   80.77 +val rty_of_lift_def = #rty o rep_lift_def;
   80.78 +val qty_of_lift_def = #qty o rep_lift_def;
   80.79 +val rhs_of_lift_def = #rhs o rep_lift_def;
   80.80 +val lift_const_of_lift_def = #lift_const o rep_lift_def;
   80.81 +val def_thm_of_lift_def = #def_thm o rep_lift_def;
   80.82 +val rsp_thm_of_lift_def = #rsp_thm o rep_lift_def;
   80.83 +val abs_eq_of_lift_def = #abs_eq o rep_lift_def;
   80.84 +val rep_eq_of_lift_def = #rep_eq o rep_lift_def;
   80.85 +val code_eq_of_lift_def = #code_eq o rep_lift_def;
   80.86 +val transfer_rules_of_lift_def = #transfer_rules o rep_lift_def;
   80.87 +
   80.88 +fun mk_lift_def rty qty rhs lift_const def_thm rsp_thm abs_eq rep_eq code_eq transfer_rules =
   80.89 +  LIFT_DEF {rty = rty, qty = qty,
   80.90 +            rhs = rhs, lift_const = lift_const,
   80.91 +            def_thm = def_thm, rsp_thm = rsp_thm, abs_eq = abs_eq, rep_eq = rep_eq, 
   80.92 +            code_eq = code_eq, transfer_rules = transfer_rules };
   80.93 +
   80.94 +fun map_lift_def f1 f2 f3 f4 f5 f6 f7 f8 f9 f10
   80.95 +  (LIFT_DEF {rty = rty, qty = qty, rhs = rhs, lift_const = lift_const,
   80.96 +  def_thm = def_thm, rsp_thm = rsp_thm, abs_eq = abs_eq, rep_eq = rep_eq, code_eq = code_eq,
   80.97 +  transfer_rules = transfer_rules }) =
   80.98 +  LIFT_DEF {rty = f1 rty, qty = f2 qty, rhs = f3 rhs, lift_const = f4 lift_const,
   80.99 +            def_thm = f5 def_thm, rsp_thm = f6 rsp_thm, abs_eq = f7 abs_eq, rep_eq = f8 rep_eq,
  80.100 +            code_eq = f9 code_eq, transfer_rules = f10 transfer_rules }
  80.101 +
  80.102 +fun morph_lift_def phi =
  80.103 +  let
  80.104 +    val mtyp = Morphism.typ phi
  80.105 +    val mterm = Morphism.term phi
  80.106 +    val mthm = Morphism.thm phi
  80.107 +  in
  80.108 +    map_lift_def mtyp mtyp mterm mterm mthm mthm mthm (Option.map mthm) I (map mthm)
  80.109 +  end
  80.110 +
  80.111 +fun mk_inst_of_lift_def qty lift_def = Vartab.empty |> Type.raw_match (qty_of_lift_def lift_def, qty)
  80.112 +
  80.113 +fun mk_lift_const_of_lift_def qty lift_def = Envir.subst_term_types (mk_inst_of_lift_def qty lift_def)
  80.114 +  (lift_const_of_lift_def lift_def)
  80.115 +
  80.116 +fun inst_of_lift_def ctxt qty lift_def =  mk_inst_of_lift_def qty lift_def
  80.117 +  |> instT_morphism ctxt |> (fn phi => morph_lift_def phi lift_def)
  80.118 +
  80.119 +(* Config *)
  80.120 +
  80.121 +type config = { notes: bool };
  80.122 +fun map_config f1 { notes = notes } = { notes = f1 notes }
  80.123 +val default_config = { notes = true };
  80.124 +
  80.125  (* Reflexivity prover *)
  80.126  
  80.127  fun mono_eq_prover ctxt prop =
  80.128 @@ -289,7 +386,6 @@
  80.129        SOME (simplify_code_eq ctxt (unabs_def RS @{thm meta_eq_to_obj_eq}))
  80.130      else 
  80.131        let
  80.132 -        val thy = Proof_Context.theory_of ctxt
  80.133          val quot_thm = Lifting_Term.prove_quot_thm ctxt (get_body_types (rty, qty))
  80.134          val rel_fun = prove_rel ctxt rsp_thm (rty, qty)
  80.135          val rep_abs_thm = [quot_thm, rel_fun] MRSL @{thm Quotient_rep_abs_eq}
  80.136 @@ -358,23 +454,39 @@
  80.137  
  80.138    in
  80.139      if is_valid_eq abs_eq_thm then
  80.140 -      Code.add_default_eqn abs_eq_thm thy
  80.141 +      (ABS_EQ, Code.add_default_eqn abs_eq_thm thy)
  80.142      else
  80.143        let
  80.144          val (rty_body, qty_body) = get_body_types (rty, qty)
  80.145        in
  80.146          if rty_body = qty_body then
  80.147 -         Code.add_default_eqn (the opt_rep_eq_thm) thy
  80.148 +          (REP_EQ, Code.add_default_eqn (the opt_rep_eq_thm) thy)
  80.149          else
  80.150            if is_some opt_rep_eq_thm andalso is_valid_abs_eq (the opt_rep_eq_thm)
  80.151            then
  80.152 -            Code.add_abs_default_eqn (the opt_rep_eq_thm) thy
  80.153 +            (REP_EQ, Code.add_abs_default_eqn (the opt_rep_eq_thm) thy)
  80.154            else
  80.155 -            thy
  80.156 +            (NONE_EQ, thy)
  80.157        end
  80.158    end
  80.159  
  80.160  local
  80.161 +  fun no_no_code ctxt (rty, qty) =
  80.162 +    if same_type_constrs (rty, qty) then
  80.163 +      forall (no_no_code ctxt) (Targs rty ~~ Targs qty)
  80.164 +    else
  80.165 +      if is_Type qty then
  80.166 +        if Lifting_Info.is_no_code_type ctxt (Tname qty) then false
  80.167 +        else 
  80.168 +          let 
  80.169 +            val (rty', rtyq) = Lifting_Term.instantiate_rtys ctxt (rty, qty)
  80.170 +            val (rty's, rtyqs) = (Targs rty', Targs rtyq)
  80.171 +          in
  80.172 +            forall (no_no_code ctxt) (rty's ~~ rtyqs)
  80.173 +          end
  80.174 +      else
  80.175 +        true
  80.176 +
  80.177    fun encode_code_eq ctxt abs_eq opt_rep_eq (rty, qty) = 
  80.178      let
  80.179        fun mk_type typ = typ |> Logic.mk_type |> Thm.cterm_of ctxt |> Drule.mk_term
  80.180 @@ -395,11 +507,20 @@
  80.181          (abs_eq, opt_rep_eq, (dest_type rty, dest_type qty)) 
  80.182        end
  80.183    
  80.184 +  structure Data = Generic_Data
  80.185 +  (
  80.186 +    type T = code_eq option
  80.187 +    val empty = NONE
  80.188 +    val extend = I
  80.189 +    fun merge _ = NONE
  80.190 +  );
  80.191 +
  80.192    fun register_encoded_code_eq thm thy =
  80.193      let
  80.194        val (abs_eq_thm, opt_rep_eq_thm, (rty, qty)) = decode_code_eq thm
  80.195 +      val (code_eq, thy) = register_code_eq_thy abs_eq_thm opt_rep_eq_thm (rty, qty) thy
  80.196      in
  80.197 -      register_code_eq_thy abs_eq_thm opt_rep_eq_thm (rty, qty) thy
  80.198 +      Context.theory_map (Data.put (SOME code_eq)) thy
  80.199      end
  80.200      handle DECODE => thy
  80.201    
  80.202 @@ -407,31 +528,28 @@
  80.203      (fn thm => Context.mapping (register_encoded_code_eq thm) I)
  80.204    val register_code_eq_attrib = Attrib.internal (K register_code_eq_attribute)
  80.205  
  80.206 -  fun no_no_code ctxt (rty, qty) =
  80.207 -    if same_type_constrs (rty, qty) then
  80.208 -      forall (no_no_code ctxt) (Targs rty ~~ Targs qty)
  80.209 -    else
  80.210 -      if is_Type qty then
  80.211 -        if Lifting_Info.is_no_code_type ctxt (Tname qty) then false
  80.212 -        else 
  80.213 -          let 
  80.214 -            val (rty', rtyq) = Lifting_Term.instantiate_rtys ctxt (rty, qty)
  80.215 -            val (rty's, rtyqs) = (Targs rty', Targs rtyq)
  80.216 -          in
  80.217 -            forall (no_no_code ctxt) (rty's ~~ rtyqs)
  80.218 -          end
  80.219 -      else
  80.220 -        true
  80.221  in
  80.222  
  80.223  fun register_code_eq abs_eq_thm opt_rep_eq_thm (rty, qty) lthy =
  80.224    let
  80.225      val encoded_code_eq = encode_code_eq lthy abs_eq_thm opt_rep_eq_thm (rty, qty)
  80.226    in
  80.227 -    if no_no_code lthy (rty, qty) then 
  80.228 -      (snd oo Local_Theory.note) ((Binding.empty, [register_code_eq_attrib]), [encoded_code_eq]) lthy
  80.229 +    if no_no_code lthy (rty, qty) then
  80.230 +      let
  80.231 +        val lthy = (snd oo Local_Theory.note) 
  80.232 +          ((Binding.empty, [register_code_eq_attrib]), [encoded_code_eq]) lthy
  80.233 +        val opt_code_eq = Data.get (Context.Theory (Proof_Context.theory_of lthy))
  80.234 +        val code_eq = if is_some opt_code_eq then the opt_code_eq 
  80.235 +          else UNKNOWN_EQ (* UNKNOWN_EQ means that we are in a locale and we do not know
  80.236 +            which code equation is going to be used. This is going to be resolved at the
  80.237 +            point when an interpretation of the locale is executed. *)
  80.238 +        val lthy = Local_Theory.declaration {syntax = false, pervasive = true} 
  80.239 +          (K (Data.put NONE)) lthy
  80.240 +      in
  80.241 +        (code_eq, lthy)
  80.242 +      end
  80.243      else
  80.244 -      lthy
  80.245 +      (NONE_EQ, lthy)
  80.246    end
  80.247  end
  80.248              
  80.249 @@ -447,7 +565,7 @@
  80.250    par_thms - a parametricity theorem for rhs
  80.251  *)
  80.252  
  80.253 -fun add_lift_def var qty rhs rsp_thm par_thms lthy =
  80.254 +fun add_lift_def (config: config) var qty rhs rsp_thm par_thms lthy =
  80.255    let
  80.256      val rty = fastype_of rhs
  80.257      val quot_thm = Lifting_Term.prove_quot_thm lthy (rty, qty)
  80.258 @@ -458,134 +576,44 @@
  80.259      val prop = Logic.mk_equals (lhs, absrep_trm $ forced_rhs)
  80.260      val (_, prop') = Local_Defs.cert_def lthy prop
  80.261      val (_, newrhs) = Local_Defs.abs_def prop'
  80.262 -
  80.263 -    val ((_, (_ , def_thm)), lthy') = 
  80.264 -      Local_Theory.define (var, ((Thm.def_binding (#1 var), []), newrhs)) lthy
  80.265 +    val var = (#notes config = false ? apfst Binding.concealed) var
  80.266 +    val def_name = if #notes config then Thm.def_binding (#1 var) else Binding.empty
  80.267 +    
  80.268 +    val ((lift_const, (_ , def_thm)), lthy) = 
  80.269 +      Local_Theory.define (var, ((def_name, []), newrhs)) lthy
  80.270  
  80.271 -    val transfer_rules = generate_transfer_rules lthy' quot_thm rsp_thm def_thm par_thms
  80.272 +    val transfer_rules = generate_transfer_rules lthy quot_thm rsp_thm def_thm par_thms
  80.273  
  80.274 -    val abs_eq_thm = generate_abs_eq lthy' def_thm rsp_thm quot_thm
  80.275 -    val opt_rep_eq_thm = generate_rep_eq lthy' def_thm rsp_thm (rty_forced, qty)
  80.276 +    val abs_eq_thm = generate_abs_eq lthy def_thm rsp_thm quot_thm
  80.277 +    val opt_rep_eq_thm = generate_rep_eq lthy def_thm rsp_thm (rty_forced, qty)
  80.278  
  80.279      fun qualify defname suffix = Binding.qualified true suffix defname
  80.280  
  80.281 -    val lhs_name = (#1 var)
  80.282 -    val rsp_thm_name = qualify lhs_name "rsp"
  80.283 -    val abs_eq_thm_name = qualify lhs_name "abs_eq"
  80.284 -    val rep_eq_thm_name = qualify lhs_name "rep_eq"
  80.285 -    val transfer_rule_name = qualify lhs_name "transfer"
  80.286 -    val transfer_attr = Attrib.internal (K Transfer.transfer_add)
  80.287 -  in
  80.288 -    lthy'
  80.289 -      |> (snd oo Local_Theory.note) ((rsp_thm_name, []), [rsp_thm])
  80.290 -      |> (snd oo Local_Theory.note) ((transfer_rule_name, [transfer_attr]), transfer_rules)
  80.291 -      |> (snd oo Local_Theory.note) ((abs_eq_thm_name, []), [abs_eq_thm])
  80.292 -      |> (case opt_rep_eq_thm of 
  80.293 -            SOME rep_eq_thm => (snd oo Local_Theory.note) ((rep_eq_thm_name, []), [rep_eq_thm])
  80.294 -            | NONE => I)
  80.295 -      |> register_code_eq abs_eq_thm opt_rep_eq_thm (rty_forced, qty)
  80.296 -  end
  80.297 -
  80.298 -local
  80.299 -  val eq_onp_assms_tac_fixed_rules = map (Transfer.prep_transfer_domain_thm @{context})
  80.300 -    [@{thm pcr_Domainp_total}, @{thm pcr_Domainp_par_left_total}, @{thm pcr_Domainp_par}, 
  80.301 -      @{thm pcr_Domainp}]
  80.302 -in
  80.303 -fun mk_readable_rsp_thm_eq tm lthy =
  80.304 -  let
  80.305 -    val ctm = Thm.cterm_of lthy tm
  80.306 -    
  80.307 -    fun assms_rewr_conv tactic rule ct =
  80.308 +    fun notes names =
  80.309        let
  80.310 -        fun prove_extra_assms thm =
  80.311 -          let
  80.312 -            val assms = cprems_of thm
  80.313 -            fun finish thm = if Thm.no_prems thm then SOME (Goal.conclude thm) else NONE
  80.314 -            fun prove ctm = Option.mapPartial finish (SINGLE tactic (Goal.init ctm))
  80.315 -          in
  80.316 -            map_interrupt prove assms
  80.317 -          end
  80.318 -    
  80.319 -        fun cconl_of thm = Drule.strip_imp_concl (Thm.cprop_of thm)
  80.320 -        fun lhs_of thm = fst (Thm.dest_equals (cconl_of thm))
  80.321 -        fun rhs_of thm = snd (Thm.dest_equals (cconl_of thm))
  80.322 -        val rule1 = Thm.incr_indexes (Thm.maxidx_of_cterm ct + 1) rule;
  80.323 -        val lhs = lhs_of rule1;
  80.324 -        val rule2 = Thm.rename_boundvars (Thm.term_of lhs) (Thm.term_of ct) rule1;
  80.325 -        val rule3 =
  80.326 -          Thm.instantiate (Thm.match (lhs, ct)) rule2
  80.327 -            handle Pattern.MATCH => raise CTERM ("assms_rewr_conv", [lhs, ct]);
  80.328 -        val proved_assms = prove_extra_assms rule3
  80.329 +        val lhs_name = (#1 var)
  80.330 +        val rsp_thmN = qualify lhs_name "rsp"
  80.331 +        val abs_eq_thmN = qualify lhs_name "abs_eq"
  80.332 +        val rep_eq_thmN = qualify lhs_name "rep_eq"
  80.333 +        val transfer_ruleN = qualify lhs_name "transfer"
  80.334 +        val notes = 
  80.335 +          [(rsp_thmN, [], [rsp_thm]), 
  80.336 +          (transfer_ruleN, @{attributes [transfer_rule]}, transfer_rules),
  80.337 +          (abs_eq_thmN, [], [abs_eq_thm])] 
  80.338 +          @ (case opt_rep_eq_thm of SOME rep_eq_thm => [(rep_eq_thmN, [], [rep_eq_thm])] | NONE => [])
  80.339        in
  80.340 -        case proved_assms of
  80.341 -          SOME proved_assms =>
  80.342 -            let
  80.343 -              val rule3 = proved_assms MRSL rule3
  80.344 -              val rule4 =
  80.345 -                if lhs_of rule3 aconvc ct then rule3
  80.346 -                else
  80.347 -                  let val ceq = Thm.dest_fun2 (Thm.cprop_of rule3)
  80.348 -                  in rule3 COMP Thm.trivial (Thm.mk_binop ceq ct (rhs_of rule3)) end
  80.349 -            in Thm.transitive rule4 (Thm.beta_conversion true (rhs_of rule4)) end
  80.350 -          | NONE => Conv.no_conv ct
  80.351 +        if names then map (fn (name, attrs, thms) => ((name, []), [(thms, attrs)])) notes
  80.352 +        else map_filter (fn (_, attrs, thms) => if null attrs then NONE 
  80.353 +          else SOME ((Binding.empty, []), [(thms, attrs)])) notes
  80.354        end
  80.355 -
  80.356 -    fun assms_rewrs_conv tactic rules = Conv.first_conv (map (assms_rewr_conv tactic) rules)
  80.357 -
  80.358 -    fun simp_arrows_conv ctm =
  80.359 -      let
  80.360 -        val unfold_conv = Conv.rewrs_conv 
  80.361 -          [@{thm rel_fun_eq_eq_onp[THEN eq_reflection]}, 
  80.362 -            @{thm rel_fun_eq_onp_rel[THEN eq_reflection]},
  80.363 -            @{thm rel_fun_eq[THEN eq_reflection]},
  80.364 -            @{thm rel_fun_eq_rel[THEN eq_reflection]}, 
  80.365 -            @{thm rel_fun_def[THEN eq_reflection]}]
  80.366 -        fun binop_conv2 cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2
  80.367 -        val eq_onp_assms_tac_rules = @{thm left_unique_OO} :: 
  80.368 -            eq_onp_assms_tac_fixed_rules @ (Transfer.get_transfer_raw lthy)
  80.369 -        val eq_onp_assms_tac = (TRY o REPEAT_ALL_NEW (resolve_tac lthy eq_onp_assms_tac_rules) 
  80.370 -          THEN_ALL_NEW (DETERM o Transfer.eq_tac lthy)) 1
  80.371 -        val relator_eq_onp_conv = Conv.bottom_conv
  80.372 -          (K (Conv.try_conv (assms_rewrs_conv eq_onp_assms_tac
  80.373 -            (Lifting_Info.get_relator_eq_onp_rules lthy)))) lthy
  80.374 -        val relator_eq_conv = Conv.bottom_conv
  80.375 -          (K (Conv.try_conv (Conv.rewrs_conv (Transfer.get_relator_eq lthy)))) lthy
  80.376 -      in
  80.377 -        case (Thm.term_of ctm) of
  80.378 -          Const (@{const_name "rel_fun"}, _) $ _ $ _ => 
  80.379 -            (binop_conv2 simp_arrows_conv simp_arrows_conv then_conv unfold_conv) ctm
  80.380 -          | _ => (relator_eq_onp_conv then_conv relator_eq_conv) ctm
  80.381 -      end
  80.382 -    
  80.383 -    val unfold_ret_val_invs = Conv.bottom_conv 
  80.384 -      (K (Conv.try_conv (Conv.rewr_conv @{thm eq_onp_same_args[THEN eq_reflection]}))) lthy
  80.385 -    val unfold_inv_conv = 
  80.386 -      Conv.top_sweep_conv (K (Conv.rewr_conv @{thm eq_onp_def[THEN eq_reflection]})) lthy
  80.387 -    val simp_conv = HOLogic.Trueprop_conv (Conv.fun2_conv simp_arrows_conv)
  80.388 -    val univq_conv = Conv.rewr_conv @{thm HOL.all_simps(6)[symmetric, THEN eq_reflection]}
  80.389 -    val univq_prenex_conv = Conv.top_conv (K (Conv.try_conv univq_conv)) lthy
  80.390 -    val beta_conv = Thm.beta_conversion true
  80.391 -    val eq_thm = 
  80.392 -      (simp_conv then_conv univq_prenex_conv then_conv beta_conv then_conv unfold_ret_val_invs
  80.393 -         then_conv unfold_inv_conv) ctm
  80.394 +    val (code_eq, lthy) = register_code_eq abs_eq_thm opt_rep_eq_thm (rty_forced, qty) lthy
  80.395 +    val lift_def = mk_lift_def rty_forced qty newrhs lift_const def_thm rsp_thm abs_eq_thm 
  80.396 +          opt_rep_eq_thm code_eq transfer_rules
  80.397    in
  80.398 -    Object_Logic.rulify lthy (eq_thm RS Drule.equal_elim_rule2)
  80.399 -  end
  80.400 -end
  80.401 -
  80.402 -fun rename_to_tnames ctxt term =
  80.403 -  let
  80.404 -    fun all_typs (Const (@{const_name Pure.all}, _) $ Abs (_, T, t)) = T :: all_typs t
  80.405 -      | all_typs _ = []
  80.406 -
  80.407 -    fun rename (Const (@{const_name Pure.all}, T1) $ Abs (_, T2, t)) (new_name :: names) = 
  80.408 -        (Const (@{const_name Pure.all}, T1) $ Abs (new_name, T2, rename t names)) 
  80.409 -      | rename t _ = t
  80.410 -
  80.411 -    val (fixed_def_t, _) = yield_singleton (Variable.importT_terms) term ctxt
  80.412 -    val new_names = Old_Datatype_Prop.make_tnames (all_typs fixed_def_t)
  80.413 -  in
  80.414 -    rename term new_names
  80.415 +    lthy
  80.416 +      |> Local_Theory.notes (notes (#notes config)) |> snd
  80.417 +      |> ` (fn lthy => morph_lift_def (Local_Theory.target_morphism lthy) lift_def)
  80.418 +      ||> Local_Theory.restore
  80.419    end
  80.420  
  80.421  (* This is not very cheap way of getting the rules but we have only few active
  80.422 @@ -601,17 +629,8 @@
  80.423      Symtab.fold (fn (_, data) => fn l => collect data l) table []
  80.424    end
  80.425  
  80.426 -(*
  80.427 -
  80.428 -  lifting_definition command. It opens a proof of a corresponding respectfulness 
  80.429 -  theorem in a user-friendly, readable form. Then add_lift_def is called internally.
  80.430 -
  80.431 -*)
  80.432 -
  80.433 -fun lift_def_cmd (raw_var, rhs_raw, par_xthms) lthy =
  80.434 +fun prepare_lift_def add_lift_def var qty rhs par_thms lthy =
  80.435    let
  80.436 -    val ((binding, SOME qty, mx), lthy) = yield_singleton Proof_Context.read_vars raw_var lthy 
  80.437 -    val rhs = (Syntax.check_term lthy o Syntax.parse_term lthy) rhs_raw
  80.438      val rsp_rel = Lifting_Term.equiv_relation lthy (fastype_of rhs, qty)
  80.439      val rty_forced = (domain_type o fastype_of) rsp_rel;
  80.440      val forced_rhs = force_rty_type lthy rty_forced rhs;
  80.441 @@ -625,84 +644,31 @@
  80.442        |>> snd
  80.443      val to_rsp = rsp_prsp_eq RS Drule.equal_elim_rule2
  80.444      val opt_proven_rsp_thm = try_prove_reflexivity lthy prsp_tm
  80.445 -    val par_thms = Attrib.eval_thms lthy par_xthms
  80.446      
  80.447      fun after_qed internal_rsp_thm lthy = 
  80.448 -      add_lift_def (binding, mx) qty rhs (internal_rsp_thm RS to_rsp) par_thms lthy
  80.449 +      add_lift_def var qty rhs (internal_rsp_thm RS to_rsp) par_thms lthy
  80.450    in
  80.451      case opt_proven_rsp_thm of
  80.452 -      SOME thm => Proof.theorem NONE (K (after_qed thm)) [] lthy
  80.453 -      | NONE =>  
  80.454 -        let
  80.455 -          val readable_rsp_thm_eq = mk_readable_rsp_thm_eq prsp_tm lthy
  80.456 -          val (readable_rsp_tm, _) = Logic.dest_implies (Thm.prop_of readable_rsp_thm_eq)
  80.457 -          val readable_rsp_tm_tnames = rename_to_tnames lthy readable_rsp_tm
  80.458 -      
  80.459 -          fun after_qed' thm_list lthy = 
  80.460 -            let
  80.461 -              val internal_rsp_thm = Goal.prove lthy [] [] prsp_tm 
  80.462 -                  (fn {context = ctxt, ...} =>
  80.463 -                    rtac readable_rsp_thm_eq 1 THEN Proof_Context.fact_tac ctxt (hd thm_list) 1)
  80.464 -            in
  80.465 -              after_qed internal_rsp_thm lthy
  80.466 -            end
  80.467 -        in
  80.468 -          Proof.theorem NONE after_qed' [[(readable_rsp_tm_tnames,[])]] lthy
  80.469 -        end 
  80.470 -  end
  80.471 -
  80.472 -fun quot_thm_err ctxt (rty, qty) pretty_msg =
  80.473 -  let
  80.474 -    val error_msg = cat_lines
  80.475 -       ["Lifting failed for the following types:",
  80.476 -        Pretty.string_of (Pretty.block
  80.477 -         [Pretty.str "Raw type:", Pretty.brk 2, Syntax.pretty_typ ctxt rty]),
  80.478 -        Pretty.string_of (Pretty.block
  80.479 -         [Pretty.str "Abstract type:", Pretty.brk 2, Syntax.pretty_typ ctxt qty]),
  80.480 -        "",
  80.481 -        (Pretty.string_of (Pretty.block
  80.482 -         [Pretty.str "Reason:", Pretty.brk 2, pretty_msg]))]
  80.483 -  in
  80.484 -    error error_msg
  80.485 +      SOME thm => (NONE, K (after_qed thm))
  80.486 +      | NONE => (SOME prsp_tm, after_qed) 
  80.487    end
  80.488  
  80.489 -fun check_rty_err ctxt (rty_schematic, rty_forced) (raw_var, rhs_raw) =
  80.490 +fun gen_lift_def add_lift_def var qty rhs tac par_thms lthy =
  80.491    let
  80.492 -    val (_, ctxt') = yield_singleton Proof_Context.read_vars raw_var ctxt 
  80.493 -    val rhs = (Syntax.check_term ctxt' o Syntax.parse_term ctxt') rhs_raw
  80.494 -    val error_msg = cat_lines
  80.495 -       ["Lifting failed for the following term:",
  80.496 -        Pretty.string_of (Pretty.block
  80.497 -         [Pretty.str "Term:", Pretty.brk 2, Syntax.pretty_term ctxt rhs]),
  80.498 -        Pretty.string_of (Pretty.block
  80.499 -         [Pretty.str "Type:", Pretty.brk 2, Syntax.pretty_typ ctxt rty_schematic]),
  80.500 -        "",
  80.501 -        (Pretty.string_of (Pretty.block
  80.502 -         [Pretty.str "Reason:", 
  80.503 -          Pretty.brk 2, 
  80.504 -          Pretty.str "The type of the term cannot be instantiated to",
  80.505 -          Pretty.brk 1,
  80.506 -          Pretty.quote (Syntax.pretty_typ ctxt rty_forced),
  80.507 -          Pretty.str "."]))]
  80.508 -    in
  80.509 -      error error_msg
  80.510 -    end
  80.511 +    val (goal, after_qed) = prepare_lift_def add_lift_def var qty rhs par_thms lthy
  80.512 +  in
  80.513 +    case goal of
  80.514 +      SOME goal => 
  80.515 +        let 
  80.516 +          val rsp_thm = Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} => tac ctxt)
  80.517 +            |> Thm.close_derivation
  80.518 +        in
  80.519 +          after_qed rsp_thm lthy
  80.520 +        end
  80.521 +      | NONE => after_qed Drule.dummy_thm lthy
  80.522 +  end
  80.523  
  80.524 -fun lift_def_cmd_with_err_handling (raw_var, rhs_raw, par_xthms) lthy =
  80.525 -  (lift_def_cmd (raw_var, rhs_raw, par_xthms) lthy
  80.526 -    handle Lifting_Term.QUOT_THM (rty, qty, msg) => quot_thm_err lthy (rty, qty) msg)
  80.527 -    handle Lifting_Term.CHECK_RTY (rty_schematic, rty_forced) => 
  80.528 -      check_rty_err lthy (rty_schematic, rty_forced) (raw_var, rhs_raw)
  80.529 -
  80.530 -(* parser and command *)
  80.531 -val liftdef_parser =
  80.532 -  (((Parse.binding -- (@{keyword "::"} |-- (Parse.typ >> SOME) -- Parse.opt_mixfix')) >> Parse.triple2)
  80.533 -    --| @{keyword "is"} -- Parse.term -- 
  80.534 -      Scan.optional (@{keyword "parametric"} |-- Parse.!!! Parse.xthms1) []) >> Parse.triple1
  80.535 -val _ =
  80.536 -  Outer_Syntax.local_theory_to_proof @{command_keyword lift_definition}
  80.537 -    "definition for constants over the quotient type"
  80.538 -      (liftdef_parser >> lift_def_cmd_with_err_handling)
  80.539 -
  80.540 +fun lift_def config var qty rhs tac par_thms lthy = gen_lift_def (add_lift_def config)
  80.541 +  var qty rhs tac par_thms lthy
  80.542  
  80.543  end (* structure *)
    81.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    81.2 +++ b/src/HOL/Tools/Lifting/lifting_def_code_dt.ML	Mon May 25 22:11:43 2015 +0200
    81.3 @@ -0,0 +1,816 @@
    81.4 +(*  Title:      HOL/Tools/Lifting/lifting_def_code_dt.ML
    81.5 +    Author:     Ondrej Kuncar
    81.6 +
    81.7 +Workaround that allows us to execute lifted constants that have
    81.8 +as a return type a datatype containing a subtype; lift_definition command
    81.9 +*)
   81.10 +
   81.11 +signature LIFTING_DEF_CODE_DT =
   81.12 +sig
   81.13 +  type rep_isom_data
   81.14 +  val isom_of_rep_isom_data: rep_isom_data -> term
   81.15 +  val transfer_of_rep_isom_data: rep_isom_data -> thm
   81.16 +  val bundle_name_of_rep_isom_data: rep_isom_data -> string
   81.17 +  val pointer_of_rep_isom_data: rep_isom_data -> string
   81.18 +
   81.19 +  type code_dt
   81.20 +  val rty_of_code_dt: code_dt -> typ
   81.21 +  val qty_of_code_dt: code_dt -> typ
   81.22 +  val wit_of_code_dt: code_dt -> term
   81.23 +  val wit_thm_of_code_dt: code_dt -> thm
   81.24 +  val rep_isom_data_of_code_dt: code_dt -> rep_isom_data option
   81.25 +  val morph_code_dt: morphism -> code_dt -> code_dt
   81.26 +  val mk_witness_of_code_dt: typ -> code_dt -> term
   81.27 +  val mk_rep_isom_of_code_dt: typ -> code_dt -> term option
   81.28 +
   81.29 +  val code_dt_of: Proof.context -> typ * typ -> code_dt option
   81.30 +  val code_dt_of_global: theory -> typ * typ -> code_dt option
   81.31 +  val all_code_dt_of: Proof.context -> code_dt list
   81.32 +  val all_code_dt_of_global: theory -> code_dt list
   81.33 +
   81.34 +  type config_code_dt = { code_dt: bool, lift_config: Lifting_Def.config }
   81.35 +  val default_config_code_dt: config_code_dt
   81.36 +
   81.37 +  val add_lift_def_code_dt:
   81.38 +    config_code_dt -> binding * mixfix -> typ -> term -> thm -> thm list -> local_theory ->
   81.39 +      Lifting_Def.lift_def * local_theory
   81.40 +
   81.41 +  val lift_def_code_dt:
   81.42 +    config_code_dt -> binding * mixfix -> typ -> term -> (Proof.context -> tactic) -> thm list ->
   81.43 +    local_theory -> Lifting_Def.lift_def * local_theory
   81.44 +
   81.45 +  val lift_def_cmd:
   81.46 +    string list * (binding * string option * mixfix) * string * (Facts.ref * Token.src list) list ->
   81.47 +    local_theory -> Proof.state
   81.48 +end
   81.49 +
   81.50 +structure Lifting_Def_Code_Dt: LIFTING_DEF_CODE_DT =
   81.51 +struct
   81.52 +                                                                       
   81.53 +open Ctr_Sugar_Util BNF_Util BNF_FP_Util BNF_FP_Def_Sugar Lifting_Def Lifting_Util
   81.54 +
   81.55 +infix 0 MRSL
   81.56 +
   81.57 +(** data structures **)
   81.58 +
   81.59 +(* all type variables in qty are in rty *)
   81.60 +datatype rep_isom_data = REP_ISOM of { isom: term, transfer: thm, bundle_name: string, pointer: string }
   81.61 +fun isom_of_rep_isom_data (REP_ISOM rep_isom) = #isom rep_isom;
   81.62 +fun transfer_of_rep_isom_data (REP_ISOM rep_isom) = #transfer rep_isom;
   81.63 +fun bundle_name_of_rep_isom_data (REP_ISOM rep_isom) = #bundle_name rep_isom;
   81.64 +fun pointer_of_rep_isom_data (REP_ISOM rep_isom) = #pointer rep_isom;
   81.65 +
   81.66 +datatype code_dt = CODE_DT of { rty: typ, qty: typ, wit: term, wit_thm: thm,
   81.67 +  rep_isom_data: rep_isom_data option };
   81.68 +fun rty_of_code_dt (CODE_DT code_dt) = #rty code_dt;
   81.69 +fun qty_of_code_dt (CODE_DT code_dt) = #qty code_dt;
   81.70 +fun wit_of_code_dt (CODE_DT code_dt) = #wit code_dt;
   81.71 +fun wit_thm_of_code_dt (CODE_DT code_dt) = #wit_thm code_dt;
   81.72 +fun rep_isom_data_of_code_dt (CODE_DT code_dt) = #rep_isom_data code_dt;
   81.73 +fun ty_alpha_equiv (T, U) = Type.raw_instance (T, U) andalso Type.raw_instance (U, T);
   81.74 +fun code_dt_eq c = (ty_alpha_equiv o apply2 rty_of_code_dt) c 
   81.75 +  andalso (ty_alpha_equiv o apply2 qty_of_code_dt) c;
   81.76 +fun term_of_code_dt code_dt = code_dt |> `rty_of_code_dt ||> qty_of_code_dt |> HOLogic.mk_prodT
   81.77 +  |> Net.encode_type |> single;
   81.78 +
   81.79 +(* modulo renaming, typ must contain TVars *)
   81.80 +fun is_code_dt_of_type (rty, qty) code_dt = code_dt |> `rty_of_code_dt ||> qty_of_code_dt
   81.81 +  |> HOLogic.mk_prodT |> curry ty_alpha_equiv (HOLogic.mk_prodT (rty, qty));
   81.82 +
   81.83 +fun mk_rep_isom_data isom transfer bundle_name pointer =
   81.84 +  REP_ISOM { isom = isom, transfer = transfer, bundle_name = bundle_name, pointer = pointer}
   81.85 +
   81.86 +fun mk_code_dt rty qty wit wit_thm rep_isom_data =
   81.87 +  CODE_DT { rty = rty, qty = qty, wit = wit, wit_thm = wit_thm, rep_isom_data = rep_isom_data };
   81.88 +
   81.89 +fun map_rep_isom_data f1 f2 f3 f4
   81.90 +  (REP_ISOM { isom = isom, transfer = transfer, bundle_name = bundle_name, pointer = pointer }) =
   81.91 +  REP_ISOM { isom = f1 isom, transfer = f2 transfer, bundle_name = f3 bundle_name, pointer = f4 pointer };
   81.92 +
   81.93 +fun map_code_dt f1 f2 f3 f4 f5 f6 f7 f8
   81.94 +  (CODE_DT {rty = rty, qty = qty, wit = wit, wit_thm = wit_thm, rep_isom_data = rep_isom_data}) =
   81.95 +  CODE_DT {rty = f1 rty, qty = f2 qty, wit = f3 wit, wit_thm = f4 wit_thm,
   81.96 +    rep_isom_data = Option.map (map_rep_isom_data f5 f6 f7 f8) rep_isom_data};
   81.97 +
   81.98 +fun update_rep_isom isom transfer binding pointer i = mk_code_dt (rty_of_code_dt i) (qty_of_code_dt i)
   81.99 +  (wit_of_code_dt i) (wit_thm_of_code_dt i) (SOME (mk_rep_isom_data isom transfer binding pointer))
  81.100 +
  81.101 +fun morph_code_dt phi =
  81.102 +  let
  81.103 +    val mty = Morphism.typ phi
  81.104 +    val mterm = Morphism.term phi
  81.105 +    val mthm = Morphism.thm phi
  81.106 +  in
  81.107 +    map_code_dt mty mty mterm mthm mterm mthm I I
  81.108 +  end
  81.109 +
  81.110 +val transfer_code_dt = morph_code_dt o Morphism.transfer_morphism;
  81.111 +
  81.112 +structure Data = Generic_Data
  81.113 +(
  81.114 +  type T = code_dt Item_Net.T
  81.115 +  val empty = Item_Net.init code_dt_eq term_of_code_dt
  81.116 +  val extend = I
  81.117 +  val merge = Item_Net.merge
  81.118 +);
  81.119 +
  81.120 +fun code_dt_of_generic context (rty, qty) =
  81.121 +  let
  81.122 +    val typ = HOLogic.mk_prodT (rty, qty)
  81.123 +    val prefiltred = Item_Net.retrieve_matching (Data.get context) (Net.encode_type typ)
  81.124 +  in
  81.125 +    prefiltred |> filter (is_code_dt_of_type (rty, qty))
  81.126 +    |> map (transfer_code_dt (Context.theory_of context)) |> find_first (fn _ => true)
  81.127 +  end;
  81.128 +
  81.129 +fun code_dt_of ctxt (rty, qty) =
  81.130 +  let
  81.131 +    val sch_rty = Logic.type_map (singleton (Variable.polymorphic ctxt)) rty
  81.132 +    val sch_qty = Logic.type_map (singleton (Variable.polymorphic ctxt)) qty
  81.133 +  in
  81.134 +    code_dt_of_generic (Context.Proof ctxt) (sch_rty, sch_qty)
  81.135 +  end;
  81.136 +
  81.137 +fun code_dt_of_global thy (rty, qty) =
  81.138 +  let
  81.139 +    val sch_rty = Logic.varifyT_global rty
  81.140 +    val sch_qty = Logic.varifyT_global qty
  81.141 +  in
  81.142 +    code_dt_of_generic (Context.Theory thy) (sch_rty, sch_qty)
  81.143 +  end;
  81.144 +
  81.145 +fun all_code_dt_of_generic context =
  81.146 +    Item_Net.content (Data.get context) |> map (transfer_code_dt (Context.theory_of context));
  81.147 +
  81.148 +val all_code_dt_of = all_code_dt_of_generic o Context.Proof;
  81.149 +val all_code_dt_of_global = all_code_dt_of_generic o Context.Theory;
  81.150 +
  81.151 +fun update_code_dt code_dt =
  81.152 +  Local_Theory.declaration {syntax = false, pervasive = true}
  81.153 +    (fn phi => Data.map (Item_Net.update (morph_code_dt phi code_dt)));
  81.154 +
  81.155 +fun mk_match_of_code_dt qty code_dt = Vartab.empty |> Type.raw_match (qty_of_code_dt code_dt, qty)
  81.156 +  |> Vartab.dest |> map (fn (x, (S, T)) => (TVar (x, S), T));
  81.157 +
  81.158 +fun mk_witness_of_code_dt qty code_dt =
  81.159 +  Term.subst_atomic_types (mk_match_of_code_dt qty code_dt) (wit_of_code_dt code_dt)
  81.160 +
  81.161 +fun mk_rep_isom_of_code_dt qty code_dt = Option.map
  81.162 +  (isom_of_rep_isom_data #> Term.subst_atomic_types (mk_match_of_code_dt qty code_dt))
  81.163 +    (rep_isom_data_of_code_dt code_dt)
  81.164 +
  81.165 +
  81.166 +(** unique name for a type **)
  81.167 +
  81.168 +fun var_name name sort = if sort = @{sort "{type}"} orelse sort = [] then ["x" ^ name]
  81.169 +  else "x" ^ name :: "x_" :: sort @ ["x_"];
  81.170 +
  81.171 +fun concat_Tnames (Type (name, ts)) = name :: maps concat_Tnames ts
  81.172 +  | concat_Tnames (TFree (name, sort)) = var_name name sort
  81.173 +  | concat_Tnames (TVar ((name, _), sort)) = var_name name sort;
  81.174 +
  81.175 +fun unique_Tname (rty, qty) =
  81.176 +  let
  81.177 +    val Tnames = map Long_Name.base_name (concat_Tnames rty @ ["x_x"] @ concat_Tnames qty);
  81.178 +  in
  81.179 +    fold (Binding.qualify false) (tl Tnames) (Binding.name (hd Tnames))
  81.180 +  end;
  81.181 +
  81.182 +(** witnesses **)
  81.183 +
  81.184 +fun mk_undefined T = Const (@{const_name undefined}, T);
  81.185 +
  81.186 +fun mk_witness quot_thm =
  81.187 +  let
  81.188 +    val wit_thm = quot_thm RS @{thm type_definition_Quotient_not_empty_witness}
  81.189 +    val wit = quot_thm_rep quot_thm $ mk_undefined (quot_thm_rty_qty quot_thm |> snd)
  81.190 +  in
  81.191 +    (wit, wit_thm)
  81.192 +  end
  81.193 +
  81.194 +(** config **)
  81.195 +
  81.196 +type config_code_dt = { code_dt: bool, lift_config: config }
  81.197 +val default_config_code_dt = { code_dt = false, lift_config = default_config }
  81.198 +
  81.199 +
  81.200 +(** Main code **)
  81.201 +
  81.202 +val ld_no_notes = { notes = false }
  81.203 +
  81.204 +fun comp_lift_error _ _ = error "Composition of abstract types has not been implemented yet."
  81.205 +
  81.206 +fun lift qty (quot_thm, (lthy, rel_eq_onps)) =
  81.207 +  let
  81.208 +    val quot_thm = Lifting_Term.force_qty_type lthy qty quot_thm
  81.209 +    val (rty, qty) = quot_thm_rty_qty quot_thm;
  81.210 +  in
  81.211 +    if is_none (code_dt_of lthy (rty, qty)) then
  81.212 +      let
  81.213 +        val (wit, wit_thm) = (mk_witness quot_thm
  81.214 +          handle THM _ => error ("code_dt: " ^ quote (Tname qty) ^ " was not defined as a subtype."))
  81.215 +        val code_dt = mk_code_dt rty qty wit wit_thm NONE
  81.216 +      in
  81.217 +        (quot_thm, (update_code_dt code_dt lthy |> Local_Theory.restore, rel_eq_onps))
  81.218 +      end
  81.219 +    else
  81.220 +      (quot_thm, (lthy, rel_eq_onps))
  81.221 +  end;
  81.222 +
  81.223 +fun case_tac rule ctxt i st =
  81.224 +  (Subgoal.FOCUS_PARAMS (fn {params, ...} => HEADGOAL(rtac
  81.225 +    (Ctr_Sugar_Util.cterm_instantiate_pos [SOME (params |> hd |> snd)] rule))) ctxt i st);
  81.226 +
  81.227 +fun bundle_name_of_bundle_binding binding phi context  =
  81.228 +  Name_Space.full_name (Name_Space.naming_of context) (Morphism.binding phi binding);
  81.229 +
  81.230 +fun prove_schematic_quot_thm actions ctxt = Lifting_Term.prove_schematic_quot_thm actions
  81.231 + (Lifting_Info.get_quotients ctxt) ctxt
  81.232 +
  81.233 +fun prove_code_dt (rty, qty) lthy =
  81.234 +  let
  81.235 +    val (fold_quot_thm: (local_theory * thm list) Lifting_Term.fold_quot_thm) =
  81.236 +      { constr = constr, lift = lift, comp_lift = comp_lift_error };
  81.237 +  in prove_schematic_quot_thm fold_quot_thm lthy (rty, qty) (lthy, []) |> snd end
  81.238 +and add_lift_def_code_dt config var qty rhs rsp_thm par_thms lthy =
  81.239 +  let
  81.240 +    fun binop_conv2 cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2
  81.241 +    fun ret_rel_conv conv ctm =
  81.242 +      case (Thm.term_of ctm) of
  81.243 +        Const (@{const_name "rel_fun"}, _) $ _ $ _ =>
  81.244 +          binop_conv2 Conv.all_conv conv ctm
  81.245 +        | _ => conv ctm
  81.246 +    fun R_conv rel_eq_onps = Transfer.top_sweep_rewr_conv @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]}
  81.247 +      then_conv Transfer.bottom_rewr_conv rel_eq_onps
  81.248 +
  81.249 +    val (ret_lift_def, lthy) = add_lift_def (#lift_config config) var qty rhs rsp_thm par_thms lthy
  81.250 +  in
  81.251 +    if (not (#code_dt config) orelse (code_eq_of_lift_def ret_lift_def <> NONE_EQ)
  81.252 +      andalso (code_eq_of_lift_def ret_lift_def <> UNKNOWN_EQ))
  81.253 +      (* Let us try even in case of UNKNOWN_EQ. If this leads to problems, the user can always
  81.254 +        say that they do not want this workaround. *)
  81.255 +    then  (ret_lift_def, lthy)
  81.256 +    else
  81.257 +      let
  81.258 +        val lift_def = inst_of_lift_def lthy qty ret_lift_def
  81.259 +        val rty = rty_of_lift_def lift_def
  81.260 +        val rty_ret = body_type rty
  81.261 +        val qty_ret = body_type qty
  81.262 +
  81.263 +        val (lthy, rel_eq_onps) = prove_code_dt (rty_ret, qty_ret) lthy
  81.264 +        val code_dt = code_dt_of lthy (rty_ret, qty_ret)
  81.265 +      in
  81.266 +        if is_none code_dt orelse is_none (rep_isom_data_of_code_dt (the code_dt)) then (ret_lift_def, lthy)
  81.267 +        else
  81.268 +          let
  81.269 +            val code_dt = the code_dt
  81.270 +            val rhs = dest_comb (rhs_of_lift_def lift_def) |> snd
  81.271 +            val rep_isom_data = code_dt |> rep_isom_data_of_code_dt |> the
  81.272 +            val pointer = pointer_of_rep_isom_data rep_isom_data
  81.273 +            val quot_active = 
  81.274 +              Lifting_Info.lookup_restore_data lthy pointer |> the |> #quotient |> #quot_thm
  81.275 +              |> Lifting_Info.lookup_quot_thm_quotients lthy |> is_some
  81.276 +            val qty_code_dt_bundle_name = bundle_name_of_rep_isom_data rep_isom_data
  81.277 +            val rep_isom = mk_rep_isom_of_code_dt qty_ret code_dt |> the
  81.278 +            val lthy = if quot_active then lthy else Bundle.includes [qty_code_dt_bundle_name] lthy
  81.279 +            fun qty_isom_of_rep_isom rep = rep |> dest_Const |> snd |> domain_type
  81.280 +            val qty_isom = qty_isom_of_rep_isom rep_isom
  81.281 +            val f'_var = (Binding.suffix_name "_aux" (fst var), NoSyn);
  81.282 +            val f'_qty = strip_type qty |> fst |> rpair qty_isom |> op --->
  81.283 +            val f'_rsp_rel = Lifting_Term.equiv_relation lthy (rty, f'_qty);
  81.284 +            val rsp = rsp_thm_of_lift_def lift_def
  81.285 +            val rel_eq_onps_conv = HOLogic.Trueprop_conv (Conv.fun2_conv (ret_rel_conv (R_conv rel_eq_onps)))
  81.286 +            val rsp_norm = Conv.fconv_rule rel_eq_onps_conv rsp
  81.287 +            val f'_rsp_goal = HOLogic.mk_Trueprop (f'_rsp_rel $ rhs $ rhs);
  81.288 +            val f'_rsp = Goal.prove_sorry lthy [] [] f'_rsp_goal
  81.289 +              (K (HEADGOAL (CONVERSION (rel_eq_onps_conv) THEN' rtac rsp_norm)))
  81.290 +              |> Thm.close_derivation
  81.291 +            val (f'_lift_def, lthy) = add_lift_def ld_no_notes f'_var f'_qty rhs f'_rsp [] lthy
  81.292 +            val f'_lift_def = inst_of_lift_def lthy f'_qty f'_lift_def
  81.293 +            val f'_lift_const = mk_lift_const_of_lift_def f'_qty f'_lift_def
  81.294 +            val args_lthy = lthy
  81.295 +            val (args, lthy) = mk_Frees "x" (binder_types qty) lthy
  81.296 +            val f_alt_def_goal_lhs = list_comb (lift_const_of_lift_def lift_def, args);
  81.297 +            val f_alt_def_goal_rhs = rep_isom $ list_comb (f'_lift_const, args);
  81.298 +            val f_alt_def_goal = HOLogic.mk_Trueprop (HOLogic.mk_eq (f_alt_def_goal_lhs, f_alt_def_goal_rhs));
  81.299 +            fun f_alt_def_tac ctxt i =
  81.300 +              EVERY' [Transfer.gen_frees_tac [] ctxt, DETERM o Transfer.transfer_tac true ctxt,
  81.301 +                SELECT_GOAL (Local_Defs.unfold_tac ctxt [id_apply]), rtac refl] i;
  81.302 +            val rep_isom_transfer = transfer_of_rep_isom_data rep_isom_data
  81.303 +            val (_, transfer_lthy) = Proof_Context.note_thmss "" [((Binding.empty, []),
  81.304 +              [([rep_isom_transfer], [Transfer.transfer_add])])] lthy
  81.305 +            val f_alt_def = Goal.prove_sorry transfer_lthy [] [] f_alt_def_goal
  81.306 +              (fn {context = ctxt, prems = _} => HEADGOAL (f_alt_def_tac ctxt))
  81.307 +              |> Thm.close_derivation
  81.308 +              |> singleton (Variable.export lthy args_lthy)
  81.309 +            val lthy = args_lthy
  81.310 +            val lthy =  lthy
  81.311 +              |> Local_Theory.note ((Binding.empty, @{attributes [code]}), [f_alt_def])
  81.312 +              |> snd
  81.313 +              (* if processing a mutual datatype (there is a cycle!) the corresponding quotient 
  81.314 +                 will be needed later and will be forgotten later *)
  81.315 +              |> (if quot_active then I else Lifting_Setup.lifting_forget pointer)
  81.316 +          in
  81.317 +            (ret_lift_def, lthy)
  81.318 +          end
  81.319 +       end
  81.320 +    end
  81.321 +and mk_rep_isom qty_isom_bundle (rty, qty, qty_isom) lthy =
  81.322 +  let
  81.323 +    (* logical definition of qty qty_isom isomorphism *) 
  81.324 +    val uTname = unique_Tname (rty, qty)
  81.325 +    fun eq_onp_to_top_tac ctxt = SELECT_GOAL (Local_Defs.unfold_tac ctxt 
  81.326 +      (@{thm eq_onp_top_eq_eq[symmetric]} :: Lifting_Info.get_relator_eq_onp_rules ctxt))
  81.327 +    fun lift_isom_tac ctxt = HEADGOAL (eq_onp_to_top_tac ctxt
  81.328 +      THEN' (rtac @{thm id_transfer}));
  81.329 +
  81.330 +    val (rep_isom_lift_def, lthy) = lift_def ld_no_notes (Binding.qualified true "Rep_isom" uTname, NoSyn)
  81.331 +      (qty_isom --> qty) (HOLogic.id_const rty) lift_isom_tac [] lthy
  81.332 +      |> apfst (inst_of_lift_def lthy (qty_isom --> qty));
  81.333 +    val (abs_isom, lthy) = lift_def ld_no_notes (Binding.qualified true "Abs_isom" uTname, NoSyn)
  81.334 +      (qty --> qty_isom) (HOLogic.id_const rty) lift_isom_tac [] lthy
  81.335 +      |> apfst (mk_lift_const_of_lift_def (qty --> qty_isom));
  81.336 +    val rep_isom = lift_const_of_lift_def rep_isom_lift_def
  81.337 +
  81.338 +    val pointer = Lifting_Setup.pointer_of_bundle_binding lthy qty_isom_bundle
  81.339 +    fun code_dt phi context = code_dt_of lthy (rty, qty) |> the |>
  81.340 +      update_rep_isom rep_isom (transfer_rules_of_lift_def rep_isom_lift_def |> hd)
  81.341 +       (bundle_name_of_bundle_binding qty_isom_bundle phi context) pointer;
  81.342 +    val lthy = lthy  
  81.343 +      |> Local_Theory.declaration {syntax = false, pervasive = true}
  81.344 +        (fn phi => fn context => Data.map (Item_Net.update (morph_code_dt phi (code_dt phi context))) context)
  81.345 +      |> Local_Theory.restore
  81.346 +
  81.347 +    (* in order to make the qty qty_isom isomorphism executable we have to define discriminators 
  81.348 +      and selectors for qty_isom *)
  81.349 +    val (rty_name, typs) = dest_Type rty
  81.350 +    val (_, qty_typs) = dest_Type qty
  81.351 +    val fp = BNF_FP_Def_Sugar.fp_sugar_of lthy rty_name
  81.352 +    val fp = if is_some fp then the fp
  81.353 +      else error ("code_dt: " ^ quote rty_name ^ " is not a datatype.")
  81.354 +    val ctr_sugar = fp |> #fp_ctr_sugar |> #ctr_sugar
  81.355 +    val ctrs = map (Ctr_Sugar.mk_ctr typs) (#ctrs ctr_sugar);
  81.356 +    val qty_ctrs = map (Ctr_Sugar.mk_ctr qty_typs) (#ctrs ctr_sugar);
  81.357 +    val ctr_Tss = map (dest_Const #> snd #> binder_types) ctrs;
  81.358 +    val qty_ctr_Tss = map (dest_Const #> snd #> binder_types) qty_ctrs;
  81.359 +
  81.360 +    val n = length ctrs;
  81.361 +    val ks = 1 upto n;
  81.362 +    val (xss, _) = mk_Freess "x" ctr_Tss lthy;
  81.363 +
  81.364 +    fun sel_retT (rty' as Type (s, rtys'), qty' as Type (s', qtys')) =
  81.365 +        if (rty', qty') = (rty, qty) then qty_isom else (if s = s'
  81.366 +          then Type (s, map sel_retT (rtys' ~~ qtys')) else qty')
  81.367 +      | sel_retT (_, qty') = qty';
  81.368 +
  81.369 +    val sel_retTs = map2 (map2 (sel_retT oo pair)) ctr_Tss qty_ctr_Tss
  81.370 +
  81.371 +    fun lazy_prove_code_dt (rty, qty) lthy =
  81.372 +      if is_none (code_dt_of lthy (rty, qty)) then prove_code_dt (rty, qty) lthy |> fst else lthy;
  81.373 +
  81.374 +    val lthy = fold2 (fold2 (lazy_prove_code_dt oo pair)) ctr_Tss sel_retTs lthy
  81.375 +
  81.376 +    val sel_argss = @{map 4} (fn k => fn xs => @{map 2} (fn x => fn qty_ret => 
  81.377 +      (k, qty_ret, (xs, x)))) ks xss xss sel_retTs;
  81.378 +
  81.379 +    fun mk_sel_casex (_, _, (_, x)) = Ctr_Sugar.mk_case typs (x |> dest_Free |> snd) (#casex ctr_sugar);
  81.380 +    val dis_casex = Ctr_Sugar.mk_case typs HOLogic.boolT (#casex ctr_sugar);
  81.381 +    fun mk_sel_case_args lthy ctr_Tss ks (k, qty_ret, (xs, x)) =
  81.382 +      let
  81.383 +        val T = x |> dest_Free |> snd;
  81.384 +        fun gen_undef_wit Ts wits =
  81.385 +          case code_dt_of lthy (T, qty_ret) of
  81.386 +            SOME code_dt =>
  81.387 +              (fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_witness_of_code_dt qty_ret code_dt),
  81.388 +                wit_thm_of_code_dt code_dt :: wits)
  81.389 +            | NONE => (fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_undefined T), wits)
  81.390 +      in
  81.391 +        @{fold_map 2} (fn Ts => fn k' => fn wits =>
  81.392 +          (if k = k' then (fold_rev Term.lambda xs x, wits) else gen_undef_wit Ts wits)) ctr_Tss ks []
  81.393 +      end;
  81.394 +    fun mk_sel_rhs arg =
  81.395 +      let val (sel_rhs, wits) = mk_sel_case_args lthy ctr_Tss ks arg
  81.396 +      in (arg |> #2, wits, list_comb (mk_sel_casex arg, sel_rhs)) end;
  81.397 +    fun mk_dis_case_args args k  = map (fn (k', arg) => (if k = k'
  81.398 +      then fold_rev Term.lambda arg @{const True} else fold_rev Term.lambda arg @{const False})) args;
  81.399 +    val sel_rhs = map (map mk_sel_rhs) sel_argss
  81.400 +    val dis_rhs = map (fn k => list_comb (dis_casex, mk_dis_case_args (ks ~~ xss) k)) ks
  81.401 +    val dis_qty = qty_isom --> HOLogic.boolT;
  81.402 +    val dis_names = map (fn k => Binding.qualified true ("dis" ^ string_of_int k) uTname) ks;
  81.403 +
  81.404 +    val (diss, lthy) = @{fold_map 2} (fn b => fn rhs => fn lthy =>
  81.405 +      lift_def ld_no_notes (b, NoSyn) dis_qty rhs (K all_tac) [] lthy
  81.406 +      |> apfst (mk_lift_const_of_lift_def dis_qty)) dis_names dis_rhs lthy
  81.407 +
  81.408 +    val unfold_lift_sel_rsp = @{lemma "(\<And>x. P1 x \<Longrightarrow> P2 (f x)) \<Longrightarrow> (rel_fun (eq_onp P1) (eq_onp P2)) f f"
  81.409 +      by (simp add: eq_onp_same_args rel_fun_eq_onp_rel)}
  81.410 +
  81.411 +    fun lift_sel_tac exhaust_rule dt_rules wits ctxt i =
  81.412 +        (Method.insert_tac wits THEN' 
  81.413 +         eq_onp_to_top_tac ctxt THEN' (* normalize *)
  81.414 +         rtac unfold_lift_sel_rsp THEN'
  81.415 +         case_tac exhaust_rule ctxt THEN_ALL_NEW (
  81.416 +        EVERY' [hyp_subst_tac ctxt, (* does not kill wits because = was rewritten to eq_onp top *)
  81.417 +        Raw_Simplifier.rewrite_goal_tac ctxt (map safe_mk_meta_eq dt_rules), 
  81.418 +        REPEAT_DETERM o etac conjE, atac])) i
  81.419 +    val pred_simps = Transfer.lookup_pred_data lthy (Tname rty) |> the |> Transfer.pred_simps
  81.420 +    val sel_tac = lift_sel_tac (#exhaust ctr_sugar) (#case_thms ctr_sugar @ pred_simps)
  81.421 +    val sel_names = map (fn (k, xs) => map (fn k' => Binding.qualified true
  81.422 +      ("sel" ^ string_of_int k ^ string_of_int k') uTname) (1 upto length xs)) (ks ~~ ctr_Tss);
  81.423 +    val (selss, lthy) = @{fold_map 2} (@{fold_map 2} (fn b => fn (qty_ret, wits, rhs) => fn lthy =>
  81.424 +        lift_def_code_dt { code_dt = true, lift_config = ld_no_notes }
  81.425 +        (b, NoSyn) (qty_isom --> qty_ret) rhs (HEADGOAL o sel_tac wits) [] lthy
  81.426 +      |> apfst (mk_lift_const_of_lift_def (qty_isom --> qty_ret)))) sel_names sel_rhs lthy
  81.427 +
  81.428 +    (* now we can execute the qty qty_isom isomorphism *)
  81.429 +    fun mk_type_definition newT oldT RepC AbsC A =
  81.430 +      let
  81.431 +        val typedefC =
  81.432 +          Const (@{const_name type_definition},
  81.433 +            (newT --> oldT) --> (oldT --> newT) --> HOLogic.mk_setT oldT --> HOLogic.boolT);
  81.434 +      in typedefC $ RepC $ AbsC $ A end;
  81.435 +    val typedef_goal = mk_type_definition qty_isom qty rep_isom abs_isom (HOLogic.mk_UNIV qty) |>
  81.436 +      HOLogic.mk_Trueprop;
  81.437 +    fun typ_isom_tac ctxt i =
  81.438 +      EVERY' [ SELECT_GOAL (Local_Defs.unfold_tac ctxt @{thms type_definition_def}),
  81.439 +        DETERM o Transfer.transfer_tac true ctxt,
  81.440 +          SELECT_GOAL (Local_Defs.unfold_tac ctxt @{thms eq_onp_top_eq_eq}) (* normalize *), 
  81.441 +          Raw_Simplifier.rewrite_goal_tac ctxt 
  81.442 +          (map safe_mk_meta_eq @{thms id_apply simp_thms Ball_def}),
  81.443 +         rtac TrueI] i;
  81.444 +
  81.445 +    val (_, transfer_lthy) = Proof_Context.note_thmss "" [((Binding.empty, []),
  81.446 +      [(@{thms right_total_UNIV_transfer},[Transfer.transfer_add]),
  81.447 +       (@{thms Domain_eq_top}, [Transfer.transfer_domain_add]) ])] lthy;
  81.448 +
  81.449 +    val quot_thm_isom = Goal.prove_sorry transfer_lthy [] [] typedef_goal
  81.450 +      (fn {context = ctxt, prems = _} => typ_isom_tac ctxt 1)
  81.451 +      |> Thm.close_derivation
  81.452 +      |> singleton (Variable.export transfer_lthy lthy)
  81.453 +      |> (fn thm => @{thm UNIV_typedef_to_Quotient} OF [thm, @{thm reflexive}])
  81.454 +    val qty_isom_name = Tname qty_isom;
  81.455 +    val quot_isom_rep =
  81.456 +      let
  81.457 +        val (quotients : Lifting_Term.quotients) = Symtab.insert (Lifting_Info.quotient_eq) (qty_isom_name,
  81.458 +          {quot_thm = quot_thm_isom, pcr_info = NONE}) Symtab.empty
  81.459 +        val id_actions = { constr = K I, lift = K I, comp_lift = K I }
  81.460 +      in
  81.461 +        fn ctxt => fn (rty, qty) => Lifting_Term.prove_schematic_quot_thm id_actions quotients
  81.462 +          ctxt (rty, qty) () |> fst |> Lifting_Term.force_qty_type ctxt qty
  81.463 +          |> quot_thm_rep
  81.464 +      end;
  81.465 +    val x_lthy = lthy
  81.466 +    val (x, lthy) = yield_singleton (mk_Frees "x") qty_isom lthy;
  81.467 +
  81.468 +    fun mk_ctr ctr ctr_Ts sels =
  81.469 +      let
  81.470 +        val sel_ret_Ts = map (dest_Const #> snd #> body_type) sels;
  81.471 +
  81.472 +        fun rep_isom lthy t (rty, qty) =
  81.473 +          let
  81.474 +            val rep = quot_isom_rep lthy (rty, qty)
  81.475 +          in
  81.476 +            if is_Const rep andalso (rep |> dest_Const |> fst) = @{const_name id} then
  81.477 +              t else rep $ t
  81.478 +          end;
  81.479 +      in
  81.480 +        @{fold 3} (fn sel => fn ctr_T => fn sel_ret_T => fn ctr =>
  81.481 +          ctr $ rep_isom lthy (sel $ x) (ctr_T, sel_ret_T)) sels ctr_Ts sel_ret_Ts ctr
  81.482 +      end;
  81.483 +
  81.484 +    (* stolen from Metis *)
  81.485 +    exception BREAK_LIST
  81.486 +    fun break_list (x :: xs) = (x, xs)
  81.487 +      | break_list _ = raise BREAK_LIST
  81.488 +
  81.489 +    val (ctr, ctrs) = qty_ctrs |> rev |> break_list;
  81.490 +    val (ctr_Ts, ctr_Tss) = qty_ctr_Tss |> rev |> break_list;
  81.491 +    val (sel, rselss) = selss |> rev |> break_list;
  81.492 +    val rdiss = rev diss |> tl;
  81.493 +
  81.494 +    val first_ctr = mk_ctr ctr ctr_Ts sel;
  81.495 +
  81.496 +    fun mk_If_ctr dis ctr ctr_Ts sel elsex = mk_If (dis$x) (mk_ctr ctr ctr_Ts sel) elsex;
  81.497 +
  81.498 +    val rhs = @{fold 4} mk_If_ctr rdiss ctrs ctr_Tss rselss first_ctr;
  81.499 +
  81.500 +    val rep_isom_code_goal = HOLogic.mk_Trueprop (HOLogic.mk_eq (rep_isom$x, rhs));
  81.501 +
  81.502 +    local
  81.503 +      val rep_isom_code_tac_rules = map safe_mk_meta_eq @{thms refl id_apply if_splits simp_thms}
  81.504 +    in
  81.505 +      fun rep_isom_code_tac (ctr_sugar:Ctr_Sugar.ctr_sugar) ctxt i =
  81.506 +        let
  81.507 +          val exhaust = ctr_sugar |> #exhaust
  81.508 +          val cases = ctr_sugar |> #case_thms
  81.509 +          val map_ids = fp |> #fp_nesting_bnfs |> map BNF_Def.map_id0_of_bnf
  81.510 +          val simp_rules = map safe_mk_meta_eq (cases @ map_ids) @ rep_isom_code_tac_rules
  81.511 +        in
  81.512 +          EVERY' [Transfer.gen_frees_tac [] ctxt, DETERM o (Transfer.transfer_tac true ctxt),
  81.513 +            case_tac exhaust ctxt THEN_ALL_NEW EVERY' [hyp_subst_tac ctxt,
  81.514 +              Raw_Simplifier.rewrite_goal_tac ctxt simp_rules, rtac TrueI ]] i
  81.515 +        end
  81.516 +    end
  81.517 +    
  81.518 +    (* stolen from bnf_fp_n2m.ML *)
  81.519 +    fun force_typ ctxt T =
  81.520 +      Term.map_types Type_Infer.paramify_vars
  81.521 +      #> Type.constraint T
  81.522 +      #> singleton (Type_Infer_Context.infer_types ctxt);
  81.523 +
  81.524 +    (* The following tests that types in rty have corresponding arities imposed by constraints of
  81.525 +       the datatype fp. Otherwise rep_isom_code_tac could fail (especially transfer in it) is such
  81.526 +       a way that it is not easy to infer the problem with sorts.
  81.527 +    *)
  81.528 +    val _ = yield_singleton (mk_Frees "x") (#T fp) lthy |> fst |> force_typ lthy qty
  81.529 +
  81.530 +    val rep_isom_code = Goal.prove_sorry lthy [] [] rep_isom_code_goal
  81.531 +      (fn {context = ctxt, prems = _} => rep_isom_code_tac ctr_sugar ctxt 1)
  81.532 +      |> Thm.close_derivation
  81.533 +      |> singleton(Variable.export lthy x_lthy)
  81.534 +    val lthy = x_lthy
  81.535 +    val lthy =
  81.536 +      lthy
  81.537 +      |> snd o Local_Theory.note ((Binding.empty, @{attributes [code]}), [rep_isom_code])
  81.538 +      |> Lifting_Setup.lifting_forget pointer
  81.539 +  in
  81.540 +    ((selss, diss, rep_isom_code), lthy)
  81.541 +  end
  81.542 +and constr qty (quot_thm, (lthy, rel_eq_onps)) =
  81.543 +  let
  81.544 +    val quot_thm = Lifting_Term.force_qty_type lthy qty quot_thm
  81.545 +    val (rty, qty) = quot_thm_rty_qty quot_thm
  81.546 +    val rty_name = Tname rty;
  81.547 +    val pred_data = Transfer.lookup_pred_data lthy rty_name
  81.548 +    val pred_data = if is_some pred_data then the pred_data
  81.549 +      else error ("code_dt: " ^ quote rty_name ^ " is not a datatype.")
  81.550 +    val rel_eq_onp = safe_mk_meta_eq (Transfer.rel_eq_onp pred_data);
  81.551 +    val rel_eq_onps = insert Thm.eq_thm rel_eq_onp rel_eq_onps
  81.552 +    val R_conv = Transfer.top_sweep_rewr_conv @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]}
  81.553 +      then_conv Conv.rewr_conv rel_eq_onp
  81.554 +    val quot_thm = Conv.fconv_rule(HOLogic.Trueprop_conv (Quotient_R_conv R_conv)) quot_thm;
  81.555 +  in
  81.556 +    if is_none (code_dt_of lthy (rty, qty)) then
  81.557 +      let
  81.558 +        val non_empty_pred = quot_thm RS @{thm type_definition_Quotient_not_empty}
  81.559 +        val pred = quot_thm_rel quot_thm |> dest_comb |> snd;
  81.560 +        val (pred, lthy) = yield_singleton (Variable.import_terms true) pred lthy;
  81.561 +        val TFrees = Term.add_tfreesT qty []
  81.562 +
  81.563 +        fun non_empty_typedef_tac non_empty_pred ctxt i =
  81.564 +          (Method.insert_tac [non_empty_pred] THEN' 
  81.565 +            SELECT_GOAL (Local_Defs.unfold_tac ctxt [mem_Collect_eq]) THEN' atac) i
  81.566 +        val uTname = unique_Tname (rty, qty)
  81.567 +        val Tdef_set = HOLogic.mk_Collect ("x", rty, pred $ Free("x", rty));
  81.568 +        val ((_, tcode_dt), lthy) = conceal_naming_result (typedef (Binding.concealed uTname, TFrees, NoSyn)
  81.569 +          Tdef_set NONE (fn lthy => HEADGOAL (non_empty_typedef_tac non_empty_pred lthy))) lthy;
  81.570 +        val type_definition_thm = tcode_dt |> snd |> #type_definition;
  81.571 +        val qty_isom = tcode_dt |> fst |> #abs_type;
  81.572 +
  81.573 +        val config = { notes = false}
  81.574 +        val (binding, lthy) = conceal_naming_result (Lifting_Setup.setup_by_typedef_thm
  81.575 +          config type_definition_thm) lthy
  81.576 +        val lthy = Local_Theory.restore lthy
  81.577 +        val (wit, wit_thm) = mk_witness quot_thm;
  81.578 +        val code_dt = mk_code_dt rty qty wit wit_thm NONE;
  81.579 +        val lthy = lthy
  81.580 +          |> update_code_dt code_dt
  81.581 +          |> Local_Theory.restore
  81.582 +          |> mk_rep_isom binding (rty, qty, qty_isom) |> snd
  81.583 +      in
  81.584 +        (quot_thm, (lthy, rel_eq_onps))
  81.585 +      end
  81.586 +    else
  81.587 +      (quot_thm, (lthy, rel_eq_onps))
  81.588 +  end
  81.589 +and lift_def_code_dt config var qty rhs tac par_thms lthy = gen_lift_def (add_lift_def_code_dt config)
  81.590 +  var qty rhs tac par_thms lthy
  81.591 +
  81.592 +
  81.593 +(** from parsed parameters to the config record **)
  81.594 +
  81.595 +fun map_config_code_dt f1 f2 ({code_dt = code_dt, lift_config = lift_config}: config_code_dt) =
  81.596 +  {code_dt = f1 code_dt, lift_config = f2 lift_config}
  81.597 +
  81.598 +fun update_config_code_dt nval = map_config_code_dt (K nval) I
  81.599 +
  81.600 +val config_flags = [("code_dt", update_config_code_dt true)]
  81.601 +
  81.602 +fun evaluate_params params =
  81.603 +  let
  81.604 +    fun eval_param param config =
  81.605 +      case AList.lookup (op =) config_flags param of
  81.606 +        SOME update => update config
  81.607 +        | NONE => error ("Unknown parameter: " ^ (quote param))
  81.608 +  in
  81.609 +    fold eval_param params default_config_code_dt
  81.610 +  end
  81.611 +
  81.612 +(**
  81.613 +
  81.614 +  lift_definition command. It opens a proof of a corresponding respectfulness
  81.615 +  theorem in a user-friendly, readable form. Then add_lift_def_code_dt is called internally.
  81.616 +
  81.617 +**)
  81.618 +
  81.619 +local
  81.620 +  val eq_onp_assms_tac_fixed_rules = map (Transfer.prep_transfer_domain_thm @{context})
  81.621 +    [@{thm pcr_Domainp_total}, @{thm pcr_Domainp_par_left_total}, @{thm pcr_Domainp_par}, 
  81.622 +      @{thm pcr_Domainp}]
  81.623 +in
  81.624 +fun mk_readable_rsp_thm_eq tm lthy =
  81.625 +  let
  81.626 +    val ctm = Thm.cterm_of lthy tm
  81.627 +    
  81.628 +    fun assms_rewr_conv tactic rule ct =
  81.629 +      let
  81.630 +        fun prove_extra_assms thm =
  81.631 +          let
  81.632 +            val assms = cprems_of thm
  81.633 +            fun finish thm = if Thm.no_prems thm then SOME (Goal.conclude thm) else NONE
  81.634 +            fun prove ctm = Option.mapPartial finish (SINGLE tactic (Goal.init ctm))
  81.635 +          in
  81.636 +            map_interrupt prove assms
  81.637 +          end
  81.638 +    
  81.639 +        fun cconl_of thm = Drule.strip_imp_concl (Thm.cprop_of thm)
  81.640 +        fun lhs_of thm = fst (Thm.dest_equals (cconl_of thm))
  81.641 +        fun rhs_of thm = snd (Thm.dest_equals (cconl_of thm))
  81.642 +        val rule1 = Thm.incr_indexes (Thm.maxidx_of_cterm ct + 1) rule;
  81.643 +        val lhs = lhs_of rule1;
  81.644 +        val rule2 = Thm.rename_boundvars (Thm.term_of lhs) (Thm.term_of ct) rule1;
  81.645 +        val rule3 =
  81.646 +          Thm.instantiate (Thm.match (lhs, ct)) rule2
  81.647 +            handle Pattern.MATCH => raise CTERM ("assms_rewr_conv", [lhs, ct]);
  81.648 +        val proved_assms = prove_extra_assms rule3
  81.649 +      in
  81.650 +        case proved_assms of
  81.651 +          SOME proved_assms =>
  81.652 +            let
  81.653 +              val rule3 = proved_assms MRSL rule3
  81.654 +              val rule4 =
  81.655 +                if lhs_of rule3 aconvc ct then rule3
  81.656 +                else
  81.657 +                  let val ceq = Thm.dest_fun2 (Thm.cprop_of rule3)
  81.658 +                  in rule3 COMP Thm.trivial (Thm.mk_binop ceq ct (rhs_of rule3)) end
  81.659 +            in Thm.transitive rule4 (Thm.beta_conversion true (rhs_of rule4)) end
  81.660 +          | NONE => Conv.no_conv ct
  81.661 +      end
  81.662 +
  81.663 +    fun assms_rewrs_conv tactic rules = Conv.first_conv (map (assms_rewr_conv tactic) rules)
  81.664 +
  81.665 +    fun simp_arrows_conv ctm =
  81.666 +      let
  81.667 +        val unfold_conv = Conv.rewrs_conv 
  81.668 +          [@{thm rel_fun_eq_eq_onp[THEN eq_reflection]}, 
  81.669 +            @{thm rel_fun_eq_onp_rel[THEN eq_reflection]},
  81.670 +            @{thm rel_fun_eq[THEN eq_reflection]},
  81.671 +            @{thm rel_fun_eq_rel[THEN eq_reflection]}, 
  81.672 +            @{thm rel_fun_def[THEN eq_reflection]}]
  81.673 +        fun binop_conv2 cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2
  81.674 +        val eq_onp_assms_tac_rules = @{thm left_unique_OO} :: 
  81.675 +            eq_onp_assms_tac_fixed_rules @ (Transfer.get_transfer_raw lthy)
  81.676 +        val intro_top_rule = @{thm eq_onp_top_eq_eq[symmetric, THEN eq_reflection]}
  81.677 +        val kill_tops = Transfer.top_sweep_rewr_conv [@{thm eq_onp_top_eq_eq[THEN eq_reflection]}]
  81.678 +        val eq_onp_assms_tac = (CONVERSION kill_tops THEN' 
  81.679 +          TRY o REPEAT_ALL_NEW (resolve_tac lthy eq_onp_assms_tac_rules) 
  81.680 +          THEN_ALL_NEW (DETERM o Transfer.eq_tac lthy)) 1
  81.681 +        val relator_eq_onp_conv = Conv.bottom_conv
  81.682 +          (K (Conv.try_conv (assms_rewrs_conv eq_onp_assms_tac
  81.683 +            (intro_top_rule :: Lifting_Info.get_relator_eq_onp_rules lthy)))) lthy
  81.684 +          then_conv kill_tops
  81.685 +        val relator_eq_conv = Conv.bottom_conv
  81.686 +          (K (Conv.try_conv (Conv.rewrs_conv (Transfer.get_relator_eq lthy)))) lthy
  81.687 +      in
  81.688 +        case (Thm.term_of ctm) of
  81.689 +          Const (@{const_name "rel_fun"}, _) $ _ $ _ => 
  81.690 +            (binop_conv2 simp_arrows_conv simp_arrows_conv then_conv unfold_conv) ctm
  81.691 +          | _ => (relator_eq_onp_conv then_conv relator_eq_conv) ctm
  81.692 +      end
  81.693 +    
  81.694 +    val unfold_ret_val_invs = Conv.bottom_conv 
  81.695 +      (K (Conv.try_conv (Conv.rewr_conv @{thm eq_onp_same_args[THEN eq_reflection]}))) lthy
  81.696 +    val unfold_inv_conv = 
  81.697 +      Conv.top_sweep_conv (K (Conv.rewr_conv @{thm eq_onp_def[THEN eq_reflection]})) lthy
  81.698 +    val simp_conv = HOLogic.Trueprop_conv (Conv.fun2_conv simp_arrows_conv)
  81.699 +    val univq_conv = Conv.rewr_conv @{thm HOL.all_simps(6)[symmetric, THEN eq_reflection]}
  81.700 +    val univq_prenex_conv = Conv.top_conv (K (Conv.try_conv univq_conv)) lthy
  81.701 +    val beta_conv = Thm.beta_conversion true
  81.702 +    val eq_thm = 
  81.703 +      (simp_conv then_conv univq_prenex_conv then_conv beta_conv then_conv unfold_ret_val_invs
  81.704 +         then_conv unfold_inv_conv) ctm
  81.705 +  in
  81.706 +    Object_Logic.rulify lthy (eq_thm RS Drule.equal_elim_rule2)
  81.707 +  end
  81.708 +end
  81.709 +
  81.710 +fun rename_to_tnames ctxt term =
  81.711 +  let
  81.712 +    fun all_typs (Const (@{const_name Pure.all}, _) $ Abs (_, T, t)) = T :: all_typs t
  81.713 +      | all_typs _ = []
  81.714 +
  81.715 +    fun rename (Const (@{const_name Pure.all}, T1) $ Abs (_, T2, t)) (new_name :: names) = 
  81.716 +        (Const (@{const_name Pure.all}, T1) $ Abs (new_name, T2, rename t names)) 
  81.717 +      | rename t _ = t
  81.718 +
  81.719 +    val (fixed_def_t, _) = yield_singleton (Variable.importT_terms) term ctxt
  81.720 +    val new_names = Old_Datatype_Prop.make_tnames (all_typs fixed_def_t)
  81.721 +  in
  81.722 +    rename term new_names
  81.723 +  end
  81.724 +
  81.725 +fun quot_thm_err ctxt (rty, qty) pretty_msg =
  81.726 +  let
  81.727 +    val error_msg = cat_lines
  81.728 +       ["Lifting failed for the following types:",
  81.729 +        Pretty.string_of (Pretty.block
  81.730 +         [Pretty.str "Raw type:", Pretty.brk 2, Syntax.pretty_typ ctxt rty]),
  81.731 +        Pretty.string_of (Pretty.block
  81.732 +         [Pretty.str "Abstract type:", Pretty.brk 2, Syntax.pretty_typ ctxt qty]),
  81.733 +        "",
  81.734 +        (Pretty.string_of (Pretty.block
  81.735 +         [Pretty.str "Reason:", Pretty.brk 2, pretty_msg]))]
  81.736 +  in
  81.737 +    error error_msg
  81.738 +  end
  81.739 +
  81.740 +fun check_rty_err ctxt (rty_schematic, rty_forced) (raw_var, rhs_raw) =
  81.741 +  let
  81.742 +    val (_, ctxt') = yield_singleton Proof_Context.read_vars raw_var ctxt
  81.743 +    val rhs = (Syntax.check_term ctxt' o Syntax.parse_term ctxt') rhs_raw
  81.744 +    val error_msg = cat_lines
  81.745 +       ["Lifting failed for the following term:",
  81.746 +        Pretty.string_of (Pretty.block
  81.747 +         [Pretty.str "Term:", Pretty.brk 2, Syntax.pretty_term ctxt rhs]),
  81.748 +        Pretty.string_of (Pretty.block
  81.749 +         [Pretty.str "Type:", Pretty.brk 2, Syntax.pretty_typ ctxt rty_schematic]),
  81.750 +        "",
  81.751 +        (Pretty.string_of (Pretty.block
  81.752 +         [Pretty.str "Reason:",
  81.753 +          Pretty.brk 2,
  81.754 +          Pretty.str "The type of the term cannot be instantiated to",
  81.755 +          Pretty.brk 1,
  81.756 +          Pretty.quote (Syntax.pretty_typ ctxt rty_forced),
  81.757 +          Pretty.str "."]))]
  81.758 +    in
  81.759 +      error error_msg
  81.760 +    end
  81.761 +
  81.762 +fun lift_def_cmd (params, raw_var, rhs_raw, par_xthms) lthy =
  81.763 +  let
  81.764 +    val config = evaluate_params params
  81.765 +    val ((binding, SOME qty, mx), lthy) = yield_singleton Proof_Context.read_vars raw_var lthy
  81.766 +    val var = (binding, mx)
  81.767 +    val rhs = (Syntax.check_term lthy o Syntax.parse_term lthy) rhs_raw
  81.768 +    val par_thms = Attrib.eval_thms lthy par_xthms
  81.769 +    val (goal, after_qed) = prepare_lift_def (add_lift_def_code_dt config) var qty rhs par_thms lthy
  81.770 +    val (goal, after_qed) =
  81.771 +      case goal of
  81.772 +        NONE => (goal, K (after_qed Drule.dummy_thm))
  81.773 +        | SOME prsp_tm =>
  81.774 +          let
  81.775 +            val readable_rsp_thm_eq = mk_readable_rsp_thm_eq prsp_tm lthy
  81.776 +            val (readable_rsp_tm, _) = Logic.dest_implies (Thm.prop_of readable_rsp_thm_eq)
  81.777 +            val readable_rsp_tm_tnames = rename_to_tnames lthy readable_rsp_tm
  81.778 +        
  81.779 +            fun after_qed' [[thm]] lthy = 
  81.780 +              let
  81.781 +                val internal_rsp_thm = Goal.prove lthy [] [] prsp_tm 
  81.782 +                    (fn {context = ctxt, ...} =>
  81.783 +                      rtac readable_rsp_thm_eq 1 THEN Proof_Context.fact_tac ctxt [thm] 1)
  81.784 +              in
  81.785 +                after_qed internal_rsp_thm lthy
  81.786 +              end
  81.787 +          in
  81.788 +            (SOME readable_rsp_tm_tnames, after_qed')
  81.789 +          end
  81.790 +    fun after_qed_with_err_handling thmss ctxt = (after_qed thmss ctxt
  81.791 +      handle Lifting_Term.QUOT_THM (rty, qty, msg) => quot_thm_err lthy (rty, qty) msg)
  81.792 +      handle Lifting_Term.CHECK_RTY (rty_schematic, rty_forced) =>
  81.793 +        check_rty_err lthy (rty_schematic, rty_forced) (raw_var, rhs_raw);
  81.794 +  in
  81.795 +    Proof.theorem NONE (snd oo after_qed_with_err_handling) [map (rpair []) (the_list goal)] lthy
  81.796 +  end
  81.797 +
  81.798 +fun lift_def_cmd_with_err_handling (params, (raw_var, rhs_raw, par_xthms)) lthy =
  81.799 +  (lift_def_cmd (params, raw_var, rhs_raw, par_xthms) lthy
  81.800 +    handle Lifting_Term.QUOT_THM (rty, qty, msg) => quot_thm_err lthy (rty, qty) msg)
  81.801 +    handle Lifting_Term.CHECK_RTY (rty_schematic, rty_forced) =>
  81.802 +      check_rty_err lthy (rty_schematic, rty_forced) (raw_var, rhs_raw);
  81.803 +
  81.804 +val parse_param = Parse.name
  81.805 +val parse_params = Scan.optional (Args.parens (Parse.list parse_param)) [];
  81.806 +
  81.807 +(* parser and command *)
  81.808 +val liftdef_parser =
  81.809 +  parse_params --
  81.810 +  (((Parse.binding -- (@{keyword "::"} |-- (Parse.typ >> SOME) -- Parse.opt_mixfix') >> Parse.triple2)
  81.811 +    --| @{keyword "is"} -- Parse.term --
  81.812 +      Scan.optional (@{keyword "parametric"} |-- Parse.!!! Parse.xthms1) []) >> Parse.triple1)
  81.813 +
  81.814 +val _ =
  81.815 +  Outer_Syntax.local_theory_to_proof @{command_keyword "lift_definition"}
  81.816 +    "definition for constants over the quotient type"
  81.817 +      (liftdef_parser >> lift_def_cmd_with_err_handling)
  81.818 +
  81.819 +end
    82.1 --- a/src/HOL/Tools/Lifting/lifting_info.ML	Sat May 23 22:13:24 2015 +0200
    82.2 +++ b/src/HOL/Tools/Lifting/lifting_info.ML	Mon May 25 22:11:43 2015 +0200
    82.3 @@ -16,6 +16,7 @@
    82.4    val quotient_eq: quotient * quotient -> bool
    82.5    val transform_quotient: morphism -> quotient -> quotient
    82.6    val lookup_quotients: Proof.context -> string -> quotient option
    82.7 +  val lookup_quot_thm_quotients: Proof.context -> thm -> quotient option
    82.8    val update_quotients: string -> quotient -> Context.generic -> Context.generic
    82.9    val delete_quotients: thm -> Context.generic -> Context.generic
   82.10    val print_quotients: Proof.context -> unit
   82.11 @@ -221,6 +222,17 @@
   82.12  
   82.13  fun lookup_quotients ctxt type_name = Symtab.lookup (get_quotients ctxt) type_name
   82.14  
   82.15 +fun lookup_quot_thm_quotients ctxt quot_thm =
   82.16 +  let
   82.17 +    val (_, qtyp) = quot_thm_rty_qty quot_thm
   82.18 +    val qty_full_name = (fst o dest_Type) qtyp
   82.19 +    fun compare_data (data:quotient) = Thm.eq_thm_prop (#quot_thm data, quot_thm)
   82.20 +  in
   82.21 +    case lookup_quotients ctxt qty_full_name of
   82.22 +      SOME quotient => if compare_data quotient then SOME quotient else NONE
   82.23 +      | NONE => NONE
   82.24 +  end
   82.25 +
   82.26  fun update_quotients type_name qinfo ctxt = 
   82.27    Data.map (map_quotients (Symtab.update (type_name, qinfo))) ctxt
   82.28  
   82.29 @@ -228,10 +240,8 @@
   82.30    let
   82.31      val (_, qtyp) = quot_thm_rty_qty quot_thm
   82.32      val qty_full_name = (fst o dest_Type) qtyp
   82.33 -    val symtab = get_quotients' ctxt
   82.34 -    fun compare_data (_, data:quotient) = Thm.eq_thm_prop (#quot_thm data, quot_thm)
   82.35    in
   82.36 -    if Symtab.member compare_data symtab (qty_full_name, quot_thm)
   82.37 +    if is_some (lookup_quot_thm_quotients (Context.proof_of ctxt) quot_thm)
   82.38        then Data.map (map_quotients (Symtab.delete qty_full_name)) ctxt
   82.39        else ctxt
   82.40    end
    83.1 --- a/src/HOL/Tools/Lifting/lifting_setup.ML	Sat May 23 22:13:24 2015 +0200
    83.2 +++ b/src/HOL/Tools/Lifting/lifting_setup.ML	Mon May 25 22:11:43 2015 +0200
    83.3 @@ -8,11 +8,19 @@
    83.4  sig
    83.5    exception SETUP_LIFTING_INFR of string
    83.6  
    83.7 -  val setup_by_quotient: thm -> thm option -> thm option -> local_theory -> local_theory
    83.8 +  type config = { notes: bool };
    83.9 +  val default_config: config;
   83.10  
   83.11 -  val setup_by_typedef_thm: thm -> local_theory -> local_theory
   83.12 +  val setup_by_quotient: config -> thm -> thm option -> thm option -> local_theory -> 
   83.13 +    binding * local_theory
   83.14 +
   83.15 +  val setup_by_typedef_thm: config -> thm -> local_theory -> binding * local_theory
   83.16  
   83.17    val lifting_restore: Lifting_Info.quotient -> Context.generic -> Context.generic
   83.18 +
   83.19 +  val lifting_forget: string -> local_theory -> local_theory
   83.20 +  val update_transfer_rules: string -> local_theory -> local_theory
   83.21 +  val pointer_of_bundle_binding: Proof.context -> binding -> string
   83.22  end
   83.23  
   83.24  structure Lifting_Setup: LIFTING_SETUP =
   83.25 @@ -24,18 +32,25 @@
   83.26  
   83.27  exception SETUP_LIFTING_INFR of string
   83.28  
   83.29 -fun define_crel rep_fun lthy =
   83.30 +(* Config *)
   83.31 +
   83.32 +type config = { notes: bool };
   83.33 +val default_config = { notes = true };
   83.34 +
   83.35 +fun define_crel (config: config) rep_fun lthy =
   83.36    let
   83.37      val (qty, rty) = (dest_funT o fastype_of) rep_fun
   83.38      val rep_fun_graph = (HOLogic.eq_const rty) $ Bound 1 $ (rep_fun $ Bound 0)
   83.39      val def_term = Abs ("x", rty, Abs ("y", qty, rep_fun_graph))
   83.40      val qty_name = (Binding.name o Long_Name.base_name o fst o dest_Type) qty
   83.41      val crel_name = Binding.prefix_name "cr_" qty_name
   83.42 -    val (fixed_def_term, lthy') = yield_singleton (Variable.importT_terms) def_term lthy
   83.43 -    val ((_, (_ , def_thm)), lthy'') =
   83.44 -      Local_Theory.define ((crel_name, NoSyn), ((Thm.def_binding crel_name, []), fixed_def_term)) lthy'
   83.45 -  in
   83.46 -    (def_thm, lthy'')
   83.47 +    val (fixed_def_term, lthy) = yield_singleton (Variable.importT_terms) def_term lthy
   83.48 +    val ((_, (_ , def_thm)), lthy) = if #notes config then
   83.49 +        Local_Theory.define ((crel_name, NoSyn), ((Thm.def_binding crel_name, []), fixed_def_term)) lthy
   83.50 +      else 
   83.51 +        Local_Theory.define ((Binding.concealed crel_name, NoSyn), ((Binding.empty, []), fixed_def_term)) lthy
   83.52 +  in  
   83.53 +    (def_thm, lthy)
   83.54    end
   83.55  
   83.56  fun print_define_pcrel_warning msg = 
   83.57 @@ -48,7 +63,7 @@
   83.58      warning warning_msg
   83.59    end
   83.60  
   83.61 -fun define_pcrel crel lthy =
   83.62 +fun define_pcrel (config: config) crel lthy =
   83.63    let
   83.64      val (fixed_crel, lthy) = yield_singleton Variable.importT_terms crel lthy
   83.65      val [rty', qty] = (binder_types o fastype_of) fixed_crel
   83.66 @@ -67,14 +82,25 @@
   83.67            (rty --> rty' --> HOLogic.boolT) --> 
   83.68            (rty' --> qty --> HOLogic.boolT) --> 
   83.69            rty --> qty --> HOLogic.boolT)
   83.70 -    val relator_type = foldr1 (op -->) ((map type_of args_fixed) @ [rty, qty, HOLogic.boolT])
   83.71      val qty_name = (fst o dest_Type) qty
   83.72      val pcrel_name = Binding.prefix_name "pcr_" ((Binding.name o Long_Name.base_name) qty_name)
   83.73 +    val relator_type = foldr1 (op -->) ((map type_of args_fixed) @ [rty, qty, HOLogic.boolT])
   83.74      val lhs = Library.foldl (op $) ((Free (Binding.name_of pcrel_name, relator_type)), args_fixed)
   83.75      val rhs = relcomp_op $ param_rel_fixed $ fixed_crel
   83.76      val definition_term = Logic.mk_equals (lhs, rhs)
   83.77 -    val ((_, (_, def_thm)), lthy) = Specification.definition ((SOME (pcrel_name, SOME relator_type, NoSyn)), 
   83.78 -      ((Binding.empty, []), definition_term)) lthy
   83.79 +    fun note_def lthy =
   83.80 +      Specification.definition ((SOME (pcrel_name, SOME relator_type, NoSyn)), 
   83.81 +        ((Binding.empty, []), definition_term)) lthy |>> (snd #> snd);
   83.82 +    fun raw_def lthy =
   83.83 +      let
   83.84 +        val ((_, rhs), prove) = Local_Defs.derived_def lthy true definition_term;
   83.85 +        val ((_, (_, raw_th)), lthy) = lthy
   83.86 +          |> Local_Theory.define ((Binding.concealed pcrel_name, NoSyn), ((Binding.empty, []), rhs));
   83.87 +        val th = prove lthy raw_th;
   83.88 +      in
   83.89 +        (th, lthy)
   83.90 +      end
   83.91 +    val (def_thm, lthy) = if #notes config then note_def lthy else raw_def lthy
   83.92    in
   83.93      (SOME def_thm, lthy)
   83.94    end
   83.95 @@ -96,10 +122,12 @@
   83.96        error error_msg
   83.97      end
   83.98  in
   83.99 -  fun define_pcr_cr_eq lthy pcr_rel_def =
  83.100 +  fun define_pcr_cr_eq (config: config) lthy pcr_rel_def =
  83.101      let
  83.102        val lhs = (Thm.term_of o Thm.lhs_of) pcr_rel_def
  83.103 -      val qty_name = (Binding.name o Long_Name.base_name o fst o dest_Type o List.last o binder_types o fastype_of) lhs
  83.104 +      val qty_name =
  83.105 +        (Binding.name o Long_Name.base_name o fst o dest_Type o
  83.106 +          List.last o binder_types o fastype_of) lhs
  83.107        val args = (snd o strip_comb) lhs
  83.108        
  83.109        fun make_inst var ctxt = 
  83.110 @@ -127,8 +155,8 @@
  83.111              |> Conv.fconv_rule (Conv.arg_conv (Conv.rewr_conv eq_OO_meta))
  83.112              |> mk_HOL_eq
  83.113              |> singleton (Variable.export lthy orig_lthy)
  83.114 -          val ((_, [thm]), lthy) =
  83.115 -            Local_Theory.note ((Binding.qualified true "pcr_cr_eq" qty_name, []), [thm]) lthy
  83.116 +          val lthy = (#notes config ? (Local_Theory.note 
  83.117 +              ((Binding.qualified true "pcr_cr_eq" qty_name, []), [thm]) #> snd)) lthy
  83.118          in
  83.119            (thm, lthy)
  83.120          end
  83.121 @@ -229,18 +257,19 @@
  83.122        |> Local_Theory.declaration {syntax = false, pervasive = true}
  83.123             (fn phi => Lifting_Info.init_restore_data bundle_name (phi_qinfo phi))
  83.124        |> Bundle.bundle ((binding, [restore_lifting_att])) []
  83.125 +      |> pair binding
  83.126    end
  83.127  
  83.128 -fun setup_lifting_infr quot_thm opt_reflp_thm lthy =
  83.129 +fun setup_lifting_infr config quot_thm opt_reflp_thm lthy =
  83.130    let
  83.131      val _ = quot_thm_sanity_check lthy quot_thm
  83.132      val (_, qty) = quot_thm_rty_qty quot_thm
  83.133 -    val (pcrel_def, lthy) = define_pcrel (quot_thm_crel quot_thm) lthy
  83.134 +    val (pcrel_def, lthy) = define_pcrel config (quot_thm_crel quot_thm) lthy
  83.135      (**)
  83.136      val pcrel_def = Option.map (Morphism.thm (Local_Theory.target_morphism lthy)) pcrel_def
  83.137      (**)
  83.138      val (pcr_cr_eq, lthy) = case pcrel_def of
  83.139 -      SOME pcrel_def => apfst SOME (define_pcr_cr_eq lthy pcrel_def)
  83.140 +      SOME pcrel_def => apfst SOME (define_pcr_cr_eq config lthy pcrel_def)
  83.141        | NONE => (NONE, lthy)
  83.142      val pcr_info = case pcrel_def of
  83.143        SOME pcrel_def => SOME { pcrel_def = pcrel_def, pcr_cr_eq = the pcr_cr_eq }
  83.144 @@ -444,10 +473,10 @@
  83.145          (dom_thm RS @{thm pcr_Domainp})
  83.146            |> fold_Domainp_pcrel pcrel_def
  83.147        val thms =
  83.148 -        [("domain",                 pcr_Domainp),
  83.149 -         ("domain_par",             pcr_Domainp_par),
  83.150 -         ("domain_par_left_total",  pcr_Domainp_par_left_total),
  83.151 -         ("domain_eq",              pcr_Domainp_eq)]
  83.152 +        [("domain",                 [pcr_Domainp], @{attributes [transfer_domain_rule]}),
  83.153 +         ("domain_par",             [pcr_Domainp_par], @{attributes [transfer_domain_rule]}),
  83.154 +         ("domain_par_left_total",  [pcr_Domainp_par_left_total], @{attributes [transfer_domain_rule]}),
  83.155 +         ("domain_eq",              [pcr_Domainp_eq], @{attributes [transfer_domain_rule]})]
  83.156      in
  83.157        thms
  83.158      end
  83.159 @@ -459,7 +488,7 @@
  83.160            |> fold_Domainp_pcrel pcrel_def 
  83.161            |> reduce_Domainp ctxt (Transfer.get_relator_domain ctxt)
  83.162      in
  83.163 -      [("domain", thm)]
  83.164 +      [("domain", [thm], @{attributes [transfer_domain_rule]})]
  83.165      end
  83.166  
  83.167  end
  83.168 @@ -470,6 +499,19 @@
  83.169  fun get_Domainp_thm quot_thm =
  83.170     the (get_first (try(curry op RS quot_thm)) [@{thm eq_onp_to_Domainp}, @{thm Quotient_to_Domainp}])
  83.171  
  83.172 +fun notes names thms = 
  83.173 +  let
  83.174 +    val notes =
  83.175 +        if names then map (fn (name, thms, attrs) => ((name, []), [(thms, attrs)])) thms
  83.176 +        else map_filter (fn (_, thms, attrs) => if null attrs then NONE 
  83.177 +          else SOME ((Binding.empty, []), [(thms, attrs)])) thms
  83.178 +  in
  83.179 +    Local_Theory.notes notes #> snd
  83.180 +  end
  83.181 +
  83.182 +fun map_thms map_name map_thm thms = 
  83.183 +  map (fn (name, thms, attr) => (map_name name, map map_thm thms, attr)) thms
  83.184 +
  83.185  (*
  83.186    Sets up the Lifting package by a quotient theorem.
  83.187  
  83.188 @@ -479,64 +521,55 @@
  83.189    opt_par_thm - a parametricity theorem for R
  83.190  *)
  83.191  
  83.192 -fun setup_by_quotient quot_thm opt_reflp_thm opt_par_thm lthy =
  83.193 +fun setup_by_quotient (config: config) quot_thm opt_reflp_thm opt_par_thm lthy =
  83.194    let
  83.195      (**)
  83.196      val quot_thm = Morphism.thm (Local_Theory.target_morphism lthy) quot_thm
  83.197      (**)
  83.198 -    val transfer_attr = Attrib.internal (K Transfer.transfer_add)
  83.199 -    val transfer_domain_attr = Attrib.internal (K Transfer.transfer_domain_add)
  83.200      val (rty, qty) = quot_thm_rty_qty quot_thm
  83.201      val induct_attr = Attrib.internal (K (Induct.induct_type (fst (dest_Type qty))))
  83.202      val qty_full_name = (fst o dest_Type) qty
  83.203      val qty_name = (Binding.name o Long_Name.base_name) qty_full_name
  83.204      fun qualify suffix = Binding.qualified true suffix qty_name
  83.205 -    val lthy = case opt_reflp_thm of
  83.206 +    val notes1 = case opt_reflp_thm of
  83.207        SOME reflp_thm =>
  83.208          let 
  83.209            val thms =
  83.210 -            [("abs_induct",     @{thm Quotient_total_abs_induct}, [induct_attr]),
  83.211 -             ("abs_eq_iff",     @{thm Quotient_total_abs_eq_iff}, []           )]
  83.212 +            [("abs_induct",     @{thms Quotient_total_abs_induct}, [induct_attr]),
  83.213 +             ("abs_eq_iff",     @{thms Quotient_total_abs_eq_iff}, []           )]
  83.214          in
  83.215 -          lthy
  83.216 -            |> fold (fn (name, thm, attr) => (snd oo Local_Theory.note) ((qualify name, attr), 
  83.217 -              [[quot_thm, reflp_thm] MRSL thm])) thms
  83.218 +          map_thms qualify (fn thm => [quot_thm, reflp_thm] MRSL thm) thms
  83.219          end
  83.220        | NONE =>
  83.221          let
  83.222            val thms = 
  83.223 -            [("abs_induct",     @{thm Quotient_abs_induct},       [induct_attr])]
  83.224 +            [("abs_induct",     @{thms Quotient_abs_induct},       [induct_attr])]
  83.225          in
  83.226 -          fold (fn (name, thm, attr) => (snd oo Local_Theory.note) ((qualify name, attr), 
  83.227 -            [quot_thm RS thm])) thms lthy
  83.228 +          map_thms qualify (fn thm => quot_thm RS thm) thms
  83.229          end
  83.230      val dom_thm = get_Domainp_thm quot_thm
  83.231  
  83.232 -    fun setup_transfer_rules_nonpar lthy =
  83.233 +    fun setup_transfer_rules_nonpar notes =
  83.234        let
  83.235 -        val lthy =
  83.236 +        val notes1 =
  83.237            case opt_reflp_thm of
  83.238              SOME reflp_thm =>
  83.239                let 
  83.240                  val thms =
  83.241 -                  [("id_abs_transfer",@{thm Quotient_id_abs_transfer}),
  83.242 -                   ("left_total",     @{thm Quotient_left_total}     ),
  83.243 -                   ("bi_total",       @{thm Quotient_bi_total})]
  83.244 +                  [("id_abs_transfer",@{thms Quotient_id_abs_transfer}, @{attributes [transfer_rule]}),
  83.245 +                   ("left_total",     @{thms Quotient_left_total},      @{attributes [transfer_rule]}),
  83.246 +                   ("bi_total",       @{thms Quotient_bi_total},        @{attributes [transfer_rule]})]
  83.247                in
  83.248 -                fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_attr]), 
  83.249 -                    [[quot_thm, reflp_thm] MRSL thm])) thms lthy
  83.250 +                map_thms qualify (fn thm => [quot_thm, reflp_thm] MRSL thm) thms
  83.251                end
  83.252 -            | NONE =>
  83.253 -              lthy
  83.254 -              |> (snd oo Local_Theory.note) ((qualify "domain", [transfer_domain_attr]), [dom_thm])
  83.255 +            | NONE => map_thms qualify I [("domain", [dom_thm], @{attributes [transfer_domain_rule]})]
  83.256  
  83.257 -        val thms = 
  83.258 -          [("rel_eq_transfer", @{thm Quotient_rel_eq_transfer}),
  83.259 -           ("right_unique",    @{thm Quotient_right_unique}   ), 
  83.260 -           ("right_total",     @{thm Quotient_right_total}    )]
  83.261 +        val notes2 = map_thms qualify (fn thm => quot_thm RS thm)
  83.262 +          [("rel_eq_transfer", @{thms Quotient_rel_eq_transfer}, @{attributes [transfer_rule]}),
  83.263 +           ("right_unique",    @{thms Quotient_right_unique},    @{attributes [transfer_rule]}), 
  83.264 +           ("right_total",     @{thms Quotient_right_total},     @{attributes [transfer_rule]})]
  83.265        in
  83.266 -        fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_attr]), 
  83.267 -          [quot_thm RS thm])) thms lthy
  83.268 +         notes2 @ notes1 @ notes
  83.269        end
  83.270  
  83.271      fun generate_parametric_rel_eq lthy transfer_rule opt_param_thm =
  83.272 @@ -551,11 +584,11 @@
  83.273            error error_msg
  83.274          end
  83.275  
  83.276 -    fun setup_transfer_rules_par lthy =
  83.277 +    fun setup_transfer_rules_par lthy notes =
  83.278        let
  83.279          val pcrel_info = (the (get_pcrel_info lthy qty_full_name))
  83.280          val pcrel_def = #pcrel_def pcrel_info
  83.281 -        val lthy =
  83.282 +        val notes1 =
  83.283            case opt_reflp_thm of
  83.284              SOME reflp_thm =>
  83.285                let
  83.286 @@ -568,22 +601,17 @@
  83.287                  val left_total = parametrize_class_constraint lthy pcrel_def left_total
  83.288                  val bi_total = parametrize_class_constraint lthy pcrel_def bi_total
  83.289                  val thms = 
  83.290 -                  [("id_abs_transfer",id_abs_transfer),
  83.291 -                   ("left_total",     left_total     ),  
  83.292 -                   ("bi_total",       bi_total       )]
  83.293 +                  [("id_abs_transfer", [id_abs_transfer], @{attributes [transfer_rule]}),
  83.294 +                   ("left_total",      [left_total],      @{attributes [transfer_rule]}),  
  83.295 +                   ("bi_total",        [bi_total],        @{attributes [transfer_rule]})]
  83.296                in
  83.297 -                lthy
  83.298 -                |> fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_attr]), 
  83.299 -                     [thm])) thms
  83.300 -                |> fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_domain_attr]), 
  83.301 -                     [thm])) domain_thms
  83.302 +                map_thms qualify I thms @ map_thms qualify I domain_thms
  83.303                end
  83.304              | NONE =>
  83.305                let
  83.306                  val thms = parametrize_domain dom_thm pcrel_info lthy
  83.307                in
  83.308 -                fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_domain_attr]), 
  83.309 -                  [thm])) thms lthy
  83.310 +                map_thms qualify I thms
  83.311                end
  83.312  
  83.313          val rel_eq_transfer = generate_parametric_rel_eq lthy 
  83.314 @@ -593,22 +621,25 @@
  83.315              (quot_thm RS @{thm Quotient_right_unique})
  83.316          val right_total = parametrize_class_constraint lthy pcrel_def 
  83.317              (quot_thm RS @{thm Quotient_right_total})
  83.318 -        val thms = 
  83.319 -          [("rel_eq_transfer", rel_eq_transfer),
  83.320 -           ("right_unique",    right_unique   ), 
  83.321 -           ("right_total",     right_total    )]      
  83.322 +        val notes2 = map_thms qualify I
  83.323 +          [("rel_eq_transfer", [rel_eq_transfer], @{attributes [transfer_rule]}),
  83.324 +           ("right_unique",    [right_unique],    @{attributes [transfer_rule]}), 
  83.325 +           ("right_total",     [right_total],     @{attributes [transfer_rule]})]      
  83.326        in
  83.327 -        fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_attr]), 
  83.328 -          [thm])) thms lthy
  83.329 +        notes2 @ notes1 @ notes
  83.330        end
  83.331  
  83.332 -    fun setup_transfer_rules lthy = 
  83.333 -      if is_some (get_pcrel_info lthy qty_full_name) then setup_transfer_rules_par lthy
  83.334 -                                                     else setup_transfer_rules_nonpar lthy
  83.335 +    fun setup_rules lthy = 
  83.336 +      let
  83.337 +        val thms =  if is_some (get_pcrel_info lthy qty_full_name) 
  83.338 +          then setup_transfer_rules_par lthy notes1 else setup_transfer_rules_nonpar notes1
  83.339 +      in
  83.340 +        notes (#notes config) thms lthy
  83.341 +      end
  83.342    in
  83.343      lthy
  83.344 -      |> setup_lifting_infr quot_thm opt_reflp_thm
  83.345 -      |> setup_transfer_rules
  83.346 +      |> setup_lifting_infr config quot_thm opt_reflp_thm
  83.347 +      ||> setup_rules
  83.348    end
  83.349  
  83.350  (*
  83.351 @@ -619,12 +650,10 @@
  83.352    typedef_thm - a typedef theorem (type_definition Rep Abs S)
  83.353  *)
  83.354  
  83.355 -fun setup_by_typedef_thm typedef_thm lthy =
  83.356 +fun setup_by_typedef_thm config typedef_thm lthy =
  83.357    let
  83.358 -    val transfer_attr = Attrib.internal (K Transfer.transfer_add)
  83.359 -    val transfer_domain_attr = Attrib.internal (K Transfer.transfer_domain_add)
  83.360      val (_ $ rep_fun $ _ $ typedef_set) = (HOLogic.dest_Trueprop o Thm.prop_of) typedef_thm
  83.361 -    val (T_def, lthy) = define_crel rep_fun lthy
  83.362 +    val (T_def, lthy) = define_crel config rep_fun lthy
  83.363      (**)
  83.364      val T_def = Morphism.thm (Local_Theory.target_morphism lthy) T_def
  83.365      (**)    
  83.366 @@ -646,40 +675,37 @@
  83.367          | _ =>  NONE
  83.368      val dom_thm = get_Domainp_thm quot_thm
  83.369  
  83.370 -    fun setup_transfer_rules_nonpar lthy =
  83.371 +    fun setup_transfer_rules_nonpar notes =
  83.372        let
  83.373 -        val lthy =
  83.374 +        val notes1 =
  83.375            case opt_reflp_thm of
  83.376              SOME reflp_thm =>
  83.377                let 
  83.378                  val thms =
  83.379 -                  [("id_abs_transfer",@{thm Quotient_id_abs_transfer}),
  83.380 -                   ("left_total",     @{thm Quotient_left_total}     ),
  83.381 -                   ("bi_total",     @{thm Quotient_bi_total}         )]
  83.382 +                  [("id_abs_transfer",@{thms Quotient_id_abs_transfer}, @{attributes [transfer_rule]}),
  83.383 +                   ("left_total",     @{thms Quotient_left_total},      @{attributes [transfer_rule]}),
  83.384 +                   ("bi_total",       @{thms Quotient_bi_total},        @{attributes [transfer_rule]})]
  83.385                in
  83.386 -                fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_attr]), 
  83.387 -                    [[quot_thm, reflp_thm] MRSL thm])) thms lthy
  83.388 +                map_thms qualify (fn thm => [quot_thm, reflp_thm] MRSL thm) thms
  83.389                end
  83.390              | NONE =>
  83.391 -              lthy
  83.392 -              |> (snd oo Local_Theory.note) ((qualify "domain", [transfer_domain_attr]), [dom_thm])
  83.393 +              map_thms qualify I [("domain", [dom_thm], @{attributes [transfer_domain_rule]})]
  83.394          val thms = 
  83.395 -          [("rep_transfer", @{thm typedef_rep_transfer}),
  83.396 -           ("left_unique",  @{thm typedef_left_unique} ),
  83.397 -           ("right_unique", @{thm typedef_right_unique}), 
  83.398 -           ("right_total",  @{thm typedef_right_total} ),
  83.399 -           ("bi_unique",    @{thm typedef_bi_unique}   )]
  83.400 -      in
  83.401 -        fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_attr]), 
  83.402 -          [[typedef_thm, T_def] MRSL thm])) thms lthy
  83.403 +          [("rep_transfer", @{thms typedef_rep_transfer}, @{attributes [transfer_rule]}),
  83.404 +           ("left_unique",  @{thms typedef_left_unique},  @{attributes [transfer_rule]}),
  83.405 +           ("right_unique", @{thms typedef_right_unique}, @{attributes [transfer_rule]}), 
  83.406 +           ("right_total",  @{thms typedef_right_total},  @{attributes [transfer_rule]}),
  83.407 +           ("bi_unique",    @{thms typedef_bi_unique},    @{attributes [transfer_rule]})]
  83.408 +      in                                               
  83.409 +        map_thms qualify (fn thm => [typedef_thm, T_def] MRSL thm) thms @ notes1 @ notes
  83.410        end
  83.411  
  83.412 -    fun setup_transfer_rules_par lthy =
  83.413 +    fun setup_transfer_rules_par lthy notes =
  83.414        let
  83.415          val pcrel_info = (the (get_pcrel_info lthy qty_full_name))
  83.416          val pcrel_def = #pcrel_def pcrel_info
  83.417  
  83.418 -        val lthy =
  83.419 +        val notes1 =
  83.420            case opt_reflp_thm of
  83.421              SOME reflp_thm =>
  83.422                let
  83.423 @@ -692,48 +718,46 @@
  83.424                    (Lifting_Term.parametrize_transfer_rule lthy
  83.425                      ([quot_thm, reflp_thm] MRSL @{thm Quotient_id_abs_transfer}))
  83.426                  val thms = 
  83.427 -                  [("left_total",     left_total     ),
  83.428 -                   ("bi_total",       bi_total       ),
  83.429 -                   ("id_abs_transfer",id_abs_transfer)]              
  83.430 +                  [("left_total",     [left_total],      @{attributes [transfer_rule]}),
  83.431 +                   ("bi_total",       [bi_total],        @{attributes [transfer_rule]}),
  83.432 +                   ("id_abs_transfer",[id_abs_transfer], @{attributes [transfer_rule]})]              
  83.433                in
  83.434 -                lthy
  83.435 -                |> fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_attr]), 
  83.436 -                     [thm])) thms
  83.437 -                |> fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_domain_attr]), 
  83.438 -                     [thm])) domain_thms
  83.439 +                map_thms qualify I thms @ map_thms qualify I domain_thms
  83.440                end
  83.441              | NONE =>
  83.442                let
  83.443                  val thms = parametrize_domain dom_thm pcrel_info lthy
  83.444                in
  83.445 -                fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_domain_attr]), 
  83.446 -                  [thm])) thms lthy
  83.447 +                map_thms qualify I thms
  83.448                end
  83.449                
  83.450 -        val thms = 
  83.451 -          ("rep_transfer", generate_parametric_id lthy rty 
  83.452 -            (Lifting_Term.parametrize_transfer_rule lthy ([typedef_thm, T_def] MRSL @{thm typedef_rep_transfer})))
  83.453 -          ::
  83.454 -          (map_snd (fn thm => parametrize_class_constraint lthy pcrel_def ([typedef_thm, T_def] MRSL thm))
  83.455 -          [("left_unique",  @{thm typedef_left_unique} ),
  83.456 -           ("right_unique", @{thm typedef_right_unique}),
  83.457 -           ("bi_unique",    @{thm typedef_bi_unique} ),
  83.458 -           ("right_total",  @{thm typedef_right_total} )])
  83.459 +        val notes2 = map_thms qualify (fn thm => generate_parametric_id lthy rty 
  83.460 +            (Lifting_Term.parametrize_transfer_rule lthy ([typedef_thm, T_def] MRSL thm)))
  83.461 +          [("rep_transfer", @{thms typedef_rep_transfer}, @{attributes [transfer_rule]})];
  83.462 +        val notes3 =
  83.463 +          map_thms qualify
  83.464 +          (fn thm => parametrize_class_constraint lthy pcrel_def ([typedef_thm, T_def] MRSL thm))
  83.465 +          [("left_unique",  @{thms typedef_left_unique}, @{attributes [transfer_rule]}),
  83.466 +           ("right_unique", @{thms typedef_right_unique},@{attributes [transfer_rule]}),
  83.467 +           ("bi_unique",    @{thms typedef_bi_unique},   @{attributes [transfer_rule]}),
  83.468 +           ("right_total",  @{thms typedef_right_total}, @{attributes [transfer_rule]})]
  83.469        in
  83.470 -        fold (fn (name, thm) => (snd oo Local_Theory.note) ((qualify name, [transfer_attr]), 
  83.471 -          [thm])) thms lthy
  83.472 +        notes3 @ notes2 @ notes1 @ notes
  83.473        end
  83.474  
  83.475 -    fun setup_transfer_rules lthy = 
  83.476 -      if is_some (get_pcrel_info lthy qty_full_name) then setup_transfer_rules_par lthy
  83.477 -                                                     else setup_transfer_rules_nonpar lthy
  83.478 +    val notes1 = [(Binding.prefix_name "Quotient_" qty_name, [quot_thm], [])]
  83.479  
  83.480 +    fun setup_rules lthy = 
  83.481 +      let
  83.482 +        val thms =  if is_some (get_pcrel_info lthy qty_full_name) 
  83.483 +          then setup_transfer_rules_par lthy notes1 else setup_transfer_rules_nonpar notes1
  83.484 +      in
  83.485 +        notes (#notes config) thms lthy
  83.486 +      end
  83.487    in
  83.488      lthy
  83.489 -      |> (snd oo Local_Theory.note) ((Binding.prefix_name "Quotient_" qty_name, []), 
  83.490 -            [quot_thm])
  83.491 -      |> setup_lifting_infr quot_thm opt_reflp_thm
  83.492 -      |> setup_transfer_rules
  83.493 +      |> setup_lifting_infr config quot_thm opt_reflp_thm
  83.494 +      ||> setup_rules
  83.495    end
  83.496  
  83.497  fun setup_lifting_cmd xthm opt_reflp_xthm opt_par_xthm lthy =
  83.498 @@ -755,7 +779,7 @@
  83.499      fun check_qty qty = if not (is_Type qty) 
  83.500            then error "The abstract type must be a type constructor."
  83.501            else ()
  83.502 -
  83.503 +   
  83.504      fun setup_quotient () = 
  83.505        let
  83.506          val opt_reflp_thm = Option.map (singleton (Attrib.eval_thms lthy)) opt_reflp_xthm
  83.507 @@ -763,7 +787,7 @@
  83.508          val opt_par_thm = Option.map (singleton (Attrib.eval_thms lthy)) opt_par_xthm
  83.509          val _ = check_qty (snd (quot_thm_rty_qty input_thm))
  83.510        in
  83.511 -        setup_by_quotient input_thm opt_reflp_thm opt_par_thm lthy
  83.512 +        setup_by_quotient default_config input_thm opt_reflp_thm opt_par_thm lthy |> snd
  83.513        end
  83.514  
  83.515      fun setup_typedef () = 
  83.516 @@ -776,7 +800,7 @@
  83.517            | NONE => (
  83.518              case opt_par_xthm of
  83.519                SOME _ => error "The parametricity theorem cannot be specified if the type_definition theorem is used."
  83.520 -              | NONE => setup_by_typedef_thm input_thm lthy
  83.521 +              | NONE => setup_by_typedef_thm default_config input_thm lthy |> snd
  83.522            )
  83.523        end
  83.524    in
  83.525 @@ -969,6 +993,9 @@
  83.526        | _ => error "The provided bundle is not a lifting bundle."
  83.527    end
  83.528  
  83.529 +fun pointer_of_bundle_binding ctxt binding = Name_Space.full_name (Name_Space.naming_of 
  83.530 +      (Context.Theory (Proof_Context.theory_of ctxt))) binding
  83.531 +
  83.532  fun lifting_forget pointer lthy =
  83.533    let
  83.534      fun get_transfer_rules_to_delete qinfo ctxt =
    84.1 --- a/src/HOL/Tools/Lifting/lifting_term.ML	Sat May 23 22:13:24 2015 +0200
    84.2 +++ b/src/HOL/Tools/Lifting/lifting_term.ML	Mon May 25 22:11:43 2015 +0200
    84.3 @@ -11,6 +11,16 @@
    84.4    exception MERGE_TRANSFER_REL of Pretty.T
    84.5    exception CHECK_RTY of typ * typ
    84.6  
    84.7 +  type 'a fold_quot_thm = { constr: typ -> thm * 'a -> thm * 'a, lift: typ -> thm * 'a -> thm * 'a, 
    84.8 +  comp_lift: typ -> thm * 'a -> thm * 'a }
    84.9 +
   84.10 +  type quotients = Lifting_Info.quotient Symtab.table
   84.11 +  
   84.12 +  val force_qty_type: Proof.context -> typ -> thm -> thm
   84.13 +
   84.14 +  val prove_schematic_quot_thm: 'a fold_quot_thm -> quotients -> Proof.context -> 
   84.15 +    typ * typ -> 'a -> thm * 'a
   84.16 +
   84.17    val instantiate_rtys: Proof.context -> typ * typ -> typ * typ
   84.18  
   84.19    val prove_quot_thm: Proof.context -> typ * typ -> thm
   84.20 @@ -40,6 +50,8 @@
   84.21  exception MERGE_TRANSFER_REL of Pretty.T
   84.22  exception CHECK_RTY of typ * typ
   84.23  
   84.24 +type quotients = Lifting_Info.quotient Symtab.table
   84.25 +
   84.26  fun match ctxt err ty_pat ty =
   84.27    let
   84.28      val thy = Proof_Context.theory_of ctxt
   84.29 @@ -61,43 +73,43 @@
   84.30         Pretty.str "don't match."])
   84.31    end
   84.32  
   84.33 -fun get_quot_data ctxt s =
   84.34 -  case Lifting_Info.lookup_quotients ctxt s of
   84.35 +fun get_quot_data (quotients: quotients) s =
   84.36 +  case Symtab.lookup quotients s of
   84.37      SOME qdata => qdata
   84.38    | NONE => raise QUOT_THM_INTERNAL (Pretty.block 
   84.39      [Pretty.str ("No quotient type " ^ quote s), 
   84.40       Pretty.brk 1, 
   84.41       Pretty.str "found."])
   84.42  
   84.43 -fun get_quot_thm ctxt s =
   84.44 +fun get_quot_thm quotients ctxt s =
   84.45    let
   84.46      val thy = Proof_Context.theory_of ctxt
   84.47    in
   84.48 -    Thm.transfer thy (#quot_thm (get_quot_data ctxt s))
   84.49 +    Thm.transfer thy (#quot_thm (get_quot_data quotients s))
   84.50    end
   84.51  
   84.52 -fun has_pcrel_info ctxt s = is_some (#pcr_info (get_quot_data ctxt s))
   84.53 +fun has_pcrel_info quotients s = is_some (#pcr_info (get_quot_data quotients s))
   84.54  
   84.55 -fun get_pcrel_info ctxt s =
   84.56 -  case #pcr_info (get_quot_data ctxt s) of
   84.57 +fun get_pcrel_info quotients s =
   84.58 +  case #pcr_info (get_quot_data quotients s) of
   84.59      SOME pcr_info => pcr_info
   84.60    | NONE => raise QUOT_THM_INTERNAL (Pretty.block 
   84.61      [Pretty.str ("No parametrized correspondce relation for " ^ quote s), 
   84.62       Pretty.brk 1, 
   84.63       Pretty.str "found."])
   84.64  
   84.65 -fun get_pcrel_def ctxt s =
   84.66 +fun get_pcrel_def quotients ctxt s =
   84.67    let
   84.68      val thy = Proof_Context.theory_of ctxt
   84.69    in
   84.70 -    Thm.transfer thy (#pcrel_def (get_pcrel_info ctxt s))
   84.71 +    Thm.transfer thy (#pcrel_def (get_pcrel_info quotients s))
   84.72    end
   84.73  
   84.74 -fun get_pcr_cr_eq ctxt s =
   84.75 +fun get_pcr_cr_eq quotients ctxt s =
   84.76    let
   84.77      val thy = Proof_Context.theory_of ctxt
   84.78    in
   84.79 -    Thm.transfer thy (#pcr_cr_eq (get_pcrel_info ctxt s))
   84.80 +    Thm.transfer thy (#pcr_cr_eq (get_pcrel_info quotients s))
   84.81    end
   84.82  
   84.83  fun get_rel_quot_thm ctxt s =
   84.84 @@ -188,11 +200,12 @@
   84.85            rel_quot_thm_prems
   84.86        end
   84.87  
   84.88 -fun rty_is_TVar ctxt qty = (is_TVar o fst o quot_thm_rty_qty o get_quot_thm ctxt o Tname) qty
   84.89 +fun gen_rty_is_TVar quotients ctxt qty = qty |> Tname |> get_quot_thm quotients ctxt |> 
   84.90 +  quot_thm_rty_qty |> fst |> is_TVar
   84.91  
   84.92 -fun instantiate_rtys ctxt (rty, (qty as Type (qty_name, _))) =
   84.93 +fun gen_instantiate_rtys quotients ctxt (rty, (qty as Type (qty_name, _))) =
   84.94    let
   84.95 -    val quot_thm = get_quot_thm ctxt qty_name
   84.96 +    val quot_thm = get_quot_thm quotients ctxt qty_name
   84.97      val (rty_pat, qty_pat) = quot_thm_rty_qty quot_thm
   84.98  
   84.99      fun inst_rty (Type (s, tys), Type (s', tys')) = 
  84.100 @@ -216,27 +229,39 @@
  84.101    in
  84.102      (inst_rty (rty_pat, rty), Envir.subst_type qtyenv rty_pat)
  84.103    end
  84.104 -  | instantiate_rtys _ _ = error "instantiate_rtys: not Type"
  84.105 +  | gen_instantiate_rtys _ _ _ = error "gen_instantiate_rtys: not Type"
  84.106 +
  84.107 +fun instantiate_rtys ctxt (rty, qty) = 
  84.108 +  gen_instantiate_rtys (Lifting_Info.get_quotients ctxt) ctxt (rty, qty)
  84.109  
  84.110 -fun prove_schematic_quot_thm ctxt (rty, qty) =
  84.111 +type 'a fold_quot_thm = { constr: typ -> thm * 'a -> thm * 'a, lift: typ -> thm * 'a -> thm * 'a, 
  84.112 +  comp_lift: typ -> thm * 'a -> thm * 'a }
  84.113 +
  84.114 +fun prove_schematic_quot_thm (actions: 'a fold_quot_thm) quotients ctxt (rty, qty) fold_val =
  84.115    let
  84.116      fun lifting_step (rty, qty) =
  84.117        let
  84.118 -        val (rty', rtyq) = instantiate_rtys ctxt (rty, qty)
  84.119 -        val (rty's, rtyqs) = if rty_is_TVar ctxt qty then ([rty'],[rtyq]) 
  84.120 +        val (rty', rtyq) = gen_instantiate_rtys quotients ctxt (rty, qty)
  84.121 +        val (rty's, rtyqs) = if gen_rty_is_TVar quotients ctxt qty then ([rty'],[rtyq]) 
  84.122            else (Targs rty', Targs rtyq) 
  84.123 -        val args = map (prove_schematic_quot_thm ctxt) (rty's ~~ rtyqs)
  84.124 +        val (args, fold_val) = 
  84.125 +          fold_map (prove_schematic_quot_thm actions quotients ctxt) (rty's ~~ rtyqs) fold_val
  84.126        in
  84.127          if forall is_id_quot args
  84.128          then
  84.129 -          get_quot_thm ctxt (Tname qty)
  84.130 +          let
  84.131 +            val quot_thm = get_quot_thm quotients ctxt (Tname qty)
  84.132 +          in
  84.133 +            #lift actions qty (quot_thm, fold_val)
  84.134 +          end
  84.135          else
  84.136            let
  84.137 -            val quot_thm = get_quot_thm ctxt (Tname qty)
  84.138 -            val rel_quot_thm = if rty_is_TVar ctxt qty then the_single args else
  84.139 +            val quot_thm = get_quot_thm quotients ctxt (Tname qty)
  84.140 +            val rel_quot_thm = if gen_rty_is_TVar quotients ctxt qty then the_single args else
  84.141                args MRSL (get_rel_quot_thm ctxt (Tname rty))
  84.142 +            val comp_quot_thm = [rel_quot_thm, quot_thm] MRSL @{thm Quotient_compose}
  84.143            in
  84.144 -            [rel_quot_thm, quot_thm] MRSL @{thm Quotient_compose}
  84.145 +            #comp_lift actions qty (comp_quot_thm, fold_val)
  84.146           end
  84.147        end
  84.148    in
  84.149 @@ -245,18 +270,24 @@
  84.150          if s = s'
  84.151          then
  84.152            let
  84.153 -            val args = map (prove_schematic_quot_thm ctxt) (zip_Tvars ctxt s tys tys')
  84.154 +            val (args, fold_val) = 
  84.155 +              fold_map (prove_schematic_quot_thm actions quotients ctxt) 
  84.156 +                (zip_Tvars ctxt s tys tys') fold_val
  84.157            in
  84.158              if forall is_id_quot args
  84.159              then
  84.160 -              @{thm identity_quotient}
  84.161 +              (@{thm identity_quotient}, fold_val)
  84.162              else
  84.163 -              args MRSL (get_rel_quot_thm ctxt s)
  84.164 +              let
  84.165 +                val quot_thm = args MRSL (get_rel_quot_thm ctxt s)
  84.166 +              in
  84.167 +                #constr actions qty (quot_thm, fold_val)
  84.168 +              end
  84.169            end
  84.170          else
  84.171            lifting_step (rty, qty)
  84.172        | (_, Type (s', tys')) => 
  84.173 -        (case try (get_quot_thm ctxt) s' of
  84.174 +        (case try (get_quot_thm quotients ctxt) s' of
  84.175            SOME quot_thm => 
  84.176              let
  84.177                val rty_pat = (fst o quot_thm_rty_qty) quot_thm
  84.178 @@ -267,9 +298,10 @@
  84.179              let                                               
  84.180                val rty_pat = Type (s', map (fn _ => TFree ("a",[])) tys')
  84.181              in
  84.182 -              prove_schematic_quot_thm ctxt (rty_pat, qty)
  84.183 +              prove_schematic_quot_thm actions quotients ctxt (rty_pat, qty) fold_val
  84.184              end)
  84.185 -      | _ => @{thm identity_quotient})
  84.186 +      | _ => (@{thm identity_quotient}, fold_val)
  84.187 +      )
  84.188    end
  84.189    handle QUOT_THM_INTERNAL pretty_msg => raise QUOT_THM (rty, qty, pretty_msg)
  84.190  
  84.191 @@ -302,14 +334,20 @@
  84.192      qty, a representation type of the theorem is an instance of rty in general.
  84.193  *)
  84.194  
  84.195 -fun prove_quot_thm ctxt (rty, qty) =
  84.196 -  let
  84.197 -    val schematic_quot_thm = prove_schematic_quot_thm ctxt (rty, qty)
  84.198 -    val quot_thm = force_qty_type ctxt qty schematic_quot_thm
  84.199 -    val _ = check_rty_type ctxt rty quot_thm
  84.200 -  in
  84.201 -    quot_thm
  84.202 -  end
  84.203 +
  84.204 +local
  84.205 +  val id_actions = { constr = K I, lift = K I, comp_lift = K I }
  84.206 +in
  84.207 +  fun prove_quot_thm ctxt (rty, qty) =
  84.208 +    let
  84.209 +      val quotients = Lifting_Info.get_quotients ctxt
  84.210 +      val (schematic_quot_thm, _) = prove_schematic_quot_thm id_actions quotients ctxt (rty, qty) ()
  84.211 +      val quot_thm = force_qty_type ctxt qty schematic_quot_thm
  84.212 +      val _ = check_rty_type ctxt rty quot_thm
  84.213 +    in
  84.214 +      quot_thm
  84.215 +    end
  84.216 +end
  84.217  
  84.218  (*
  84.219    Computes the composed abstraction function for rty and qty.
  84.220 @@ -449,17 +487,7 @@
  84.221    fun rewrs_imp rules = first_imp (map rewr_imp rules)
  84.222  in
  84.223  
  84.224 -  (*
  84.225 -    ctm - of the form "[POS|NEG] (par_R OO T) t f) ?X", where par_R is a parametricity transfer 
  84.226 -    relation for t and T is a transfer relation between t and f, which consists only from
  84.227 -    parametrized transfer relations (i.e., pcr_?) and equalities op=. POS or NEG encodes
  84.228 -    co-variance or contra-variance.
  84.229 -    
  84.230 -    The function merges par_R OO T using definitions of parametrized correspondence relations
  84.231 -    (e.g., (rel_S R) OO (pcr_T op=) --> pcr_T R using the definition pcr_T R = (rel_S R) OO cr_T).
  84.232 -  *)
  84.233 -
  84.234 -  fun merge_transfer_relations ctxt ctm =
  84.235 +  fun gen_merge_transfer_relations quotients ctxt ctm =
  84.236      let
  84.237        val ctm = Thm.dest_arg ctm
  84.238        val tm = Thm.term_of ctm
  84.239 @@ -507,19 +535,21 @@
  84.240                  in
  84.241                    case distr_rule of
  84.242                      NONE => raise MERGE_TRANSFER_REL (cannot_merge_error_msg ())
  84.243 -                    | SOME distr_rule =>  (map (merge_transfer_relations ctxt) (cprems_of distr_rule)) 
  84.244 +                    | SOME distr_rule =>  (map (gen_merge_transfer_relations quotients ctxt) 
  84.245 +                                            (cprems_of distr_rule)) 
  84.246                        MRSL distr_rule
  84.247                  end
  84.248                else
  84.249                  let 
  84.250 -                  val pcrel_def = get_pcrel_def ctxt ((fst o dest_Type) qty)
  84.251 +                  val pcrel_def = get_pcrel_def quotients ctxt ((fst o dest_Type) qty)
  84.252                    val pcrel_const = (head_of o fst o Logic.dest_equals o Thm.prop_of) pcrel_def
  84.253                  in
  84.254                    if same_constants pcrel_const (head_of trans_rel) then
  84.255                      let
  84.256                        val unfolded_ctm = Thm.rhs_of (Conv.arg1_conv (Conv.arg_conv (Conv.rewr_conv pcrel_def)) ctm)
  84.257                        val distr_rule = rewrs_imp @{thms POS_pcr_rule NEG_pcr_rule} unfolded_ctm
  84.258 -                      val result = (map (merge_transfer_relations ctxt) (cprems_of distr_rule)) MRSL distr_rule
  84.259 +                      val result = (map (gen_merge_transfer_relations quotients ctxt) 
  84.260 +                        (cprems_of distr_rule)) MRSL distr_rule
  84.261                        val fold_pcr_rel = Conv.rewr_conv (Thm.symmetric pcrel_def)
  84.262                      in  
  84.263                        Conv.fconv_rule (HOLogic.Trueprop_conv (Conv.combination_conv 
  84.264 @@ -531,17 +561,22 @@
  84.265              end
  84.266      end
  84.267      handle QUOT_THM_INTERNAL pretty_msg => raise MERGE_TRANSFER_REL pretty_msg
  84.268 +
  84.269 +  (*
  84.270 +    ctm - of the form "[POS|NEG] (par_R OO T) t f) ?X", where par_R is a parametricity transfer 
  84.271 +    relation for t and T is a transfer relation between t and f, which consists only from
  84.272 +    parametrized transfer relations (i.e., pcr_?) and equalities op=. POS or NEG encodes
  84.273 +    co-variance or contra-variance.
  84.274 +    
  84.275 +    The function merges par_R OO T using definitions of parametrized correspondence relations
  84.276 +    (e.g., (rel_S R) OO (pcr_T op=) --> pcr_T R using the definition pcr_T R = (rel_S R) OO cr_T).
  84.277 +  *)
  84.278 +
  84.279 +  fun merge_transfer_relations ctxt ctm = gen_merge_transfer_relations 
  84.280 +    (Lifting_Info.get_quotients ctxt) ctxt ctm
  84.281  end
  84.282  
  84.283 -(*
  84.284 -  It replaces cr_T by pcr_T op= in the transfer relation. For composed
  84.285 -  abstract types, it replaces T_rel R OO cr_T by pcr_T R. If the parametrized
  84.286 -  correspondce relation does not exist, the original relation is kept.
  84.287 -
  84.288 -  thm - a transfer rule
  84.289 -*)
  84.290 -
  84.291 -fun parametrize_transfer_rule ctxt thm =
  84.292 +fun gen_parametrize_transfer_rule quotients ctxt thm =
  84.293    let
  84.294      fun parametrize_relation_conv ctm =
  84.295        let
  84.296 @@ -558,21 +593,21 @@
  84.297                val q = (fst o dest_Type) qty
  84.298              in
  84.299                let
  84.300 -                val (rty', rtyq) = instantiate_rtys ctxt (rty, qty)
  84.301 -                val (rty's, rtyqs) = if rty_is_TVar ctxt qty then ([rty'],[rtyq]) 
  84.302 +                val (rty', rtyq) = gen_instantiate_rtys quotients ctxt (rty, qty)
  84.303 +                val (rty's, rtyqs) = if gen_rty_is_TVar quotients ctxt qty then ([rty'],[rtyq]) 
  84.304                    else (Targs rty', Targs rtyq)
  84.305                in
  84.306                  if forall op= (rty's ~~ rtyqs) then
  84.307                    let
  84.308 -                    val pcr_cr_eq = (Thm.symmetric o mk_meta_eq) (get_pcr_cr_eq ctxt q)
  84.309 +                    val pcr_cr_eq = (Thm.symmetric o mk_meta_eq) (get_pcr_cr_eq quotients ctxt q)
  84.310                    in      
  84.311                      Conv.rewr_conv pcr_cr_eq ctm
  84.312                    end
  84.313                    handle QUOT_THM_INTERNAL _ => Conv.all_conv ctm
  84.314                  else
  84.315 -                  if has_pcrel_info ctxt q then
  84.316 +                  if has_pcrel_info quotients q then
  84.317                      let 
  84.318 -                      val pcrel_def = Thm.symmetric (get_pcrel_def ctxt q)
  84.319 +                      val pcrel_def = Thm.symmetric (get_pcrel_def quotients ctxt q)
  84.320                      in
  84.321                        (Conv.rewr_conv pcrel_def then_conv all_args_conv parametrize_relation_conv) ctm
  84.322                      end
  84.323 @@ -584,4 +619,16 @@
  84.324      in
  84.325        Conv.fconv_rule (HOLogic.Trueprop_conv (Conv.fun2_conv parametrize_relation_conv)) thm
  84.326      end
  84.327 +
  84.328 +(*
  84.329 +  It replaces cr_T by pcr_T op= in the transfer relation. For composed
  84.330 +  abstract types, it replaces T_rel R OO cr_T by pcr_T R. If the parametrized
  84.331 +  correspondce relation does not exist, the original relation is kept.
  84.332 +
  84.333 +  thm - a transfer rule
  84.334 +*)
  84.335 +
  84.336 +fun parametrize_transfer_rule ctxt thm = 
  84.337 +  gen_parametrize_transfer_rule (Lifting_Info.get_quotients ctxt) ctxt thm
  84.338 +
  84.339  end
    85.1 --- a/src/HOL/Tools/Lifting/lifting_util.ML	Sat May 23 22:13:24 2015 +0200
    85.2 +++ b/src/HOL/Tools/Lifting/lifting_util.ML	Mon May 25 22:11:43 2015 +0200
    85.3 @@ -16,6 +16,8 @@
    85.4    val quot_thm_rep: thm -> term
    85.5    val quot_thm_crel: thm -> term
    85.6    val quot_thm_rty_qty: thm -> typ * typ
    85.7 +  val Quotient_conv: conv -> conv -> conv -> conv -> conv
    85.8 +  val Quotient_R_conv: conv -> conv
    85.9  
   85.10    val undisch: thm -> thm
   85.11    val undisch_all: thm -> thm
   85.12 @@ -32,6 +34,9 @@
   85.13    val mk_HOL_eq: thm -> thm
   85.14    val safe_HOL_meta_eq: thm -> thm
   85.15    val map_interrupt: ('a -> 'b option) -> 'a list -> 'b list option
   85.16 +  val instT_thm: Proof.context -> Type.tyenv -> thm -> thm
   85.17 +  val instT_morphism: Proof.context -> Type.tyenv -> morphism
   85.18 +  val conceal_naming_result: (local_theory -> 'a * local_theory) -> local_theory -> 'a * local_theory
   85.19  end
   85.20  
   85.21  
   85.22 @@ -80,6 +85,11 @@
   85.23      (domain_type abs_type, range_type abs_type)
   85.24    end
   85.25  
   85.26 +fun Quotient_conv R_conv Abs_conv Rep_conv T_conv = Conv.combination_conv (Conv.combination_conv 
   85.27 +  (Conv.combination_conv (Conv.arg_conv R_conv) Abs_conv) Rep_conv) T_conv;
   85.28 +  
   85.29 +fun Quotient_R_conv R_conv = Quotient_conv R_conv Conv.all_conv Conv.all_conv Conv.all_conv;
   85.30 +
   85.31  fun undisch thm =
   85.32    let
   85.33      val assm = Thm.cprem_of thm 1
   85.34 @@ -132,4 +142,23 @@
   85.35      map_interrupt' f l []
   85.36    end
   85.37  
   85.38 +fun instT_thm ctxt env =
   85.39 +  let
   85.40 +    val cinst = env |> Vartab.dest 
   85.41 +      |> map (fn (x, (S, T)) => (Thm.ctyp_of ctxt (TVar (x, S)), Thm.ctyp_of ctxt T));
   85.42 +  in
   85.43 +    Thm.instantiate (cinst, [])
   85.44 +  end;
   85.45 +
   85.46 +fun instT_morphism ctxt env =
   85.47 +  Morphism.morphism "Lifting_Util.instT"
   85.48 +    {binding = [],
   85.49 +    typ = [Envir.subst_type env],
   85.50 +    term = [Envir.subst_term_types env],
   85.51 +    fact = [map (instT_thm ctxt env)]};
   85.52 +
   85.53 +fun conceal_naming_result f lthy = 
   85.54 +  let val old_lthy = lthy
   85.55 +  in lthy |> Proof_Context.concealed |> f ||> Proof_Context.restore_naming old_lthy end;
   85.56 +
   85.57  end
    86.1 --- a/src/HOL/Tools/Nitpick/nitpick_commands.ML	Sat May 23 22:13:24 2015 +0200
    86.2 +++ b/src/HOL/Tools/Nitpick/nitpick_commands.ML	Mon May 25 22:11:43 2015 +0200
    86.3 @@ -377,7 +377,7 @@
    86.4    Outer_Syntax.command @{command_keyword nitpick}
    86.5      "try to find a counterexample for a given subgoal using Nitpick"
    86.6      (parse_params -- Scan.optional Parse.nat 1 >> (fn (params, i) =>
    86.7 -      Toplevel.keep (fn state =>
    86.8 +      Toplevel.keep_proof (fn state =>
    86.9          ignore (pick_nits params Normal i (Toplevel.proof_position_of state)
   86.10            (Toplevel.proof_of state)))))
   86.11  
    87.1 --- a/src/HOL/Tools/Nitpick/nitpick_model.ML	Sat May 23 22:13:24 2015 +0200
    87.2 +++ b/src/HOL/Tools/Nitpick/nitpick_model.ML	Mon May 25 22:11:43 2015 +0200
    87.3 @@ -879,8 +879,11 @@
    87.4          t1 = t2
    87.5      end
    87.6  
    87.7 -fun pretty_term_auto_global ctxt t =
    87.8 +fun pretty_term_auto_global ctxt t0 =
    87.9    let
   87.10 +    val t = map_aterms (fn t as Const (s, _) =>
   87.11 +      if s = irrelevant orelse s = unknown then Term.dummy else t | t => t) t0
   87.12 +
   87.13      fun add_fake_const s =
   87.14        Sign.declare_const_global ((Binding.name s, @{typ 'a}), NoSyn)
   87.15        #> #2
    88.1 --- a/src/HOL/Tools/Quotient/quotient_type.ML	Sat May 23 22:13:24 2015 +0200
    88.2 +++ b/src/HOL/Tools/Quotient/quotient_type.ML	Mon May 25 22:11:43 2015 +0200
    88.3 @@ -125,9 +125,11 @@
    88.4        | Const (@{const_name part_equivp}, _) $ _ =>
    88.5            (NONE, [quot3_thm, T_def] MRSL @{thm Quotient3_to_Quotient})
    88.6        | _ => error "unsupported equivalence theorem")
    88.7 +    val config = { notes = true }
    88.8    in
    88.9      lthy'
   88.10 -      |> Lifting_Setup.setup_by_quotient quot_thm reflp_thm opt_par_thm
   88.11 +      |> Lifting_Setup.setup_by_quotient config quot_thm reflp_thm opt_par_thm
   88.12 +      |> snd
   88.13        |> (snd oo Local_Theory.note) ((quotient_thm_name, []), [quot_thm])
   88.14    end
   88.15  
    89.1 --- a/src/HOL/Tools/SMT/cvc4_proof_parse.ML	Sat May 23 22:13:24 2015 +0200
    89.2 +++ b/src/HOL/Tools/SMT/cvc4_proof_parse.ML	Mon May 25 22:11:43 2015 +0200
    89.3 @@ -15,29 +15,32 @@
    89.4  struct
    89.5  
    89.6  fun parse_proof ({ll_defs, assms, ...} : SMT_Translate.replay_data) xfacts prems _ output =
    89.7 -  let
    89.8 -    val num_ll_defs = length ll_defs
    89.9 +  if exists (String.isPrefix "(error \"This build of CVC4 doesn't have proof support") output then
   89.10 +    {outcome = NONE, fact_ids = NONE, atp_proof = K []}
   89.11 +  else
   89.12 +    let
   89.13 +      val num_ll_defs = length ll_defs
   89.14  
   89.15 -    val id_of_index = Integer.add num_ll_defs
   89.16 -    val index_of_id = Integer.add (~ num_ll_defs)
   89.17 +      val id_of_index = Integer.add num_ll_defs
   89.18 +      val index_of_id = Integer.add (~ num_ll_defs)
   89.19  
   89.20 -    val used_assert_ids = map_filter (try SMTLIB_Interface.assert_index_of_name) output
   89.21 -    val used_assm_js =
   89.22 -      map_filter (fn id => let val i = index_of_id id in if i >= 0 then SOME i else NONE end)
   89.23 -        used_assert_ids
   89.24 +      val used_assert_ids = map_filter (try SMTLIB_Interface.assert_index_of_name) output
   89.25 +      val used_assm_js =
   89.26 +        map_filter (fn id => let val i = index_of_id id in if i >= 0 then SOME i else NONE end)
   89.27 +          used_assert_ids
   89.28  
   89.29 -    val conjecture_i = 0
   89.30 -    val prems_i = conjecture_i + 1
   89.31 -    val num_prems = length prems
   89.32 -    val facts_i = prems_i + num_prems
   89.33 +      val conjecture_i = 0
   89.34 +      val prems_i = conjecture_i + 1
   89.35 +      val num_prems = length prems
   89.36 +      val facts_i = prems_i + num_prems
   89.37  
   89.38 -    val fact_ids' =
   89.39 -      map_filter (fn j =>
   89.40 -        let val (i, _) = nth assms j in
   89.41 -          try (apsnd (nth xfacts)) (id_of_index j, i - facts_i)
   89.42 -        end) used_assm_js
   89.43 -  in
   89.44 -    {outcome = NONE, fact_ids = fact_ids', atp_proof = fn () => []}
   89.45 -  end
   89.46 +      val fact_ids' =
   89.47 +        map_filter (fn j =>
   89.48 +          let val (i, _) = nth assms j in
   89.49 +            try (apsnd (nth xfacts)) (id_of_index j, i - facts_i)
   89.50 +          end) used_assm_js
   89.51 +    in
   89.52 +      {outcome = NONE, fact_ids = SOME fact_ids', atp_proof = K []}
   89.53 +    end
   89.54  
   89.55  end;
    90.1 --- a/src/HOL/Tools/SMT/smt_solver.ML	Sat May 23 22:13:24 2015 +0200
    90.2 +++ b/src/HOL/Tools/SMT/smt_solver.ML	Mon May 25 22:11:43 2015 +0200
    90.3 @@ -11,7 +11,7 @@
    90.4  
    90.5    type parsed_proof =
    90.6      {outcome: SMT_Failure.failure option,
    90.7 -     fact_ids: (int * ((string * ATP_Problem_Generate.stature) * thm)) list,
    90.8 +     fact_ids: (int * ((string * ATP_Problem_Generate.stature) * thm)) list option,
    90.9       atp_proof: unit -> (term, string) ATP_Proof.atp_step list}
   90.10  
   90.11    type solver_config =
   90.12 @@ -140,7 +140,7 @@
   90.13  
   90.14  type parsed_proof =
   90.15    {outcome: SMT_Failure.failure option,
   90.16 -   fact_ids: (int * ((string * ATP_Problem_Generate.stature) * thm)) list,
   90.17 +   fact_ids: (int * ((string * ATP_Problem_Generate.stature) * thm)) list option,
   90.18     atp_proof: unit -> (term, string) ATP_Proof.atp_step list}
   90.19  
   90.20  type solver_config =
   90.21 @@ -195,7 +195,7 @@
   90.22        (Unsat, lines) =>
   90.23          (case parse_proof0 of
   90.24            SOME pp => pp outer_ctxt replay_data xfacts prems concl lines
   90.25 -        | NONE => {outcome = NONE, fact_ids = [], atp_proof = K []})
   90.26 +        | NONE => {outcome = NONE, fact_ids = NONE, atp_proof = K []})
   90.27      | (result, _) => raise SMT_Failure.SMT (SMT_Failure.Counterexample (result = Sat)))
   90.28  
   90.29    fun replay outcome replay0 oracle outer_ctxt
   90.30 @@ -270,7 +270,7 @@
   90.31    in
   90.32      parse_proof ctxt replay_data xfacts (map Thm.prop_of prems) (Thm.term_of concl) output
   90.33    end
   90.34 -  handle SMT_Failure.SMT fail => {outcome = SOME fail, fact_ids = [], atp_proof = K []}
   90.35 +  handle SMT_Failure.SMT fail => {outcome = SOME fail, fact_ids = NONE, atp_proof = K []}
   90.36  
   90.37  
   90.38  (* SMT tactic *)
    91.1 --- a/src/HOL/Tools/SMT/smt_systems.ML	Sat May 23 22:13:24 2015 +0200
    91.2 +++ b/src/HOL/Tools/SMT/smt_systems.ML	Mon May 25 22:11:43 2015 +0200
    91.3 @@ -27,10 +27,13 @@
    91.4      " failed -- enable tracing using the " ^ quote (Config.name_of SMT_Config.trace) ^
    91.5      " option for details"))
    91.6  
    91.7 +fun is_blank_or_error_line "" = true
    91.8 +  | is_blank_or_error_line s = String.isPrefix "(error " s
    91.9 +
   91.10  fun on_first_line test_outcome solver_name lines =
   91.11    let
   91.12      val split_first = (fn [] => ("", []) | l :: ls => (l, ls))
   91.13 -    val (l, ls) = split_first (snd (take_prefix (curry (op =) "") lines))
   91.14 +    val (l, ls) = split_first (snd (take_prefix is_blank_or_error_line lines))
   91.15    in (test_outcome solver_name l, ls) end
   91.16  
   91.17  fun on_first_non_unsupported_line test_outcome solver_name lines =
   91.18 @@ -59,7 +62,6 @@
   91.19  
   91.20  end
   91.21  
   91.22 -
   91.23  (* CVC4 *)
   91.24  
   91.25  val cvc4_extensions = Attrib.setup_config_bool @{binding cvc4_extensions} (K false)
   91.26 @@ -68,6 +70,7 @@
   91.27    fun cvc4_options ctxt = [
   91.28      "--random-seed=" ^ string_of_int (Config.get ctxt SMT_Config.random_seed),