pax_global_header00006660000000000000000000000064147603054120014514gustar00rootroot0000000000000052 comment=cc14288a06aeb44437dd98aaf10d4c4a058e00ca QuickChick-2.1.0/000077500000000000000000000000001476030541200135325ustar00rootroot00000000000000QuickChick-2.1.0/.circleci/000077500000000000000000000000001476030541200153655ustar00rootroot00000000000000QuickChick-2.1.0/.circleci/config.yml000066400000000000000000000053011476030541200173540ustar00rootroot00000000000000version: 2.1 defaults: &defaults environment: OPAMJOBS: 2 OPAMVERBOSE: 1 OPAMYES: true OPAMWITHTEST: true OPAMIGNORECONSTRAINTS: dune # ignore upper bound from coq-simple-io.dev which is a workaround to pass opam CI TERM: xterm SKIP_BUILD: '' parameters: coq: type: string docker: - image: <> commands: startup: steps: - checkout - run: name: Configure environment command: echo . ~/.profile >> $BASH_ENV prepare: steps: - run: name: Install dependencies command: | opam update opam install --deps-only . no_output_timeout: 30m - run: name: List installed packages command: | opam list opam info coq build: steps: - run: name: Building QuickChick command: | dune build test: steps: - run: name: Test command: | dune runtest --stop-on-first-error -j1 dune build @install dune install coq-quickchick # Make quickChick tool available on path dune build @cram - run: name: Test dependants no_output_timeout: 20m command: | PINS=$(echo `opam list -s --pinned --columns=package` | sed 's/ /,/g') PACKAGES=`opam list -s --depends-on coq-quickchick --coinstallable-with $PINS` for PACKAGE in $PACKAGES do DEPS_FAILED=false echo $SKIP_BUILD | tr ' ' '\n' | grep ^$PACKAGE$ > /dev/null && echo Skip $PACKAGE && continue opam install --deps-only $PACKAGE || DEPS_FAILED=true [ $DEPS_FAILED == true ] || opam install -t $PACKAGE done remove: steps: - run: name: Removing QuickChick command: dune uninstall coq-quickchick jobs: test: <<: *defaults steps: - startup - prepare - build - test - remove opam-install: <<: *defaults steps: - startup - prepare - run: opam pin coq-quickchick . - run: opam remove . workflows: version: 2 build: jobs: - test: name: Coq 8.15 coq: 'coqorg/coq:8.15' - test: name: Coq 8.16 coq: 'coqorg/coq:8.16' - test: name: Coq 8.17 coq: 'coqorg/coq:8.17' - test: name: Coq 8.18 coq: 'coqorg/coq:8.18' - test: name: Coq 8.19 coq: 'coqorg/coq:8.19' - test: name: Coq 8.20 coq: 'coqorg/coq:8.20' - test: name: Coq dev coq: 'rocq/rocq-prover:dev' - opam-install: name: Install and test coq: 'coqorg/coq:8.19' QuickChick-2.1.0/.gitattributes000066400000000000000000000001441476030541200164240ustar00rootroot00000000000000*.ml.cppo linguist-language=OCaml *.mlg.cppo linguist-language=OCaml *.v.cppo linguist-language=Coq QuickChick-2.1.0/.github/000077500000000000000000000000001476030541200150725ustar00rootroot00000000000000QuickChick-2.1.0/.github/workflows/000077500000000000000000000000001476030541200171275ustar00rootroot00000000000000QuickChick-2.1.0/.github/workflows/check-conflicts.yml000066400000000000000000000004161476030541200227120ustar00rootroot00000000000000name: "Check conflicts" on: [push, pull_request_target] jobs: main: runs-on: ubuntu-latest steps: - uses: eps1lon/actions-label-merge-conflict@v2.0.0 with: dirtyLabel: "needs: rebase" repoToken: "${{ secrets.GITHUB_TOKEN }}" QuickChick-2.1.0/.gitignore000066400000000000000000000015041476030541200155220ustar00rootroot00000000000000.depend dsss17/full dsss17/sol dsss17/terse .depend *.cmo *.cmi *.cmx *.cmxa *.cmxs *.cmt *.cmti *.hi *.o *.v.d *.mlg.d *.ml.d *.glob *.vo *.vok *.vos *.aux *.a *.annot .coq-native \#* *~ *.bak *.d Makefile.coq Makefile.coq.conf plugin/META.coq-quickchick *.out *.so *.opt *.byte _qc_*.tmp .DS_Store _build/ .merlin *.install quickChickTool.byte plugin/depDriver.ml plugin/genericLib.ml plugin/mergeTypes.ml plugin/driver.ml plugin/driver.mlg plugin/quickChick.ml plugin/quickChick.mli plugin/quickChick.mlg plugin/tactic_quickchick.ml plugin/tactic_quickchick.mlg plugin/weightmap.ml plugin/weightmap.mlg plugin/unifyQC.ml plugin/unifyQC.mli src/ExtractionQC.v *.pyc __pycache__ .nfs* .lia.cache plugin/compat.ml src/Compat.v src/ExtractionQCCompat.v src/TacticsUtil.v src/QuickChick.v _CoqProject META examples/other/TacticExampleX.v QuickChick-2.1.0/CHANGELOG.md000066400000000000000000000177731476030541200153620ustar00rootroot00000000000000# Changelog All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). ## [2.1.0] - 2025-02-28 - Add compatibility with Rocq 9. - Extend deriving for simple mutually inductive types. - Fix a file system race that could happen when multiple `QuickChick` commands run in the same directory. ## [2.0.5] - 2024-12-05 - Fix `mycppo` script for Windows. ## [2.0.4] - 2024-09-18 - Add compatibility with Coq 8.20. - Fix exponential blow up in derived generators and other deriving bugs. - Rename `Derive` command to `QuickChickDerive` to disambiguate from Equation's `Derive` command. ## [2.0.3] - 2024-04-05 - Add compatiblity with Coq 8.19 - Improve robustness of `QuickChick` by generating truly unique temporary directories - Resolve extraction warnings: + Avoid extraction-opaque-accessed by not depending on `Qed` reflection lemmas. + Make `StringOT.compare` and `AsciiOT.compare` `Defined` instead of `Qed` + Disable extraction-reserved-identifier ## [2.0.2] - 2024-01-04 ## [2.0.1] - 2023-10-08 - Add compatibility with Coq 8.18 ## [2.0.0] - 2022-04-13 Major 2.0 Release of QuickChick - Introduce the notion of `Producer`, a typeclass that abstracts both generators and enumerators. - No longer support a Monad instance for `G (option A)`. - bind notation for optional generators can be obtained by importing `BindOptNotation`, `x <-- c1 ;; c2` with a double arrow, resolving typeclass resolution issues. - Include support for deriving checkers for inductive relations based on [PLDI 2022](https://lemonidas.github.io/pdf/ComputingCorrectly.pdf). `Derive Checker for (P x1 x2 ... xn)` Defines an instance of the `DecOpt` typeclass that can be access using `??` notation. - Introduce an enumeration monad `E`, with the same API as generators. Automatic type-based enumerators for an inductive `T` can be derived using `Derive` notation: `Derive EnumSized for T.` - Introduce the `EnumSizedSuchThat` typeclass for constrained enumeration, similar to `GenSizedSuchThat`. Include support for deriving enumerators for inductive relations based on [PLDI 2022](https://lemonidas.github.io/pdf/ComputingCorrectly.pdf). `Derive EnumSizedSuchThat for (fun y => P x1 ... xn y xm ...).` - Introduce convenient notation for deriving constrained generators: `Derive Generator for (fun y => P x1 x2 ... y ... xm ...)` - Introduce a mechanism for [Merging Inductive Relations](https://lemonidas.github.io/pdf/MergingInductiveRelations.pdf). `Merge P with Q as R.` - No longer support Coq 8.13 and 8.14 ## [1.6.5] - 2022-04-13 - Support Coq 8.17 - No longer support Coq 8.11 and 8.12 ## [1.6.4] - 2022-08-14 - Future proofing (internal changes, resolve warnings, keep up with the times) ## [1.6.3] - 2022-05-25 - Add `-use-ocamlfind` to invocations of `ocamlbuild` - Add `--root=.` to invocations of `dune`, fixing tests using Dune without a `dune-project` file ## [1.6.2] - 2022-04-08 - Fix Windows compatibility: pass on environment when running test executable This fixes QuickChick in a Coq Platform "compiled from source" environment. (issue #269) ## [1.6.1] - 2022-03-03 - Add Windows compatibility - Improve extraction of `randomRNat`, `randomRInt`, `randomRN` by using `Random.State.full_int` instead of `Random.State.int`. ## [1.6.0] - Remove all dependency on perl (replaced with cppo (OCaml preprocessor) at compile time; awk at runtime). - Added more informative error messages when tests fail to compile or throw exceptions. - Fixed inefficient extraction of Nat arithmetic; this previously caused tests to run in time quadratic in the number of generated test cases. - Added `RelDec` instance for `eq`. ## [1.5.1] - Support Coq 8.11 to 8.14. ## [1.5.0] - Support Coq 8.13. - No longer support Coq 8.12. ## [1.4.0] ### Added - Support Coq 8.12. ### Removed - No longer support Coq 8.11. ## [1.3.2] - 2020-07-11 ### Added - `QCInclude` command to replace `Declare ML Module`. ### Fixed - Sound extraction of `modn`. ### Changed - `Decimal.int` no longer depend on an external file for extraction. ## [1.3.1] - 2020-04-06 ### Changed - Add `-cflags -w -3` to `ocamlbuild` for running extracted code. This silences the warning from using the deprecated `Pervasives` functions until it's fixed by Coq (Issue #11359). - Rename `src/unify.ml` to `src/unifyQC.ml` to avoid clashing with the Coq module of the same name. ### Removed - Remove our own reliance on `Pervasives`. This will enforce OCaml >= 4.07 going forward, but it's marked for deprecation anyways. ### Fixed - Declare all scopes before using them. - Fix most remaining warnings during compilation. - Fix compatibility with ExtLib monad notations. ## [1.3.0] - 2020-03-19 ### Added - Support Coq 8.11. ### Removed - No longer support Coq 8.10. ## [1.2.1] - 2020-04-09 Backport some fixes in [1.3.1] to Coq 8.10. These changes are not included in [1.3.0]. ### Fixed - Fix most remaining warnings during compilation. - Fix compatibility with ExtLib monad notations. ## [1.2.0] - 2020-01-30 ### Added - Support Coq 8.10. ### Removed - No longer support Coq 8.9. ### Fixed - `div`, `divn`, and `modn` no longer throw `Division_by_zero` exceptions. ## [1.1.0] - 2019-04-19 ### Added - Support Coq 8.9. ### Removed - No longer support Coq 8.8. ### Fixed - Examples use new generator combinators. - Determine C source files with `*.c` rather than `*c`. - Derive instances properly regardless of interpretation scope. ### Deprecated - `-exclude` option in `quickChickTool` is deprecated. Use `-include` instead. ## [1.0.2] - 2018-08-22 ### Added - Functor and Applicative instances for generators. - Decidable equivalence between `unit`s. - `-N` option to modify max success in `quickChickTool`. - Collect labels for discarded tests. - `quickChickTool` takes Python and Solidity files. ### Changed - Rename `BasicInterface` to `QuickChickInterface`. - Rename `Eq` to `Dec_Eq`. - Separate generator interface from implementation. ### Deprecated - `elements` is deprecated in favor of `elems_`. - `oneof` is deprecated in favor of `oneOf_`. - `frequency` is deprecated in favor of `freq_`. ### Fixed - Show lists with elements separated by `;` rather than `,`. ## [1.0.1] - 2018-06-13 ### Added - Support Coq 8.8 - `-include` option for `quickChickTool`. - Highlighted success message for `quickChickTool`. - Checker combinator `whenFail'`. - Tagged mutants. - Line number information of mutants. ### Fixed - OPAM dependencies. ### Removed - No longer support Coq 8.7 ## [1.0.0] - 2018-04-06 ### Added - OPAM package `coq-quickchick` on [coq-released](https://coq.inria.fr/opam/www/). [1.6.5]: https://github.com/QuickChick/QuickChick/compare/v1.6.4...v1.6.5 [1.6.4]: https://github.com/QuickChick/QuickChick/compare/v1.6.3...v1.6.4 [1.6.3]: https://github.com/QuickChick/QuickChick/compare/v1.6.2...v1.6.3 [1.6.2]: https://github.com/QuickChick/QuickChick/compare/v1.6.1...v1.6.2 [1.6.1]: https://github.com/QuickChick/QuickChick/compare/v1.6.0...v1.6.1 [1.6.0]: https://github.com/QuickChick/QuickChick/compare/v1.5.1...v1.6.0 [1.5.1]: https://github.com/QuickChick/QuickChick/compare/v1.5.0...v1.5.1 [1.5.0]: https://github.com/QuickChick/QuickChick/compare/v1.4.0...v1.5.0 [1.4.0]: https://github.com/QuickChick/QuickChick/compare/v1.3.2...v1.4.0 [1.3.2]: https://github.com/QuickChick/QuickChick/compare/v1.3.1...v1.3.2 [1.3.1]: https://github.com/QuickChick/QuickChick/compare/v1.3.0...v1.3.1 [1.3.0]: https://github.com/QuickChick/QuickChick/compare/v1.2.1...v1.3.0 [1.2.1]: https://github.com/QuickChick/QuickChick/compare/v1.2.0...v1.2.1 [1.2.0]: https://github.com/QuickChick/QuickChick/compare/v1.1.0...v1.2.0 [1.1.0]: https://github.com/QuickChick/QuickChick/compare/v1.0.2...v1.1.0 [1.0.2]: https://github.com/QuickChick/QuickChick/compare/v1.0.1...v1.0.2 [1.0.1]: https://github.com/QuickChick/QuickChick/compare/v1.0.0...v1.0.1 [1.0.0]: https://github.com/QuickChick/QuickChick/compare/itp-2015-final...v1.0.0 QuickChick-2.1.0/CONTRIBUTING.md000066400000000000000000000012221476030541200157600ustar00rootroot00000000000000# Contribute to QuickChick The master branch of QuickChick is pull-request based only. It is used to track the developmental branch of Coq for use in the Coq CI. Changes that specifically aim at forward compatibility with unreleased versions of Coq should be proposed to master branch. Otherwise, if you are proposing a fix or improvement, please submit the PR to corresponding branch: - `master` works with `coq.dev` - `8.*` works with the specific version of Coq Please state the compatibility with other Coq versions in your pull request. Our next release will be based on `8.10` branch by default, unless older branches require a critical fix. QuickChick-2.1.0/LICENSE000066400000000000000000000022111476030541200145330ustar00rootroot00000000000000The MIT License (aka Expat License) Copyright (c) 2014 Maxime Dénès, Catalin Hritcu, Leonidas Lampropoulos, and Zoe Paraskevopoulou Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. QuickChick-2.1.0/Makefile000066400000000000000000000076621476030541200152050ustar00rootroot00000000000000V=@ .PHONY: plugin install install-plugin clean quickChickTool compat QCTOOL_DIR=quickChickTool QCTOOL_EXE=quickChickTool.byte QCTOOL_SRC=$(QCTOOL_DIR)/quickChickTool.ml \ $(QCTOOL_DIR)/quickChickToolTypes.ml \ $(QCTOOL_DIR)/quickChickToolLexer.mll \ $(QCTOOL_DIR)/quickChickToolParser.mly INSTALLDIR?=$(dir $(shell which coqc)) # Here is a hack to make $(eval $(shell work # (copied from coq_makefile generated stuff): define donewline endef includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\r' | tr '\n' '@'; }))) $(call includecmdwithout@,$(COQBIN)coqtop -config) all: quickChickTool plugin documentation-check plugin: compat Makefile.coq $(MAKE) -f Makefile.coq documentation-check: plugin coqc -R src QuickChick -Q doc doc -I plugin doc/QuickChickInterface.v coqc -R src QuickChick -Q doc doc -I plugin doc/DocumentationCheck.v TEMPFILE := $(shell mktemp) install: quickChickTool plugin $(V)$(MAKE) -f Makefile.coq install > $(TEMPFILE) # Manually copying the remaining files $(V)cp $(QCTOOL_DIR)/$(QCTOOL_EXE) $(INSTALLDIR)/quickChick # $(V)cp src/quickChickLib.cmx $(COQLIB)/user-contrib/QuickChick # $(V)cp src/quickChickLib.o $(COQLIB)/user-contrib/QuickChick install-fuzz: $(V)cp fuzz/alloc-inl.h $(COQLIB)/user-contrib/QuickChick/ $(V)cp fuzz/config.h $(COQLIB)/user-contrib/QuickChick/ $(V)cp fuzz/debug.h $(COQLIB)/user-contrib/QuickChick/ $(V)cp fuzz/types.h $(COQLIB)/user-contrib/QuickChick/ $(V)cp fuzz/SHM.c $(COQLIB)/user-contrib/QuickChick/ $(V)cp fuzz/Stub.ml $(COQLIB)/user-contrib/QuickChick/ $(V)cp fuzz/Main.ml $(COQLIB)/user-contrib/QuickChick/ $(V)cp fuzz/cmdprefix.pl $(COQLIB)/user-contrib/QuickChick/ $(V)cp fuzz/cmdsuffix.pl $(COQLIB)/user-contrib/QuickChick/ install-plugin: Makefile.coq $(V)$(MAKE) -f Makefile.coq install | tee $(TEMPFILE) uninstall: $(V)if [ -e Makefile.coq ]; then $(MAKE) -f Makefile.coq uninstall; fi $(RM) $(INSTALLDIR)/quickChick quickChickTool: $(QCTOOL_DIR)/$(QCTOOL_EXE) $(QCTOOL_DIR)/$(QCTOOL_EXE): $(QCTOOL_SRC) cd $(QCTOOL_DIR); ocamlbuild -use-ocamlfind -pkg str -pkg unix -use-ocamlfind $(QCTOOL_EXE) tests: $(MAKE) -C tutorials tutorials $(MAKE) -C test cd benchmarks/stlc; make clean && make cd benchmarks/BST; make clean && make cd examples/ifc-basic; make clean && make $(MAKE) -C examples/RedBlack test $(MAKE) -C examples/multifile-mutation test # This takes too long. # $(MAKE) -C examples/c-mutation test # coqc examples/BSTTest.v coqc examples/DependentTest.v coqc examples/TacticExample.v COMPATFILES:= \ plugin/depDriver.ml \ plugin/genericLib.ml \ plugin/mergeTypes.ml \ plugin/quickChick.mli \ plugin/quickChick.mlg \ plugin/unifyQC.ml \ plugin/unifyQC.mli \ plugin/tactic_quickchick.mlg \ plugin/weightmap.mlg \ src/Compat.v \ src/ExtractionQC.v \ src/QuickChick.v \ src/TacticsUtil.v \ _CoqProject compat: $(COMPATFILES) %: %.cppo $(V)cppo -V OCAML:$(shell ocamlc -version) -V COQ:$(word 1, $(shell coqc -print-version)) -n -o $@ $^ Makefile.coq: _CoqProject $(V)coq_makefile -f _CoqProject -o Makefile.coq clean: $Vif [ -e Makefile.coq ]; then $(MAKE) -f Makefile.coq clean; fi $Vcd $(QCTOOL_DIR); ocamlbuild -clean # This might not work on macs find . -name '*.vo' -print -delete find . -name '*.glob' -print -delete find . -name *.d -print -delete find . -name *.o -print -delete find . -name *.cmi -print -delete find . -name *.cmx -print -delete find . -name *.cmxs -print -delete find . -name *.cmo -print -delete find . -name *.bak -print -delete find . -name *~ -print -delete find . -name *.conflicts -print -delete find . -name *.output -print -delete find . -name *.aux -print -delete rm -f Makefile.coq Makefile.coq.conf rm -f $(COMPATFILES) bc: coqwc src/*.v coqwc examples/RedBlack/*.v coqwc ../ifc/*.v .merlin: Makefile.coq make -f Makefile.coq .merlin publish%: opam publish --packages-directory=released/packages \ --repo=coq/opam-coq-archive --tag=v$* -v $* QuickChick/QuickChick QuickChick-2.1.0/Makefile.coq.local000066400000000000000000000002541476030541200170450ustar00rootroot00000000000000OCAMLWARN=-w -8 COQ_VERSION=$(word 1, $(shell coqc -print-version)) ifeq ($(shell expr $(COQ_VERSION) \>= "8.16"), 1) CAMLPKGS+= -package coq-core.plugins.extraction endifQuickChick-2.1.0/PROFILING000066400000000000000000000003641476030541200150110ustar00rootroot00000000000000 cd /tmp ocamlopt -rectypes -I ~/Apps/coq-8.4pl4/user-contrib/QuickChick quickChickLib.cmx QuickChick8baf2f.ml -p -o QuickChick ./QuickChick gprof QuickChick > profile.txt gprof2dot profile.txt > profile.dot dot -Tpng profile.dot > profile.png QuickChick-2.1.0/README.md000066400000000000000000000102611476030541200150110ustar00rootroot00000000000000QuickChick ========== [![CircleCI](https://circleci.com/gh/QuickChick/QuickChick.svg?style=svg)](https://circleci.com/gh/QuickChick/QuickChick) [![project chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://coq.zulipchat.com/#narrow/stream/237977-Coq-users) ## Description - Randomized property-based testing plugin for Coq; a clone of [Haskell QuickCheck] - Includes a [foundational verification framework for testing code] - Includes a [mechanism for automatically deriving generators for inductive relations] [Haskell QuickCheck]: https://hackage.haskell.org/package/QuickCheck [foundational verification framework for testing code]: http://prosecco.gforge.inria.fr/personal/hritcu/publications/foundational-pbt.pdf [mechanism for automatically deriving generators for inductive relations]: https://lemonidas.github.io/pdf/GeneratingGoodGenerators.pdf ## Tutorial - Small tutorials on Basic Usage and Automation can be found under `tutorials/` - An extended introduction can be found in [QuickChick: Property-Based Testing in Coq][sfqc] (Software Foundations, Volume 4) [sfqc]: https://softwarefoundations.cis.upenn.edu/qc-current/index.html ## Installation ### From OPAM # Add the Coq opam repository (if you haven't already) opam repo add coq-released https://coq.inria.fr/opam/released opam update # Install the coq-quickchick opam package opam install coq-quickchick ## Simple Examples - `examples/Tutorial.v` - `examples/RedBlack` - `examples/stlc` - `examples/ifc-basic` Running `make tests` in the top-level QuickChick folder will check and execute all of these. If successful, you should see "success" at the end. ## Documentation The public API of QuickChick is summarized in `QuickChickInterface.v`. ### Top-level Commands - `QuickCheck c` - `Sample g` - `Derive Arbitrary for c` - `Derive Show for c` - `Derive ArbitrarySizedSuchThat for (fun x => p)` - `Derive DecOpt for p` - `Derive EnumSizedSuchThat for (fun x => p)` - `Derive ArbitrarySizedSuchThat for (fun x => let (x1,x2...) := x in p)` - `QuickCheckWith args c` - `MutateCheck c p` - `MutateCheckWith args c p` - `MutateCheckMany c ps` - `MutateCheckManyWith args c ps` ### More resources Here is some more reading material: - Our PLDI 2022 paper on [a mechanism for automatically deriving generators, enumerators, and checkers for inductive relations](https://lemonidas.github.io/pdf/ComputingCorrectly.pdf) - Our POPL 2018 paper on [a mechanism for automatically deriving generators for inductive relations](https://lemonidas.github.io/pdf/GeneratingGoodGenerators.pdf) - Our ITP 2015 paper on [Foundational Property-Based Testing](http://prosecco.gforge.inria.fr/personal/hritcu/publications/foundational-pbt.pdf) - Our PLDI 2023 paper on [a mechanism for merging multiple inductive relations into one](https://lemonidas.github.io/pdf/MergingInductiveRelations.pdf) - Leo's invited talk at CLA on [Random Testing in the Coq Proof Assistant](https://lemonidas.github.io/pdf/InvitedCLA.pdf) - Catalin's [internship topic proposals for 2015](http://prosecco.gforge.inria.fr/personal/hritcu/students/topics/2015/quick-chick.pdf) - Catalin's [presentation at CoqPL 2015 workshop (2015-01-18)](http://prosecco.gforge.inria.fr/personal/hritcu/talks/QuickChick-Verified-Testing-CoqPL.pdf) - Zoe's [thesis defense at NTU Athens (2014-09-08)](http://prosecco.gforge.inria.fr/personal/hritcu/talks/zoe-defense.pdf) - Maxime's [presentation at the Coq Workshop (2014-07-18)](http://prosecco.gforge.inria.fr/personal/hritcu/talks/QuickChick-Coq.pdf) - Catalin's [presentation at the Coq Working Group @ PPS (2014-03-19)](http://prosecco.gforge.inria.fr/personal/hritcu/talks/QuickChick-PPS.pdf) --- ## Developer's corner ### Build dependencies Dependencies are listed in [`coq-quickchick.opam`](./coq-quickchick.opam). # To get the dependencies, add the Coq opam repository if you haven't already opam repo add coq-released https://coq.inria.fr/opam/released opam update opam install . --deps-only ### Build dune build ## Run tests dune runtest ### Run extra tests for quickChick tool dune install coq-quickchick # Makes QuickChick available globally dune build @cram QuickChick-2.1.0/TODOQC.org000066400000000000000000000057341476030541200152450ustar00rootroot00000000000000HIGH PRIORITY: - We need a way of naming mutants so that, for example, we can test just a single mutant (that we have just added) instead of all mutants. I'm going to guess that this will be so common a usage mode that we are going to want to name ALL mutants. This will also be a more convenient way of printing them than printing diffs. - We probably also need a syntax for nested mutants - When displaying counterexamples, would it be easy to print the name of each bound variable along with the failing value that's been found for it? - The top-level QC interface should expose as little as possible, so that modules that Import QC do not have their namespaces too polluted. (And there should be a single file that most users import, rather than several.) - At the moment, most files that use QC include this at the top -- how much of it is really needed?? From QuickChick Require Export QuickChick. Set Bullet Behavior "Strict Subproofs". Import QcNotation. Open Scope qc_scope. Import GenLow GenHigh. Require Import List ZArith. Import ListNotations. Set Warnings "-extraction-opaque-accessed,-extraction". Unset Refine Instance Mode. (* Don't be too automatic! *) - Can we try again to fix the "Section... extends..." parsing issue? * Make a simpler tactic for deriving equality. Derive Arbitrary, Show, Eq for file_access_mode. * play with precedence for ? -- should bind tigher than implication - and could we automatically make decidable props checkable, without ? MINOR: - Figure out how to check different mutants in parallel - Catch C-c and terminate QC tool - Add Set Warnings "-notation-overridden,-parsing". to all .v files to get rid of compilation warnings. - eliminate the rest of the compilation warnings (including nonexhaustive patterns!) COSMETIC: - Document (for emacs compile users): (require 'ansi-color) (defun endless/colorize-compilation () "Colorize from `compilation-filter-start' to `point'." (let ((inhibit-read-only t)) (ansi-color-apply-on-region compilation-filter-start (point)))) (add-hook 'compilation-filter-hook #'endless/colorize-compilation) ABOUT DECIDABILITY: - Can we make every EqDec automatically be a Dec? - Dec seems not to be working as intended. Leo hoped that the ? would not be necessary to coerce a (decidable) Prop to a Checkable... - How do I create a Dec instance for options? - How should we phrase specs like the one for filesystem operations in DW? Is there a way of using Dec to (semi?-)automatically calculate decision procedures for things like /\ and forall formulas? TASKS FOR THE SUMMER SCHOOL: - documentation -- coqdoc comments, especially on the most user-visible parts! - update and test opam package QuickChick-2.1.0/_CoqProject.cppo000066400000000000000000000026771476030541200166410ustar00rootroot00000000000000#if COQ_VERSION >= (8, 16, 0) plugin/META.coq-quickchick.in #endif -R src QuickChick -I plugin plugin/quickChick.mli plugin/driver.mli plugin/tactic_quickchick.mli plugin/weightmap.mli plugin/genericLib.mli plugin/mergeTypes.mli plugin/error.mli plugin/simplDriver.mli plugin/depDriver.mli plugin/setLib.mli plugin/semLib.mli plugin/coqLib.mli plugin/arbitrarySized.mli plugin/arbitrarySizedST.mli plugin/checkerSizedST.mli plugin/genLib.mli plugin/unifyQC.mli plugin/sizeUtils.mli plugin/sized.mli plugin/quickChick.mlg plugin/driver.mlg plugin/tactic_quickchick.mlg plugin/weightmap.mlg plugin/quickchick_plugin.mlpack plugin/genericLib.ml plugin/error.ml plugin/simplDriver.ml plugin/depDriver.ml plugin/mergeTypes.ml plugin/setLib.ml plugin/semLib.ml plugin/coqLib.ml plugin/arbitrarySized.ml plugin/arbitrarySizedST.ml plugin/enumSized.ml plugin/enumSizedST.ml plugin/checkerSizedST.ml plugin/genLib.ml plugin/unifyQC.ml plugin/sizeUtils.ml plugin/sized.ml src/Compat.v src/Tactics.v src/Sets.v src/Nat_util.v src/LazyList.v src/RandomQC.v src/RoseTrees.v src/Producer.v src/Generators.v src/Enumerators.v src/Classes.v src/Instances.v src/CoArbitrary.v src/StringOT.v src/Show.v src/ShowFacts.v src/State.v src/Checker.v src/SemChecker.v src/Test.v src/Mutation.v src/Typeclasses.v src/QuickChick.v src/MutateCheck.v src/DependentClasses.v src/Decidability.v src/ExtractionQC.v src/TacticsUtil.v src/CheckerProofs.v src/EnumProofs.v src/GenProofs.v src/Proofs.v QuickChick-2.1.0/_CoqProject.dune000066400000000000000000000000721476030541200166160ustar00rootroot00000000000000-R _build/default/src QuickChick -I _build/default/plugin QuickChick-2.1.0/benchmarks/000077500000000000000000000000001476030541200156475ustar00rootroot00000000000000QuickChick-2.1.0/benchmarks/BST/000077500000000000000000000000001476030541200162775ustar00rootroot00000000000000QuickChick-2.1.0/benchmarks/BST/BST.v000066400000000000000000000051101476030541200171130ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Import QcNotation. Require Import List. Import ListNotations. Require Import String. Open Scope string. From ExtLib Require Import Monad. Import MonadNotation. Inductive Tree := | Leaf : Tree | Node : nat -> Tree -> Tree -> Tree. Derive (Arbitrary, Show) for Tree. Inductive between : nat -> nat -> nat -> Prop := | between_n : forall n m, le n m -> between n (S n) (S (S m)) | between_S : forall n m o, between n m o -> between n (S m) (S o). Derive DecOpt for (le x y). Derive ArbitrarySizedSuchThat for (fun x => le y x). QuickChickWeights [(between_n, 1); (between_S, 7)]. Derive ArbitrarySizedSuchThat for (fun x => between lo x hi). Derive DecOpt for (between lo x hi). Inductive bst : nat -> nat -> Tree -> Prop := | bst_leaf : forall lo hi, bst lo hi Leaf | bst_node : forall lo hi x l r, between lo x hi -> bst lo x l -> bst x hi r -> bst lo hi (Node x l r). Derive ArbitrarySizedSuchThat for (fun t => bst lo hi t). Derive DecOpt for (bst lo hi t). Fixpoint gen_bst (s : nat) (lo hi : nat) : G Tree := match s with | O => ret Leaf | S s' => freq [(1, ret Leaf) ;(if hi - lo < 2? then 0 else s, x <- choose (lo+1, hi-1);; l <- gen_bst s' lo x;; r <- gen_bst s' x hi;; ret (Node x l r))] end. Fixpoint is_bst (lo hi : nat) (t : Tree) := match t with | Leaf => true | Node x l r => andb ((lo < x /\ x < hi) ?) (andb (is_bst lo x l) (is_bst x hi r)) end. Fixpoint insert (x : nat) (t : Tree) := match t with | Leaf => Node x Leaf Leaf | Node y l r => (*! *) if x < y ? then (*!! IF-LE-L *) (*! if x <= y ? then *) Node y (insert x l) r (*! *) else if x > y ? then (*!! IF-LE-R *) (*! else if x >= y ? then *) Node y l (insert x r) else t end. Extract Constant defNumTests => "100000". (*! Section base *) Definition insert_bst := forAll (gen_bst 5 0 10) (fun t => forAll (choose (1, 9)) (fun x => is_bst 0 10 (insert x t))). (*! QuickChick insert_bst. *) (*! Section derived-dec *) Definition insert_bst_derived_checker := forAll (gen_bst 5 0 10) (fun t => forAll (choose (1, 9)) (fun x => bst 0 10 (insert x t) ?? 10)). (*! QuickChick insert_bst_derived_checker. *) (*! Section derived-gen *) Definition insert_bst_derived_gen := forAllMaybe (@arbitrarySizeST _ (fun t => bst 0 10 t) _ 5) (fun t => forAll (choose (1, 9)) (fun x => is_bst 0 10 (insert x t))). (*! QuickChick insert_bst_derived_gen. *) QuickChick-2.1.0/benchmarks/BST/Makefile000066400000000000000000000004431476030541200177400ustar00rootroot00000000000000QC=quickChick -color -top BST all: Makefile.coq $(MAKE) -f Makefile.coq Makefile.coq: coq_makefile -f _CoqProject -o Makefile.coq clean: Makefile.coq $(MAKE) -f Makefile.coq clean rm -rf ../_qc_BST.tmp *.bak test: clean time $(QC) testinclude: $(QC) -m 0 -include _CoqProject QuickChick-2.1.0/benchmarks/BST/_CoqProject000066400000000000000000000000161476030541200204270ustar00rootroot00000000000000-Q . BST BST.vQuickChick-2.1.0/benchmarks/stlc/000077500000000000000000000000001476030541200166145ustar00rootroot00000000000000QuickChick-2.1.0/benchmarks/stlc/Makefile000066400000000000000000000004441476030541200202560ustar00rootroot00000000000000QC=quickChick -color -top stlc all: Makefile.coq $(MAKE) -f Makefile.coq Makefile.coq: coq_makefile -f _CoqProject -o Makefile.coq clean: Makefile.coq $(MAKE) -f Makefile.coq clean rm -rf ../_qc_stlc.tmp *.bak test: clean time $(QC) testinclude: $(QC) -m 0 -include _CoqProject QuickChick-2.1.0/benchmarks/stlc/_CoqProject000066400000000000000000000000201476030541200207370ustar00rootroot00000000000000-Q . stlc stlc.vQuickChick-2.1.0/benchmarks/stlc/stlc.v000066400000000000000000000151751476030541200177610ustar00rootroot00000000000000Set Warnings "-notation-overridden, -parsing". From mathcomp Require Import ssreflect ssrbool eqtype. Require Import Arith List String Lia. From QuickChick Require Import QuickChick. Import ListNotations. (* Types *) Inductive type : Type := | N : type | Arrow : type -> type -> type. Derive (Arbitrary, Show, EnumSized) for type. #[local] Instance dec_type (t1 t2 : type) : Dec (t1 = t2). Proof. dec_eq. Defined. (* Terms *) Definition var := nat. Inductive term : Type := | Const : nat -> term | Id : var -> term | App : term -> term -> term | Abs : type -> term -> term. Derive Arbitrary for term. (* Environments *) Definition env := list type. Inductive bind : env -> nat -> type -> Prop := | BindNow : forall t G, bind (t :: G) 0 t | BindLater : forall t t' x G, bind G x t -> bind (t' :: G) (S x) t. (* Generate variables of a specific type in an env. *) Derive ArbitrarySizedSuchThat for (fun x => bind G x t). (* Get the type of a given variable in an env. *) Derive EnumSizedSuchThat for (fun t => bind G x t). (* Check whether a variable has a given type in an env. *) Derive DecOpt for (bind G e t). (* Typing *) Inductive typing (G : env) : term -> type -> Prop := | TId : forall x t, bind G x t -> typing G (Id x) t | TConst : forall n, typing G (Const n) N | TAbs : forall e t1 t2, typing (t1 :: G) e t2 -> typing G (Abs t1 e) (Arrow t1 t2) | TApp : forall e1 e2 t1 t2, typing G e2 t1 -> typing G e1 (Arrow t1 t2) -> typing G (App e1 e2) t2. Fixpoint typeOf G e : option type := match e with | Id x => nth_error G x | Const n => Some N | Abs t e' => match typeOf (t::G) e' with | Some t' => Some (Arrow t t') | None => None end | App e1 e2 => match typeOf G e1, typeOf G e2 with | Some (Arrow t1 t2), Some t1' => if t1 = t1'? then Some t2 else None | _, _ => None end end. Definition vars (Γ : env) (t : type) (g : G term) : G term := let vs := map (fun p => Id (snd p)) (filter (fun p => t = fst p?) (combine Γ (seq 0 (List.length Γ)))) in match vs with | [] => g | _ => oneOf_ (ret (Const 0)) [elems_ (Const 0) vs; g] end. Fixpoint gen_base (Γ : env) (t : type) : G term := match t with | N => vars Γ t (bindGen (choose (0,10)) (fun n => returnGen (Const n))) | Arrow t1 t2 => bindGen (gen_base (t1::Γ) t2) (fun e => returnGen (Abs t1 e)) end. Fixpoint gen_typed (sz : nat) (Γ : env) (t : type) : G term := match sz with | O => gen_base Γ t | S sz' => let app := bindGen (@arbitrarySized type _ 3) (fun t' => bindGen (gen_typed sz' Γ (Arrow t' t)) (fun e1 => bindGen (gen_typed sz' Γ t') (fun e2 => returnGen (App e1 e2)))) in match t with | N => vars Γ t (oneOf_ app [app; liftGen Const arbitrary]) | Arrow t1 t2 => vars Γ t (oneOf_ app [app; liftGen (Abs t1) (gen_typed sz' Γ t2)]) end end. (* Generate terms of a specific type in an env. *) Derive ArbitrarySizedSuchThat for (fun e => typing G e t). Derive EnumSizedSuchThat for (fun t => typing G e t). (* Check whether a variable has a given type in an env. *) Derive DecOpt for (typing G e t). (* Small step CBV semantics *) Inductive value : term -> Prop := | VConst : forall n, value (Const n) | VAbs : forall t e, value (Abs t e). Derive DecOpt for (value e). Definition is_value (e : term) : bool := match e with | Const _ | Abs _ _ => true | _ => false end. Fixpoint subst (y : var) (e1 : term) (e2 : term) : term := match e2 with | Const n => Const n | Id x => (*! *) if eq_nat_dec x y then e1 else e2 (*!! SUBST-swap *) (*! if eq_nat_dec x y then e2 else e1 *) | App e e' => App (subst y e1 e) (subst y e1 e') | Abs t e => (*! *) Abs t (subst (S y) e1 e) (*!! SUBST-no-lift *) (*! Abs t (subst y e1 e) *) end. Fixpoint step (e : term) : option term := match e with | Const _ | Id _ => None | Abs _ x => None | App (Abs t e1) e2 => if is_value e2 then Some (subst 0 e2 e1) else match step e2 with | Some e2' => Some (App (Abs t e1) e2') | None => None end | App e1 e2 => match step e1 with | Some e1' => Some (App e1' e2) | None => None end end. (* Eval compute in (step (App (Abs N (Id 0)) (Const 42))). Eval compute in (step (App (Abs N (Abs N (Id 0))) (Const 42))). Eval compute in (subst 0 (Const 42) (Abs N (Id 0))). *) (* Printing *) Open Scope string. Fixpoint show_type (tau : type) := match tau with | N => "N" | Arrow tau1 tau2 => "(Arrow " ++ show_type tau1 ++ " -> " ++ show_type tau2 ++ ")" end. #[local] Instance showType : Show type := { show := show_type }. Fixpoint show_term (e : term) := match e with | Const n => "(Const " ++ show n ++ ")" | Id x => "(Id " ++ show x ++ ")" | App e1 e2 => "(App " ++ show_term e1 ++ " " ++ show_term e2 ++ ")" | Abs t e => "(Abs " ++ show t ++ " " ++ show_term e ++ ")" end. Close Scope string. #[local] Instance showTerm : Show term := { show := show_term }. #[local] Instance dec_eq_opt_type : Dec_Eq (option type). Proof. dec_eq. Defined. Definition preservation (e : term) (t: type) : Checker := match step e with | Some e' => checker ((typeOf nil e' = Some t)?) | None => checker true end. Definition preservation_derived (e : term) (t: type) : Checker := match step e with | Some e' => checker (typing nil e' t ?? 10) | None => checker true end. Definition preservation_check (e : term) : Checker := match typeOf nil e, step e with | Some t, Some e' => checker ((typeOf nil e' = Some t)?) | None, _ => checker tt | _, _ => checker true end. Extract Constant defNumTests => "100000". (*! Section base *) Definition prop_preservation := forAll (@arbitrary type _) (fun t => forAll (gen_typed 5 nil t) (fun e => preservation e t)). (*! QuickChick prop_preservation. *) (*! Section derived-dec *) Definition prop_preservation_derived_checker := forAll (@arbitrary type _) (fun t => forAll (gen_typed 5 nil t) (fun e => preservation_derived e t)). (*! QuickChick prop_preservation_derived_checker. *) (*! Section derived-gen *) Definition prop_preservation_derived_gen := forAll (@arbitrary type _) (fun t => forAllMaybe (@arbitrarySizeST _ (fun e => typing nil e t) _ 5) (fun e => preservation e t)). (*! QuickChick prop_preservation_derived_gen. *) (*! Section naive-gen *) Definition prop_preservation_naive_gen := forAll (@arbitrary term _) (fun e => preservation_check e). (*! QuickChick prop_preservation_naive_gen. *) QuickChick-2.1.0/coq-quickchick.opam000066400000000000000000000022631476030541200173110ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "dev" synopsis: "Randomized Property-Based Testing for Coq" description: """ A library for property-based testing in Coq. - Combinators for testable properties and random generators. - QuickChick plugin for running tests in a Coq session. - Includes a mutation testing tool.""" maintainer: ["leonidas@umd.edu"] authors: [ "Leonidas Lampropoulos" "Zoe Paraskevopoulou" "Maxime Denes" "Catalin Hritcu" "Benjamin Pierce" "Li-yao Xia" "Arthur Azevedo de Amorim" "Yishuai Li" "Antal Spector-Zabusky" ] license: "MIT" homepage: "https://github.com/QuickChick/QuickChick" bug-reports: "https://github.com/QuickChick/QuickChick/issues" depends: [ "dune" {>= "3.12"} "ocaml" {>= "4.07"} "menhir" {build} "cppo" {build & >= "1.6.8"} "coq" {>= "8.15~"} "coq-ext-lib" "coq-mathcomp-ssreflect" "coq-simple-io" {>= "1.6.0"} "ocamlfind" "ocamlbuild" "odoc" {with-doc} ] dev-repo: "git+https://github.com/QuickChick/QuickChick.git" build: [ ["dune" "subst"] {dev} ["dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} "--stop-on-first-error"] ] QuickChick-2.1.0/coq-quickchick.opam.template000066400000000000000000000002271476030541200211210ustar00rootroot00000000000000build: [ ["dune" "subst"] {dev} ["dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} "--stop-on-first-error"] ] QuickChick-2.1.0/doc/000077500000000000000000000000001476030541200142775ustar00rootroot00000000000000QuickChick-2.1.0/doc/DocumentationCheck.v000066400000000000000000000173441476030541200202460ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". Require Import mathcomp.ssreflect.ssreflect. From mathcomp Require Import ssrbool. From Coq Require Import Relations ZArith Strings.Ascii Strings.String. From QuickChick Require Import LazyList QuickChick. From doc Require Import QuickChickInterface. (* This module is just to keep the BasicInterface up-to-date with the implementation. *) Module ConsistencyCheck : QuickChickSig. Definition RandomSeed := RandomSeed. Definition G := @G. Definition semGen := @semProd G ProducerGen. Definition semGenSize := @semGenSize. Definition Functor_G := @Functor_Monad _ (@super _ ProducerGen). Definition Applicative_G := @Applicative_Monad _ (@super _ ProducerGen). Definition Monad_G := @super _ ProducerGen. Definition bindGen' := @bindPf G ProducerGen. Definition bindGenOpt := @bindOpt G ProducerGen. Definition run := @Generators.run. Definition listOf := @listOf G ProducerGen. Definition vectorOf := @vectorOf G ProducerGen. Definition elems_ := @elems_ G ProducerGen. Definition oneOf_ := @oneOf_ G ProducerGen. Definition freq_ := @freq_. Definition backtrack := @backtrack. Definition resize := @resize G ProducerGen. Definition sized := @sized G ProducerGen. Definition suchThatMaybe := @suchThatMaybe. Definition suchThatMaybeOpt := @suchThatMaybeOpt. Class ChoosableFromInterval (A : Type) (le : relation A) : Type := { randomR : A * A -> RandomSeed -> A * RandomSeed; randomRCorrect : forall (a a1 a2 : A), le a1 a2 -> (le a1 a /\ le a a2 <-> exists seed, fst (randomR (a1, a2) seed) = a); enumR : A * A -> LazyList A; enumRCorrect : forall (a a1 a2 : A), le a1 a2 -> (le a1 a /\ le a a2 <-> In_ll a (enumR (a1,a2))) }. #[global] Existing Instance super. Definition ChooseN := ChooseN. Definition ChooseNat := ChooseNat. Definition ChooseZ := ChooseZ. Definition choose := @choose G ProducerGen. Module QcDefaultNotation. (* (** 'elems' as a shorthand for elements without a default argument *) Notation " 'elems' [ x ] " := (elements x (cons x nil)) : qc_scope. Notation " 'elems' [ x ; y ] " := (elements x (cons x (cons y nil))) : qc_scope. Notation " 'elems' [ x ; y ; .. ; z ] " := (elements x (cons x (cons y .. (cons z nil) ..))) : qc_scope. Notation " 'elems' ( x ;; l ) " := (elements x (cons x l)) (at level 1, no associativity) : qc_scope. (** 'oneOf' as a shorthand for oneof without a default argument *) Notation " 'oneOf' [ x ] " := (oneof x (cons x nil)) : qc_scope. Notation " 'oneOf' [ x ; y ] " := (oneof x (cons x (cons y nil))) : qc_scope. Notation " 'oneOf' [ x ; y ; .. ; z ] " := (oneof x (cons x (cons y .. (cons z nil) ..))) : qc_scope. Notation " 'oneOf' ( x ;; l ) " := (oneof x (cons x l)) (at level 1, no associativity) : qc_scope. (** 'freq' as a shorthund for frequency without a default argument *) Notation " 'freq' [ x ] " := (frequency x (cons x nil)) : qc_scope. Notation " 'freq' [ ( n , x ) ; y ] " := (frequency x (cons (n, x) (cons y nil))) : qc_scope. Notation " 'freq' [ ( n , x ) ; y ; .. ; z ] " := (frequency x (cons (n, x) (cons y .. (cons z nil) ..))) : qc_scope. Notation " 'freq' ( ( n , x ) ;; l ) " := (frequency x (cons (n, x) l)) (at level 1, no associativity) : qc_scope. *) End QcDefaultNotation. (* Note: These will soon be replaced by an ExtLib dependency. *) Module QcDoNotation. Notation "'do!' X <- A ; B" := (bindGen A (fun X => B)) (at level 200, X name, A at level 100, B at level 200). Notation "'do\'' X <- A ; B" := (bindGen' A (fun X H => B)) (at level 200, X name, A at level 100, B at level 200). Notation "'doM!' X <- A ; B" := (bindGenOpt A (fun X => B)) (at level 200, X name, A at level 100, B at level 200). End QcDoNotation. Definition showNat := showNat . Definition showBool := showBool . Definition showZ := showZ . Definition showString := showString . Definition showList := @showList . Definition showPair := @showPair . Definition showOpt := @showOpt . Definition showEx := @showEx . Definition nl := nl. Definition GenOfGenSized := @GenOfGenSized. Definition genBoolSized := @genBoolSized . Definition genNatSized := @genNatSized . Definition genZSized := @genZSized . Definition genListSized := @genListSized . Definition genList := @genList . Definition genOption := @genOption . Definition genPairSized := @genPairSized . Definition genPair := @Instances.genPair . (* TODO: Strings? *) Definition shrinkBool := shrinkBool. Definition shrinkNat := shrinkNat . Definition shrinkZ := shrinkZ . Definition shrinkList := @shrinkList . Definition shrinkPair := @shrinkPair . Definition shrinkOption := @shrinkOption . Definition ArbitraryOfGenShrink := @ArbitraryOfGenShrink. Definition Checker := @Checker. Definition testBool := testBool . Definition testUnit := testUnit . Definition forAll := @forAll. Definition forAllProof := @forAllProof. Definition forAllShrink := @forAllShrink. Definition testFun := @testFun . Definition testProd := @testProd. Definition testPolyFun := @testPolyFun. Definition whenFail := @whenFail. Definition expectFailure := @expectFailure. Definition collect := @collect. Definition tag := @tag. Definition conjoin := @conjoin. Definition disjoin := @disjoin. Definition implication := @implication. Module QcNotation. Export QcDefaultNotation. Notation "x ==> y" := (implication x y) (at level 55, right associativity) : Checker_scope. End QcNotation. Definition testDec := @testDec . Definition Dec_neg := @Dec_neg . Definition Dec_conj := @Dec_conj . Definition Dec_disj := @Dec_disj . (* Convenient notation. *) Notation "P '?'" := (match (@dec P _) with | left _ => true | right _ => false end) (at level 100). Definition dec_if_dec_eq := @dec_if_dec_eq. Definition Dec_Eq_implies_DecEq := @Dec_Eq_implies_DecEq. Definition Dec_eq_unit := @Dec_eq_unit. Definition Dec_eq_bool := @Dec_eq_bool. Definition Dec_eq_nat := @Dec_eq_nat. Definition Dec_eq_Z := @Dec_eq_Z. Definition Dec_eq_N := @Dec_eq_N. Definition Dec_eq_opt := @Dec_eq_opt. Definition Dec_eq_prod := @Dec_eq_prod. Definition Dec_eq_sum := @Dec_eq_sum. Definition Dec_eq_list := @Dec_eq_list. Definition Dec_eq_ascii := @Dec_eq_ascii. Definition Dec_eq_string := @Dec_eq_string. (** =================================================================== *) (** QuickChick toplevel commands and arguments. *) (** =================================================================== *) (* Samples a generator. 'g' is of type 'G A' for showable 'A'. *) (** Sample g. *) (* Runs a test. 'prop' must be 'Checkable'. *) (** QuickChick prop. *) (* Arguments to customize execution. *) Record Args := MkArgs { (* Re-execute a test. *) (* Default: None *) replay : option (RandomSeed * nat); (* Maximum number of successful tests to run. *) (* Default: 10000 *) maxSuccess : nat; (* Maximum number of discards to accept. *) (* Default: 20000 *) maxDiscard : nat; (* Maximum number of shrinks to perform before terminating. *) (* Default : 1000 *) maxShrinks : nat; (* Maximum size of terms to generate (depth). *) (* Default : 7 *) maxSize : nat; (* Verbosity. Note: Doesn't do much... *) (* Default true. *) chatty : bool }. End ConsistencyCheck. QuickChick-2.1.0/doc/QuickChickInterface.v000066400000000000000000000762321476030541200203370ustar00rootroot00000000000000(** * QuickChickInterface: QuickChick Reference Manual *) From QuickChick Require Import QuickChick. Require Import ZArith Strings.Ascii Strings.String. From ExtLib.Structures Require Import Functor Applicative. (** QuickChick provides a large collection of combinators and notations for writing property-based random tests. This file documents the entire public interface (the module type [QuickChickSig]). *) Set Warnings "-already-existing-class, -automation". Module Type QuickChickSig. (* #################################################################### *) (** * The [Show] Typeclass *) (** [Show] typeclass allows the test case to be printed as a string. *) (** [[ Class Show (A : Type) : Type := { show : A -> string }. ]] *) (** Here are some [Show] instances for some basic types: *) #[global] Declare Instance showNat : Show nat. #[global] Declare Instance showBool : Show bool. #[global] Declare Instance showZ : Show Z. #[global] Declare Instance showString : Show string. #[global] Declare Instance showList : forall {A : Type} `{Show A}, Show (list A). #[global] Declare Instance showPair : forall {A B : Type} `{Show A} `{Show B}, Show (A * B). #[global] Declare Instance showOpt : forall {A : Type} `{Show A}, Show (option A). #[global] Declare Instance showEx : forall {A} `{Show A} P, Show ({x : A | P x}). (** When defining [Show] instance for your own datatypes, you sometimes need to start a new line for better printing. [nl] is a shorthand for it. *) Definition nl : string := String (ascii_of_nat 10) EmptyString. (* #################################################################### *) (** * Generators *) (* #################################################################### *) (** ** Fundamental Types *) (** A [RandomSeed] represents a particular starting point in a pseudo-random sequence. *) Parameter RandomSeed : Type. (** [G A] is the type of random generators for type [A]. *) Parameter G : Type -> Type. (** Run a generator with a size parameter (a natural number denoting the maximum depth of the generated A) and a random seed. *) Parameter run : forall {A : Type}, G A -> nat -> RandomSeed -> A. (* #################################################################### *) (** ** Structural Combinators *) (** Generators are also instances of several generic typeclasses. Many handy generator combinators can be found in the [Monad], [Functor], [Applicative], [Foldable], and [Traversable] modules in the [ExtLib.Structures] library from [coq-ext-lib]. *) #[global] Declare Instance Monad_G : Monad G. #[global] Declare Instance Functor_G : Functor G. #[global] Declare Instance Applicative_G : Applicative G. (** A variant of bind for the [(G (option --))] monad. Useful for chaining generators that can fail / backtrack. *) Parameter bindGenOpt : forall {A B : Type}, G (option A) -> (A -> G (option B)) -> G (option B). (* #################################################################### *) (** ** Basic Generator Combinators *) (** The [listOf] and [vectorOf] combinators construct generators for [list A], provided a generator [g] for type [A]: [listOf g] yields an arbitrary-sized list (which might be empty), while [vectorOf n g] yields a list of fixed size [n]. *) Parameter listOf : forall {A : Type}, G A -> G (list A). Parameter vectorOf : forall {A : Type}, nat -> G A -> G (list A). (** [elems_ a l] constructs a generator from a list [l] and a default element [a]. If [l] is non-empty, the generator picks an element from [l] uniformly; otherwise it always yields [a]. *) Parameter elems_ : forall {A : Type}, A -> list A -> G A. (** Similar to [elems_], instead of choosing from a list of [A]s, [oneOf_ g l] returns [g] if [l] is empty; otherwise it uniformly picks a generator for [A] in [l]. *) Parameter oneOf_ : forall {A : Type}, G A -> list (G A) -> G A. (** We can also choose generators with distributions other than the uniform one. [freq_ g l] returns [g] if [l] is empty; otherwise it chooses a generator from [l], where the first field indicates the chance that the second field is chosen. For example, [freq_ z [(2, x); (3, y)]] has 40%% probability of choosing [x] and 60%% probability of choosing [y]. *) Parameter freq_ : forall {A : Type}, G A -> list (nat * G A) -> G A. (** Try all generators until one returns a [Some] value or all failed once with [None]. The generators are picked at random according to their weights (like [frequency]), and each one is run at most once. *) Parameter backtrack : forall {A : Type}, list (nat * G (option A)) -> G (option A). (** Internally, the G monad hides a [size] parameter that can be accessed by generators. The [sized] combinator provides such access. The [resize] combinator sets it. *) Parameter sized : forall {A: Type}, (nat -> G A) -> G A. Parameter resize : forall {A: Type}, nat -> G A -> G A. (** Generate-and-test approach to generate data with preconditions. *) Parameter suchThatMaybe : forall {A : Type}, G A -> (A -> bool) -> G (option A). Parameter suchThatMaybeOpt : forall {A : Type}, G (option A) -> (A -> bool) -> G (option A). (* #################################################################### *) (** The [elems_], [oneOf_], and [freq_] combinators all take default values; these are only used if their list arguments are empty, which should not normally happen. The [QcDefaultNotation] sub-module exposes notation (without the underscores) to hide this default. *) Module QcDefaultNotation. (** [elems] is a shorthand for [elems_] without a default argument. *) Notation " 'elems' [ x ] " := (elems_ x (cons x nil)) : qc_scope. Notation " 'elems' [ x ; y ] " := (elems_ x (cons x (cons y nil))) : qc_scope. Notation " 'elems' [ x ; y ; .. ; z ] " := (elems_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope. Notation " 'elems' ( x ;; l ) " := (elems_ x (cons x l)) (at level 1, no associativity) : qc_scope. (** [oneOf] is a shorthand for [oneOf_] without a default argument. *) Notation " 'oneOf' [ x ] " := (oneOf_ x (cons x nil)) : qc_scope. Notation " 'oneOf' [ x ; y ] " := (oneOf_ x (cons x (cons y nil))) : qc_scope. Notation " 'oneOf' [ x ; y ; .. ; z ] " := (oneOf_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope. Notation " 'oneOf' ( x ;; l ) " := (oneOf_ x (cons x l)) (at level 1, no associativity) : qc_scope. (** [freq] is a shorthand for [freq_] without a default argument. *) Notation " 'freq' [ x ] " := (freq_ x (cons x nil)) : qc_scope. Notation " 'freq' [ ( n , x ) ; y ] " := (freq_ x (cons (n, x) (cons y nil))) : qc_scope. Notation " 'freq' [ ( n , x ) ; y ; .. ; z ] " := (freq_ x (cons (n, x) (cons y .. (cons z nil) ..))) : qc_scope. Notation " 'freq' ( ( n , x ) ;; l ) " := (freq_ x (cons (n, x) l)) (at level 1, no associativity) : qc_scope. End QcDefaultNotation. (** The original version of QuickChick used [elements], [oneof] and [frequency] as the default-argument versions of the corresponding combinators. These have since been deprecated in favor of a more consistent naming scheme. *) (* #################################################################### *) (** ** Choosing from Intervals *) (** The combinators above allow us to generate elements by enumeration and lifting. However, for numeric data types, we sometimes hope to choose from an interval without writing down all the possible values. Such intervals can be defined on ordered data types, whose ordering [leq] satisfies reflexive, transitive, and antisymmetric predicates. *) (** We also expect the random function to be able to pick every element in any given interval. *) Existing Class ChoosableFromInterval. (** QuickChick has provided some instances for ordered data types that are choosable from intervals, including [N], [nat], and [Z]. *) #[global] Declare Instance ChooseN : ChoosableFromInterval N N.le. #[global] Declare Instance ChooseNat : ChoosableFromInterval nat Nat.le. #[global] Declare Instance ChooseZ : ChoosableFromInterval Z Z.le. (** [choose l r] generates a value between [l] and [r], inclusive the two extremes. It causes a runtime error if [r < l]. *) Parameter choose : forall {A : Type} `{ChoosableFromInterval A}, (A * A) -> G A. (* #################################################################### *) (** ** The [Gen] and [GenSized] Typeclasses *) (** [GenSized] and [Gen] are typeclasses whose instances can be generated randomly. More specifically, [GenSized] depends on a generator for any given natural number that indicate the size of output. *) (** [[ Class GenSized (A : Type) := { arbitrarySized : nat -> G A }. Class Gen (A : Type) := { arbitrary : G A }. ]] *) (** Given an instance of [GenSized], we can convert it to [Gen] automatically, using [sized] function. *) #[global] Declare Instance GenOfGenSized {A} `{GenSized A} : Gen A. (** Here are some basic instances for generators: *) #[global] Declare Instance genBoolSized : GenSized bool. #[global] Declare Instance genNatSized : GenSized nat. #[global] Declare Instance genZSized : GenSized Z. #[global] Declare Instance genListSized : forall {A : Type} `{GenSized A}, GenSized (list A). #[global] Declare Instance genList : forall {A : Type} `{Gen A}, Gen (list A). #[global] Declare Instance genOption : forall {A : Type} `{Gen A}, Gen (option A). #[global] Declare Instance genPairSized : forall {A B : Type} `{GenSized A} `{GenSized B}, GenSized (A*B). #[global] Declare Instance genPair : forall {A B : Type} `{Gen A} `{Gen B}, Gen (A * B). (* #################################################################### *) (** ** Generators for Data Satisfying Inductive Predicates *) (** Just as QuickChick provides the [GenSized] and [Gen] typeclasses for generators of type [A], it provides constrained variants for generators of type [A] such that [P : A -> Prop] holds of all generated values. Since it is not guaranteed that any such [A] exist, these generators are partial. *) (** [[ Class GenSizedSuchThat (A : Type) (P : A -> Prop) := { arbitrarySizeST : nat -> G (option A) }. Class GenSuchThat (A : Type) (P : A -> Prop) := { arbitraryST : G (option A) }. ]] *) (** So, for example, if you have a typing relation [has_type : exp -> type -> Prop] for some language, you could, given some type [T] as input, write (or derive as we will see later on) an instance of [GenSizedSuchThat (fun e => has_type e T)], that produces an expression of with type [T]. Calling [arbitraryST] through such an instance would require making an explicit application to [@arbitraryST] as follows: [[ @arbitraryST _ (fun e => has_type e T) _ ]] where the first placeholder is the type of expressions [exp] and the second placeholder is the actual instance to be inferred. To avoid this, QuickChick also provides convenient notation to call by providing only the predicate [P] that constraints the generation. The typeclass constraint is inferred. *) Notation "'genSizedST' x" := ((@arbitrarySizeST _ x _)) (at level 10). Notation "'genST' x" := ((@arbitraryST _ x _)) (at level 10). (* #################################################################### *) (** * Shrinking *) (** ** The [Shrink] Typeclass *) (** [Shrink] is a typeclass whose instances have an operation for shrinking larger elements to smaller ones, allowing QuickChick to search for a minimal counter example when errors occur. *) (** [[ Class Shrink (A : Type) := { shrink : A -> list A }. ]] *) (** Default shrinkers for some basic datatypes: *) #[global] Declare Instance shrinkBool : Shrink bool. #[global] Declare Instance shrinkNat : Shrink nat. #[global] Declare Instance shrinkZ : Shrink Z. #[global] Declare Instance shrinkList {A : Type} `{Shrink A} : Shrink (list A). #[global] Declare Instance shrinkPair {A B} `{Shrink A} `{Shrink B} : Shrink (A * B). #[global] Declare Instance shrinkOption {A : Type} `{Shrink A} : Shrink (option A). (* #################################################################### *) (** ** The [Arbitrary] Typeclass *) (** The [Arbitrary] typeclass combines generation and shrinking. *) (** [[ Class Arbitrary (A : Type) `{Gen A} `{Shrink A}. ]] *) (* #################################################################### *) (** ** The Generator Typeclass Hierarchy *) (** [[ GenSized | | Gen Shrink \ / \ / Arbitrary ]] *) (** If a type has a [Gen] and a [Shrink] instance, it automatically gets an [Arbitrary] one. *) #[global] Declare Instance ArbitraryOfGenShrink : forall {A} `{Gen A} `{Shrink A}, Arbitrary A. (* #################################################################### *) (** * Checkers *) (** ** Basic Definitions *) (** [Checker] is the opaque type of QuickChick properties. *) Parameter Checker : Type. (** The [Checkable] class indicates we can check a type A. *) (** [[ Class Checkable (A : Type) : Type := { checker : A -> Checker }. ]] *) (** Boolean checkers always pass or always fail. *) #[global] Declare Instance testBool : Checkable bool. (** The unit checker is always discarded (that is, it represents a useless test). It is used, for example, in the implementation of the "implication [Checker]" combinator [==>]. *) #[global] Declare Instance testUnit : Checkable unit. (** Given a generator for showable [A]s, construct a [Checker]. *) Parameter forAll : forall {A prop : Type} `{Checkable prop} `{Show A} (gen : G A) (pf : A -> prop), Checker. (** Given a generator and a shrinker for showable [A]s, construct a [Checker]. *) Parameter forAllShrink : forall {A prop : Type} `{Checkable prop} `{Show A} (gen : G A) (shrinker : A -> list A) (pf : A -> prop), Checker. (** Lift ([Show], [Gen], [Shrink]) instances for [A] to a [Checker] for functions [A] -> prop. This is what makes it possible to write (for some example property [foo := fun x => x >? 0], say) [QuickChick foo] instead of [QuickChick (forAllShrink arbitrary shrink foo)]. *) #[global] Declare Instance testFun : forall {A prop : Type} `{Show A} `{Arbitrary A} `{Checkable prop}, Checkable (A -> prop). (** Lift products similarly. *) #[global] Declare Instance testProd : forall {A : Type} {prop : A -> Type} `{Show A} `{Arbitrary A} `{forall x : A, Checkable (prop x)}, Checkable (forall (x : A), prop x). (** Lift polymorphic functions by instantiating to 'nat'. :-) *) #[global] Declare Instance testPolyFun : forall {prop : Type -> Type} `{Checkable (prop nat)}, Checkable (forall T, prop T). (* #################################################################### *) (** ** Checker Combinators *) (** Print a specific string if the property fails. *) Parameter whenFail : forall {prop : Type} `{Checkable prop} (str : string), prop -> Checker. (** Record an expectation that a property should fail, i.e. the property will fail if all the tests succeed. *) (* SOONER: Don't understand this explanation. A Checker, in my model of the world, maps a random seed to the outcome of a *single* test. This seems to suggest that an expectFailure checker somehow knows the value of the test on *all* random seeds... *) (* SOONER: I think I need help with the phrasing here. What I mean is QuickChick will run its default number of tests (whether that is 100 or 10000000 doesn't matter). If all of those 100 or 10000000 tests succeed, then an [expectFailure property] is considered to fail because a failure was expected but not found. Does this make sense? BCP: Sort of, but not really. E.g., can I nest uses of expectFailure? What happens then? (How many tests get run?) Or, what happens if I conjoin an expectFailure with some other checkers? I guess I need a model for how it is implemented. (Which I think we didn't give in QC.v, right?)*) Parameter expectFailure : forall {prop: Type} `{Checkable prop} (p: prop), Checker. (** Collect statistics across all tests. *) Parameter collect : forall {A prop : Type} `{Show A} `{Checkable prop} (x : A), prop -> Checker. (** Set the reason for failure. Will only count shrinks as valid if they preserve the tag. *) (* SOONER: Explain better. *) Parameter tag : forall {prop : Type} `{Checkable prop} (t : string), prop -> Checker. (** Form the conjunction / disjunction of a list of checkers. *) (* SOONER: We are not very consistent about when we name arguments and when we do not. E.g. [l] here: *) (* SOONER: We name all non-implicit/Typeclass ones, no? *) (* SOONER: whenFail does not. Nor does, for example (of many) resize. *) (* SOONER: What convention would you prefer to keep? Delete all names? Keep all non-implicit names? Something else? I can do a consistency pass after we fix everything. *) (* SOONER: BCP: I think keeping is best. *) Parameter conjoin : forall (l : list Checker), Checker. Parameter disjoin : forall (l : list Checker), Checker. (** Define a checker for a conditional property. Invalid generated inputs (ones for which the antecedent fails) are discarded. *) Parameter implication : forall {prop : Type} `{Checkable prop} (b : bool) (p : prop), Checker. (** Notation for implication. Clashes with many other notations in other libraries, so it lives in its own module. Note that this includes the notations for the generator combinators above to avoid needing to import two modules. *) Module QcNotation. Export QcDefaultNotation. Notation "x ==> y" := (implication x y) (at level 55, right associativity) : Checker_scope. End QcNotation. (* #################################################################### *) (** * Decidability *) (** ** The [Dec] Typeclass *) (** Decidability typeclass using ssreflect's 'decidable'. *) (** [[ Class Dec (P : Prop) : Type := { dec : decidable P }. ]] *) (** Decidable properties are Checkable. *) #[global] Declare Instance testDec {P} `{H : Dec P} : Checkable P. (** Logic Combinator instances. *) #[global] Declare Instance Dec_neg {P} {H : Dec P} : Dec (~ P). #[global] Declare Instance Dec_conj {P Q} {H : Dec P} {I : Dec Q} : Dec (P /\ Q). #[global] Declare Instance Dec_disj {P Q} {H : Dec P} {I : Dec Q} : Dec (P \/ Q). (* SOONER: We had discussed changing this to the partial decision procedure at some point. *) (** A convenient notation for coercing a decidable proposition to a [bool]. *) Notation "P '?'" := (match (@dec P _) with | left _ => true | right _ => false end) (at level 100). (** ** The [Dec_Eq] Typeclass *) (** [[ Class Dec_Eq (A : Type) := { dec_eq : forall (x y : A), decidable (x = y) }. ]] *) (** Automation and conversions for Dec. *) #[global] Declare Instance Dec_Eq_implies_DecEq {A} `{H : Dec_Eq A} (x y : A) : Dec (x = y). (** Since deciding equalities is a very common requirement in testing, QuickChick provides a tactic that can define instances of the form [Dec_Eq]. *) (** [[ Ltac dec_eq. ]] *) (** QuickChick also lifts common decidable instances to the [Dec] typeclass. *) #[global] Declare Instance Dec_eq_unit : Dec_Eq unit. #[global] Declare Instance Dec_eq_bool : Dec_Eq bool. #[global] Declare Instance Dec_eq_nat : Dec_Eq nat. #[global] Declare Instance Dec_eq_Z : Dec_Eq Z. #[global] Declare Instance Dec_eq_N : Dec_Eq N. #[global] Declare Instance Dec_eq_ascii : Dec_Eq ascii. #[global] Declare Instance Dec_eq_string : Dec_Eq string. #[global] Declare Instance Dec_eq_opt (A : Type) `{Dec_Eq A} : Dec_Eq (option A). #[global] Declare Instance Dec_eq_prod (A B : Type) `{Dec_Eq A} `{Dec_Eq B} : Dec_Eq (A * B). #[global] Declare Instance Dec_eq_sum (A B : Type) `{Dec_Eq A} `{Dec_Eq B} : Dec_Eq (A + B). #[global] Declare Instance Dec_eq_list (A : Type) `{Dec_Eq A} : Dec_Eq (list A). (* #################################################################### *) (** * Automatic Instance Derivation *) (** QuickChick allows the automatic derivation of typeclass instances for simple types: [[ Derive for T. ]] Here [] must be one of [GenSized], [Shrink], [Arbitrary], or [Show], and [T] must be an inductive defined datatype (think Haskell/OCaml). To derive multiple classes at once, write: [[ Derive (,...,) for T. ]] *) (** QuickChick also allows for the automatic derivation of generators satisfying preconditions in the form of inductive relations: Derive ArbitrarySizedSuchThat for (fun x => P x1 ... x .... xn).

must be an inductively defined relation. is the function to be generated. are (implicitly universally quantified) variable names. *) (** QuickChick also allows automatic derivations of proofs of correctness of its derived generators! For more, look at: - A paper on deriving QuickChick generators for a large class of inductive relations. {http://www.cis.upenn.edu/~llamp/pdf/GeneratingGoodGenerators.pdf} - Leo's PhD dissertation. {https://lemonidas.github.io/pdf/Leo-PhD-Thesis.pdf} - examples/DependentTest.v *) (* #################################################################### *) (** * Top-level Commands and Settings *) (** QuickChick provides a series of toplevel commands to sample generators, test properties, and derive useful typeclass instances. *) (** The [Sample] command samples a generator. The argument [g] needs to have type [G A] for some showable type [A]. *) (** [[ Sample g. ]] *) (** The main testing command, [QuickChick], runs a test. The argument [prop] must belong to a type that is an instance of [Checkable]. *) (** [[ QuickChick prop. ]] *) (** QuickChick uses arguments to customize execution. *) Record Args := MkArgs { (* Re-execute a test. *) (* Default: None *) replay : option (RandomSeed * nat); (* Maximum number of successful tests to run. *) (* Default: 10000 *) maxSuccess : nat; (* Maximum number of discards to accept. *) (* Default: 20000 *) maxDiscard : nat; (* Maximum number of shrinks to perform before terminating. *) (* Default : 1000 *) maxShrinks : nat; (* Maximum size of terms to generate (depth). *) (* Default : 7 *) maxSize : nat; (* Verbosity. Note: Doesn't do much... *) (* Default true. *) chatty : bool }. (** Instead of record updates, you should overwrite extraction constants. *) (** [[ Extract Constant defNumTests => "10000". Extract Constant defNumDiscards => "(2 * defNumTests)". Extract Constant defNumShrinks => "1000". Extract Constant defSize => "7". ]] *) (* Semantics of Generators *) (* To reason about generators, we need to import the Proofs module from QuickChick. *) Set Warnings "-notation-overwritten, -parsing". Set Warnings "-require-in-module, -fragile]". From QuickChick Require Import Proofs. Local Open Scope set_scope. (** The semantics of a generator is its set of possible outcomes. *) Parameter semGen : forall {A : Type} (g : G A), set A. Parameter semGenSize : forall {A : Type} (g : G A) (size : nat), set A. (* SOONER: Where does [set] come from?? Where can I read about what operations / theorems are available? *) (* SOONER: [set] comes from src/Sets.v. I think Maxime/Zoe wrote most of that file quite a while ago (during her thesis at Catalin). It is not really documented... would you want all of that file here? *) (* SOONER: I want this file to be a complete description of what most people need to know to use QC. One possible approach could be to split this interface into a "programming interface" for most users and a "proving interface" for people that also want to do proofs involving the QC semantics. Then the functions from Sets.v would be relevant only to the second. (I actually kind of like this idea, as it would streamline what most people need to think about.) *) (* SOONER: It *is* a complete description of what _the vast majority_ people need to know to use QC. There are exactly three uses of the set library: 1) Allow derivation of correctness proofs. Here, the user doesn't need to know all the lemmas that the proof uses in order to enjoy the benefits of an end-to-end specification (but the lemmas need to be exposed). 2) Allow manual correctness proofs. I don't think anyone has ever done that outside of ourselves to practice before writing the generic derivation of proofs. Writing correctness proofs for generators is hard and not really worth it from the user's perspective. 3) The only potential use of the set library from a user would be in forAllProof variants to define dependently typed data. However, this intrinsic verification approach is very rarely used and comes with more severe testing problems than an undocumented set library. My thinking was to have [semGen] and [forAllProof] here as a small glance into the world of generator semantics. I do think that presenting the view that a generator is characterized by its set of outcomes is a very useful notion, even if a user never has to actively play with that notion. Do you want to just remove every mention to [set]/[semGen] from this file to keep it a "programming only" interface? Besides, what would the "proving interface" entail? We can't really document the entirety of the sets library. That's like 200 low-level lemmas that are only expanded to facilitate proof derivation... For example, we have lemmas like the following: [[ Lemma isSome_subset {A : Type} (s1 s2 s1' s2' : set (option A)) : isSome :&: s1 \subset isSome :&: s2 -> isSome :&: (s1 :|: ([set None] :&: s1')) \subset isSome :&: (s2 :|: ([set None] :&: s2')). ]] This says that if the set of all "Some"s in s1 is a subset of all the "Some"s in s2, then the set of all "Some"s in the the union of s1 with [the intersection of {None} and s1'] is a subset of the set of all somes in the union of s2 with [the intersection of {None} and s2']. Of course, the intersection of {None} with any set is at most {None}, and that none will be filtered out by [isSome], so this looks like a completely useless lemma. However, we do need this lemma because of the particular structure of the proofs involving the backtrack combinator. How can we explain this lemma and its point to a user if we turn this file into a complete documentation of everything that needs to be exposed? *) (** A variant of monadic bind where the continuation also takes a _proof_ that the value received is within the set of outcomes of the first generator. *) Parameter bindGen' : forall {A B : Type} (g : G A), (forall (a : A), (a \in semGen g) -> G B) -> G B. (** A variant of [forAll] that provides evidence that the generated values are members of the semantics of the generator. (Such evidence can be useful when constructing dependently typed data, such as bounded integers.) *) Parameter forAllProof : forall {A prop : Type} `{Checkable prop} `{Show A} (gen : G A) (pf : forall (x : A), semGen gen x -> prop), Checker. (* #################################################################### *) (** * The [quickChick] Command-Line Tool *) (** QuickChick comes with a command-line tool that supports: - Batch processing, compilation and execution of tests - Mutation testing - Sectioning of tests and mutants Comments that begin with an exclamation mark are special to the QuickChick command-line tool parser and signify a test, a section, or a mutant. *) (** ** Test Annotations *) (** A test annotation is just a [QuickChick] command wrapped inside a comment with an exclamation mark. [[ (*! QuickChick prop. *) ]] Only tests that are annotated this way will be processed. Only property names are allowed. *) (** ** Mutant Annotations *) (** A mutant annotation consists of 4 components. First an anottation that signifies the beginning of the mutant [(*! *)]. That is followed by the actual code. Then, we can include an optional annotation (in a comment with double exclamation marks) that corresponds to the mutant names. Finally, we can add a list of mutations inside normal annotated comments. Each mutant should be able to be syntactically substituted in for the normal code. [[ (*! *) Normal code (*!! mutant-name *) (*! mutant 1 *) (*! mutant 2 *) ... etc ... ]] *) (** ** Section Annotations *) (** To organize larger developments better, we can group together different tests and mutants in sections. A section annotation is a single annotation that defines the beginning of the section (which lasts until the next section or the end of the file). [[ (*! Section section-name *) ]] Optionally, one can include an extends clause [[ (*! Section section-name *)(*! extends other-section-name *) ]] This signifies that the section being defined also contains all tests and mutants from [other-section-name]. *) (** ** Command-Line Tool Flags *) (** The QuickChick command line tool can be passed the following options: - [-s

]: Specify which sections properties and mutants to test - [-v]: Verbose mode for debugging - [-failfast]: Stop as soon as a problem is detected - [-color]: Use colors on an ANSI-compatible terminal - [-cmd ]: What compile command is used to compile the current directory if it is not [make] - [-top ]: Specify the name of the top-level logical module. That should be the same as the [-Q] or [-R] directive in [_CoqProject] or [Top] which is the default - [-ocamlbuild ]: Any arguments necessary to pass to ocamlbuild when compiling the extracted code (e.g. linked libraries) - [-nobase]: Pass this option to not test the base mutant - [-m ]: Pass this to only test a mutant with a specific id number - [-tag ]: Pass this to only test a mutant with a specific tag - [-include ]: Specify a to include in the compilation - [-exclude ]: Specify files to be excluded from compilation. Must be the last argument passed. *) (* #################################################################### *) (** * Deprecated Features *) (** The following features are retained for backward compatibility, but their use is deprecated. *) (** Use the monad notations from [coq-ext-lib] instead of the [QcDoNotation] sub-module: *) Module QcDoNotation. Notation "'do!' X <- A ; B" := (bindGen A (fun X => B)) (at level 200, X name, A at level 100, B at level 200). Notation "'do\'' X <- A ; B" := (bindGen' A (fun X H => B)) (at level 200, X name, A at level 100, B at level 200). Notation "'doM!' X <- A ; B" := (bindGenOpt A (fun X => B)) (at level 200, X name, A at level 100, B at level 200). End QcDoNotation. End QuickChickSig. QuickChick-2.1.0/doc/dune000066400000000000000000000001601476030541200151520ustar00rootroot00000000000000(coq.theory (name QuickChick.Doc) (theories QuickChick) (modules QuickChickInterface DocumentationCheck)) QuickChick-2.1.0/dune000066400000000000000000000000731476030541200144100ustar00rootroot00000000000000(alias (name default) (deps (package coq-quickchick))) QuickChick-2.1.0/dune-project000066400000000000000000000017021476030541200160540ustar00rootroot00000000000000(lang dune 3.12) (using coq 0.7) (warnings (deprecated_coq_lang_lt_08 disabled)) (using menhir 2.0) (name coq-quickchick) (version dev) (generate_opam_files true) (source (github QuickChick/QuickChick)) (license MIT) (authors "Leonidas Lampropoulos" "Zoe Paraskevopoulou" "Maxime Denes" "Catalin Hritcu" "Benjamin Pierce" "Li-yao Xia" "Arthur Azevedo de Amorim" "Yishuai Li" "Antal Spector-Zabusky") (maintainers "leonidas@umd.edu") (package (name coq-quickchick) (synopsis "Randomized Property-Based Testing for Coq") (description "A library for property-based testing in Coq. - Combinators for testable properties and random generators. - QuickChick plugin for running tests in a Coq session. - Includes a mutation testing tool.") (depends (ocaml (>= 4.07)) (menhir :build) (cppo (and :build (>= 1.6.8))) (coq (>= 8.15~)) coq-ext-lib coq-mathcomp-ssreflect (coq-simple-io (>= 1.6.0)) ocamlfind ocamlbuild) ) QuickChick-2.1.0/example.dir-locals.el000066400000000000000000000002661476030541200175430ustar00rootroot00000000000000((coq-mode . ( ;; HACK: Include everything at two levels, so that relative paths ;; make sense when editing a file at either level. (coq-load-path . ("../src" "./src"))))) QuickChick-2.1.0/examples/000077500000000000000000000000001476030541200153505ustar00rootroot00000000000000QuickChick-2.1.0/examples/RedBlack/000077500000000000000000000000001476030541200170175ustar00rootroot00000000000000QuickChick-2.1.0/examples/RedBlack/dune000066400000000000000000000003631476030541200176770ustar00rootroot00000000000000(coq.theory (name QuickChick.RedBlack) (theories QuickChick) (modules redblack testing verif )) (rule (alias testing) (target testing.v) (action (run sh %{dep:../../scripts/mycppo} %{dep:testing.v.cppo} %{target}))) QuickChick-2.1.0/examples/RedBlack/redblack.v000066400000000000000000000045501476030541200207610ustar00rootroot00000000000000Set Warnings "-notation-overridden". From mathcomp Require Import ssreflect ssrnat ssrbool eqtype. (* Formalization inspired from https://www.cs.princeton.edu/~appel/papers/redblack.pdf *) (* An implementation of Red-Black Trees (insert only) *) (* begin tree *) Inductive color := Red | Black. Inductive tree := Leaf : tree | Node : color -> tree -> nat -> tree -> tree. (* end tree *) (* insertion *) Definition balance rb t1 k t2 := match rb with | Red => Node Red t1 k t2 | _ => match t1 with | Node Red (Node Red a x b) y c => Node Red (Node Black a x b) y (Node Black c k t2) | Node Red a x (Node Red b y c) => Node Red (Node Black a x b) y (Node Black c k t2) | _ => match t2 with | Node Red (Node Red b y c) z d => Node Red (Node Black t1 k b) y (Node Black c z d) | Node Red b y (Node Red c z d) => Node Red (Node Black t1 k b) y (Node Black c z d) | _ => Node Black t1 k t2 end end end. Fixpoint ins x s := match s with | Leaf => Node Red Leaf x Leaf | Node c a y b => if x < y then balance c (ins x a) y b else if y < x then balance c a y (ins x b) else Node c a x b end. Definition makeBlack t := match t with | Leaf => Leaf | Node _ a x b => Node Black a x b end. Definition insert x s := makeBlack (ins x s). (* Red-Black Tree invariant: declarative definition *) (* begin is_redblack *) Inductive is_redblack' : tree -> color -> nat -> Prop := | IsRB_leaf: forall c, is_redblack' Leaf c 0 | IsRB_r: forall n tl tr h, is_redblack' tl Red h -> is_redblack' tr Red h -> is_redblack' (Node Red tl n tr) Black h | IsRB_b: forall c n tl tr h, is_redblack' tl Black h -> is_redblack' tr Black h -> is_redblack' (Node Black tl n tr) c (S h). Definition is_redblack (t:tree) : Prop := exists h, is_redblack' t Red h. (* end is_redblack *) (* begin insert_preserves_redblack *) Definition insert_preserves_redblack : Prop := forall x s, is_redblack s -> is_redblack (insert x s). (* end insert_preserves_redblack *) (* Declarative Proposition *) Lemma insert_preserves_redblack_correct : insert_preserves_redblack. Abort. (* if this wasn't about testing, we would just prove this *) QuickChick-2.1.0/examples/RedBlack/testing.v.cppo000066400000000000000000000166261476030541200216360ustar00rootroot00000000000000From QuickChick Require Import QuickChick Generators. Require Import Lia. Set Warnings "-notation-overridden". From mathcomp Require Import ssreflect ssrnat ssrbool eqtype. From QuickChick.RedBlack Require Import redblack. Require Import List String. Import ListNotations. Open Scope string. Open Scope Checker_scope. (* Red-Black Tree invariant: executable definition *) Fixpoint black_height_bool (t: tree) : option nat := match t with | Leaf => Some 0 | Node c tl _ tr => let h1 := black_height_bool tl in let h2 := black_height_bool tr in match h1, h2 with | Some n1, Some n2 => if n1 == n2 then match c with | Black => Some (S n1) | Red => Some n1 end else None | _, _ => None end end. Definition is_black_balanced (t : tree) : bool := isSome (black_height_bool t). Fixpoint has_no_red_red (c : color) (t : tree) : bool := match t with | Leaf => true | Node Red t1 _ t2 => match c with | Red => false | Black => has_no_red_red Red t1 && has_no_red_red Red t2 end | Node Black t1 _ t2 => has_no_red_red Black t1 && has_no_red_red Black t2 end. (* begin is_redblack_bool *) Definition is_redblack_bool (t : tree) : bool := is_black_balanced t && has_no_red_red Red t. (* end is_redblack_bool *) Definition showColor (c : color) := match c with | Red => "Red" | Black => "Black" end. Fixpoint tree_to_string (t : tree) := match t with | Leaf => "Leaf" | Node c l x r => "Node " ++ showColor c ++ " " ++ "(" ++ tree_to_string l ++ ") " ++ show x ++ " " ++ "(" ++ tree_to_string r ++ ")" end. #[global] Instance showTree {A : Type} `{_ : Show A} : Show tree := {| show t := "" (* CH: tree_to_string t causes a 9x increase in runtime *) |}. (* begin insert_preserves_redblack_checker *) Definition insert_preserves_redblack_checker (genTree : G tree) : Checker := forAll arbitrary (fun n => forAll genTree (fun t => is_redblack_bool t ==> is_redblack_bool (insert n t))). (* end insert_preserves_redblack_checker *) Import QcDefaultNotation. Open Scope qc_scope. (* begin genAnyTree *) Definition genColor := elems [Red; Black]. Fixpoint genAnyTree_depth (d : nat) : G tree := match d with | 0 => returnGen Leaf | S d' => freq [(1, returnGen Leaf); (9, liftGen4 Node genColor (genAnyTree_depth d') arbitrary (genAnyTree_depth d'))] end. Definition genAnyTree : G tree := sized genAnyTree_depth. (* end genAnyTree *) Extract Constant defSize => "10". Definition test_naive := insert_preserves_redblack_checker genAnyTree. (* begin QC_naive *) (*! QuickChick test_naive. *) (* end QC_naive *) (* gathering some size statistics *) Fixpoint tree_size (t : tree) : nat := match t with | Leaf => 1 | Node c tl _ tr => 1 + (tree_size tl) + (tree_size tr) end. Definition insert_preserves_redblack_checker_size (genTree : G tree) : Checker := forAll arbitrary (fun n => forAll genTree (fun t => collect (append "size " (show (tree_size t))) (is_redblack_bool t ==> is_redblack_bool (insert n t)))). (* Extract Constant Test.defNumTests => "100000". QuickChick (insert_preserves_redblack_checker_size genAnyTree). *) Module DoNotation. Import ssrfun. Notation "'do!' X <- A ; B" := (bindGen A (fun X => B)) (at level 200, X ident, A at level 100, B at level 200). End DoNotation. Import DoNotation. Require Import Relations Wellfounded Lexicographic_Product. Definition ltColor (c1 c2: color) : Prop := match c1, c2 with | Red, Black => True | _, _ => False end. Lemma well_foulded_ltColor : well_founded ltColor. Proof. unfold well_founded. intros c; destruct c; repeat (constructor; intros c ?; destruct c; try now (exfalso; auto)). Qed. Definition sigT_of_prod {A B : Type} (p : A * B) : {_ : A & B} := let (a, b) := p in existT (fun _ : A => B) a b. Definition prod_of_sigT {A B : Type} (p : {_ : A & B}) : A * B := let (a, b) := p in (a, b). Definition wf_hc (c1 c2 : (nat * color)) : Prop := lexprod nat (fun _ => color) lt (fun _ => ltColor) (sigT_of_prod c1) (sigT_of_prod c2). Lemma well_founded_hc : well_founded wf_hc. Proof. unfold wf_hc. apply wf_inverse_image. apply wf_lexprod. now apply Wf_nat.lt_wf. intros _; now apply well_foulded_ltColor. Qed. #if COQ_VERSION >= (8, 21, 0) From Stdlib.Program Require Import Wf WfExtensionality. Import WfExtensionality. #else From Coq.Program Require Import Wf. Import WfExtensionality. #endif Require Import FunctionalExtensionality. (* begin genRBTree_height *) Program Fixpoint genRBTree_height (hc : nat*color) {wf wf_hc hc} : G tree := match hc with | (0, Red) => returnGen Leaf | (0, Black) => oneOf [returnGen Leaf; (do! n <- arbitrary; returnGen (Node Red Leaf n Leaf))] | (S h, Red) => liftGen4 Node (returnGen Black) (genRBTree_height (h, Black)) arbitrary (genRBTree_height (h, Black)) | (S h, Black) => do! c' <- genColor; let h' := match c' with Red => S h | Black => h end in liftGen4 Node (returnGen c') (genRBTree_height (h', c')) arbitrary (genRBTree_height (h', c')) end. (* end genRBTree_height *) Next Obligation. unfold wf_hc; simpl; left; lia. Qed. Next Obligation. unfold wf_hc; simpl; left; lia. Qed. Next Obligation. unfold wf_hc; simpl; destruct c'; [right; apply I | left; lia]. Qed. Next Obligation. unfold wf_hc; simpl; destruct c'; [right; apply I | left; lia]. Qed. Next Obligation. abstract (apply well_founded_hc). Defined. Lemma genRBTree_height_eq (hc : nat*color) : genRBTree_height hc = match hc with | (0, Red) => returnGen Leaf | (0, Black) => oneOf [returnGen Leaf; (do! n <- arbitrary; returnGen (Node Red Leaf n Leaf))] | (S h, Red) => liftGen4 Node (returnGen Black) (genRBTree_height (h, Black)) arbitrary (genRBTree_height (h, Black)) | (S h, Black) => do! c' <- genColor; let h' := match c' with Red => S h | Black => h end in liftGen4 Node (returnGen c') (genRBTree_height (h', c')) arbitrary (genRBTree_height (h', c')) end. Proof. unfold_sub genRBTree_height (genRBTree_height hc). f_equal. destruct hc as [[|h] [|]]; try reflexivity. f_equal. apply functional_extensionality => [[|]]; reflexivity. Qed. (* Hope that this is enough for preventing unfolding genRBTree_height *) Global Opaque genRBTree_height. (* begin genRBTree *) Definition genRBTree := bindGen arbitrary (fun h => genRBTree_height (h, Red)). (* end genRBTree *) Definition showDiscards (r : Result) := match r with | Success ns nd _ _ => "Success: number of successes " ++ show (ns-1) ++ newline ++ " number of discards " ++ show nd ++ newline | _ => show r end. Definition testInsert := showDiscards (quickCheck (insert_preserves_redblack_checker genRBTree)). Extract Constant defSize => "10". Definition test_smart := (insert_preserves_redblack_checker genRBTree). (* begin QC_good *) (*! QuickChick test_smart. *) (* end QC_good *) (* gathering some size statistics Extract Constant Test.defNumTests => "100000". QuickChick (insert_preserves_redblack_checker_size genRBTree). *) QuickChick-2.1.0/examples/RedBlack/verif.v000066400000000000000000000233401476030541200203230ustar00rootroot00000000000000Set Warnings "-notation-overridden". From mathcomp Require Import ssreflect ssrnat ssrbool eqtype. Require Import List String Lia. From QuickChick Require Import QuickChick. Local Open Scope set_scope. From QuickChick.RedBlack Require Import redblack testing. (* correspondence between the inductive and the executable definitions *) Lemma has_black_height : forall t h c, is_redblack' t c h -> black_height_bool t = Some h. Proof. elim => [| c t1 IHt1 n t2 IHt2] h c' Hrb; first by inversion Hrb. inversion Hrb as [| n' tl tr h' Htl Htr | c'' n' tl tr h' Htl Htr]; subst; move: Htl Htr => /IHt1 Htl /IHt2 Htr; simpl; by rewrite Htl Htr eq_refl. Qed. Lemma is_redblack'P : forall (t : tree) n c, reflect (is_redblack' t c n) ((black_height_bool t == Some n) && has_no_red_red c t). Proof. elim => [| c t1 IHt1 n t2 IHt2] n' c'. - simpl. apply (@iffP ((Some 0 == Some n') && true)); first by apply/idP. + move => /andP [/eqP [H1] _]; subst. econstructor. + move => Hrb. apply/andP. inversion Hrb; subst. split => //. - apply (@iffP ((black_height_bool (Node c t1 n t2) == Some n') && has_no_red_red c' (Node c t1 n t2))); first by apply/idP. + move => /andP [/eqP /= H1 H2]; subst. destruct (black_height_bool t1) eqn:Heqh1, (black_height_bool t2) eqn:Heqh2; (try discriminate). have Heq : (n0 = n1) by apply/eqP; destruct (n0 == n1). subst. rewrite eq_refl in H1. destruct c; inversion H1; subst; clear H1; destruct c' => //=; move : H2 => /andP [Ht1 Ht2]; (constructor; [apply/IHt1 | apply/IHt2]); apply/andP; split => //. + move => Hrb. inversion Hrb as [| n'' tl tr h Hrbl Hrbr | c'' n'' tl tr h Hrbl Hrbr]; subst; move: Hrbl Hrbr => /IHt1/andP [/eqP Hbhl Hrrl] /IHt2/andP [/eqP Hbhr Hrrr]; apply/andP; split => //; simpl; (try by rewrite Hbhl Hbhr eq_refl); by (apply/andP; split => //). Qed. (* begin is_redblackP *) Lemma is_redblackP t : reflect (is_redblack t) (is_redblack_bool t). (* end is_redblackP *) Proof. apply (@iffP (is_redblack_bool t)); first by apply/idP. rewrite /is_redblack_bool. + move => /andP [Hb Hrr]. rewrite /is_black_balanced in Hb. have [h Hbh] : exists h, black_height_bool t = Some h by destruct (black_height_bool t) => //; eexists. exists h. apply/is_redblack'P. apply/andP; split => //; apply/eqP => //. + move => [h /is_redblack'P /andP [/eqP H1 H2]]. rewrite /is_redblack_bool /is_black_balanced H1. apply/andP; split => //. Qed. (* begin semColor *) Lemma semColor : semProd genColor <--> [set : color]. (* end semColor *) Proof. rewrite /genColor. rewrite semElements. intros c. destruct c; simpl; unfold setT; tauto. Qed. Corollary genColor_correctSize': forall s, semProdSize genColor s <--> setT. Proof. move => s. rewrite unsized_alt_def. by apply semColor. Qed. Ltac returnSolver := try apply returnGenSizeMonotonic; try apply ProducerSemanticsGen. #[global] Instance genRBTree_heightMonotonic p : @SizeMonotonic _ _ ProducerGen (genRBTree_height p). Proof. move : p. eapply (well_founded_induction well_founded_hc). move => [[|n] c] IH; rewrite genRBTree_height_eq. - case : c {IH}; returnSolver. apply oneofMonotonic; returnSolver. move => t [H1 | [H2 | //]]; subst; returnSolver. eauto with typeclass_instances; apply (@bindMonotonic _ ProducerGen _); eauto with typeclass_instances; move => x; returnSolver. - case : c IH => IH. apply (@liftM4Monotonic); returnSolver. + eapply IH; eauto; by constructor; lia. + eauto with typeclass_instances. + eapply IH; eauto; by constructor; lia. + unfold genColor. apply bindMonotonic; eauto with typeclass_instances. move => x /=. apply liftM4Monotonic; returnSolver; eauto with typeclass_instances. * eapply IH; eauto; (case : x; [ by right | by left; lia]). * eapply IH; eauto; (case : x; [ by right | by left; lia]). Qed. #[global] Instance genRBTreeMonotonic : SizeMonotonic genRBTree. Proof. apply bindMonotonic; eauto with typeclass_instances. Qed. (* (* begin semGenRBTreeHeight *) Lemma semGenRBTreeHeight h c : semProd (genRBTree_height (h, c)) <--> [set t | is_redblack' t c h ]. (* end semGenRBTreeHeight *) Proof. replace c with (snd (h, c)); replace h with (fst (h, c)); try reflexivity. move : (h, c). clear h c. eapply (well_founded_induction well_founded_hc). move => [[|h] []] IH /=; rewrite genRBTree_height_eq. - rewrite semReturn. split. move => <-. constructor. move => H. inversion H; subst; reflexivity. - rewrite semOneof. move => t. split. + move => [gen [[H1 | [H1 | // _]] H2]]; subst. apply @semReturn in H2. * rewrite - H2. constructor. * apply ProducerSemanticsGen. * move : H2 => . move => [n [_ /semReturn <-]]. constructor. constructor. constructor. move => H. inversion H; subst. { eexists. split. left. reflexivity. inversion H; subst. by apply semThunkGen, semReturn. } { inversion H0; subst. inversion H1; subst. eexists. split. right. left. reflexivity. apply semThunkGen, semBindSizeMonotonic; eauto with typeclass_instances. eexists. split; last by apply semReturn; reflexivity. by apply arbNat_correct. } - rewrite semLiftGen4SizeMonotonic. split. + move => /= [c [t1 [n [t2 [/semReturn H1 [H2 [H3 [H4 H5]]]]]]]]. rewrite <- H1 in *. clear H1. subst. apply IH in H2; last by left; lia. apply IH in H4; last by left; lia. constructor; eauto. + move => H. inversion H; subst. apply (IH (h, Black)) in H1; last by left; lia. apply (IH (h, Black)) in H4; last by left; lia. eexists. eexists. eexists. eexists. repeat (split; auto; try reflexivity). by apply semReturn. by auto. by apply arbNat_correct. by auto. - rewrite semBindSizeMonotonic /=. split. + move => [c [_ /= /semLiftGen4SizeMonotonic [c' [t1 [n [t2 [/semReturn H1 [H2 [_ [H4 H5]]]]]]]]]]. rewrite <- H1 in *. clear H1. subst. destruct c. apply IH in H2; last by right. apply IH in H4; last by right. simpl in *. constructor; eauto. apply IH in H2; last by left; lia. apply IH in H4; last by left; lia. constructor; eauto. + move => H. inversion H; subst. apply (IH (h.+1, Red)) in H0; last by right. apply (IH (h.+1, Red)) in H1; last by right. eexists Red. split; first by apply semColor. apply semLiftGen4SizeMonotonic; eauto with typeclass_instances. eexists. eexists. eexists. eexists. repeat (split; auto; try reflexivity). by apply semReturn. by auto. by apply arbNat_correct. by auto. apply (IH (h, Black)) in H1; last by left; lia. apply (IH (h, Black)) in H4; last by left; lia. eexists Black. split; first by apply semColor. apply semLiftGen4SizeMonotonic; eauto with typeclass_instances. eexists. eexists. eexists. eexists. repeat (split; auto; try reflexivity). by apply semReturn. by auto. by apply arbNat_correct. by auto. Qed. (* begin semRBTree *) Lemma semRBTree : semGen genRBTree <--> [set t | is_redblack t]. (* end semRBTree *) Proof. rewrite /genRBTree /is_redblack. rewrite semBindSizeMonotonic. setoid_rewrite semGenRBTreeHeight. move => t. split. - move => [n [_ H2]]. eexists; eauto. - move => [n H3]. eexists. split; eauto. by apply arbNat_correct. Qed. (* begin insert_preserves_redblack_checker_correct *) Lemma insert_preserves_redblack_checker_correct: semChecker (insert_preserves_redblack_checker genRBTree) <-> insert_preserves_redblack. (* end insert_preserves_redblack_checker_correct *) Proof. rewrite (mergeForAlls arbitrary genRBTree). rewrite -> semForAllUnsized2. rewrite /genPair. split. - move => H n t irt. specialize (H (n,t)). simpl in H. rewrite /semCheckable in H. simpl in H. rewrite -> semReturnGen in H. unfold insert_preserves_redblack. { apply semCheckableBool in H; eauto. destruct (is_redblack_bool t) eqn:Hyp; simpl in *; try congruence. + apply /is_redblackP; auto. + move: irt. move => /is_redblackP irt. congruence. + apply semLiftGen2SizeMonotonic; eauto with typeclass_instances. exists (n, t). split => //. split => //. by apply arbNat_correct. by apply semRBTree. } - move => H [a t] /semLiftGen2SizeMonotonic [[n t'] [[_ Hg] [<- <-]]]. simpl. rewrite semCheckableBool. unfold insert_preserves_redblack in H. specialize (H n t'). destruct (is_redblack_bool t') eqn:Hyp. + simpl; move: Hyp => /is_redblackP Hyp. apply H in Hyp. apply /is_redblackP; auto. + simpl; auto. - simpl. eauto with typeclass_instances. Qed. (* Lemma insert_preserves_redblack_checker_correct' : semChecker (insert_preserves_redblack_checker genRBTree) <-> insert_preserves_redblack. Proof. rewrite /insert_preserves_redblack_checker /insert_preserves_redblack. rewrite -> semForAllSizeMonotonic; try by eauto with typeclass_instances. - split. + move => H n t irt. have HH : semGen arbitrary n by (apply arbNat_correct; reflexivity). specialize (H n HH). rewrite -> semForAllSizeMonotonic in H; try by (try move => ? /=); auto with typeclass_instances. specialize (H t). rewrite -> (semRBTree t) in H. simpl in H. specialize (H irt). rewrite -> semImplication in H. apply /is_redblackP. rewrite -> semCheckableBool in H. apply H. by apply /is_redblackP. + move => H a _ /=. rewrite -> semForAllSizeMonotonic; try by (try move => ? /=); auto with typeclass_instances. move => t Hg. rewrite -> semImplication => Hrb. rewrite semCheckableBool. apply /is_redblackP; apply H. by apply /is_redblackP. - move => n /=. apply forAllMonotonic; try by (try move => ? /=); auto with typeclass_instances. Qed. *) *) QuickChick-2.1.0/examples/c-mutation.t/000077500000000000000000000000001476030541200176725ustar00rootroot00000000000000QuickChick-2.1.0/examples/c-mutation.t/.gitignore000066400000000000000000000000041476030541200216540ustar00rootroot00000000000000Foo QuickChick-2.1.0/examples/c-mutation.t/Foo.c000066400000000000000000000002001476030541200205510ustar00rootroot00000000000000#include int main() { int x, y; scanf("%d%d", &x, &y); printf("%d\n", /*!*/ x + y /*! x * y */); return 0; } QuickChick-2.1.0/examples/c-mutation.t/Makefile000066400000000000000000000002731476030541200213340ustar00rootroot00000000000000QC=quickChick -color -ocamlbuild '-lib unix' all: Makefile.coq Foo @$(MAKE) -f $< test: time $(QC) lesstest: time $(QC) -N 100 Makefile.coq: _CoqProject @coq_makefile -o $@ -f $< QuickChick-2.1.0/examples/c-mutation.t/_CoqProject000066400000000000000000000000071476030541200220220ustar00rootroot00000000000000plus.v QuickChick-2.1.0/examples/c-mutation.t/extract.ml000066400000000000000000000003471476030541200217020ustar00rootroot00000000000000open Unix;; let plus x y = let (ic, oc) = open_process "./Foo" in output_string oc (string_of_int x ^ " " ^ string_of_int y); close_out oc; let str = input_line ic in ignore (close_process (ic, oc)); int_of_string str QuickChick-2.1.0/examples/c-mutation.t/plus.v000066400000000000000000000003351476030541200210450ustar00rootroot00000000000000From QuickChick Require Import QuickChick. QCInclude ".". Parameter plus' : nat -> nat -> nat. Extract Constant plus' => "Extract.plus". Definition plus_prop x y := plus' x y = x + y?. (*! QuickChick plus_prop. *) QuickChick-2.1.0/examples/c-mutation.t/run.t000066400000000000000000000001521476030541200206610ustar00rootroot00000000000000Testing Multifile Mutation $ quickChick -color -ocamlbuild '-lib unix' > log 2>&1 || (cat log ; exit 1) QuickChick-2.1.0/examples/caml/000077500000000000000000000000001476030541200162645ustar00rootroot00000000000000QuickChick-2.1.0/examples/caml/Makefile000066400000000000000000000016051476030541200177260ustar00rootroot00000000000000QC=quickChick -color -ocamlbuild '-lib unix -no-hygiene' TMP_DIR=../_qc_$(shell basename $(CURDIR)).tmp all: Makefile.coq $(MAKE) -f $< test: time $(QC) lesstest: time $(QC) -N 100 Makefile.coq: _CoqProject coq_makefile -o $@ -f $< %.o: %.c ocamlc -c $< libcamlplus.a: camlplus.o cplus.o ocamlmklib -custom -o camlplus $^ dllcamlplus.so: camlplus.o cplus.o ocamlmklib -o camlplus $^ testextract.opt: extract.ml testextract.ml libcamlplus.a ocamlopt -o $@ extract.ml testextract.ml -cclib -lcamlplus -ccopt -L. testextract.byte: extract.ml testextract.ml dllcamlplus.so ocamlc -o $@ extract.ml testextract.ml -dllib -lcamlplus testextract: testextract.opt testextract.byte ./testextract.opt ./testextract.byte clean: ocamlbuild -clean if [ -e Makefile.coq ]; then $(MAKE) -f Makefile.coq clean; fi $(RM) -r Makefile.coq* *.[oa] *.so *.cm[ixoa] *.cmx* *.opt *.byte *~ $(TMP_DIR) QuickChick-2.1.0/examples/caml/_CoqProject000066400000000000000000000000071476030541200204140ustar00rootroot00000000000000plus.v QuickChick-2.1.0/examples/caml/camlplus.c000066400000000000000000000002741476030541200202530ustar00rootroot00000000000000#include extern int cplus(int, int); CAMLprim value camlplus(value vx, value vy) { int x = Int_val(vx); int y = Int_val(vy); return Val_int(cplus(x, y)); } QuickChick-2.1.0/examples/caml/cplus.c000066400000000000000000000001011476030541200175460ustar00rootroot00000000000000int cplus(int x, int y) { return /*!*/ x + y /*! x * y */; } QuickChick-2.1.0/examples/caml/extract.ml000066400000000000000000000000571476030541200202720ustar00rootroot00000000000000external plus : int -> int -> int = "camlplus" QuickChick-2.1.0/examples/caml/plus.v000066400000000000000000000003351476030541200174370ustar00rootroot00000000000000From QuickChick Require Import QuickChick. QCInclude ".". Parameter plus' : nat -> nat -> nat. Extract Constant plus' => "Extract.plus". Definition plus_prop x y := plus' x y = x + y?. (*! QuickChick plus_prop. *) QuickChick-2.1.0/examples/caml/testextract.ml000066400000000000000000000000411476030541200211630ustar00rootroot00000000000000print_int (Extract.plus 123 456) QuickChick-2.1.0/examples/deriving-tests/000077500000000000000000000000001476030541200203175ustar00rootroot00000000000000QuickChick-2.1.0/examples/deriving-tests/function.v000066400000000000000000000017641476030541200223430ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import Nat. Inductive square_of_equiv : nat -> nat -> Prop := | sq' : forall n m, mult n n = m -> square_of_equiv n m. Derive EnumSizedSuchThat for (fun n => square_of_equiv n m). Derive DecOpt for (square_of_equiv n m). Example equiv_1 : @decOpt (square_of_equiv 2 4) _ 42 = Some true. Proof. reflexivity. Qed. Example equiv_2 : @decOpt (square_of_equiv 2 5) _ 42 = Some false. Proof. reflexivity. Qed. Inductive square_of : nat -> nat -> Prop := | sq : forall n, square_of n (n * n). Derive EnumSizedSuchThat for (fun n => square_of n m). Derive DecOpt for (square_of n m). Example sq_1 : @decOpt (square_of 2 4) _ 42 = Some true. Proof. reflexivity. Qed. Example sq_2 : @decOpt (square_of 2 5) _ 42 = Some false. Proof. reflexivity. Qed. Inductive correct_prod : (prod nat bool) -> Prop := | CorrectR1 : forall (p : prod nat bool) (n : nat), correct_prod (pair n (snd p)). Derive ArbitrarySizedSuchThat for (fun x => correct_prod x). QuickChick-2.1.0/examples/deriving-tests/in.v000066400000000000000000000013201476030541200211100ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Inductive merge {X:Type} : list X -> list X -> list X -> Prop := | merge_empty : merge nil nil nil | merge_left : forall l1 l2 l3 x, merge l1 l2 l3 -> merge (x::l1) l2 (x::l3) | merge_right : forall l1 l2 l3 x, merge l1 l2 l3 -> merge l1 (x::l2) (x::l3). Derive DecOpt for (merge l1 l2 l3). Derive ArbitrarySizedSuchThat for (fun l3 => merge l1 l2 l3). Derive EnumSizedSuchThat for (fun l3 => merge l1 l2 l3). Inductive In' {A:Type} : A -> list A -> Prop := | In_hd : forall x l, In' x (cons x l) | In_tl : forall x y l, In' x l -> In' x (cons y l). Derive EnumSizedSuchThat for (fun x => In' x l). Derive DecOpt for (In' x l). QuickChick-2.1.0/examples/deriving-tests/nodup.v000066400000000000000000000022001476030541200216250ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Inductive In' (A:Type) : A -> list A -> Prop := | In_hd : forall x l, In' A x (cons x l) | In_tl : forall x y l, In' A x l -> In' A x (cons y l). Derive DecOpt for (In' a l). Derive ArbitrarySizedSuchThat for (fun x => In' x l). Derive EnumSizedSuchThat for (fun x => In' x l). Derive EnumSizedSuchThat for (fun l => In' x l). Inductive NoDup {A:Type} : list A -> Prop := | NoDup_nil : NoDup nil | NoDup_cons : forall a l, ~ In' A a l -> NoDup l -> NoDup (a :: l). (* XXX LEO Error: Anomaly "Uncaught exception Failure("Simultaneous Some/None")." *) (* Error: Anomaly "Uncaught exception Failure("Incompatible modes/1")." *) Derive DecOpt for (NoDup l). Derive EnumSizedSuchThat for (fun l => NoDup l). Derive ArbitrarySizedSuchThat for (fun l => NoDup l). Inductive repeats {X:Type} : list X -> Prop := | rep_here : forall a l, In' X a l -> repeats (a::l) | rep_later : forall a l, repeats l -> repeats (a::l). Derive DecOpt for (repeats l). Derive ArbitrarySizedSuchThat for (fun l => repeats l). Derive EnumSizedSuchThat for (fun l => repeats l). QuickChick-2.1.0/examples/deriving-tests/nostutter.v000066400000000000000000000006561476030541200225640ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Derive EnumSizedSuchThat for (fun n => eq x n). Inductive nostutter {X:Type} : list X -> Prop := | nostutter0: nostutter nil | nostutter1 n : nostutter (n::nil) | nostutter2 a b r : a <> b -> nostutter (b::r) -> nostutter (a::b::r). Derive DecOpt for (nostutter l). Derive EnumSizedSuchThat for (fun l => nostutter l). Derive ArbitrarySizedSuchThat for (fun l => nostutter l). QuickChick-2.1.0/examples/deriving-tests/stlc.v000066400000000000000000000110151476030541200214510ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrbool eqtype. Require Import Arith List String Lia. From QuickChick Require Import QuickChick. Import ListNotations. (* Types *) Inductive type : Type := | N : type | Arrow : type -> type -> type. Derive (Arbitrary, Show, EnumSized) for type. Instance dec_type (t1 t2 : type) : Dec (t1 = t2). Proof. dec_eq. Defined. (* Terms *) Definition var := nat. Inductive term : Type := | Const : nat -> term | Id : var -> term | App : term -> term -> term | Abs : type -> term -> term. (* Environments *) Definition env := list type. Inductive bind : env -> nat -> type -> Prop := | BindNow : forall t G, bind (t :: G) 0 t | BindLater : forall t t' x G, bind G x t -> bind (t' :: G) (S x) t. (* Generate variables of a specific type in an env. *) Derive ArbitrarySizedSuchThat for (fun x => bind G x t). (* Get the type of a given variable in an env. *) Derive EnumSizedSuchThat for (fun t => bind G x t). (* Check whether a variable has a given type in an env. *) Derive DecOpt for (bind G e t). (* Typing *) Inductive typing (G : env) : term -> type -> Prop := | TId : forall x t, bind G x t -> typing G (Id x) t | TConst : forall n, typing G (Const n) N | TAbs : forall e t1 t2, typing (t1 :: G) e t2 -> typing G (Abs t1 e) (Arrow t1 t2) | TApp : forall e1 e2 t1 t2, typing G e2 t1 -> typing G e1 (Arrow t1 t2) -> typing G (App e1 e2) t2. Fixpoint typeOf G e : option type := match e with | Id x => nth_error G x | Const n => Some N | Abs t e' => match typeOf (t::G) e' with | Some t' => Some (Arrow t t') | None => None end | App e1 e2 => match typeOf G e1, typeOf G e2 with | Some (Arrow t1 t2), Some t1' => if t1 = t1'? then Some t2 else None | _, _ => None end end. (* Generate terms of a specific type in an env. *) Derive ArbitrarySizedSuchThat for (fun e => typing G e t). Derive EnumSizedSuchThat for (fun t => typing G e t). (* Check whether a variable has a given type in an env. *) Derive DecOpt for (typing G e t). (* Small step CBV semantics *) Inductive value : term -> Prop := | VConst : forall n, value (Const n) | VAbs : forall t e, value (Abs t e). Derive DecOpt for (value e). Definition is_value (e : term) : bool := match e with | Const _ | Abs _ _ => true | _ => false end. Fixpoint subst (y : var) (e1 : term) (e2 : term) : term := match e2 with | Const n => Const n | Id x => if eq_nat_dec x y then e1 else e2 | App e e' => App (subst y e1 e) (subst y e1 e') | Abs t e => Abs t (subst (S y) e1 e) end. Fixpoint step (e : term) : option term := match e with | Const _ | Id _ => None | Abs _ x => None | App (Abs t e1) e2 => if is_value e2 then Some (subst 0 e2 e1) else match step e2 with | Some e2' => Some (App (Abs t e1) e2') | None => None end | App e1 e2 => match step e1 with | Some e1' => Some (App e1' e2) | None => None end end. Eval compute in (step (App (Abs N (Id 0)) (Const 42))). Eval compute in (step (App (Abs N (Abs N (Id 0))) (Const 42))). Eval compute in (subst 0 (Const 42) (Abs N (Id 0))). (* Printing *) Open Scope string. Fixpoint show_type (tau : type) := match tau with | N => "N" | Arrow tau1 tau2 => "(Arrow " ++ show_type tau1 ++ " -> " ++ show_type tau2 ++ ")" end. Instance showType : Show type := { show := show_type }. Fixpoint show_term (e : term) := match e with | Const n => "(Const " ++ show n ++ ")" | Id x => "(Id " ++ show x ++ ")" | App e1 e2 => "(App " ++ show_term e1 ++ " " ++ show_term e2 ++ ")" | Abs t e => "(Abs " ++ show t ++ " " ++ show_term e ++ ")" end. Close Scope string. Instance showTerm : Show term := { show := show_term }. Instance dec_eq_opt_type : Dec_Eq (option type). Proof. dec_eq. Defined. Definition preservation (e : term) (t: type) : Checker := match step e with | Some e' => checker ((typeOf nil e' = Some t)?) | None => checker true end. Definition preservation' (e : term) (t: type) : Checker := match step e with | Some e' => typing nil e' t ?? 10 | None => checker true end. Definition preservation_prop (c : term -> type -> Checker) := forAll (@arbitrary type _) (fun t => forAllMaybe ((genST (fun e => typing nil e t))) (fun e => c e t)). Extract Constant defNumTests => "20000". QuickChick (preservation_prop preservation). QuickChick (preservation_prop preservation'). QuickChick-2.1.0/examples/dune000066400000000000000000000004331476030541200162260ustar00rootroot00000000000000(alias (name runtest) (deps (alias_rec all))) (cram (deps (package coq-quickchick)) ; These cram tests require a global installation of QuickChick ; available to the quickChick tool or to coqc, so we don't run them by default. (runtest_alias false) (alias cram)) QuickChick-2.1.0/examples/ifc-basic/000077500000000000000000000000001476030541200171705ustar00rootroot00000000000000QuickChick-2.1.0/examples/ifc-basic/DerivedGen.v000066400000000000000000000214261476030541200214000ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import ZArith. Require Import List. Import ListNotations. From QuickChick.ifcbasic Require Import Machine Printing Generation. Set Bullet Behavior "Strict Subproofs". Local Open Scope nat. (* Overriding default instance to generate "in-bounds" things *) (* Definition gen_Z := choose (0,1). *) Inductive good_Z : Z -> Prop := | GoodZ0 : good_Z 0 | GoodZ1 : good_Z 1. Derive ArbitrarySizedSuchThat for (fun z => good_Z z). (* Definition gen_label := elements L [L; H]. *) Derive Arbitrary for Label. (* Definition gen_atom := liftGen2 Atm gen_Z gen_label. *) Inductive good_atom : Atom -> Prop := | GoodAtom : forall z l, good_Z z -> good_atom (Atm z l). Derive ArbitrarySizedSuchThat for (fun a => good_atom a). (* Definition gen_memory := vectorOf 2 gen_atom. *) Inductive good_mem : Mem -> Prop := | GoodMem : forall a1 a2, good_atom a1 -> good_atom a2 -> good_mem [a1 ; a2]. Derive ArbitrarySizedSuchThat for (fun m => good_mem m). Definition is_atom_low (a : Atom) := match a with | _ @ L => true | _ => false end. (* Fixpoint gen_stack (n : nat) (onlyLow : bool) : G Stack := (* There is no invariant that says this. Why is this here? *) (* let gen_atom := if onlyLow then liftGen2 Atm gen_Z (returnGen L) else gen_atom in *) match n with | O => returnGen Mty | S n' => frequency (returnGen Mty) [ (10, liftGen2 Cons gen_atom (gen_stack n' onlyLow)); (4, bindGen gen_atom (fun pc => liftGen (RetCons pc) (gen_stack n' (is_atom_low pc))))] end. *) (* I could write this without the nat to exploit the default size! *) Inductive good_stack : nat -> Stack -> Prop := | GoodStackMty : good_stack 0 Mty | GoodStackCons : forall n a s , good_atom a -> good_stack n s -> good_stack (S n) (a :: s) | GoodStackRet : forall n pc s, good_atom pc -> good_stack n s -> good_stack (S n) (RetCons pc s). QuickChickWeights [(GoodStackCons, 10); (GoodStackRet, 4)]. Derive ArbitrarySizedSuchThat for (fun s => good_stack n s). (* Definition ainstr (st : State) : G Instruction := let '(St im m stk pc ) := st in let fix stack_length s := match s with | _ :: s' => 1 + stack_length s' | _ => 0 end in let sl := stack_length stk in let fix containsRet s := match s with | _ ::: _ => true | _ :: s' => containsRet s' | _ => false end in let onLength len x := if leb x len then x else 0 in frequency (returnGen Nop) [ (1, returnGen Nop); (10, liftGen Push gen_Z); (10, liftGen BCall (if beq_nat sl 0 then returnGen 0 else choose (0, Z.of_nat sl-1))%Z); (if containsRet stk then 10 else 0, returnGen BRet); (10, returnGen Add); (10, returnGen Load); (100, returnGen Store)]. *) Inductive contains_ret : Stack -> Prop := | RetHere : forall pc s, contains_ret (RetCons pc s) | RetLater : forall a s, contains_ret s -> contains_ret (a :: s). #[global] Instance dec_contains_ret (s : Stack) : Dec (contains_ret s). Proof. dec_eq. induction s. - right => H; inversion H. - destruct IHs. + left; constructor; auto. + right => H; inversion H; eauto. - left; constructor; auto. Defined. Inductive stack_length : Stack -> nat -> Prop := | LenMty : stack_length Mty 0 | LenRet : forall pc s, stack_length (pc :: s) 0 | LenCons : forall a s n, stack_length s n -> stack_length (a :: s) (S n). Derive ArbitrarySizedSuchThat for (fun n => stack_length s n). Inductive between (x y : Z) (z : nat) : Prop := | Bet : (x < y -> y < Z.of_nat z -> between x y z)%Z. #[global] Instance genST_bet x z : GenSizedSuchThat Z (fun y => between x y z) := {| arbitrarySizeST n := liftGen Some (choose (x, Z.of_nat z)) |}. Inductive good_instr (stk : Stack) : Instruction -> Prop := | GoodNop : good_instr stk Nop | GoodPush : forall z, good_Z z -> good_instr stk (Push z) | GoodCall : forall z n, stack_length stk n -> between 0 z n -> good_instr stk (BCall z) | GoodRet : contains_ret stk -> good_instr stk BRet | GoodAdd : good_instr stk Add | GoodLoad : good_instr stk Load | GoodStore : good_instr stk Store. QuickChickWeights [ (GoodNop, 1) ; (GoodPush, 10) ; (GoodCall, 10) ; (GoodRet, 10) ; (GoodAdd, 10) ; (GoodLoad, 10) ; (GoodStore, 100) ]. Derive ArbitrarySizedSuchThat for (fun i => good_instr stk i). (* Definition gen_state : G State := let imem0 := [Nop; Nop] in bindGen gen_atom (fun pc => bindGen gen_memory (fun mem => bindGen (gen_stack 4 (is_atom_low pc)) (fun stk => bindGen (ainstr (St imem0 mem stk pc)) (fun i => returnGen (St [i;i] mem stk pc))))). *) Inductive good_state : State -> Prop := | GoodState : forall i m stk pc, good_atom pc -> good_mem m -> good_stack 4 stk -> good_instr stk i -> good_state (St [i;i] m stk pc). Derive ArbitrarySizedSuchThat for (fun st => good_state st). (* Sample (@arbitrarySizeST _ (fun st => good_state st) _ 10).*) (* Class Vary (A : Type) := { vary : A -> G A }. *) (* Instance vary_atom : Vary Atom := {| vary a := let '(x @ l) := a in match l with | L => returnGen a | H => liftGen2 Atm gen_Z (returnGen H) end |}. *) Inductive variation_atom : Atom -> Atom -> Prop := | VaryAtomL : forall x , variation_atom (x @ L) (x @ L) | VaryAtomH : forall x y, good_Z y -> variation_atom (x @ H) (y @ H). Derive ArbitrarySizedSuchThat for (fun y => variation_atom x y). (* Instance vary_mem : Vary Mem := {| vary m := sequenceGen (map vary m) |}. *) Inductive variation_mem : Mem -> Mem -> Prop := | VaryMemNil : variation_mem [] [] | VaryMemCons : forall a a' m m', variation_atom a a' -> variation_mem m m' -> variation_mem (cons a m) (cons a' m'). Derive ArbitrarySizedSuchThat for (fun m2 => variation_mem m1 m2). (* Fixpoint vary_stack (s : Stack) (isLow : bool) : G Stack := match s with | a :: s' => if isLow then liftGen2 Cons (vary a) (vary_stack s' isLow) else liftGen2 Cons gen_atom (vary_stack s' isLow) | (x@l) ::: s' => match l with | L => liftGen (RetCons (x@l)) (vary_stack s' true) | H => liftGen2 RetCons (vary (x@l)) (vary_stack s' false) end | Mty => returnGen Mty end. *) Inductive variation_stack : Stack -> Stack -> Prop := | VaryStkMty : variation_stack Mty Mty | VaryStkCons : forall a a' s s', variation_atom a a' -> variation_stack s s' -> variation_stack (a :: s) (a' :: s') | VaryStkRet : forall a a' s s', variation_atom a a' -> variation_stack s s' -> variation_stack (RetCons a s) (RetCons a' s'). Derive ArbitrarySizedSuchThat for (fun s2 => variation_stack s1 s2). (* Instance vary_state : Vary State := {| vary st := let '(St imem mem stk pc) := st in bindGen (vary mem) (fun mem' => bindGen (vary pc) (fun pc' => let isLow := match pc with | _ @ L => true | _ @ H => false end in if isLow then bindGen (vary_stack stk isLow) (fun stk' => returnGen (St imem mem' stk' pc')) else bindGen (vary_stack stk isLow) (fun stk' => bindGen gen_atom (fun extra_elem => returnGen (St imem mem' (extra_elem :: stk') pc'))))) |}. *) Inductive variation_high_stack : Atom -> Stack -> Stack -> Prop := | VaryStkAny : forall pc stk stk', variation_stack stk stk' -> variation_high_stack pc stk stk' | VarystkHigh : forall pcx stk stk' a, variation_stack stk stk' -> good_atom a -> variation_high_stack (pcx @ H) stk (a :: stk'). Derive ArbitrarySizedSuchThat for (fun stk' => variation_high_stack pc stk stk'). Inductive variation_state : State -> State -> Prop := | VaryState : forall imem mem stk pc mem' stk' pc', variation_mem mem mem' -> variation_atom pc pc' -> variation_high_stack pc stk stk' -> variation_state (St imem mem stk pc) (St imem mem' stk' pc'). Derive ArbitrarySizedSuchThat for (fun st' => variation_state st st'). Definition gen_variation_state_derived : G (option (@Variation State)) := bindOpt (genST (fun st => good_state st)) (fun st => bindOpt (genST (fun st' => variation_state st st')) (fun st' => returnGen (Some (V st st')))). (* bindGen gen_state (fun st => bindGen (vary st) (fun st' => returnGen (V st st'))). *) QuickChick-2.1.0/examples/ifc-basic/Driver.v000066400000000000000000000202511476030541200206120ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import List. Import ListNotations. From QuickChick.ifcbasic Require Import Machine Printing Generation Indist DerivedGen. From QuickChick.ifcbasic Require GenExec. Require Import Coq.Strings.String. Local Open Scope string. Definition SSNI (t : table) (v : @Variation State) : Checker := let '(V st1 st2) := v in let '(St _ _ _ (_@l1)) := st1 in let '(St _ _ _ (_@l2)) := st2 in match lookupInstr st1 with | Some i => collect (show i) ( if indist st1 st2 then match l1, l2 with | L,L => match exec t st1, exec t st2 with | Some st1', Some st2' => (* whenFail ("Initial states: " ++ nl ++ show_pair st1 st2 ++ nl ++ "Final states: " ++ nl ++ show_pair st1' st2' ++nl) *) (* collect ("L -> L")*) (checker (indist st1' st2')) | _, _ => (* collect "L,L,FAIL" true *) checker rejected end | H, H => match exec t st1, exec t st2 with | Some st1', Some st2' => if is_atom_low (st_pc st1') && is_atom_low (st_pc st2') then (* whenFail ("Initial states: " ++ nl ++ show_pair st1 st2 ++ nl ++ "Final states: " ++ nl ++ show_pair st1' st2' ++nl) *) (* collect ("H -> L")*) (checker (indist st1' st2') ) else if is_atom_low (st_pc st1') then (* whenFail ("States: " ++ nl ++ show_pair st2 st2' ++ nl )*) (* collect ("H -> H")*) (checker (indist st2 st2')) else (* whenFail ("States: " ++ nl ++ show_pair st1 st1' ++ nl )*) (* collect ("H -> H")*) (checker (indist st1 st1')) | _, _ => checker rejected end | H,_ => match exec t st1 with | Some st1' => (* whenFail ("States: " ++ nl ++ show_pair st1 st1' ++ nl )*) (* collect "H -> H"*) (checker (indist st1 st1')) | _ => (*collect "H,_,FAIL" true *) checker rejected end | _,H => match exec t st2 with | Some st2' => (* whenFail ("States: " ++ nl ++ show_pair st2 st2' ++ nl )*) (* collect "H -> H"*) (checker (indist st2 st2')) | _ => (*collect "L,H,FAIL" true *) checker rejected end end else (* collect "Not indist!" true*) checker rejected ) | _ => checker rejected end. Definition prop_SSNI t : Checker := forAllShrink gen_variation_state (fun _ => nil) (SSNI t : Variation -> G QProp). Definition prop_SSNI_derived t : Checker := forAllShrink gen_variation_state_derived (fun _ => nil) (fun mv => match mv with | Some v => SSNI t v | _ => checker tt end). Definition prop_gen_indist := forAllShrink gen_variation_state (fun _ => nil) (fun v => let '(V st1 st2) := v in indist st1 st2). Definition prop_gen_indist_derived := forAllShrink (gen_variation_state_derived) (fun _ => nil) (fun mv => match mv with | Some (V st1 st2) => indist st1 st2 | _ => true end). Extract Constant defNumDiscards => "30000". QuickCheck (prop_SSNI default_table). QuickCheck (prop_SSNI_derived default_table). Axiom numTests : nat. Extract Constant numTests => "10000". Fixpoint MSNI (fuel : nat) (t : table) (v : @Variation State) : Checker := let '(V st1 st2) := v in let '(St _ _ _ (_@l1)) := st1 in let '(St _ _ _ (_@l2)) := st2 in match fuel with | O => checker true | S fuel' => match lookupInstr st1 with | Some i => collect (show i) ( if indist st1 st2 then match l1, l2 with | L,L => match exec t st1, exec t st2 with | Some st1', Some st2' => (* whenFail ("Initial states: " ++ nl ++ show_pair st1 st2 ++ nl ++ "Final states: " ++ nl ++ show_pair st1' st2' ++nl) *) (* collect ("L -> L")*) if indist st1' st2' then MSNI fuel' t (V st1' st2') else checker false | _, _ => (* collect "L,L,FAIL" true *) checker true end | H, H => match exec t st1, exec t st2 with | Some st1', Some st2' => if is_atom_low (st_pc st1') && is_atom_low (st_pc st2') then (* whenFail ("Initial states: " ++ nl ++ show_pair st1 st2 ++ nl ++ "Final states: " ++ nl ++ show_pair st1' st2' ++nl) *) (* collect ("H -> L")*) if indist st1' st2' then MSNI fuel' t (V st1' st2') else checker false else if is_atom_low (st_pc st1') then (* whenFail ("States: " ++ nl ++ show_pair st2 st2' ++ nl )*) (* collect ("H -> H")*) if indist st2 st2' then (* Ensure still a variation by not executing st1 *) MSNI fuel' t (V st1 st2') else checker false else if indist st1 st1' then MSNI fuel' t (V st1' st2) else checker false (* whenFail ("States: " ++ nl ++ show_pair st1 st1' ++ nl )*) (* collect ("H -> H")*) | _, _ => checker true end | H,_ => match exec t st1 with | Some st1' => if indist st1 st1' then MSNI fuel' t (V st1' st2) else checker false | _ => (*collect "H,_,FAIL" true *) checker true end | _,H => match exec t st2 with | Some st2' => if indist st2 st2' then MSNI fuel' t (V st1 st2') else checker false | _ => (*collect "L,H,FAIL" true *) checker true end end else checker rejected (* whenFail ("Indist with states: " ++ nl ++ show_pair st1 st2 ++ nl ++ " after steps: " ++ show fuel ++ nl) (checker false) *) ) | _ => checker rejected end end. Definition prop_MSNI t : Checker := forAllShrink GenExec.gen_variation_state' (fun _ => nil) (MSNI 20 t : Variation -> G QProp). QuickCheck (prop_MSNI default_table). (* QuickCheck (prop_SSNI_derived default_table).*) (* Definition prop_SSNI_derived t : Checker := forAllShrink gen_variation_state_derived (fun _ => nil) (fun mv => match mv with | Some v => SSNI t v | _ => checker tt end). *) Definition myArgs : Args := let '(MkArgs rp mSuc md mSh mSz c a) := stdArgs in MkArgs rp numTests md mSh mSz c a. From QuickChick Require Import Mutate MutateCheck. #[global] Instance mutateable_table : Mutateable table := {| mutate := mutate_table |}. Require Import ZArith. Definition testMutantX n := match nth (mutate_table default_table) n with | Some t => prop_SSNI t | _ => checker tt end. MutateCheckWith myArgs default_table (fun t => (forAllShrinkShow gen_variation_state (fun _ => nil) (fun _ => "") (SSNI t ))). MutateCheckWith myArgs default_table (fun t => (forAllShrinkShow GenExec.gen_variation_state' (fun _ => nil) (fun _ => "") (MSNI 20 t ))). MutateCheckWith myArgs default_table (fun t => (forAllShrinkShow (gen_variation_state_derived) (fun _ => nil) (fun _ => "") (fun mv => match mv with | Some v => SSNI t v | None => checker tt end ))). (* Eval lazy -[labelCount helper] in nth (mutate_table default_table) 2. *) (* Definition st1 := St [Store; Store] [0 @ L] (0 @ L :: 0 @ H :: Mty) (0 @ L). Definition st2 := St [Store; Store] [0 @ L] (0 @ L :: 1 @ H :: Mty) (0 @ L). Definition ex_indist : indist st1 st2 = true. auto. Qed. Definition st1' := St [Add; Add] [0 @ L] (0 @ L :: 0 @ H :: Mty) (0 @ L). Definition st2' := St [Add; Add] [0 @ L] (0 @ L :: 1 @ H :: Mty) (0 @ L). Definition ex_indist' : indist st1' st2' = true. auto. Qed. Definition ex_test := match nth (mutate_table default_table) 8 with | Some t => SSNI t (V st1' st2') | _ => checker tt end. Eval compute in exec default_table st1'. QuickCheck ex_test. QuickCheck (testMutantX 18). *) QuickChick-2.1.0/examples/ifc-basic/GenExec.v000066400000000000000000000107161476030541200207020ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import ZArith. Require Import List. Import ListNotations. From QuickChick.ifcbasic Require Import Machine. (* Overriding default instance to generate "in-bounds" things *) Definition mem_length : Z := 10. Definition gen_Z := choose (0,mem_length). Definition gen_label := elements L [L; H]. Definition gen_atom := liftGen2 Atm gen_Z gen_label. Definition gen_memory := vectorOf 10 gen_atom. Definition is_atom_low (a : Atom) := match a with | _ @ L => true | _ => false end. Local Open Scope nat. Definition ainstr (st : State) : G Instruction := let '(St im m stk pc ) := st in let fix stack_length s := match s with | _ :: s' => 1 + stack_length s' | _ => 0 end in let sl := stack_length stk in let fix containsRet s := match s with | _ ::: _ => true | _ :: s' => containsRet s' | _ => false end in let onLength len x := if leb x len then x else 0 in freq_ (returnGen Nop) [ (1, returnGen Nop); (10, liftGen Push gen_Z); (if sl < 1 ? then 0 else 10, liftGen BCall (if Nat.eqb sl 0 then returnGen 0 else choose (0, Z.of_nat sl-1))%Z); (if containsRet stk then 10 else 0, returnGen BRet); (if sl < 2 ? then 0 else 10, returnGen Add); (if sl < 1 ? then 0 else 10, returnGen Load); (if sl < 2 ? then 0 else 100, returnGen Store)]. Fixpoint gen_stack (n : nat) (onlyLow : bool) : G Stack := (* let gen_atom := if onlyLow then liftGen2 Atm gen_Z (returnGen L) else gen_atom in *) match n with | O => returnGen Mty | S n' => freq_ (returnGen Mty) [ (10, liftGen2 Cons gen_atom (gen_stack n' onlyLow)); (4, bindGen gen_atom (fun pc => liftGen (RetCons pc) (gen_stack n' (is_atom_low pc))))] end. Fixpoint gen_by_exec (t : table) (fuel : nat) (st : State) := let '(St im m stk (Atm addr pcl)) := st in match fuel with | O => returnGen st | S fuel' => match nth im addr with | Some Nop => (* If it is a noop, generate *) bindGen (ainstr st) (fun i => match upd im addr i with | Some im' => let st' := St im' m stk (Atm addr pcl) in gen_by_exec t fuel' st' | None => returnGen st end) | Some _ => (* Existing instruction, execute *) match exec t st with | Some st' => gen_by_exec t fuel' st' | None => returnGen st end | None => (* Out of bounds, terminate *) returnGen st end end. Require Import ExtLib.Structures.Monads. Import MonadNotation. Open Scope monad_scope. Definition gen_state : G State := let imem0 := replicate 10 Nop in pc <- gen_atom ;; mem <- gen_memory ;; stk <- gen_stack 10 (is_atom_low pc) ;; st' <- gen_by_exec default_table 20 (St imem0 mem stk pc) ;; ret st'. From QuickChick.ifcbasic Require Import Generation. #[global] Instance vary_atom' : Vary Atom := {| vary a := let '(x @ l) := a in match l with | L => returnGen a | H => liftGen2 Atm gen_Z (returnGen H) end |}. #[global] Instance vary_mem' : Vary Mem := {| vary m := sequenceGen (map vary m) |}. Fixpoint vary_stack (s : Stack) (isLow : bool) : G Stack := match s with | a :: s' => if isLow then liftGen2 Cons (vary a) (vary_stack s' isLow) else liftGen2 Cons gen_atom (vary_stack s' isLow) | (x@l) ::: s' => match l with | L => liftGen (RetCons (x@l)) (vary_stack s' true) | H => liftGen2 RetCons (vary (x@l)) (vary_stack s' false) end | Mty => returnGen Mty end. Import QcDefaultNotation. #[global] Instance vary_state' : Vary State := {| vary st := let '(St imem mem stk pc) := st in mem' <- vary mem ;; pc' <- vary pc ;; let isLow := match pc with | _ @ L => true | _ @ H => false end in if isLow then stk' <- vary_stack stk isLow ;; ret (St imem mem' stk' pc') else stk' <- vary_stack stk isLow ;; bindGen (@arbitrary bool _) (fun b : bool => if b then extra_elem <- gen_atom ;; ret (St imem mem' (extra_elem :: stk') pc') else ret (St imem mem' stk' pc')) |}. Definition gen_variation_state' : G (@Variation State) := bindGen gen_state (fun st => bindGen (vary st) (fun st' => returnGen (V st st'))). QuickChick-2.1.0/examples/ifc-basic/Generation.v000066400000000000000000000076641476030541200214670ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import ZArith. Require Import List. Import ListNotations. From QuickChick.ifcbasic Require Import Machine. (* Overriding default instance to generate "in-bounds" things *) Definition gen_Z := choose (0,1). Definition gen_label := elems_ L [L; H]. Definition gen_atom := liftGen2 Atm gen_Z gen_label. Definition gen_memory := vectorOf 2 gen_atom. Definition is_atom_low (a : Atom) := match a with | _ @ L => true | _ => false end. Local Open Scope nat. Definition ainstr (st : State) : G Instruction := let '(St im m stk pc ) := st in let fix stack_length s := match s with | _ :: s' => 1 + stack_length s' | _ => 0 end in let sl := stack_length stk in let fix containsRet s := match s with | _ ::: _ => true | _ :: s' => containsRet s' | _ => false end in let onLength len x := if leb x len then x else 0 in freq_ (returnGen Nop) [ (1, returnGen Nop); (10, liftGen Push gen_Z); (10, liftGen BCall (if Nat.eqb sl 0 then returnGen 0 else choose (0, Z.of_nat sl-1))%Z); (if containsRet stk then 10 else 0, returnGen BRet); (10, returnGen Add); (10, returnGen Load); (100, returnGen Store)]. (* (onLength 1 10, liftGen BCall (chooseZ (0, (Z.of_nat sl-1))%Z)); (if containsRet stk then 10 else 0, returnGen BRet); (onLength 2 10, returnGen Add); (onLength 1 10, returnGen Load); (onLength 2 10, returnGen Store)]. *) Fixpoint gen_stack (n : nat) (onlyLow : bool) : G Stack := (* There is no invariant that says this. Why is this here? *) (* let gen_atom' := if onlyLow then liftGen2 Atm gen_Z (returnGen L) else gen_atom in *) match n with | O => returnGen Mty | S n' => freq_ (returnGen Mty) [ (10, liftGen2 Cons gen_atom (gen_stack n' onlyLow)); (4, bindGen gen_atom (fun pc => liftGen (RetCons pc) (gen_stack n' (is_atom_low pc))))] end. Definition gen_state : G State := let imem0 := [Nop; Nop] in bindGen gen_atom (fun pc => bindGen gen_memory (fun mem => bindGen (gen_stack 4 (is_atom_low pc)) (fun stk => bindGen (ainstr (St imem0 mem stk pc)) (fun i => returnGen (St [i;i] mem stk pc))))). (* State Variations *) Inductive Variation {A : Type} := V : A -> A -> @Variation A. Class Vary (A : Type) := { vary : A -> G A }. #[global] Instance vary_atom : Vary Atom := {| vary a := let '(x @ l) := a in match l with | L => returnGen a | H => liftGen2 Atm gen_Z (returnGen H) end |}. #[global] Instance vary_mem : Vary Mem := {| vary m := sequenceGen (map vary m) |}. Fixpoint vary_stack (s : Stack) (isLow : bool) : G Stack := match s with | a :: s' => if isLow then liftGen2 Cons (vary a) (vary_stack s' isLow) else liftGen2 Cons gen_atom (vary_stack s' isLow) | (x@l) ::: s' => match l with | L => liftGen (RetCons (x@l)) (vary_stack s' true) | H => liftGen2 RetCons (vary (x@l)) (vary_stack s' false) end | Mty => returnGen Mty end. #[global] Instance vary_state : Vary State := {| vary st := let '(St imem mem stk pc) := st in bindGen (vary mem) (fun mem' => bindGen (vary pc) (fun pc' => let isLow := match pc with | _ @ L => true | _ @ H => false end in if isLow then bindGen (vary_stack stk isLow) (fun stk' => returnGen (St imem mem' stk' pc')) else bindGen (vary_stack stk isLow) (fun stk' => bindGen gen_atom (fun extra_elem => returnGen (St imem mem' (extra_elem :: stk') pc'))))) |}. Definition gen_variation_state : G (@Variation State) := bindGen gen_state (fun st => bindGen (vary st) (fun st' => returnGen (V st st'))). QuickChick-2.1.0/examples/ifc-basic/Indist.v000066400000000000000000000063651476030541200206230ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import ZArith. Require Import List. From QuickChick.ifcbasic Require Import Machine. (* Manual, handwritten indist instances *) Fixpoint forallb2 {A : Type} (f : A -> A -> bool) (l1 l2 :list A) : bool := match l1, l2 with | nil, nil => true | cons h1 t1, cons h2 t2 => f h1 h2 && forallb2 f t1 t2 | _, _ => false end. (* Indistinguishability type class *) Class Indist (A : Type) : Type := { indist : A -> A -> bool }. #[global] Instance indist_atom : Indist Atom := {| indist a1 a2 := let '(x1@l1) := a1 in let '(x2@l2) := a2 in match l1, l2 with | L, L => Z.eqb x1 x2 | H, H => true | _, _ => false end |}. #[global] Instance indist_mem : Indist Mem := {| indist m1 m2 := forallb2 indist m1 m2 |}. Fixpoint cropTop (s:Stack) : Stack := match s with | Mty => Mty | x::s' => cropTop s' | (x@H:::s') => cropTop s' | (_@L:::_) => s end. (* Assumes stacks have been cropTopped! *) #[global] Instance indist_stack : Indist Stack := {| indist s1 s2 := let fix aux s1 s2 := match s1, s2 with | a1::s1', a2::s2' => indist a1 a2 && aux s1' s2' | a1:::s1', a2:::s2' => indist a1 a2 && aux s1' s2' | Mty, Mty => true | _, _ => false end in aux s1 s2 |}. #[global] Instance indist_state : Indist State := {| indist st1 st2 := let '(St imem1 mem1 stk1 pc1) := st1 in let '(St imem2 mem2 stk2 pc2) := st2 in if negb (indist mem1 mem2) then (* trace "Memory" *) false else if negb (indist pc1 pc2) then (* trace "PC" *) false else let (stk1',stk2') := match pc1 with | _ @ H => (cropTop stk1, cropTop stk2) | _ => (stk1, stk2) end in if negb (indist stk1' stk2') then (* trace "Stack" *) false else true |}. (* Inductive versions *) Inductive IndistAtom : Atom -> Atom -> Prop := | IAtom_Lo : forall x, IndistAtom (x@L) (x@L) | IAtom_Hi : forall x y, IndistAtom (x@H) (y@H). Derive DecOpt for (IndistAtom a1 a2). Inductive IndistMem : Mem -> Mem -> Prop := | IMem_Nil : IndistMem nil nil | IMem_Cons : forall a1 a2 m1 m2, IndistAtom a1 a2 -> IndistMem m1 m2 -> IndistMem (cons a1 m1) (cons a2 m2). Derive DecOpt for (IndistMem m1 m2). Inductive IndistStack : Stack -> Stack -> Prop := | IStack_Mty : IndistStack Mty Mty | IStack_Cons : forall a1 a2 s1 s2, IndistAtom a1 a2 -> IndistStack s1 s2 -> IndistStack (Cons a1 s1) (Cons a2 s2) | IStack_RetCons : forall a1 a2 s1 s2, IndistAtom a1 a2 -> IndistStack s1 s2 -> IndistStack (RetCons a1 s1) (RetCons a2 s2). Derive DecOpt for (IndistStack s1 s2). #[global] Instance Label_DecEq (l1 l2 : Label) : Dec (l1 = l2). Proof. dec_eq. Defined. Inductive IndistState : State -> State -> Prop := | IState_Low : forall im1 im2 m1 m2 s1 s2 pc1 pc2, IndistAtom pc1 pc2 -> IndistMem m1 m2 -> pc_lab pc1 = L -> IndistStack s1 s2 -> IndistState (St im1 m1 s1 pc1) (St im2 m2 s2 pc2) | IState_High : forall im1 im2 m1 m2 s1 s2 pc1 pc2, IndistAtom pc1 pc2 -> IndistMem m1 m2 -> pc_lab pc1 = H -> IndistStack (cropTop s1) (cropTop s2) -> IndistState (St im1 m1 s1 pc1) (St im2 m2 s2 pc2). Derive DecOpt for (IndistState s1 s2). QuickChick-2.1.0/examples/ifc-basic/Instructions.v000066400000000000000000000014001476030541200220560ustar00rootroot00000000000000Require Import ZArith. Require Import List. Import ListNotations. Inductive Instruction : Type := | Nop | Push (n : Z) | BCall (n : Z) (* How many things to pass as arguments *) | BRet | Add | Load | Store. Inductive OpCode : Type := | OpBCall | OpBRet | OpNop | OpPush | OpAdd | OpLoad | OpStore. Definition opCodes := [ OpBCall; OpBRet; OpNop; OpPush; OpAdd; OpLoad; OpStore]. Definition opCode_eq_dec : forall o1 o2 : OpCode, {o1 = o2} + {o1 <> o2}. Proof. decide equality. Defined. Definition opcode_of_instr (i : Instruction) : OpCode := match i with | BCall _ => OpBCall | BRet => OpBRet | Push _ => OpPush | Nop => OpNop | Add => OpAdd | Load => OpLoad | Store => OpStore end. QuickChick-2.1.0/examples/ifc-basic/Machine.v000066400000000000000000000145231476030541200207300ustar00rootroot00000000000000Require Import ZArith. Require Import List. Import ListNotations. Require Import MSetPositive. From QuickChick.ifcbasic Require Export Rules Instructions. Open Scope Z_scope. Open Scope bool_scope. (** * Basic List manipulation *) (* [nth l n] returns the [n]th element of [l] if [0 <= n < Zlength l] *) Definition nth {A:Type} (l:list A) (n:Z) : option A := if Z_lt_dec n 0 then None else nth_error l (Z.to_nat n). (* [upd_nat l n a] returns a list [l'] that is pointwise equal to [l], except the [n]th element that is now [a]. Only suceeds if [n < length l] *) Fixpoint upd_nat {A:Type} (l:list A) (n:nat) (a:A) : option (list A) := match l with | nil => None | x::q => match n with | O => Some (a::q) | S p => match upd_nat q p a with | None => None | Some q' => Some (x::q') end end end. (* [upd l n a] returns a list [l'] that is pointwise equal to [l], except the [n]th element that is now [a]. Only suceeds if [0 <= n < Zlength l] *) Definition upd {A:Type} (l:list A) (n:Z) (a:A) : option (list A) := if Z_lt_dec n 0 then None else upd_nat l (Z.to_nat n) a. Fixpoint replicate {A:Type} (n:nat) (a:A) : list A := match n with | O => nil | S n' => a :: replicate n' a end. Definition zreplicate {A:Type} (n:Z) (a:A) : option (list A) := if Z_lt_dec n 0 then None else Some (replicate (Z.to_nat n) a). (** * Machine definition *) Inductive Atom : Type := Atm (x:Z) (l:Label). Infix "@" := Atm (no associativity, at level 50). Definition pc_lab (pc : Atom) : Label := let (_,l) := pc in l. Notation "'∂' pc" := (pc_lab pc) (at level 0). Inductive Stack := | Mty (* empty stack *) | Cons (a:Atom) (s:Stack) (* stack atom cons *) | RetCons (pc:Atom) (s:Stack) (* stack frame marker cons *) . Infix "::" := Cons (at level 60, right associativity). Infix ":::" := RetCons (at level 60, right associativity). Fixpoint app_stack (l:list Atom) (s:Stack) : Stack := match l with | nil => s | cons a q => a::(app_stack q s) end. Infix "$" := app_stack (at level 60, right associativity). Definition IMem := list Instruction. Definition Mem := list Atom. Record State := St { st_imem : IMem ; (* instruction memory *) st_mem : Mem ; (* memory *) st_stack : Stack; (* operand stack *) st_pc : Atom (* program counter *) }. Definition labelCount (c:OpCode) : nat := match c with | OpBCall => 1 | OpBRet => 2 | OpNop => 0 | OpPush => 0 | OpAdd => 2 | OpLoad => 2 | OpStore => 3 end%nat. Definition table := forall op, AllowModify (labelCount op). Definition default_table : table := fun op => match op with | OpBCall => ≪ TRUE , LabPC , JOIN Lab1 LabPC≫ | OpBRet => ≪ TRUE , JOIN Lab2 LabPC , Lab1 ≫ | OpNop => ≪ TRUE , __ , LabPC ≫ | OpPush => ≪ TRUE , BOT , LabPC ≫ | OpAdd => ≪ TRUE , JOIN Lab1 Lab2, LabPC ≫ | OpLoad => ≪ TRUE , JOIN Lab1 Lab2 , LabPC ≫ | OpStore => ≪ LE (JOIN Lab1 LabPC) Lab3, JOIN LabPC (JOIN Lab1 Lab2) , LabPC ≫ end. Definition run_tmr (t : table) (op: OpCode) (labs:Vector.t Label (labelCount op)) (pc: Label) : option (option Label * Label) := let r := t op in apply_rule r labs pc. Definition bind (A B:Type) (f:A->option B) (a:option A) : option B := match a with | None => None | Some a => f a end. Notation "'do' X <- A ; B" := (bind _ _ (fun X => B) A) (at level 200, X ident, A at level 100, B at level 200). Notation "'do' X : T <- A ; B" := (bind _ _ (fun X : T => B) A) (at level 200, X ident, A at level 100, B at level 200). Fixpoint insert_nat (s:Stack) (n:nat) (a:Atom) : option Stack := match n,s with | O, _ => Some (a:::s) | S n', x :: xs => do s' <- insert_nat xs n' a; Some (x :: s') | _, _ => None end. Fixpoint findRet (s:Stack) : option (Atom * Stack) := match s with | x ::: s' => Some (x,s') | x :: s' => findRet s' | Mty => None end. Definition insert (s:Stack) (n:Z) (a:Atom) : option Stack := if Z_lt_dec n 0 then None else insert_nat s (Z.to_nat n) a. Definition lookupInstr (st : State) : option Instruction := let '(St μ _ _ (pc@_)) := st in nth μ pc. Definition exec (t : table) (st:State) : option State := do instr <- lookupInstr st; match instr, st with | BCall n, St μ m (x @ l :: σ) (xpc@lpc) => match run_tmr t OpBCall <|l|> lpc with | Some (Some rl, rpcl) => let pc' := x @ rpcl in let ret_pc := (xpc + 1 @ rl) in do σ' <- insert σ n ret_pc; Some (St μ m σ' pc') | _ => None end | BRet, St μ m ((ax@al)::σ) (xpc@lpc) => do tmp <- findRet σ; let '(xrpc @ lrpc, σ') := tmp in match run_tmr t OpBRet <|lrpc; al|> lpc with | Some (Some rl, rpcl) => let pc' := xrpc @ rpcl in Some (St μ m ((ax@rl)::σ') pc') | _ => None end | Load, St μ m ((x @ l) :: σ) (xpc@lpc) => do a <- nth m x; let '(ax @ al) := a in match run_tmr t OpLoad <|al; l|> lpc with | Some (Some rl, rpcl) => Some (St μ m ((ax @ rl)::σ) ((xpc+1) @ rpcl)) | _ => None end | Store, St μ m ((x @ lx) :: (a@la) :: σ) (xpc@lpc) => do inMem <- nth m x; match run_tmr t OpStore <|lx; la; ∂inMem|> lpc with | Some (Some rl, rpcl) => do m' <- upd m x (a@rl); Some (St μ m' σ ((xpc+1)@rpcl)) | _ => None end | Push r, St μ m σ (xpc@lpc) => match run_tmr t OpPush <||> lpc with | Some (Some rl, rpcl) => Some (St μ m ((r@rl)::σ) ((xpc+1)@rpcl)) | _ => None end | Nop, St μ m σ (xpc@lpc) => match run_tmr t OpNop <||> lpc with | Some (_, rpcl) => Some (St μ m σ ((xpc+1)@rpcl)) | _ => None end | Add, St μ m ((x @ lx) :: (y @ ly) :: σ) (xpc@lpc) => match run_tmr t OpAdd <|lx ; ly|> lpc with | Some (Some rl, rpcl) => Some (St μ m (((x + y) @ rl) :: σ) ((xpc+1)@rpcl)) | _ => None end | _,_ => None end. Fixpoint execN (t : table) (n : nat) (s : State) : list State := match n with | O => [s] | S n' => match exec t s with | Some s' => s :: execN t n' s' | None => s :: nil end end%list. QuickChick-2.1.0/examples/ifc-basic/Mutate.v000066400000000000000000000115231476030541200206200ustar00rootroot00000000000000From QuickChick.ifcbasic Require Import Rules Machine. Require Import List. Import ListNotations. Set Implicit Arguments. Fixpoint break_expr n (e : rule_expr n) : list (rule_expr n) := match e with | L_Bot _ => [] | L_Var m => [L_Var m] | L_Join e1 e2 => break_expr e1 ++ break_expr e2 end. Fixpoint join_exprs n (es : list (rule_expr n)) : rule_expr n := match es with | nil => L_Bot n | e :: nil => e | e :: es' => L_Join e (join_exprs es') end. Fixpoint break_scond n (c : rule_scond n) : list (rule_scond n) := match c with | A_True _ => [] | A_LE e1 e2 => List.map (fun e1' => A_LE e1' e2) (break_expr e1) | A_And c1 c2 => break_scond c1 ++ break_scond c2 | A_Or c1 c2 => [c] end. Fixpoint and_sconds n (cs : list (rule_scond n)) : rule_scond n := match cs with | nil => A_True n | c :: nil => c | c :: cs' => A_And c (and_sconds cs') end. Fixpoint drop_each X (xs : list X) : list (list X) := match xs with | nil => [] | x :: xs' => xs' :: (map (fun xs'' => x :: xs'') (drop_each xs')) end. Example ex_drop_each : drop_each [1;2;3;4] = [[2;3;4];[1;3;4];[1;2;4];[1;2;3]]. Proof. reflexivity. Qed. Definition mutate_expr n (e : rule_expr n) : list (rule_expr n) := let es := (break_expr e) in match es with | nil => [] | _ => List.map (@join_exprs n) (drop_each es) end. Definition eL1 : rule_expr 3 := Lab1. Definition eL2 : rule_expr 3 := Lab2. Definition eL3 : rule_expr 3 := Lab3. Example ex_break_expr : break_expr (L_Join (L_Join eL1 eL2) eL3) = [eL1; eL2; eL3]. Proof. reflexivity. Qed. Example ex_drop_each' : drop_each [eL1; eL2; eL3] = [[eL2;eL3]; [eL1;eL3]; [eL1;eL2]]. Proof. reflexivity. Qed. Example ex_join_exprs : join_exprs [eL1; eL2; eL3] = L_Join eL1 (L_Join eL2 eL3). Proof. reflexivity. Qed. Example ex_mutate_expr : mutate_expr (L_Join (L_Join eL1 eL2) eL3) = [L_Join eL2 eL3; L_Join eL1 eL3; L_Join eL1 eL2]. Proof. reflexivity. Qed. Example ex_mutate_expr_var : mutate_expr eL1 = [L_Bot 3]. Proof. reflexivity. Qed. Example ex_mutate_expr_bot : mutate_expr (L_Bot 3) = []. Proof. compute. reflexivity. Qed. Definition mutate_scond n (c : rule_scond n) : list (rule_scond n) := let cs := (break_scond c) in match cs with | nil => [] | _ => List.map (@and_sconds n) (drop_each cs) end. Definition c123 := A_LE (L_Join eL1 eL2) eL3. Definition c321 := A_LE eL3 (L_Join eL1 eL2). Definition c13 := A_LE eL1 eL3. Definition c23 := A_LE eL2 eL3. Example ex_break_scond : break_scond (A_And c123 c321) = [c13; c23; c321]. Proof. reflexivity. Qed. Example ex_and_sconds : and_sconds [c13; c23; c321] = A_And c13 (A_And c23 c321). Proof. reflexivity. Qed. Example ex_mutate_scond : mutate_scond (A_And c123 c321) = [A_And c23 c321; A_And c13 c321; A_And c13 c23]. Proof. reflexivity. Qed. Example ex_mutate_scond_true : mutate_scond (A_True 3) = []. Proof. reflexivity. Qed. Definition mutate_rule n (r : AllowModify n) : list (AllowModify n) := let a := allow r in let res := labRes r in let pc := labResPC r in (List.map (fun a' => almod a' res pc) (mutate_scond a)) ++ (match res with | Some lres => List.map (fun lres' => almod a (Some lres') pc) (mutate_expr lres) | None => [] end) ++ (List.map (fun pc' => almod a res pc') (mutate_expr pc)). (* Printing Eval cbv in (mutate_rule (≪ AND (LE Lab2 LabPC) (LE (JOIN LabPC (JOIN Lab1 Lab2)) Lab3), JOIN Lab1 Lab2, LabPC ≫)). *) (* This displays bad Definition mutate_table (t : table) : list table := fold_left (@List.app table) (List.map (fun (o : OpCode) => (List.map (fun (mr : AllowModify (labelCount o)) (o' : OpCode) => match opCode_eq_dec o o' with | left H => eq_rec_r _ (fun x => x) H mr | right _ => t o' end ) (mutate_rule (t o))) ) opCodes) []. *) (* Breaking this out gives more control on the evaluation *) Definition helper o (mr : AllowModify (labelCount o)) o' (orig : AllowModify (labelCount o')) : AllowModify (labelCount o') := match opCode_eq_dec o o' with | left h => eq_rec_r _ (fun x => x) h mr | right _ => orig end. (* The dummy argument t' will be the same as t, just that I wanted more control on evaluation *) Definition mutate_table' (t t' : table) : list table := fold_left (@List.app table) (List.map (fun (o : OpCode) => (List.map (fun (mr : AllowModify (labelCount o)) (o' : OpCode) => helper o mr o' (t' o') ) (mutate_rule (t o))) ) opCodes) []. Definition mutate_table t := mutate_table' t t. (* Printing Definition copy_table := default_table. Eval lazy -[labelCount helper copy_table] in (mutate_table' default_table copy_table). (* can achieve the same with partial application *) Eval lazy -[labelCount helper] in (mutate_table' default_table). Eval lazy in (List.length (mutate_table default_table)). *)QuickChick-2.1.0/examples/ifc-basic/Printing.v000066400000000000000000000107551476030541200211610ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import List. Require Import ZArith. From QuickChick.ifcbasic Require Import Machine Generation. Require Import Coq.Strings.String. Local Open Scope string. #[global] Instance show_label : Show Label := {| show lab := match lab with | L => "L" | H => "H" end |}. #[global] Instance show_instruction : Show Instruction := {| show x := match x with | Nop => "Nop" | Push n => "Push " ++ show n | BCall n => "BCall " ++ show n | BRet => "BRet" | Add => "Add" | Load => "Load" | Store => "Store" end |}. Fixpoint numed_contents {A : Type} (s : A -> string) (l : list A) (n : nat) : string := match l with | nil => ""%string | cons h t => show n ++ " : " ++ s h ++ nl ++ (numed_contents s t (S n)) end. Definition par (s : string) := "( " ++ s ++ " )". #[global] Instance show_atom : Show Atom := {| show a := let '(v @ l) := a in show v ++ " @ " ++ show l |}. #[global] Instance show_list {A : Type} `{_ : Show A} : Show (list A) := {| show l := numed_contents show l 0 |}. #[global] Instance show_stack : Show Stack := {| show s := let fix aux s := match s with | a :: s' => show a ++ " : " ++ aux s' | a ::: s' => "R " ++ show a ++ " : " ++ aux s' | Mty => "[]" end in aux s |}. #[global] Instance show_state : Show State := {| show st := let '(St imem1 mem1 stk1 pc1) := st in "Instructions: " ++ nl ++ show imem1 ++ nl ++ "Memory: " ++ nl ++ show mem1 ++ nl ++ "Stack: " ++ nl ++ show stk1 ++ nl ++ "PC: " ++ show pc1 ++ nl |}. Class ShowPair (A : Type) : Type := { show_pair : A -> A -> string }. Definition show_variation (s1 s2 : string) := "{ " ++ s1 ++ " / " ++ s2 ++ " }". #[global] Instance show_int_pair : ShowPair Z := {| show_pair v1 v2 := if Z.eqb v1 v2 then show v1 else show_variation (show v1) (show v2) |}. #[global] Instance show_label_pair : ShowPair Label := {| show_pair l1 l2 := if label_eq l1 l2 then show l1 else show_variation (show l1) (show l2) |}. #[global] Instance show_atom_pair : ShowPair Atom := {| show_pair a1 a2 := let '(v1 @ l1) := a1 in let '(v2 @ l2) := a2 in show_pair v1 v2 ++ " @ " ++ show_pair l1 l2 |}. #[global] Instance show_mem_pair : ShowPair Mem := {| show_pair m1 m2 := numed_contents (fun (xy : Atom * Atom) => let (x,y) := xy in show_pair x y) (combine m1 m2) 0 |}. Fixpoint total_stack_length s := match s with | _ :: s' => S (total_stack_length s') | _ ::: s' => S (total_stack_length s') | _ => O end. #[global] Instance show_stack_pair : ShowPair Stack := {| show_pair s1 s2 := let len1 := total_stack_length s1 in let len2 := total_stack_length s2 in let fix show_until s n := match n with | O => ("",s) | S n' => match s with | x :: s' => let (str, sf) := show_until s' n' in (show x ++ " : " ++ str, sf) | x ::: s' => let (str, sf) := show_until s' n' in ("R " ++ show x ++ " : " ++ str, sf) | Mty => ("error: Mty", Mty) end end in let '(prefix,(s1,s2)) := if Nat.ltb len1 len2 then let (show_pre, s2') := show_until s2 (len2 - len1)%nat in ("Bigger part of 2: " ++ nl ++ show_pre ++ nl, (s1, s2')) else if Nat.ltb len2 len1 then let (show_pre, s1') := show_until s1 (len1 - len2)%nat in ("Bigger part of 1: " ++ nl ++ show_pre ++ nl, (s1', s2)) else ("", (s1,s2)) in let fix aux s1 s2 := match s1, s2 with | a1::s1', a2::s2' => show_pair a1 a2 ++ " : " ++ aux s1' s2' | a1:::s1', a2:::s2' => "R " ++ show_pair a1 a2 ++ " : " ++ aux s1' s2' | Mty, Mty => "[]" | _, _ => show_variation (show s1) (show s2) end in prefix ++ "Common part: " ++ nl ++ aux s1 s2 |}. #[global] Instance show_state_pair : ShowPair State := {| show_pair st1 st2 := let '(St imem1 mem1 stk1 pc1) := st1 in let '(St imem2 mem2 stk2 pc2) := st2 in "Instructions: " ++ nl ++ show imem1 ++ nl ++ "Memory: " ++ nl ++ show_pair mem1 mem2 ++ nl ++ "Stack: " ++ nl ++ show_pair stk1 stk2 ++ nl ++ "PC: " ++ show_pair pc1 pc2 ++ nl |}. #[global] Instance show_var {A} `{_ :ShowPair A} : Show (@Variation A) := {| show x := let '(V x1 x2) := x in show_pair x1 x2 |}. QuickChick-2.1.0/examples/ifc-basic/Rules.v000066400000000000000000000121331476030541200204510ustar00rootroot00000000000000Require Import List. Require Import Lia. Require Import Utils. Require Import Coq.Unicode.Utf8. Require Import Coq.Vectors.Vector. Set Implicit Arguments. (** This file defines the notion of rule, [AllowModify], and the associated manipulation, hypotheses... Defining the simplest language you would need to express simple rules: we need to model - when the rule applies: [allow : rule_scond] - the label of the result value: [labRes : option rule_expr] Optional because not all ops return results. - the label of the result PC: [labResPC : rule_expr] *) Section Rules. Inductive Label := L | H. Definition label_eq (l1 l2 : Label) : bool := match l1, l2 with | L, L => true | H, H => true | _, _ => false end. Definition label_join (l1 l2 : Label) : Label := match l1, l2 with | _, H => H | H, _ => H | _, _ => L end. Notation "x ∪ y" := (label_join x y) (right associativity, at level 55). Definition flows_to (l1 l2 : Label) : bool := match l1, l2 with | L, _ => true | _, H => true | _, _ => false end. Notation " x ≼ y " := (flows_to x y) (no associativity, at level 55). (** * Label expressions *) (** Labels variables *) Inductive LAB (n: nat) : Type := | lab1 : 1 <= n -> LAB n | lab2 : 2 <= n -> LAB n | lab3 : 3 <= n -> LAB n | labpc : LAB n. (* A better alternative... *) Fixpoint nlem (n:nat) (m:nat) : n<=(n+m). refine (match m with | O => _ (le_n n) | S m' => _ (le_S _ _ (nlem n m')) end). intros; lia. intros; lia. Qed. Inductive rule_expr (n: nat) : Type := | L_Bot: rule_expr n | L_Var: LAB n -> rule_expr n | L_Join: rule_expr n -> rule_expr n -> rule_expr n. (** Side conditions for rules: the Allow part *) Inductive rule_scond (n : nat) : Type := | A_True: @rule_scond n | A_LE: rule_expr n -> rule_expr n -> @rule_scond n | A_And: @rule_scond n -> @rule_scond n -> @rule_scond n | A_Or: @rule_scond n -> @rule_scond n -> @rule_scond n . (** * Rules *) (** The allow-modify part of a rule *) Record AllowModify (n:nat) := almod { allow : rule_scond n; labRes : option (rule_expr n); (* The label of the result value *) labResPC : rule_expr n (* The label of the result PC *) }. (** * Rule evaluation *) (** * Rules Evaluation *) (*(* eval_var is a mapping from abstract label names to concrete label values (a context). The function [apply_rule] below uses this context to evaluate the rule ([AllowModify]). *) Definition mk_eval_var (n:nat) (v1 v2 v3: option T) (pc: T) : LAB n -> T := fun lv => match lv with | lab1 => v1 | lab2 => v2 | lab3 => v3 | labpc => Some pc end. ********) Definition mk_eval_var {n:nat} (vs:Vector.t Label n) (pc:Label) : LAB n -> Label := fun lv => match lv with | lab1 p => nth_order vs p | lab2 p => nth_order vs p | lab3 p => nth_order vs p | labpc _ => pc end. Fixpoint eval_expr {n:nat} (eval_var:LAB n -> Label) (e: rule_expr n) : Label := match e with | L_Bot _ => L | L_Var labv => eval_var labv | L_Join e1 e2 => (eval_expr eval_var e1) ∪ (eval_expr eval_var e2) end. (** eval_cond : evaluates a side_condition with given values for the argument *) Fixpoint eval_cond {n:nat} (eval_var:LAB n -> Label) (c: rule_scond n) : bool := match c with | A_True _ => true | A_And c1 c2 => andb (eval_cond eval_var c1) (eval_cond eval_var c2) | A_Or c1 c2 => orb (eval_cond eval_var c1) (eval_cond eval_var c2) | A_LE e1 e2 => (eval_expr eval_var e1) ≼ (eval_expr eval_var e2) end. (** apply_rule applies the allow-modify r to the given parameters.= Returns the (optional) result value label and result PC label, or nothing when the side condition fails. *) Definition apply_rule {n:nat} (r: AllowModify n) (vlabs: Vector.t Label n) (pclab:Label) : option (option Label * Label) := let eval_var := mk_eval_var vlabs pclab in match eval_cond eval_var (allow r) with | false => None | true => let rpc := eval_expr eval_var (labResPC r) in let rres := match (labRes r) with | Some lres => Some (eval_expr eval_var lres) | None => None end in Some (rres, rpc) end. End Rules. (** * Cosmetic notations for writing and applying rules *) Notation "'≪' c1 , e1 , lpc '≫'" := (almod c1 (Some e1) lpc) (at level 95, no associativity). Notation "'≪' c1 , '__' , lpc '≫'" := (almod c1 None lpc) (at level 95, no associativity). Notation "'LabPC'" := (L_Var (labpc _)). Notation "'Lab1'" := (L_Var (lab1 (nlem _ _))). Notation "'Lab2'" := (L_Var (lab2 (nlem _ _))). Notation "'Lab3'" := (L_Var (lab3 (nlem _ _))). (* Notation "'Lab1/1'" := (L_Var lab1_of_1). Notation "'Lab1/2'" := (L_Var lab1_of_2). Notation "'Lab2/2'" := (L_Var lab2_of_2). Notation "'Lab1/3'" := (L_Var lab1_of_3). Notation "'Lab2/3'" := (L_Var lab2_of_3). Notation "'Lab3/3'" := (L_Var lab3_of_3). *) Notation "'BOT'" := (L_Bot _). Notation "'JOIN'" := L_Join. Notation "'TRUE'" := (A_True _). Notation "'AND'" := A_And. Notation "'OR'" := A_Or. Notation "'LE'" := A_LE. Notation "<||>" := (Vector.nil _). Notation " <| x ; .. ; y |> " := (Vector.cons _ x _ .. (Vector.cons _ y _ (Vector.nil _)) ..). QuickChick-2.1.0/examples/ifc-basic/Timing.v000066400000000000000000000106511476030541200206110ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import List. Import ListNotations. From QuickChick.ifcbasic Require Import Machine Printing Generation Indist DerivedGen. From QuickChick.ifcbasic Require GenExec. Require Import Coq.Strings.String. Local Open Scope string. Definition SSNI_manual (t : table) (v : @Variation State) : Checker := let '(V st1 st2) := v in let '(St _ _ _ (_@l1)) := st1 in let '(St _ _ _ (_@l2)) := st2 in if indist st1 st2 then match l1, l2 with | L,L => match exec t st1, exec t st2 with | Some st1', Some st2' => checker (indist st1' st2') | _, _ => checker rejected end | H, H => match exec t st1, exec t st2 with | Some st1', Some st2' => if is_atom_low (st_pc st1') && is_atom_low (st_pc st2') then checker (indist st1' st2') else if is_atom_low (st_pc st1') then (checker (indist st2 st2')) else (checker (indist st1 st1')) | _, _ => checker rejected end | H,_ => match exec t st1 with | Some st1' => checker (indist st1 st1') | _ => checker rejected end | _,H => match exec t st2 with | Some st2' => checker (indist st2 st2') | _ => checker rejected end end else checker rejected. Instance CheckableOptBool : Checkable (option bool) := { checker x := match x with | Some true => checker true | Some false => checker false | None => checker rejected end }. Definition SSNI_derived (t : table) (v : @Variation State) : Checker := let '(V st1 st2) := v in let '(St _ _ _ (_@l1)) := st1 in let '(St _ _ _ (_@l2)) := st2 in match @decOpt (IndistState st1 st2) _ 5 with | Some true => match l1, l2 with | L,L => match exec t st1, exec t st2 with | Some st1', Some st2' => (* whenFail ("Initial states: " ++ nl ++ show_pair st1 st2 ++ nl ++ "Final states: " ++ nl ++ show_pair st1' st2' ++nl)*) (checker (@decOpt (IndistState st1' st2') _ 5)) | _, _ => checker rejected end | H, H => match exec t st1, exec t st2 with | Some st1', Some st2' => if is_atom_low (st_pc st1') && is_atom_low (st_pc st2') then whenFail ("Initial states: " ++ nl ++ show_pair st1 st2 ++ nl ++ "Final states: " ++ nl ++ show_pair st1' st2' ++nl) (checker (@decOpt (IndistState st1' st2') _ 5)) else if is_atom_low (st_pc st1') then whenFail ("States: " ++ nl ++ show_pair st2 st2' ++ nl ) (checker (@decOpt (IndistState st2 st2') _ 5)) else whenFail ("States: " ++ nl ++ show_pair st1 st1' ++ nl ) (checker (@decOpt (IndistState st1 st1') _ 5)) | _, _ => checker rejected end | H,_ => match exec t st1 with | Some st1' => whenFail ("States: " ++ nl ++ show_pair st1 st1' ++ nl ) (checker (@decOpt (IndistState st1 st1') _ 5)) | _ => checker rejected end | _,H => match exec t st2 with | Some st2' => whenFail ("States: " ++ nl ++ show_pair st2 st2' ++ nl ) (checker (@decOpt (IndistState st2 st2') _ 5)) | _ => checker rejected end end | _ => checker rejected end. Axiom withTime : Checker -> Checker. Extract Constant withTime => "(fun c -> Printf.printf ""%.8f\n"" (Sys.time ()); c)". Definition prop_manual : Checker := forAllShrink gen_variation_state (fun _ => nil) (fun v => SSNI_manual default_table v). Definition prop_derived : Checker := forAllShrink gen_variation_state (fun _ => nil) (fun v => SSNI_derived default_table v). Extract Constant defNumTests => "20000". QuickChick prop_manual. QuickChick prop_derived. (* Definition prop_test : Checker := forAllShrink gen_variation_state (fun _ => nil) (fun v => let r0 := trace ("Next" ++ nl) (checker true) in let r2 := withTime (SSNI_derived default_table v) in let r1 := withTime (SSNI_manual default_table v) in withTime (conjoin [r0;r2;r1])). QuickChick prop_test. *) QuickChick-2.1.0/examples/ifc-basic/dune000066400000000000000000000003211476030541200200420ustar00rootroot00000000000000(coq.theory (name QuickChick.ifcbasic) (theories QuickChick) (modules Indist Instructions Machine Mutate Printing Generation DerivedGen GenExec Rules Driver )) QuickChick-2.1.0/examples/multifile-mutation.t/000077500000000000000000000000001476030541200214425ustar00rootroot00000000000000QuickChick-2.1.0/examples/multifile-mutation.t/.gitignore000066400000000000000000000000031476030541200234230ustar00rootroot00000000000000_qcQuickChick-2.1.0/examples/multifile-mutation.t/Bar.v000066400000000000000000000007301476030541200223350ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import Arith. Require Import Foo. (*! Section prop_plus_one *)(*! extends plus_one *) Definition prop_plus_one x := whenFail (show (x, plus_one x)) (x log 2>&1 || (cat log ; exit 1) QuickChick-2.1.0/examples/multifile-mutation.t/src/000077500000000000000000000000001476030541200222315ustar00rootroot00000000000000QuickChick-2.1.0/examples/multifile-mutation.t/src/Zoo.v000066400000000000000000000004231476030541200231660ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import Arith. Require Import Foo. (*! Section prop_plus_one_again *)(*! extends plus_one *) Definition prop_plus_one_again x := whenFail (show (x, plus_one x)) (x (-m test) -s Prop12 *) (*! QuickChick testProp1. *) (*! QuickChick testProp2. *) (*! Section Prop3 *)(*! extends Prop12 *) Definition testProp3 (x y : nat) := x =? y. (*! QuickChick testProp3. *) (*! Section Prop4 *) Definition testProp4 (x y : nat) := x =? y. (*! QuickChick testProp4. *) (*! Section Mutant *) Definition plus1 (x : nat) := (*!*) x + 1 (*! x *) (*! x + x *) . (*! Section PropPlus *)(*! extends Mutant *) (* quickChick -m mutate -s PropPlus *) Definition propPlus x := x log 2>&1 || (cat log ; exit 1) QuickChick-2.1.0/examples/ocaml-interop/000077500000000000000000000000001476030541200201215ustar00rootroot00000000000000QuickChick-2.1.0/examples/ocaml-interop/Interop.v000066400000000000000000000006341476030541200217330ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import ZArith. Require Import String. Local Open Scope string. Inductive foo := | A : Z -> foo (* | B : string -> foo *) | C : foo -> foo -> foo. Derive (Arbitrary, Show) for foo. Extract Inductive foo => "Foo.foo" [ "Foo.A" "Foo.C" ]. Axiom good_foo : foo -> bool. Extract Constant good_foo => "Foo.good_foo". QCInclude "ocaml/*". QuickChick good_foo. QuickChick-2.1.0/examples/ocaml-interop/ocaml/000077500000000000000000000000001476030541200212145ustar00rootroot00000000000000QuickChick-2.1.0/examples/ocaml-interop/ocaml/foo.ml000066400000000000000000000003341476030541200223310ustar00rootroot00000000000000type foo = A of int (* | B of string *) | C of foo * foo let rec good_foo (x : foo) : bool = match x with | A n -> n > 0 (* | B _ -> true *) | C (x1,x2) -> good_foo x1 && good_foo x2 QuickChick-2.1.0/examples/other/000077500000000000000000000000001476030541200164715ustar00rootroot00000000000000QuickChick-2.1.0/examples/other/BSTTest.v000066400000000000000000000024441476030541200201540ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import List. Import ListNotations. Require Import String. Open Scope string. Inductive Tree := | Leaf : Tree | Node : nat -> Tree -> Tree -> Tree. Derive (Arbitrary, Show) for Tree. Inductive bst : nat -> nat -> Tree -> Prop := | bst_leaf : forall lo hi, bst lo hi Leaf | bst_node : forall lo hi x l r, le (S lo) x -> le (S x) hi -> bst lo x l -> bst x hi r -> bst lo hi (Node x l r). Derive DecOpt for (le x y). Derive ArbitrarySizedSuchThat for (fun x => le y x). Derive ArbitrarySizedSuchThat for (fun t => bst lo hi t). Derive DecOpt for (bst lo hi t). Fixpoint is_bst (lo hi : nat) (t : Tree) := match t with | Leaf => true | Node x l r => andb ((lo < x /\ x < hi) ?) (andb (is_bst lo x l) (is_bst x hi r)) end. Fixpoint insert (x : nat) (t : Tree) := match t with | Leaf => Node x Leaf Leaf | Node y l r => if x < y ? then Node y (insert x l) r else if x > y ? then Node y l (insert x r) else t end. Definition bst_checker_prop := forAllMaybe (genST (fun t => bst 0 17 t)) (fun t => forAll (choose (1, 16)) (fun x => bst 0 17 (insert x t) ?? 10)). (* *) (* is_bst 0 17 (insert x t))). *) Extract Constant defNumTests => "100". QuickChick bst_checker_prop. QuickChick-2.1.0/examples/other/DependentTest.v000066400000000000000000000401071476030541200214300ustar00rootroot00000000000000From QuickChick Require Import QuickChick Tactics. Require Import String. Open Scope string. Require Import List. Import ListNotations. Import QcDefaultNotation. Open Scope qc_scope. Require Export ExtLib.Structures.Monads. Import MonadNotation. Open Scope monad_scope. Set Bullet Behavior "Strict Subproofs". Derive ArbitrarySizedSuchThat for (fun x => eq x y). Definition GenSizedSuchThateq_manual {A} (y_ : A) := let fix aux_arb (init_size size : nat) (y_0 : A) {struct size} : G (option A) := match size with | 0 => backtrack [(1, returnGen (Some y_0))] | S _ => backtrack [(1, returnGen (Some y_0))] end in fun size => aux_arb size size y_. Theorem GenSizedSuchThateq_proof A (n : A) `{Dec_Eq A} `{Gen A} `{Enum A}: GenSizedSuchThateq_manual n = @arbitrarySizeST _ (fun x => eq x n) _. Proof. reflexivity. Qed. Inductive Foo := | Foo1 : Foo | Foo2 : Foo -> Foo | Foo3 : nat -> Foo -> Foo. QuickChickWeights [(Foo1, 1); (Foo2, size); (Foo3, size)]. Derive (Arbitrary, Show) for Foo. Derive EnumSized for Foo. (* Use custom formatting of generated code, and prove them equal (by reflexivity) *) (* begin show_foo *) Fixpoint showFoo' (x : Foo) := match x with | Foo1 => "Foo1" | Foo2 f => "Foo2 " ++ smart_paren (showFoo' f) | Foo3 n f => "Foo3 " ++ smart_paren (show n) ++ " " ++ smart_paren (showFoo' f) end%string. (* end show_foo *) Lemma show_foo_equality : showFoo' = (@show Foo _). Proof. reflexivity. Qed. (* begin genFooSized *) Fixpoint genFooSized (size : nat) := match size with | O => returnGen Foo1 | S size' => freq [ (1, returnGen Foo1) ; (S size', f <- genFooSized size';; ret (Foo2 f)) ; (S size', n <- arbitrary ;; f <- genFooSized size' ;; ret (Foo3 n f)) ] end. (* end genFooSized *) (* begin shrink_foo *) Fixpoint shrink_foo x := match x with | Foo1 => [] | Foo2 f => ([f] ++ map (fun f' => Foo2 f') (shrink_foo f) ++ []) ++ [] | Foo3 n f => (map (fun n' => Foo3 n' f) (shrink n) ++ []) ++ ([f] ++ map (fun f' => Foo3 n f') (shrink_foo f) ++ []) ++ [] end. (* end shrink_foo *) (* JH: Foo2 -> Foo1, Foo3 n f -> Foo2 f *) (* Avoid exponential shrinking *) Lemma genFooSizedNotation : genFooSized = @arbitrarySized Foo _. Proof. reflexivity. Qed. Lemma shrinkFoo_equality : shrink_foo = @shrink Foo _. Proof. reflexivity. Qed. (* Completely unrestricted case *) (* begin good_foo *) Inductive goodFoo : nat -> Foo -> Prop := | GoodFoo : forall n foo, goodFoo n foo. (* end good_foo *) Derive ArbitrarySizedSuchThat for (fun foo => goodFoo n foo). Derive EnumSizedSuchThat for (fun foo => goodFoo n foo). (* Need to write it as 'fun x => goodFoo 0 x'. Sadly, 'goodFoo 0' doesn't work *) Definition g : G (option Foo) := @arbitrarySizeST _ (fun x => goodFoo 0 x) _ 4. (* Sample g. *) (* Simple generator for goodFoos *) (* begin gen_good_foo_simple *) (* Definition genGoodFoo {_ : Arbitrary Foo} (n : nat) : G Foo := arbitrary.*) (* end gen_good_foo_simple *) (* begin gen_good_foo *) Definition genGoodFoo `{_ : Arbitrary Foo} (n : nat) := let fix aux_arb init_size size n := match size with | 0 => backtrack [(1, foo <- arbitrary ;; ret (Some foo))] | S _ => backtrack [(1, foo <- arbitrary ;; ret (Some foo))] end in fun sz => aux_arb sz sz n. (* end gen_good_foo *) Lemma genGoodFoo_equality n : genGoodFoo n = @arbitrarySizeST _ (fun foo => goodFoo n foo) _. Proof. reflexivity. Qed. (* Copy to extract just the relevant generator part *) Definition genGoodFoo'' `{_ : Arbitrary Foo} (n : nat) := let fix aux_arb init_size size n := match size with | 0 => backtrack [(1, (* begin gen_good_foo_gen *) foo <- arbitrary;; ret (Some foo) (* end gen_good_foo_gen *) )] | S _ => backtrack [(1, foo <- arbitrary;; ret (Some foo))] end in fun sz => aux_arb sz sz n. Lemma genGoodFoo_equality' : genGoodFoo = genGoodFoo''. Proof. reflexivity. Qed. (* Basic Unification *) (* begin good_unif *) Inductive goodFooUnif : nat -> Foo -> Prop := | GoodUnif : forall n, goodFooUnif n Foo1. (* end good_unif *) Derive ArbitrarySizedSuchThat for (fun foo => goodFooUnif n foo). Definition genGoodUnif (n : nat) := let fix aux_arb init_size size n := match size with | 0 => backtrack [(1, (* begin good_foo_unif_gen *) ret (Some Foo1) (* end good_foo_unif_gen *) )] | S _ => backtrack [(1, ret (Some Foo1))] end in fun sz => aux_arb sz sz n. Lemma genGoodUnif_equality n : genGoodUnif n = @arbitrarySizeST _ (fun foo => goodFooUnif n foo) _. Proof. reflexivity. Qed. (* The foo is generated by arbitrary *) (* begin good_foo_combo *) Inductive goodFooCombo : nat -> Foo -> Prop := | GoodCombo : forall n foo, goodFooCombo n (Foo2 foo). (* end good_foo_combo *) Derive ArbitrarySizedSuchThat for (fun foo => goodFooCombo n foo). Definition genGoodCombo `{_ : Arbitrary Foo} (n : nat) := let fix aux_arb init_size size n := match size with | 0 => backtrack [(1, (* begin good_foo_combo_gen *) foo <- arbitrary;; ret (Some (Foo2 foo)) (* end good_foo_combo_gen *) )] | S _ => backtrack [(1, foo <- arbitrary;; ret (Some (Foo2 foo)))] end in fun sz => aux_arb sz sz n. Lemma genGoodCombo_equality n : genGoodCombo n = @arbitrarySizeST _ (fun foo => goodFooCombo n foo) _. Proof. reflexivity. Qed. (* Requires input nat to match 0 *) (* begin good_input_match *) Inductive goodFooMatch : nat -> Foo -> Prop := | GoodMatch : goodFooMatch 0 Foo1. (* end good_input_match *) Derive ArbitrarySizedSuchThat for (fun foo => goodFooMatch n foo). Definition genGoodMatch (n : nat) := let fix aux_arb init_size size n := match size with | 0 => backtrack [(1, thunkGen (fun _ => (* begin good_foo_match_gen *) match n with | 0 => ret (Some Foo1) | S _ => ret None end) (* end good_foo_match_gen *) )] | S _ => backtrack [(1, thunkGen (fun _ => match n with | 0 => ret (Some Foo1) | S _ => ret None end))] end in fun sz => aux_arb sz sz n. Lemma genGoodMatch_equality n : genGoodMatch n = @arbitrarySizeST _ (fun foo => goodFooMatch n foo) _. Proof. reflexivity. Qed. (* Requires recursive call of generator *) (* begin good_foo_rec *) Inductive goodFooRec : nat -> Foo -> Prop := | GoodRecBase : forall n, goodFooRec n Foo1 | GoodRec : forall n foo, goodFooRec 0 foo -> goodFooRec n (Foo2 foo). (* end good_foo_rec *) Derive ArbitrarySizedSuchThat for (fun foo => goodFooRec n foo). (* begin gen_good_rec *) Definition genGoodRec (n : nat) := let fix aux_arb (init_size size : nat) n : G (option Foo) := match size with | 0 => backtrack [(1, thunkGen (fun _ => ret (Some Foo1))) ;(1, thunkGen (fun _ => ret None))] | S size' => backtrack [ (1, thunkGen (fun _ => ret (Some Foo1))) ; (S size',thunkGen (fun _ => bindOpt (aux_arb init_size size' 0) (fun foo => ret (Some (Foo2 foo))))) ] end in fun sz => aux_arb sz sz n. (* end gen_good_rec *) Lemma genGoodRec_equality n : genGoodRec n = @arbitrarySizeST _ (fun foo => goodFooRec n foo) _. Proof. reflexivity. Qed. (* Precondition *) Inductive goodFooPrec : nat -> Foo -> Prop := | GoodPrecBase : forall n, goodFooPrec n Foo1 | GoodPrec : forall n foo, goodFooPrec 0 Foo1 -> goodFooPrec n foo. Derive DecOpt for (goodFooPrec n foo). Definition DecOptgoodFooPrec_manual (n_ : nat) (foo_ : Foo) := let fix aux_arb (init_size size0 n_0 : nat) (foo_0 : Foo) {struct size0} : option bool := match size0 with | 0 => checker_backtrack [(fun u:unit => match foo_0 with | Foo1 => Some true | _ => Some false end ); fun u:unit => None] | S size' => checker_backtrack [(fun u:unit => match foo_0 with | Foo1 => Some true | _ => Some false end) ;(fun u:unit => match aux_arb init_size size' 0 Foo1 with | Some true => Some true | Some false => Some false | None => None end) ] end in fun size0 : nat => aux_arb size0 size0 n_ foo_. Theorem DecOptgoodFooPrec_proof n foo : DecOptgoodFooPrec_manual n foo = @decOpt (goodFooPrec n foo) _. Proof. reflexivity. Qed. Derive ArbitrarySizedSuchThat for (fun foo => goodFooPrec n foo). Definition genGoodPrec (n : nat) : nat -> G (option (Foo)):= let fix aux_arb init_size size (n : nat) : G (option (Foo)) := match size with | O => backtrack [ (1, thunkGen (fun _ => ret (Some Foo1))) ; (1, thunkGen (fun _ => match @decOpt (goodFooPrec O Foo1) _ init_size with | Some true => foo <- arbitrary;; ret (Some foo) | _ => ret None end)) ] | S size' => backtrack [ (1, thunkGen (fun _ => ret (Some Foo1))) ; (1, thunkGen (fun _ => match @decOpt (goodFooPrec O Foo1) _ init_size with | Some true => foo <- arbitrary;; ret (Some foo) | _ => ret None end ))] end in fun sz => aux_arb sz sz n. Lemma genGoodPrec_equality n : genGoodPrec n = @arbitrarySizeST _ (fun foo => goodFooPrec n foo) _. Proof. reflexivity. Qed. (* Generation followed by check - backtracking necessary *) Inductive goodFooNarrow : nat -> Foo -> Prop := | GoodNarrowBase : forall n, goodFooNarrow n Foo1 | GoodNarrow : forall n foo, goodFooNarrow 0 foo -> goodFooNarrow 1 foo -> goodFooNarrow n foo. Derive DecOpt for (goodFooNarrow n foo). Definition goodFooNarrow_decOpt (n_ : nat) (foo_ : Foo) := let fix aux_arb (init_size size0 n_0 : nat) (foo_0 : Foo) : option bool := match size0 with | 0 => checker_backtrack [(fun _ : unit => match foo_0 with | Foo1 => Some true | _ => Some false end) ; (fun _ : unit => None)] | S size' => checker_backtrack [(fun _ : unit => match foo_0 with | Foo1 => Some true | _ => Some false end) ; (fun _ : unit => match aux_arb init_size size' 0 foo_0 with | Some true => match aux_arb init_size size' 1 foo_0 with | Some true => Some true | Some false => Some false | None => None end | Some false => Some false | None => None end)] end in fun size0 : nat => aux_arb size0 size0 n_ foo_. Lemma goodFooNarrow_decOpt_correct n foo : goodFooNarrow_decOpt n foo = @decOpt (goodFooNarrow n foo) _. Proof. reflexivity. Qed. Derive ArbitrarySizedSuchThat for (fun foo => goodFooNarrow n foo). Definition genGoodNarrow (n : nat) : nat -> G (option (Foo)) := let fix aux_arb init_size size (n : nat) : G (option (Foo)) := match size with | O => backtrack [(1, thunkGen (fun _ => ret (Some Foo1))); (1, thunkGen (fun _ => ret None))] | S size' => backtrack [ (1, thunkGen (fun _ => ret (Some Foo1))) ; (S size', thunkGen (fun _ => bindOpt (aux_arb init_size size' 0) (fun foo => match @decOpt (goodFooNarrow 1 foo) _ init_size with | Some true => ret (Some foo) | _ => ret None end )))] end in fun sz => aux_arb sz sz n. Lemma genGoodNarrow_equality n : genGoodNarrow n = @arbitrarySizeST _ (fun foo => goodFooNarrow n foo) _. Proof. reflexivity. Qed. (* Non-linear constraint *) Inductive goodFooNL : nat -> Foo -> Foo -> Prop := | GoodNL : forall n foo, goodFooNL n (Foo2 foo) foo. #[global] Instance EqDecFoo (f1 f2 : Foo) : Dec (f1 = f2). Proof. dec_eq. Defined. Derive ArbitrarySizedSuchThat for (fun foo => goodFooNL n m foo). Derive DecOpt for (goodFooNL n m foo). (* Parameters don't work yet :) *) (* Inductive Bar A B := | Bar1 : A -> Bar A B | Bar2 : Bar A B -> Bar A B | Bar3 : A -> B -> Bar A B -> Bar A B -> Bar A B. Arguments Bar1 {A} {B} _. Arguments Bar2 {A} {B} _. Arguments Bar3 {A} {B} _ _ _ _. Inductive goodBar {A B : Type} (n : nat) : Bar A B -> Prop := | goodBar1 : forall a, goodBar n (Bar1 a) | goodBar2 : forall bar, goodBar 0 bar -> goodBar n (Bar2 bar) | goodBar3 : forall a b bar, goodBar n bar -> goodBar n (Bar3 a b (Bar1 a) bar). *) (* Generation followed by check - backtracking necessary *) (* Untouched variables - ex soundness bug *) Inductive goodFooFalse : Foo -> Prop := | GoodFalse : forall (x : False), goodFooFalse Foo1. #[global] Instance arbFalse : Gen False. Admitted. Set Warnings "+quickchick-uninstantiated-variables". Fail Derive ArbitrarySizedSuchThat for (fun foo => goodFooFalse foo). Set Warnings "quickchick-uninstantiated-variables". Definition addFoo2 (x : Foo) := Foo2 x. Fixpoint foo_depth f := match f with | Foo1 => 0 | Foo2 f => 1 + foo_depth f | Foo3 n f => 1 + foo_depth f end. Derive ArbitrarySizedSuchThat for (fun n => goodFooPrec n x). Inductive goodFun : Foo -> Prop := | GoodFun : forall (n : nat) (a : Foo), goodFooPrec n (addFoo2 a) -> goodFun a. Derive ArbitrarySizedSuchThat for (fun a => goodFun a). Inductive Foo_and : (bool * bool) -> bool -> Prop := | Foo_andtt : Foo_and (true, true) true. Inductive Foo_rel : nat -> bool -> Prop := | R1 : forall n, Foo_rel n true | R2' : forall a1 l1 a2 l2 l, Foo_and (l1, l2) l -> Foo_rel a1 l1 -> Foo_rel a2 l2 -> Foo_rel a1 l. Derive Generator for (fun l12 => Foo_and l12 l). Derive Generator for (fun a => Foo_rel a b). Definition gen_foo_and (l : bool) : nat -> G (option (bool * bool)) := let fix aux_arb (init_size size : nat) (l_0 : bool) {struct size} : G (option (bool * bool)) := match size with | 0 | _ => backtrack [(1, thunkGen (fun _ : unit => if l_0 then returnGen (Some (true, true)) else returnGen None))] end in fun size : nat => aux_arb size size l. Lemma gen_foo_and_equality l : gen_foo_and l = @arbitrarySizeST _ (fun l12 => Foo_and l12 l) _. Proof. reflexivity. Qed. Definition gen_foo_rel (b_ : bool) : nat -> G (option nat) := let fix aux_arb (init_size size : nat) (b_0 : bool) {struct size} : G (option nat) := match size with | 0 => backtrack [(1, thunkGen (fun _ : unit => if b_0 then bindGen arbitrary (fun n : nat => returnGen (Some n)) else returnGen None)); (1, thunkGen (fun _ : unit => returnGen None))] | S size' => backtrack [(1, thunkGen (fun _ : unit => if b_0 then bindGen arbitrary (fun n : nat => returnGen (Some n)) else returnGen None)); (S size', thunkGen (fun _ : unit => bindOpt (genST (fun unkn_11_ : bool * bool => Foo_and unkn_11_ b_0)) (fun unkn_11_ : bool * bool => let (l1, l2) := unkn_11_ in bindOpt (aux_arb init_size size' l1) (fun a_ : nat => bindOpt (aux_arb init_size size' l2) (fun _ : nat => returnGen (Some a_))))))] end in fun size : nat => aux_arb size size b_. Lemma gen_foo_rel_equality b : gen_foo_rel b = @arbitrarySizeST _ (fun l => Foo_rel l b) _. Proof. reflexivity. Qed. Definition success := "success". Print success. QuickChick-2.1.0/examples/other/Fuzz.v000066400000000000000000000006071476030541200176210ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Import MonadNotation. Require Import Arith. Definition test_prop (n : nat) := Some (n <=? 10). Definition gen : G nat := choose (0,5). Definition fuzz (n : nat) : G nat := x <- choose (1,3);; ret (n + x). Definition fuzzer := fun (u : unit) => fuzzLoop gen fuzz show test_prop. QuickChickDebug Debug On. FuzzChick test_prop (fuzzer tt). QuickChick-2.1.0/examples/other/MergeExample.v000066400000000000000000000157761476030541200212530ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import List. Import ListNotations. Require Import String. Open Scope string. Inductive Tree := | Leaf : Tree | Node : nat -> Tree -> Tree -> Tree. Inductive Foo (A : Type) := | Foo1 : Foo A | Foo2 : A -> Foo A -> Foo A -> Foo A. Arguments Foo1 {A}. Arguments Foo2 {A}. Inductive NoParam : Foo nat -> Prop := | NoParam1 : NoParam Foo1 | NoParam2 : forall a f, NoParam f -> NoParam (Foo2 a f f). Inductive Good {A : Type} : Foo A -> Prop := | Good1 : Good Foo1 | Good2 : forall a f, Good (Foo2 a f f). (* QuickChickDebug Debug On. *) MergeTest (fun x => NoParam x). MergeTest (fun x => Good x). Inductive bst : nat -> nat -> Tree -> Prop := | bst_leaf : forall lo hi, bst lo hi Leaf | bst_node : forall lo hi x l r, le (S lo) x -> le (S x) hi -> bst lo x l -> bst x hi r -> bst lo hi (Node x l r). Inductive bal : nat -> Tree -> Prop := | bal_leaf0 : bal 0 Leaf | bal_leaf1 : bal 1 Leaf | bal_node : forall n t1 t2 m, bal n t1 -> bal n t2 -> bal (S n) (Node m t1 t2). Derive (Arbitrary, Show) for Tree. Merge (fun t => bst lo hi t) With (fun t => bal n t) As bst_bal. Print bst_bal. Fixpoint size (t : Tree) : nat := match t with | Leaf => 0 | Node x l r => 1 + max (size l) (size r) end. (* Inductive bstbal : nat -> nat -> nat -> Tree -> Prop := | leafleaf0 : forall lo hi, bstbal lo hi 0 Leaf | leafleaf1 : forall lo hi, bstbal lo hi 1 Leaf | nodenode : forall lo hi n x l r, le (S lo) x -> le (S x) hi -> bstbal lo hi n l -> bstbal x hi n r -> bstbal lo hi (S n) (Node x l r). Derive ArbitrarySizedSuchThat for (fun t => bal n t). Derive DecOpt for (bal n t). Derive EnumSizedSuchThat for (fun n => bal n t). Definition Empty {A} (e : E A) (n : nat) : bool := match (Enumerators.run e n) with | LazyList.lnil => false | LazyList.lcons _ _ => true end. Derive DecOpt for (le x y). Derive ArbitrarySizedSuchThat for (fun x => le y x). QuickChickWeights [ (bst_leaf, 1) ; (bst_node, size) ]. Derive ArbitrarySizedSuchThat for (fun t => bst lo hi t). Derive ArbitrarySizedSuchThat for (fun t => bstbal a b c t). Sample (@arbitrarySizeST _ (fun t => bst 0 10 t) _ 5). Print GenSizedSuchThatbst. Sample (@arbitrarySizeST _ (fun t => bst 0 42 t) _ 10). Derive DecOpt for (bst lo hi t). Check @decOpt. Check GenSizedSuchThatbst. Compute (@decOpt (bal 0 Leaf) _ 5). Definition balBst_any_test := forAllMaybe (@arbitrarySizeST _ (fun t => bst 0 42 t) _ 10) (fun t => if Empty (@enumSizeST _ (fun n => bal n t) _ 10) 10 then (collect (size t) (checker true)) else (checker tt)). (*QuickChick balBst_any_test.*) Definition balBst_merged := forAllMaybe (@arbitrarySizeST _ (fun t => bstbal 0 42 3 t) _ 10) (fun t => checker true). (* QuickChick balBst_merged. *) (*An issue is that these two aren't really comparing the same thing. Ideally, we should generate trees for which all three parameters can be anything.*) Inductive foo : nat -> Prop := | Foo1 : foo O | Foo2 : forall n, foo n -> foo (S n) | Foo3 : forall n1 n2, foo 0 -> foo (S n1) -> foo (S n2). (* Merge (fun t => bst lo hi t) With (fun t => bal n t) As bstbalmerged. *) *) (*Same variable name test:*) Inductive P : nat -> Prop := | bla_P : forall n, P n. Inductive Q : nat -> Prop := | bla_Q : forall n, Q (S n). Merge (fun n => P n) With (fun n => Q n) As doesntgetusedanyway. (*This should have a constructor!*) Print doesntgetusedanyway. (*Simple definition test*) Definition naaat := nat. Inductive P3 : naaat -> Prop:=. Inductive Q3 : naaat -> Prop:=. Merge (fun n => P3 n) With (fun n => Q3 n) As PQ3. Print PQ3. Inductive Term : Type := | var : nat -> Term | app : Term -> Term -> Term | lam : Term -> Term | const : nat -> Term | add : Term -> Term -> Term. Inductive Ty : Type := | arr : Ty -> Ty -> Ty | number : Ty. (* Definition Context := list Ty. *) Inductive Var : list Ty -> Ty -> nat -> Prop := | zero : forall t g, Var (cons t g) t 0 | suc : forall a b g n, Var g a n -> Var (cons b g) a (S n). Inductive typed : list Ty -> Ty -> Term -> Prop := | t_var : forall g n t, Var g t n -> typed g t (var n) | t_app : forall a b g e1 e2, typed g (arr a b) e1 -> typed g a e2 -> typed g b (app e1 e2) | t_lam : forall a b g e, typed (cons a g) b e -> typed g (arr a b) (lam e) | t_const : forall n g, typed g number (const n) | t_add : forall e1 e2 g, typed g number e1 -> typed g number e2 -> typed g number (add e1 e2). Theorem falses : nat -> list bool. Proof. intros n. induction n. - apply nil. - apply cons. apply false. apply IHn. Defined. Inductive nand : bool -> bool -> bool -> Prop := | nand_ff : nand false false true | nand_ft : nand false true true | nand_tf : nand true false true | nand_tt : nand true true false. Inductive combine : list bool -> list bool -> list bool -> Prop := | combine_nil : combine nil nil nil | combine_cons : forall as1 as2 as3 a1 a2 a3, nand a1 a2 a3 -> combine as1 as2 as3 -> combine (cons a1 as1) (cons a2 as2) (cons a3 as3). Inductive var_linear : list bool -> nat -> Prop := | zero_lin : forall n, var_linear (true :: falses n) 0 | suc_lin : forall u n, var_linear u n -> var_linear (cons false u) (S n). (* Inductive linear : list bool -> Term -> Prop := | l_var : forall u n, var_linear u n -> linear u (var n) | l_app : forall u1 u2 u3 e1 e2, linear u1 e1 -> linear u2 e2 -> combine u1 u2 u3 -> linear u3 (app e1 e2) | l_con : forall len n, linear (falses len) (const n) | l_lam : forall u e, linear (true :: u) e -> linear u (lam e) | l_add : forall u1 u2 u3 e1 e2, linear u1 e1 -> linear u2 e2 -> combine u1 u2 u3 -> linear u3 (add e1 e2). *) Inductive linear : list bool -> Term -> Prop := | l_var : forall u_ n_, var_linear u_ n_ -> linear u_ (var n_) | l_app : forall u1_ u2_ u3_ e1_ e2_, linear u1_ e1_ -> linear u2_ e2_ -> combine u1_ u2_ u3_ -> linear u3_ (app e1_ e2_) | l_con : forall len_ n_, linear (falses len_) (const n_) | l_lam : forall u_ e_, linear (true :: u_) e_ -> linear u_ (lam e_) | l_add : forall u1_ u2_ u3_ e1_ e2_, linear u1_ e1_ -> linear u2_ e2_ -> combine u1_ u2_ u3_ -> linear u3_ (add e1_ e2_). Merge (fun t => typed gamma ty t) With (fun t => linear used t) As typed_and_linear. Print typed_and_linear. Axiom sub : Term -> Term -> Term. Inductive Even : nat -> Prop := | Z_Even : Even 0 | SS_Even : forall n, Even n -> Even (S (S n)). Inductive Odd : nat -> Prop := | SZ_Odd : Odd 1 | SS_Odd : forall n, Odd n -> Odd (S (S n)). Merge (fun n => Even n) With (fun n => Odd n) As EO. Print EO. Inductive step : Term -> Term -> Prop := | beta_step : forall e1 e2, step (app (lam e1) e2) (sub e1 e2). Print typed. Merge (fun t => typed gamma ty t) With (fun t => step t t2) As steptype. Print steptype. Inductive less : nat -> nat -> Prop := | less_n : forall n, less n n | less_S : forall m n, less n m -> less n (S m). Merge (fun y => less x y) With (fun y => less y z) As between. Print between. QuickChick-2.1.0/examples/other/PluginTest.v000066400000000000000000000022721476030541200207610ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Inductive Tree := | Leaf : Tree | Node : nat -> Tree -> Tree -> Tree. Derive Arbitrary for Tree. Inductive recursion_test : nat -> Tree -> Prop := | RecLeaf : forall n, recursion_test n Leaf | RecNode : forall m l r, recursion_test m l -> recursion_test m (Node m l r). Derive ArbitrarySizedSuchThat for (fun p => let (m,tr) := p in recursion_test m tr). Inductive checker_test : nat -> Tree -> Prop := | CheckerLeaf : forall n, checker_test n Leaf | CheckerNode : forall n t, checker_test O Leaf -> checker_test n t. Derive DecOpt for (checker_test n t). Derive ArbitrarySizedSuchThat for (fun p => let (m,tr) := p in checker_test m tr). Derive ArbitrarySizedSuchThat for (fun tr => recursion_test m tr). #[local] Instance test_coercion A B (P : A -> B -> Prop) `{Gen B} {_ : forall y, GenSuchThat _ (fun x => P x y)} : GenSuchThat _ (fun p : A * B => let (x,y) := p in P x y) := {| arbitraryST := bindGen arbitrary (fun y => bindOpt (@arbitraryST _ (fun x : A => P x y) _) (fun x => returnGen (Some (x,y)))) |}. Definition foo : G (option (nat * nat)) := @arbitraryST _ (fun p : nat * nat => let (x,y) := p in x = y) _. QuickChick-2.1.0/examples/other/ProofGen.v000066400000000000000000000006531476030541200204030ustar00rootroot00000000000000From QuickChick Require Import QuickChick Tactics. From Coq Require Import Arith Lia List String. Import ListNotations. Import QcDefaultNotation. Open Scope string. Open Scope qc_scope. Inductive ty : nat -> Type := | pi : forall n i , i <= n -> ty n. Program Definition gen_ty (p : nat) : G (ty p) := bindPf (choose (0, p)) (fun m H => returnGen (pi p m _) ). Next Obligation. apply semChooseGen in H; lia. Defined. QuickChick-2.1.0/examples/other/Reflection.v000066400000000000000000000026031476030541200207530ustar00rootroot00000000000000From Coq Require Import Init.Nat Lia List. From QuickChick Require Import QuickChick CheckerProofs EnumProofs. From mathcomp Require Import ssreflect ssreflect.eqtype. Import ListNotations. Inductive Sorted : list nat -> Prop := Sorted_nil : Sorted [] | Sorted_singl x : Sorted [x] | Sorted_cons x y l : x <= y -> Sorted (y :: l) -> Sorted (x :: y :: l). (* We need to derive a checker for the <= relation as well. *) Derive DecOpt for (le x y). Derive DecOpt for (Sorted l). Instance DecOptsorted_sound l : DecOptSoundPos (Sorted l). Proof. derive_sound. Qed. Lemma sorted_2000 : Sorted (repeat 1 2000). Proof. time (repeat (first [ eapply Sorted_cons; [ apply le_n | ] | eapply Sorted_singl ])). Time Qed. (* Tactic call ran for 7.39 secs (7.36u,0.03s) (success) *) (* Finished transaction in 9.623 secs (9.623u,0.s) (successful) *) (* Switch to 5000: *) (* Tactic call ran for 79.948 secs (78.952u,0.851s) (success) *) (* Finished transaction in 326.736 secs (240.418u,1.744s) (successful) *) Lemma sorted_2000' : Sorted (repeat 1 2000). Proof. time (eapply sound with (s := 2000); compute; reflexivity). Time Qed. (* Tactic call ran for 0.05 secs (0.05u,0.s) (success) *) (* Finished transaction in 0.059 secs (0.058u,0.s) (successful) *) Lemma sorted_5000' : Sorted (repeat 1 5000). Proof. time (eapply sound with (s := 5000); compute; reflexivity). Time Qed. QuickChick-2.1.0/examples/other/TacticExample.v000066400000000000000000000374101476030541200214100ustar00rootroot00000000000000From QuickChick Require Import QuickChick. From Coq Require Import Nat Arith. Extract Constant Test.defNumTests => "1000". Definition to_be_generated := forAll arbitrary (fun x => forAll arbitrary (fun y => if (x = y)? then checker ((x = 0)?) else checker tt)). (* QuickChickDebug Debug On. *) Theorem foo : forall (x y : nat) , x < 8. Proof. quickchick. Admitted. Theorem add_comm : forall n m : nat, n + m = m + n. Proof. quickchick. Admitted. Theorem add_assoc : forall n m p : nat, n + (m + p) = (n + m) + p. Proof. quickchick. Admitted. Local Open Scope nat_scope. Theorem plus_leb_compat_l : forall (n m p : nat), (Nat.leb n m = true) -> (((p + n) <=? (p + m)) = true). Proof. quickchick. Admitted. (* ################################################################# *) Inductive bin : Type := | Z | B0 (n : bin) | B1 (n : bin) . Derive (Arbitrary, Show) for bin. Fixpoint bineq (n m : bin) : bool := match n, m with | Z, Z => true | B0 n, B0 m => bineq n m | B1 n, B1 m => bineq n m | _,_ => false end. Fixpoint incr (m:bin) : bin := match m with | Z => B1 Z | B0 m' => B1 m' | B1 m' => B0 (incr m') end. Fixpoint bin_to_nat (m:bin) : nat := match m with | Z => O | B0 m' => double (bin_to_nat m') | B1 m' => S (double (bin_to_nat m')) end. Theorem bin_to_nat_pres_incr : forall b : bin, bin_to_nat (incr b) = 1 + bin_to_nat b. Proof. quickchick. Admitted. Fixpoint nat_to_bin (n:nat) : bin := match n with | O => Z | S n' => incr (nat_to_bin n') end. Theorem nat_bin_nat : forall n, bin_to_nat (nat_to_bin n) = n. Proof. quickchick. Admitted. (* ################################################################# *) Inductive natlist : Type := | nil' | cons' (n : nat) (l : natlist). Derive Show for natlist. Derive Arbitrary for natlist. #[global] Instance Dec_eq_natlist (l l' : natlist) : Dec (l = l'). Proof. dec_eq. Defined. Fixpoint app' (l l' : natlist) : natlist := match l with | nil' => l' | cons' h l => cons' h (app' l l') end. Fixpoint rev' (l:natlist) : natlist := match l with | nil' => nil' | cons' h t => app' (rev' t) (cons' h nil') end. Fixpoint length' (l : natlist) : nat := match l with | nil' => 0 | cons' _ t => S (length' t) end. Theorem app_length : forall l1 l2 : natlist, length' (app' l1 l2) = ((length' l1) + (length' l2)). Proof. quickchick. Admitted. Theorem rev_app_distr: forall l1 l2 : natlist, rev' (app' l1 l2) = app' (rev' l2) (rev' l1). Proof. quickchick. Admitted. Theorem rev_involutive : forall l : natlist, rev' (rev' l) = l. Proof. quickchick. Admitted. Theorem rev_injective : forall (l1 l2 : natlist), rev' l1 = rev' l2 -> l1 = l2. Proof. quickchick. Admitted. (*From Coq Require Import Strings.String.*) (* ================================================================= *) Inductive ty : Type := | Ty_Bool : ty | Ty_Arrow : ty -> ty -> ty. (* ================================================================= *) Inductive tm : Type := | tm_var : string -> tm | tm_app : tm -> tm -> tm | tm_abs : string -> ty -> tm -> tm | tm_true : tm | tm_false : tm | tm_if : tm -> tm -> tm -> tm. Declare Custom Entry stlc. Notation "<{ e }>" := e (e custom stlc at level 99). Notation "( x )" := x (in custom stlc, x at level 99). Notation "x" := x (in custom stlc at level 0, x constr at level 0). Notation "S -> T" := (Ty_Arrow S T) (in custom stlc at level 50, right associativity). Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity). Notation "\ x : t , y" := (tm_abs x t y) (in custom stlc at level 90, x at level 99, t custom stlc at level 99, y custom stlc at level 99, left associativity). Coercion tm_var : string >-> tm. Notation "'Bool'" := Ty_Bool (in custom stlc at level 0). Notation "'if' x 'then' y 'else' z" := (tm_if x y z) (in custom stlc at level 89, x custom stlc at level 99, y custom stlc at level 99, z custom stlc at level 99, left associativity). Notation "'true'" := true (at level 1). Notation "'true'" := tm_true (in custom stlc at level 0). Notation "'false'" := false (at level 1). Notation "'false'" := tm_false (in custom stlc at level 0). Definition x : string := "x". Definition y : string := "y". Definition z : string := "z". #[local] Hint Unfold x : core. #[local] Hint Unfold y : core. #[local] Hint Unfold z : core. Inductive value : tm -> Prop := | v_abs : forall x T2 t1, value <{\x:T2, t1}> | v_true : value <{true}> | v_false : value <{false}>. Inductive value_set : tm -> Set := | vs_abs : forall x T2 t1, value_set <{\x : T2, t1}> | vs_true : value_set <{true}> | vs_false : value_set <{false}> . (*Derive show and Arbitrary*) Derive Show for ty. Derive Arbitrary for ty. Check elems_. #[export] Instance Gen_var : Gen string := {arbitrary := elems_ x (cons x (cons y (cons z nil)))}. #[export] Instance shrink_var : Shrink string := {shrink := fun s => match s with | "x"%string => cons y (cons z nil) | "y"%string => cons z nil | _ => nil end}. Derive Arbitrary for tm. Derive Show for tm. (*Create Dec eq instances*) #[export] Instance Dec_eq_ty (T T' : ty) : Dec (T = T'). Proof. constructor. unfold ssrbool.decidable. decide equality. Defined. #[export] Instance Dec_Eq_ty : Dec_Eq ty. Proof. constructor. intros. apply Dec_eq_ty. Defined. #[global] Instance Dec_eq_option {X} `{Dec_Eq X} (x x' : option X) : Dec (x = x'). Proof. dec_eq. Defined. #[global] Instance Dec_eq_tm (t t' : tm) : Dec (t = t'). Proof. dec_eq. Defined. #[export] Instance Dec_value (t : tm) : Dec (value t). Proof. destruct t; dec_eq; try (right; intros c; inversion c; fail); left; constructor; constructor. Defined. #[global] Hint Constructors value : core. (* ================================================================= *) Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr). Fixpoint subst (x : string) (s : tm) (t : tm) : tm := match t with | tm_var y => if String.eqb x y then s else t | <{\y:T, t1}> => if String.eqb x y then t else <{\y:T, [x:=s] t1}> | <{t1 t2}> => <{([x:=s] t1) ([x:=s] t2)}> | <{true}> => <{true}> | <{false}> => <{false}> | <{if t1 then t2 else t3}> => <{if ([x:=s] t1) then ([x:=s] t2) else ([x:=s] t3)}> end where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc). Check <{[x:=true] x}>. Print tm. Inductive substi (s : tm) (x : string) : tm -> tm -> Prop := | s_var_eq : substi s x (tm_var x) s | s_var_neq : forall y, x <> y -> substi s x (tm_var y) (tm_var y) | s_abs_eq : forall T e, substi s x (tm_abs x T e) (tm_abs x T e) | s_abs_neq : forall y T e e', x <> y -> substi s x e e' -> substi s x (tm_abs y T e) (tm_abs y T e') | s_app : forall f y f' y', substi s x f f' -> substi s x y y' -> substi s x (tm_app f y) (tm_app f' y') | s_true : substi s x tm_true tm_true | s_false : substi s x tm_false tm_false | s_if : forall b b' t t' f f', substi s x b b' -> substi s x t t' -> substi s x f f' -> substi s x (tm_if b t f) (tm_if b' t' f') . #[global] Hint Constructors substi : core. (*Derive show and arbitrary*) Ltac gen x := generalize dependent x. #[export] Instance Dec_Eq_tm : Dec_Eq tm. Proof. dec_eq. Defined. Theorem substi_exists : forall s x t, { t' | substi s x t t'}. Proof. intros s x0 t; induction t; intros; eauto. - destruct (dec_eq x0 s0); subst; eauto. - destruct IHt1, IHt2; eauto. - destruct (dec_eq x0 s0), IHt; subst; eauto. - destruct IHt1, IHt2, IHt3; eauto. Qed. Theorem substi_uniq : forall s x t t' t'', substi s x t t' -> substi s x t t'' -> t' = t''. Proof. intros s x t. induction t; intros; inversion H0; inversion H; subst; eauto; try (exfalso; eauto; fail). - f_equal. + apply IHt1; auto. + apply IHt2; auto. - f_equal; apply IHt; auto. - f_equal. + apply IHt1; auto. + apply IHt2; auto. + apply IHt3; auto. Qed. #[export] Instance Dec_substi (s : tm) (x : string) (t t' : tm) : Dec (substi s x t t'). Proof with try (right; intros c; inversion c; subst; eauto; fail). dec_eq. gen t'. gen x. gen s. induction t; intros; try (right; intros c; inversion c; fail). - destruct (dec_eq x0 s). + subst. destruct (dec_eq s0 t'); subst... left; constructor. + destruct (dec_eq (tm_var s) t'); subst... left; constructor; auto. - destruct (substi_exists s x0 t1), (substi_exists s x0 t2). destruct (dec_eq (tm_app x1 x2) t'). + subst. auto. + right. intros c. assert (substi s x0 <{t1 t2}> <{x1 x2}>) by (econstructor; eauto). eapply substi_uniq in H; eauto. - destruct (dec_eq x0 s). + subst. destruct (dec_eq (<{ \ s : t, t0 }>) t'); subst... left; constructor. + destruct (substi_exists s0 x0 t0). destruct (dec_eq <{ \s : t, x1 }> t'); subst; auto. right. intros c. assert (substi s0 x0 <{\s : t, t0}> <{\s : t, x1}>) by (econstructor; eauto). eapply substi_uniq in H; eauto. - destruct (dec_eq tm_true t'); subst... left; auto. - destruct (dec_eq tm_false t'); subst... left; auto. - destruct (substi_exists s x0 t1), (substi_exists s x0 t2), (substi_exists s x0 t3). destruct (dec_eq (tm_if x1 x2 x3) t'). + subst; auto. + right; intros c; assert (substi s x0 (tm_if t1 t2 t3) (tm_if x1 x2 x3)) by (econstructor; eauto). eapply substi_uniq in H; eauto. Defined. (* In the test suite we mainly care that this runs at all, so we lower Test.defNumTests to not waste 5 sec per test. *) (* Even though most of the tests are discarded. *) Extract Constant Test.defNumTests => "100". Theorem substi_correct_l : forall s x (ts t' : tm), subst x s ts = t' -> substi s x ts t'. Proof. quickchick. Admitted. Theorem substi_correct_r : forall s x (ts t' : tm), substi s x ts t' -> subst x s ts = t'. Proof. quickchick. Admitted. (* ================================================================= *) Reserved Notation "t '-->' t'" (at level 40). Inductive step : tm -> tm -> Prop := | ST_AppAbs : forall x T2 t1 v2, value v2 -> <{(\x:T2, t1) v2}> --> <{ [x:=v2]t1 }> | ST_App1 : forall t1 t1' t2, t1 --> t1' -> <{t1 t2}> --> <{t1' t2}> | ST_App2 : forall v1 t2 t2', value v1 -> t2 --> t2' -> <{v1 t2}> --> <{v1 t2'}> | ST_IfTrue : forall t1 t2, <{if true then t1 else t2}> --> t1 | ST_IfFalse : forall t1 t2, <{if false then t1 else t2}> --> t2 | ST_If : forall t1 t1' t2 t3, t1 --> t1' -> <{if t1 then t2 else t3}> --> <{if t1' then t2 else t3}> where "t '-->' t'" := (step t t'). Derive DecOpt for (step t t'). Reserved Notation "Gamma '|--' t '\in' T" (at level 101, t custom stlc, T custom stlc at level 0). (* Print Grammar constr. *) Definition t_update (Gamma : string -> option ty) (x : string) (T : ty) (x' : string) : option ty := if (x = x')? then Some T else Gamma x'. Inductive has_type : (string -> option ty) -> tm -> ty -> Prop := | T_Var : forall Gamma x T1, Gamma x = Some T1 -> Gamma |-- x \in T1 | T_Abs : forall Gamma x T1 T2 t1, t_update Gamma x T2 |-- t1 \in T1 -> Gamma |-- \x:T2, t1 \in (T2 -> T1) | T_App : forall T1 T2 Gamma t1 t2, Gamma |-- t1 \in (T2 -> T1) -> Gamma |-- t2 \in T2 -> Gamma |-- t1 t2 \in T1 | T_True : forall Gamma, Gamma |-- true \in Bool | T_False : forall Gamma, Gamma |-- false \in Bool | T_If : forall t1 t2 t3 T1 Gamma, Gamma |-- t1 \in Bool -> Gamma |-- t2 \in T1 -> Gamma |-- t3 \in T1 -> Gamma |-- if t1 then t2 else t3 \in T1 where "Gamma '|--' t '\in' T" := (has_type Gamma t T). Print tm. Definition bindop {A B} (ma : option A) (f : A -> option B) : option B := match ma with | None => None | Some a => f a end. Print ty. Fixpoint type_eqb (T T' : ty) : bool := match T, T' with | Ty_Bool, Ty_Bool => true | Ty_Arrow l r, Ty_Arrow l' r' => (type_eqb l l') && (type_eqb r r') | _, _ => false end. Theorem type_eq_eqb : forall T T', type_eqb T T' = true <-> T = T'. Proof. induction T; intros; destruct T'; simpl in *; split; intros; auto; try discriminate. - rewrite Bool.andb_true_iff in H. destruct H. apply IHT1 in H. apply IHT2 in H0. subst; auto. - injection H as H. subst; simpl; auto. assert (forall T, type_eqb T T = true). + induction T; simpl; auto. rewrite IHT3, IHT4; auto. + do 2 rewrite H. auto. Qed. Fixpoint type_of (Gamma : string -> option ty) (t : tm) : option ty := match t with | tm_var s => Gamma s | tm_abs x T e => bindop (type_of (t_update Gamma x T) e) (fun T' => Some <{T -> T'}>) | tm_app f e => bindop (type_of Gamma f) (fun T21 => match T21 with | <{T2 -> T1}> => bindop (type_of Gamma e) (fun T2' => if type_eqb T2 T2' then Some T1 else None ) | _ => None end ) | tm_true | tm_false => Some Ty_Bool | tm_if b t f => bindop (type_of Gamma b) (fun Tb => bindop (type_of Gamma t) (fun Tt => bindop (type_of Gamma f) (fun Tf => if andb (type_eqb Tb Ty_Bool) (type_eqb Tt Tf) then Some Tt else None ))) end. Theorem type_of_correct : forall Gamma t T, type_of Gamma t = Some T -> has_type Gamma t T. Proof. intros. gen Gamma; gen T. induction t; intros; simpl 1 in *. - constructor; auto. - destruct (type_of Gamma t1) eqn: E. + simpl in H. rewrite E in H. simpl in H. destruct t; try discriminate. destruct (type_of Gamma t2) eqn: E'; try discriminate. simpl in *. destruct (type_eqb t3 t) eqn: E''; try discriminate. injection H as H. subst. apply type_eq_eqb in E''. subst. apply IHt2 in E'. apply IHt1 in E. econstructor; eauto. + simpl in H. rewrite E in *. discriminate. - simpl in *. unfold bindop in H. destruct (type_of (t_update Gamma s t) t0) eqn: E; try discriminate. injection H as H; subst. constructor. apply IHt. apply E. - injection H as H; subst. constructor. - injection H as H; subst; constructor. - simpl in H. destruct (type_of Gamma t1) eqn: E; destruct (type_of Gamma t2) eqn: E'; destruct (type_of Gamma t3) eqn: E''; simpl in H; try discriminate. apply IHt1 in E. apply IHt2 in E'. apply IHt3 in E''. destruct (type_eqb t <{ Bool }> && type_eqb t0 t4)%bool eqn: E'''; try discriminate. injection H as H; subst. apply Bool.andb_true_iff in E'''. destruct E'''. apply type_eq_eqb in H, H0. subst. constructor; auto. Qed. Definition decopt_has_type (Gamma : string -> option ty) (t : tm) (T : ty) (n : nat) : option bool := bindop (type_of Gamma t) (fun T' => Some ((T = T')?)). #[export] Instance DecOpt_has_type (Gamma : string -> option ty) (t : tm) (T : ty) : DecOpt (has_type Gamma t T). Proof. constructor. apply decopt_has_type; auto. Defined. #[global] Hint Constructors has_type : core. Definition empty_env : string -> option ty := fun _ => None. Lemma canonical_forms_bool : forall term, empty_env |-- term \in Bool -> value term -> (term = <{true}>) \/ (term = <{false}>). Proof. quickchick. Admitted. (* Quantifying over the type string -> option for Gamma causes bug. Failure(id_of_name called with anonymous). Lemma weakening_empty : forall Gamma e T, empty_env |-- e \in T -> has_type Gamma e T. Proof. quickchick. Admitted. *) (* Dep case not handled yet for exists Theorem progress : forall e T, empty_env |-- e \in T -> value e \/ exists e', e --> e'. Proof. quickchick. Admitted. *) Theorem preservation : forall e e' T, empty_env |-- e \in T -> e --> e' -> empty_env |-- e' \in T. Proof. quickchick. Admitted. QuickChick-2.1.0/examples/other/TacticExampleX.v.cppo000066400000000000000000000001631476030541200224730ustar00rootroot00000000000000#if COQ_VERSION >= (8,16,0) #include "TacticExample.v" #else (* This example does not work with Coq 8.15 *) #endif QuickChick-2.1.0/examples/other/dependentProofs.v000066400000000000000000000303351476030541200220230ustar00rootroot00000000000000From QuickChick Require Import QuickChick Tactics Instances Classes DependentClasses. Require Import String. Open Scope string. Require Import List. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq. Import ListNotations. Import QcDefaultNotation. Open Scope qc_scope. Set Bullet Behavior "Strict Subproofs". (* Typeclasses eauto := debug. *) Require Import DependentTest. (* XXX these instances should be present *) Existing Instance GenSizedFoo. Existing Instance ShrinkFoo. Derive GenSized for Foo. Inductive tree : Type := | Leaf : tree | Node : nat -> tree -> tree -> tree. (* Example with two IH *) Inductive goodTree : nat -> tree -> Prop := | GL : goodTree 0 Leaf | GN : forall k t1 t2 n m, goodTree n t1 -> goodTree m t2 -> goodTree m t1 -> goodTree (S n) (Node k t1 t2). (* Derive DecOpt for (goodTree n t). *) Instance DecgoodTree (n : nat) (t : tree) : Dec (goodTree n t). Admitted. Instance DecTreeEq (t1 t2 : tree) : Dec (t1 = t2). dec_eq. Defined. Existing Instance GenOfGenSized. Existing Instance genNatSized. Derive ArbitrarySizedSuchThat for (fun foo => goodTree n foo). QuickChickDebug Debug On. Derive SizedProofEqs for (fun foo => goodTree n foo). Derive SizeMonotonicSuchThatOpt for (fun foo => goodTree n foo). Derive GenSizedSuchThatCorrect for (fun foo => goodTree n foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodTree n foo). Definition genSTgooTree (n : nat) := @arbitraryST _ (fun foo => goodTree n foo) _. (* Definition genSTgooTreeSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => goodTree n foo) _) _. *) Existing Instance GenSizedSuchThatgoodFooUnif. (* ???? *) Derive SizeMonotonicSuchThatOpt for (fun (x : Foo) => goodFooUnif input x). Derive SizedProofEqs for (fun foo => goodFooUnif n foo). Derive GenSizedSuchThatCorrect for (fun foo => goodFooUnif n foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooUnif n foo). Definition genSTgoodFooUnif (n : nat) := @arbitraryST _ (fun foo => goodFooUnif n foo) _. Definition genSTgoodFooUnifSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => goodFooUnif n foo) _) _. (* Interesting. Do we need Global instance?? *) Existing Instance GenSizedSuchThatgoodFooNarrow. (* Why???? *) Derive SizeMonotonicSuchThatOpt for (fun foo => goodFooNarrow n foo). Derive SizedProofEqs for (fun foo => goodFooNarrow n foo). Derive GenSizedSuchThatCorrect for (fun foo => goodFooNarrow n foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooNarrow n foo). Definition genSTgoodFooNarrow (n : nat) := @arbitraryST _ (fun foo => goodFooNarrow n foo) _. Definition genSTgoodFooNarrowSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => goodFooNarrow n foo) _) _. Existing Instance GenSizedSuchThatgoodFooCombo. Derive SizeMonotonicSuchThatOpt for (fun foo => goodFooCombo n foo). Derive SizedProofEqs for (fun foo => goodFooCombo n foo). Derive GenSizedSuchThatCorrect for (fun foo => goodFooCombo n foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooCombo n foo). Definition genSTgoodFooCombo (n : nat) := @arbitraryST _ (fun foo => goodFooCombo n foo) _. Definition genSTgoodFooComboSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => goodFooCombo n foo) _) _. Existing Instance GenSizedSuchThatgoodFoo. Derive SizeMonotonicSuchThatOpt for (fun (x : Foo) => goodFoo input x). Derive SizedProofEqs for (fun (x : Foo) => goodFoo input x). Derive GenSizedSuchThatCorrect for (fun foo => goodFoo n foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFoo n foo). Definition genSTgoodFoo (n : nat) := @arbitraryST _ (fun foo => goodFoo n foo) _. Definition genSTgoodFooSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => goodFoo n foo) _) _. Existing Instance GenSizedSuchThatgoodFooPrec. (* ???? *) Derive SizeMonotonicSuchThatOpt for (fun (x : Foo) => goodFooPrec input x). Derive SizedProofEqs for (fun (x : Foo) => goodFooPrec input x). Derive GenSizedSuchThatCorrect for (fun foo => goodFooPrec n foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooPrec n foo). Definition genSTgoodFooPrec (n : nat) := @arbitraryST _ (fun foo => goodFooPrec n foo) _. Definition genSTgoodFooPrecSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => goodFooPrec n foo) _) _. Existing Instance GenSizedSuchThatgoodFooMatch. (* ???? *) Derive SizeMonotonicSuchThatOpt for (fun foo => goodFooMatch n foo). Derive SizedProofEqs for (fun foo => goodFooMatch n foo). Derive GenSizedSuchThatCorrect for (fun foo => goodFooMatch n foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooMatch n foo). Definition genSTgoodFooMatch (n : nat) := @arbitraryST _ (fun foo => goodFooMatch n foo) _. Definition genSTgoodFooMatchSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => goodFooMatch n foo) _) _. Existing Instance GenSizedSuchThatgoodFooRec. (* ???? *) Derive SizeMonotonicSuchThatOpt for (fun (x : Foo) => goodFooRec input x). Derive SizedProofEqs for (fun (x : Foo) => goodFooRec input x). Derive GenSizedSuchThatCorrect for (fun foo => goodFooRec n foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooRec n foo). Definition genSTgoodFooRec (n : nat) := @arbitraryST _ (fun foo => goodFooRec n foo) _. Definition genSTgoodFooRecSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => goodFooRec n foo) _) _. Inductive goodFooB : nat -> Foo -> Prop := | GF1 : goodFooB 2 (Foo2 Foo1) | GF2 : goodFooB 3 (Foo2 (Foo2 Foo1)). Derive ArbitrarySizedSuchThat for (fun (x : Foo) => goodFooB input x). Derive SizedProofEqs for (fun (x : Foo) => goodFooB input x). Derive SizeMonotonicSuchThatOpt for (fun foo => goodFooB n foo). Derive GenSizedSuchThatCorrect for (fun foo => goodFooB n foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooB n foo). Definition genSTgoodFooB (n : nat) := @arbitraryST _ (fun foo => goodFooB n foo) _. Definition genSTgoodFooBSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => goodFooB n foo) _) _. (* Derive SizeMonotonicSuchThat for (fun foo => goodTree n foo). *) (* XXX bug for | GL : goodTree 0 Leaf | GN : forall k t1 t2 n, goodTree n t1 -> ~ t1 = t2 ->υ (* goodTree m t1 -> *) goodTree (S n) (Node k t1 t2). *) Inductive LRTree : tree -> Prop := | PLeaf : LRTree Leaf | PNode : forall m t1 t2, ~ t1 = Node 2 Leaf Leaf -> ~ Node 4 Leaf Leaf = t1 -> LRTree t1 -> LRTree t2 -> LRTree (Node m t1 t2). Derive ArbitrarySizedSuchThat for (fun (x : tree) => LRTree x). (* XXX sucThatMaybe case *) Instance DecidableLRTree t : Dec (LRTree t). Proof. Admitted. Derive SizedProofEqs for (fun (x : tree) => LRTree x). Derive SizeMonotonicSuchThatOpt for (fun foo => LRTree foo). Derive GenSizedSuchThatCorrect for (fun foo => LRTree foo). Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => LRTree foo). Definition genSTLRTree (n : nat) := @arbitraryST _ (fun foo => LRTree foo) _. Definition genSTLRTreeSound (n : nat) := @STCorrect _ _ (@arbitraryST _ (fun foo => LRTree foo) _) _. Inductive HeightTree : nat -> tree -> Prop := | HLeaf : forall n, HeightTree n Leaf | HNode : forall t1 t2 n m, HeightTree n t1 -> HeightTree n t2 -> HeightTree (S n) (Node m t1 t2). Instance ArbitrarySuchThatEql {A} (x : A) : GenSuchThat A (fun y => eq x y) := {| arbitraryST := returnGen (Some x) |}. (* XXX breaks gen *) (* Inductive ex_test : tree -> Prop := *) (* | B : ex_test Leaf *) (* | Ind : *) (* forall (list y12 : nat) t, *) (* list = y12 -> *) (* ex_test (Node 4 t t). *) (* Derive ArbitrarySizedSuchThat for (fun (x : tree) => ex_test x). *) (* Set Printing All. *) (* Inductive LRTree : tree -> Prop := *) (* | PLeaf : LRTree Leaf *) (* | PNode : *) (* forall m t1 t2, *) (* Node 2 Leaf Leaf = t1 -> *) (* t1 = Node 2 Leaf Leaf -> *) (* LRTree t1 -> *) (* LRTree t2 -> *) (* LRTree (Node m t1 t2). *) (* Inductive test : nat -> Foo -> Prop := *) (* | T : forall (x : False), test 1 Foo1. *) (* Derive ArbitrarySizedSuchThat for (fun foo => test n foo). *) (* Inductive test1 : bool -> Foo -> Prop := *) (* | T1 : forall (x1 x2 x3 : bool), x1 = x3 -> test1 x2 Foo1. *) (* Derive ArbitrarySizedSuchThat for (fun foo => test1 n foo). *) (* Inductive test2 : nat -> Foo -> Prop := *) (* | T2 : forall (x1 x2 : bool), x1 = x2 -> test2 1 Foo1. *) (* Derive ArbitrarySizedSuchThat for (fun foo => test2 n foo). *) (* XXX weird bug when naming binders with name of already existing ids, e.g. nat, list*) (* Inductive HeightTree : nat -> tree -> Prop := *) (* | HLeaf : forall n, HeightTree n Leaf *) (* | HNode : *) (* forall t1 t2 n k m, *) (* k = 3 -> *) (* HeightTree k t2 -> *) (* HeightTree k t1 -> *) (* HeightTree n (Node m t1 t2). *) (* Inductive goodTree : nat -> tree -> Prop := *) (* | GL : goodTree 0 Leaf *) (* | GN : forall k t1 t2 n m, goodTree n t1 -> *) (* goodTree m t2 -> *) (* goodTree (n + m + 1) (Node k t1 t2). *) (* Lemma test2 {A} (gs1 gs2 : nat -> list (nat * G (option A))) s s1 s2 : *) (* \bigcup_(g in gs1 s1) (semGenSize (snd g) s) \subset \bigcup_(g in gs2 s2) (semGenSize (snd g) s) -> *) (* semGenSize (backtrack (gs1 s1)) s \subset semGenSize (backtrack (gs2 s2)) s. *) (* Admitted. *) (* Goal (forall inp : nat, SizedMonotonic (@arbitrarySizeST Foo (fun (x : Foo) => goodFooRec inp x) _)). *) (* Proof. *) (* intros inp. *) (* constructor. *) (* intros s s1 s2. *) (* revert inp. *) (* induction s1; induction s2; intros. *) (* - simpl. eapply subset_refl. *) (* - simpl. *) (* refine (test *) (* (fun s => [(1, returnGen (Some Foo1))]) *) (* (fun s => [(1, returnGen (Some Foo1)); *) (* (1, *) (* doM! foo <- *) (* (fix aux_arb (size0 input0_ : nat) {struct size0} : *) (* G (option Foo) := *) (* match size0 with *) (* | 0 => backtrack [(1, returnGen (Some Foo1))] *) (* | size'.+1 => *) (* backtrack *) (* [(1, returnGen (Some Foo1)); *) (* (1, doM! foo <- aux_arb size' 0; returnGen (Some (Foo2 foo)))] *) (* end) s 0; returnGen (Some (Foo2 foo)))]) *) (* s 0 s2 _). *) (* admit. *) (* - ssromega. *) (* - simpl. *) (* refine (test *) (* (fun s => [(1, returnGen (Some Foo1)); *) (* (1, *) (* doM! foo <- *) (* (fix aux_arb (size0 input0_ : nat) {struct size0} : *) (* G (option Foo) := *) (* match size0 with *) (* | 0 => backtrack [(1, returnGen (Some Foo1))] *) (* | size'.+1 => *) (* backtrack *) (* [(1, returnGen (Some Foo1)); *) (* (1, doM! foo <- aux_arb size' 0; returnGen (Some (Foo2 foo)))] *) (* end) s 0; returnGen (Some (Foo2 foo)))]) *) (* (fun s => [(1, returnGen (Some Foo1)); *) (* (1, *) (* doM! foo <- *) (* (fix aux_arb (size0 input0_ : nat) {struct size0} : *) (* G (option Foo) := *) (* match size0 with *) (* | 0 => backtrack [(1, returnGen (Some Foo1))] *) (* | size'.+1 => *) (* backtrack *) (* [(1, returnGen (Some Foo1)); *) (* (1, doM! foo <- aux_arb size' 0; returnGen (Some (Foo2 foo)))] *) (* end) s 0; returnGen (Some (Foo2 foo)))]) *) (* s s1 s2 _). *) (* admit. *) Definition success := "Proofs work!". Print success. QuickChick-2.1.0/examples/other/dune000066400000000000000000000010201476030541200173400ustar00rootroot00000000000000(coq.theory (name QuickChick.Examples.Other) (theories QuickChick) (modules BSTTest DependentTest ; dependentProofs ; broken enumProofs ; enumSTProofs ; broken ; Fuzz ; broken ; genProofs ; broken MergeExample PluginTest ProofGen ; Reflection ; slow TacticExampleX tagging ; zoo ; broken )) (rule (alias compat) (target TacticExampleX.v) (action (run sh %{dep:../../scripts/mycppo} %{dep:TacticExampleX.v.cppo} %{target})) (deps TacticExample.v)) QuickChick-2.1.0/examples/other/enumProofs.v000066400000000000000000000045151476030541200210220ustar00rootroot00000000000000From QuickChick Require Import QuickChick Tactics TacticsUtil Instances Classes DependentClasses Sets EnumProofs. Require Import String. Open Scope string. From Coq Require Import List Lia. From Ltac2 Require Import Ltac2. Import ListNotations. Import QcDefaultNotation. Open Scope qc_scope. Set Warnings "-notation-overridden". From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq. Set Bullet Behavior "Strict Subproofs". (** Examples *) Inductive tree A : Type := | Leaf : A -> tree A | Leaf' : A -> A -> tree A | Node : A -> tree A -> tree A -> tree A. Derive EnumSized for tree. #[local] Instance EnumTree_SizedMonotonic A {_ : Enum A} : SizedMonotonic (@enumSized _ (@EnumSizedtree A _)). Proof. derive_enum_SizedMonotonic (). Qed. #[local] Instance EnumTree_SizeMonotonic A `{EnumMonotonic A} : forall s, SizeMonotonic (@enumSized _ (@EnumSizedtree A _) s). Proof. derive_enum_SizeMonotonic (). Qed. #[local] Instance EnumTree_correct A `{EnumMonotonicCorrect A} : CorrectSized (@enumSized _ (@EnumSizedtree A _)). Proof. derive_enum_Correct (). Qed. Inductive Foo : Type := | Bar. Derive EnumSized for Foo. #[local] Instance EnumFoo_SizedMonotonic : SizedMonotonic (@enumSized _ EnumSizedFoo). Proof. derive_enum_SizedMonotonic (). Qed. #[local] Instance EnumFoo_SizeMonotonic : forall s, SizeMonotonic (@enumSized _ EnumSizedFoo s). Proof. derive_enum_SizeMonotonic (). Qed. #[local] Instance EnumFoo_correct : CorrectSized (@enumSized _ EnumSizedFoo). Proof. derive_enum_Correct (). Qed. Inductive Foo2 A : Type := | Bar1 | Bar2 : A -> Foo2 A. Derive EnumSized for Foo2. #[local] Instance EnumFoo2_SizedMonotonic A {_ : Enum A} : SizedMonotonic (@enumSized _ (@EnumSizedFoo2 A _)). Proof. derive_enum_SizedMonotonic (). Qed. #[local] Instance EnumFoo2_SizeMonotonic A `{EnumMonotonic A} : forall s, SizeMonotonic (@enumSized _ (@EnumSizedFoo2 A _) s). Proof. derive_enum_SizeMonotonic (). Qed. #[local] Instance EnumFoo2_correct A `{EnumMonotonicCorrect A} : CorrectSized (@enumSized _ (@EnumSizedFoo2 A _)). Proof. derive_enum_Correct (). Qed. (* Example with two IH *) Inductive goodTree : nat -> tree nat -> Prop := | GL : goodTree 0 (Leaf nat 0) | GN : forall k t1 t2 n m, goodTree n t1 -> goodTree m t2 -> goodTree m t1 -> goodTree (S n) (Node nat k t1 t2). QuickChick-2.1.0/examples/other/enumSTProofs.v000066400000000000000000000170241476030541200212700ustar00rootroot00000000000000From QuickChick Require Import QuickChick Tactics TacticsUtil Instances Classes DependentClasses CheckerProofs EnumProofs. Require Import String. Open Scope string. Require Import List micromega.Lia. Require Import enumProofs. Import ListNotations. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq. From Ltac2 Require Import Ltac2. #[local] Open Scope set_scope. Inductive square_of : nat -> nat -> Prop := sq : forall n m, m = n * n -> square_of n m. Derive EnumSizedSuchThat for (fun x => square_of x n). Inductive tree1 := | Leaf1 : tree1 | Node1 : nat -> tree1 -> tree1 -> tree1. Inductive perfect' : nat -> tree1 -> Prop := | PerfectLeaf : perfect' 0 Leaf1 | PerfectNode : forall x l r n, perfect' n l -> perfect' n r -> perfect' (S n) (Node1 x l r). Derive DecOpt for (perfect' n t). Derive EnumSizedSuchThat for (fun n => perfect' n t). Inductive perfect : tree1 -> Prop := | Perfect : forall n t, perfect' n t -> perfect t. Derive DecOpt for (perfect t). Lemma semProdSizeOpt_bicupNone A s (S : set A) : (\bigcup_(x in [:: returnEnum (@None A)]) semProdSizeOpt x s \subset S). Proof. intros x Hin. inv Hin. inv H. inv H0. - inv H1. congruence. inv H. - inv H. Qed. Set Bullet Behavior "Strict Subproofs". Inductive In' {A} : A -> list A -> Prop := | In_hd : forall x l, In' x (cons x l) | In_tl : forall x y l, In' x l -> In' x (cons y l). Derive DecOpt for (In' a l). Instance DecOptIn'_listSizeMonotonic A {_ : Enum A} {_ : Dec_Eq A} (x : A) (l : list A) : DecOptSizeMonotonic (In' x l). Proof. derive_mon (). Qed. Instance DecOptIn'_list_sound A {_ : Enum A} {_ : Dec_Eq A} (x : A) (l : list A) : DecOptSoundPos (In' x l). Proof. derive_sound (). Qed. Instance DecOptIn'_list_complete A {_ : Enum A} {_ : Dec_Eq A} (x : A) (l : list A) : DecOptCompletePos (In' x l). Proof. derive_complete (). Qed. Derive ArbitrarySizedSuchThat for (fun x => In' x l). Derive EnumSizedSuchThat for (fun x => In' x l). Instance EnumSizedSuchThatIn'_SizedMonotonic A {_ : Enum A} {_ : Dec_Eq A} l : SizedMonotonicOpt (@enumSizeST A _ (EnumSizedSuchThatIn' l)). Proof. derive_enumST_SizedMonotonic (). Qed. Instance EnumSizedSuchThatIn'_SizeMonotonic A {_ : Enum A} {_ : Dec_Eq A} (* `{EnumMonotonic A} *) l : forall s, SizeMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThatIn' l) s). Proof. derive_enumST_SizeMonotonic (). Qed. Instance EnumSizedSuchThatIn'_Correct A {_ : Enum A} {_ : Dec_Eq A} (* `{EnumMonotonicCorrect A} *) l : CorrectSizedST (fun x => In' x l) (@enumSizeST _ _ (EnumSizedSuchThatIn' l)). Proof. derive_enumST_Correct (). Admitted. (* TODO *) Derive EnumSizedSuchThat for (fun l => In' x l). Inductive bst : nat -> nat -> tree1 -> Prop := | BstLeaf : forall n1 n2, bst n1 n2 Leaf1 | BstNode : forall min max n t1 t2, le min max -> le min n -> le n max -> bst min n t1 -> bst n max t2 -> bst min max (Node1 n t1 t2). Derive DecOpt for (le min max). Derive EnumSizedSuchThat for (fun m => le n m). Derive EnumSizedSuchThat for (fun t => bst min max t). Derive ArbitrarySizedSuchThat for (fun m => le n m). Derive ArbitrarySizedSuchThat for (fun t => bst min max t). Derive DecOpt for (bst min max t). Instance EnumSizedSuchThatle_SizedAMonotonic n : SizedMonotonicOptFP (@enumSizeST _ _ (@EnumSizedSuchThatle n)). Proof. derive_enumST_SizedMonotonicFP (). Qed. Instance EnumSizedSuchThatle_SizedMonotonic n : SizedMonotonicOpt (@enumSizeST _ _ (@EnumSizedSuchThatle n)). Proof. derive_enumST_SizedMonotonic (). Qed. Instance EnumSizedSuchThatle_SizeMonotonic n : forall s, SizeMonotonicOpt (@enumSizeST _ _ (@EnumSizedSuchThatle n) s). Proof. derive_enumST_SizeMonotonic (). Qed. Instance EnumSizedSuchThatle_SizeMonotonicFP n : forall s, SizeMonotonicOptFP (@enumSizeST _ _ (@EnumSizedSuchThatle n) s). Proof. derive_enumST_SizeMonotonicFP (). Qed. (* XXX predicate must be eta expanded, otherwise typeclass resolution fails *) Instance EnumSizedSuchThatle_Correct n : CorrectSizedST [eta le n] (@enumSizeST _ _ (@EnumSizedSuchThatle n)). Proof. derive_enumST_Correct (). Qed. Instance EnumSizedSuchThatbst_SizedMonotonicFP min max : SizedMonotonicOptFP (@enumSizeST _ _ (@EnumSizedSuchThatbst min max)). Proof. derive_enumST_SizedMonotonicFP (). Qed. Instance EnumSizedSuchThatbst_SizedMonotonic min max : SizedMonotonicOpt (@enumSizeST _ _ (@EnumSizedSuchThatbst min max)). Proof. derive_enumST_SizedMonotonic (). Qed. Instance EnumSizedSuchThatbst_SizeMonotonic min max : forall s, SizeMonotonicOpt (@enumSizeST _ _ (@EnumSizedSuchThatbst min max) s). Proof. derive_enumST_SizeMonotonic (). Qed. Instance EnumSizedSuchThatbst_SizeMonotonicFP min max : forall s, SizeMonotonicOptFP (@enumSizeST _ _ (@EnumSizedSuchThatbst min max) s). Proof. derive_enumST_SizeMonotonicFP (). Qed. Instance EnumSizedSuchThatbst_Correct n m : CorrectSizedST (bst n m) (@enumSizeST _ _ (@EnumSizedSuchThatbst n m)). Proof. derive_enumST_Correct (). Qed. (* XXX missing enum list instances. *) (* Instance EnumSizedSuchThatIn'0_SizedMonotonic A {_ : Enum A} x : *) (* SizedMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThatIn'0 x)). *) (* Proof. derive_enumST_SizedMonotonic (). Qed. *) Inductive ltest : list nat -> nat -> Prop := | ltestnil : ltest [] 0 | ltestcons : forall x m' m l, (m' + 1) = m -> (* In' m' l -> *) ltest l m' -> ltest (x :: l) m. Derive EnumSizedSuchThat for (fun n => eq x n). Derive EnumSizedSuchThat for (fun n => eq n x). Derive DecOpt for (ltest l n). Instance DecOptltest_listSizeMonotonic l x : DecOptSizeMonotonic (ltest l x). Proof. derive_mon (). Qed. Instance DecOptltest_listsound l x : DecOptSoundPos (ltest l x). Proof. derive_sound (). Qed. Instance DecOptIn'ltest_complete A {_ : Enum A} {_ : Dec_Eq A} x l : DecOptCompletePos (ltest x l). Proof. derive_complete (). Qed. (* Set Typeclasses Debug. *) (* QuickChickDebug Debug On. *) (* XXX error *) (* Derive EnumSizedSuchThat for (fun l => ltest l n). *) Inductive goodTree : nat -> tree nat -> Prop := | GL : forall a, goodTree 0 (Leaf nat a) | GN : forall k t1 t2 n (* m : nat)*), (* le m n -> *) goodTree n t1 -> goodTree n t1 -> goodTree (S n) (Node nat k t1 t2). Derive DecOpt for (goodTree n t). (* XXX this fails if tree has type param A ... *) Instance DecOptgoodTree_listSizeMonotonic n t : DecOptSizeMonotonic (goodTree n t). Proof. derive_mon (). Qed. Instance DecOptgoodTree_list_sound n t : DecOptSoundPos (goodTree n t). Proof. derive_sound (). Qed. Instance DecOptgoodTree_list_complete n t : DecOptCompletePos (goodTree n t). Proof. derive_complete (). Qed. Derive EnumSizedSuchThat for (fun t => goodTree k t). Instance EnumSizedSuchThatgoodTree_SizedMonotonic n : SizedMonotonicOpt (@enumSizeST _ _ (@EnumSizedSuchThatgoodTree n)). Proof. derive_enumST_SizedMonotonic (). Qed. Instance EnumSizedSuchThatgoodTree_SizeMonotonic n : forall s, SizeMonotonicOpt (@enumSizeST _ _ (@EnumSizedSuchThatgoodTree n) s). Proof. derive_enumST_SizeMonotonic (). Qed. Instance EnumSizedSuchThatgoodTree_SizedMonotonicFP n : SizedMonotonicOptFP (@enumSizeST _ _ (@EnumSizedSuchThatgoodTree n)). Proof. derive_enumST_SizedMonotonicFP (). Qed. Instance EnumSizedSuchThatgoodTree_SizeMonotonicFP n : forall s, SizeMonotonicOptFP (@enumSizeST _ _ (@EnumSizedSuchThatgoodTree n) s). Proof. derive_enumST_SizeMonotonicFP (). Qed. Instance EnumSizedSuchThatgoodTree_Correct n : CorrectSizedST (goodTree n) (@enumSizeST _ _ (@EnumSizedSuchThatgoodTree n)). Proof. derive_enumST_Correct (). Qed. QuickChick-2.1.0/examples/other/genProofs.v000066400000000000000000000050431476030541200206240ustar00rootroot00000000000000From QuickChick Require Import QuickChick Tactics TacticsUtil Instances Classes DependentClasses Sets. Require Import String. Open Scope string. Require Import List micromega.Lia. From Ltac2 Require Import Ltac2. Import ListNotations. Import QcDefaultNotation. Open Scope qc_scope. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq. Set Bullet Behavior "Strict Subproofs". Inductive tree A : Type := | Leaf : A -> tree A | Leaf' : A -> A -> tree A | Node : A -> tree A -> tree A -> tree A. Derive GenSized for tree. Instance GenTree_SizedMonotonic A {_ : Gen A} : SizedMonotonic (@arbitrarySized _ (@GenSizedtree A _)). Proof. derive_gen_SizedMonotonic (). Qed. Instance GenTree_SizeMonotonic A `{GenMonotonic A} : forall s, SizeMonotonic (@arbitrarySized _ (@GenSizedtree A _) s). Proof. derive_gen_SizeMonotonic (). Qed. Instance GenTree_correct A `{GenMonotonicCorrect A} : CorrectSized (@arbitrarySized _ (@GenSizedtree A _)). Proof. derive_gen_Correct (). Qed. Inductive tree1 := | Leaf1 : tree1 | Node1 : nat -> tree1 -> tree1 -> tree1. Inductive bst : nat -> nat -> tree1 -> Prop := | BstLeaf : forall n1 n2, bst n1 n2 Leaf1 | BstNode : forall min max n t1 t2, le min max -> le min n -> le n max -> bst min n t1 -> bst n max t2 -> bst min max (Node1 n t1 t2). Derive EnumSizedSuchThat for (fun m => le n m). Derive ArbitrarySizedSuchThat for (fun m => le n m). Derive DecOpt for (bst min max t). Derive EnumSizedSuchThat for (fun t => bst min max t). Derive ArbitrarySizedSuchThat for (fun t => bst min max t). Instance GenSizedSuchThatbst_SizedMonotonic min max : SizedMonotonicOpt (@arbitrarySizeST _ _ (@GenSizedSuchThatbst min max)). Proof. derive_genST_SizedMonotonic (). Qed. Instance GenSizedSuchThatle_SizedMonotonic n : SizedMonotonicOpt (@arbitrarySizeST _ _ (@GenSizedSuchThatle n)). Proof. derive_genST_SizedMonotonic (). Qed. Instance GenSizedSuchThatle_SizeMonotonic n : forall s, SizeMonotonicOpt (@arbitrarySizeST _ _ (@GenSizedSuchThatle n) s). Proof. derive_genST_SizeMonotonic (). Qed. Instance EnumSizedSuchThatbst_SizeMonotonic min max : forall s, SizeMonotonicOpt (@arbitrarySizeST _ _ (@GenSizedSuchThatbst min max) s). Proof. derive_genST_SizeMonotonic (). Qed. Instance GenSizedSuchThatle_Correct n : CorrectSizedST [eta le n] (@arbitrarySizeST _ _ (@GenSizedSuchThatle n)). Proof. derive_genST_Correct (). Qed. Instance GenSizedSuchThatbst_Correct n m : CorrectSizedST (bst n m) (@arbitrarySizeST _ _ (@GenSizedSuchThatbst n m)). Proof. derive_genST_Correct (). Qed. QuickChick-2.1.0/examples/other/neg_example.v000066400000000000000000000046701476030541200211530ustar00rootroot00000000000000From Coq Require Import Init.Nat Lia List. From QuickChick Require Import QuickChick. From mathcomp Require Import ssreflect ssreflect.eqtype ssrnat. Import QcNotation. Import QcDefaultNotation. Import ListNotations. Require Import QuickChick.TacticsUtil ExtLib.Structures.Monads. Open Scope monad_scope. Open Scope qc_scope. Open Scope nat_scope. From Ltac2 Require Import Ltac2. (* Inductive not_In {A: Type} : A -> list A -> Prop := *) (* | In_nil: forall x, not_In x [] *) (* | In_cons : forall x y l, *) (* x <> y -> not_In x l -> not_In x (y :: l). *) (* XXX Leo DEBUG params *) (* This gives an unsound enum *) (* Inductive not_In : nat -> list nat -> Prop := *) (* | In_nil: forall x, not_In x [] *) (* | In_cons : forall x y l, *) (* x <> y -> not_In x l -> not_In x (y :: l). *) (* XXX Leo DEBUG *) Inductive not_In : nat -> list nat -> Prop := | In_nil: forall x, not_In x [] | In_cons : forall x y l, not_In x l -> x <> y -> not_In x (y :: l). Derive DecOpt for (not_In x l). Instance not_In_SizeMonotonic x l : DecOptSizeMonotonic (not_In x l). Proof. derive_mon (). Qed. Instance not_In__sound x l : DecOptSoundPos (not_In x l). Proof. derive_sound (). Qed. Instance not_In_complete x l : DecOptCompletePos (not_In x l). Proof. derive_complete (). Qed. Derive EnumSizedSuchThat for (fun x => eq x n). Instance EnumSizedSuchThateq_SizedMonotonic X {_ : Enum X} (n : X) : SizedMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThateq n)). Proof. derive_enumST_SizedMonotonic (). Qed. Instance EnumSizedSuchThateq_SizeMonotonic X `{_ : EnumMonotonic X} (n : X) : forall s, SizeMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThateq n) s). Proof. derive_enumST_SizeMonotonic (). Qed. Instance EnumSizedSuchThateq_Correct X `{_ : EnumMonotonicCorrect X} (n : X) : CorrectSizedST (fun m => eq n m) (@enumSizeST _ _ (EnumSizedSuchThateq n)). Proof. derive_enumST_Correct (). Qed. Derive EnumSizedSuchThat for (fun n => not_In n l). Instance EnumSizedSuchThatnot_In_SizedMonotonic l : SizedMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThatnot_In l)). Proof. derive_enumST_SizedMonotonic (). Qed. Instance EnumSizedSuchThatnot_In_SizeMonotonic l : forall s, SizeMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThatnot_In l) s). Proof. derive_enumST_SizeMonotonic (). Qed. Instance EnumSizedSuchThatnot_In_Correct l : CorrectSizedST (fun n => not_In n l) (@enumSizeST _ _ (EnumSizedSuchThatnot_In l)). Proof. derive_enumST_Correct (). Qed. QuickChick-2.1.0/examples/other/tagging.v000066400000000000000000000003741476030541200203040ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import Arith. Definition tag_prop (x : nat) : Checker := collect x ( if x = 3 ? then tag "3" false else if 2 nat) and size of types *) (* Example *) Inductive Zoo (A : Type) {B : Type}: Type := | Zoo1 : A -> Zoo A | Zoo2 : Zoo A -> Zoo A | Zoo3 : nat -> A -> B -> Zoo A -> Zoo A -> Zoo A | Zoo4 : Zoo A. (** Generators for type *) Derive Arbitrary for Zoo. (* genSZoo is defined shrZoo is defined *) (** Size of type *) Derive Sized for Zoo. (* SizedZoo is defined *) (** Size equations *) Derive CanonicalSized for Zoo. (* CanonicalSizedZoo is defined *) Derive SizeMonotonic for Zoo using genSZoo. (* SizeMonotonicZoo is defined *) Derive SizedMonotonic for Zoo. (* SizedMonotonicZoo is defined *) Derive SizedCorrect for Zoo using genSZoo and SizeMonotonicZoo. (* SizedCorrectZoo is defined *) (** * Abstract away form size *) (** Automatically derive generator... *) Definition genZoo {A B : Type} `{H1 : Arbitrary A} `{H2 : Arbitrary B} `{H1' : Sized A} `{H2' : Sized B} : G (@Zoo A B) := @arbitrary (@Zoo A B) _. (* Program Instance LalaG {A B} : Gen (@Zoo A B). *) (* Instance Lala {A B : Type} `{H1 : Arbitrary A} `{H2 : Arbitrary B} *) (* `{H1' : Sized A} `{H2' : Sized B} *) (* `{H1 : GenMonotonicCorrect A} `{H2 : GenMonotonicCorrect B}: *) (* Correct (@Zoo A B) arbitrary. *) (* Proof. *) (* refine (@GenCorrectOfSized _ _ _ _ _ _ _ _ _). *) (* eauto with typeclass_instances. *) (* eauto with typeclass_instances. *) (* eauto with typeclass_instances. *) (* {A B : Type} `{H1 : Arbitrary A} `{H2 : Arbitrary B}.z *) (* eapply *) (** ... and correctness proof *) Definition corrZoo {A B : Type} `{GenMonotonicCorrect A} `{GenMonotonicCorrect B} `{CanonicalSized A} `{CanonicalSized B} := @arbitraryCorrect (@Zoo A B) arbitrary _. QuickChick-2.1.0/examples/pyml/000077500000000000000000000000001476030541200163315ustar00rootroot00000000000000QuickChick-2.1.0/examples/pyml/Makefile000066400000000000000000000004721476030541200177740ustar00rootroot00000000000000QC=quickChick -color TMP_DIR=../_qc_pyml.tmp V=@ all: Makefile.coq $V$(MAKE) -f $< test: time $(QC) Makefile.coq: _CoqProject $Vcoq_makefile -o $@ -f $< clean: $Vif [ -e Makefile.coq ]; then $(MAKE) -f Makefile.coq clean; fi $V$(RM) -r *~ .*.aux Makefile.coq* *.pyc __pycache__ \ $(TMP_DIR) $(EXTR_BIN) QuickChick-2.1.0/examples/pyml/_CoqProject000066400000000000000000000000071476030541200204610ustar00rootroot00000000000000plus.v QuickChick-2.1.0/examples/pyml/_tags000066400000000000000000000000241476030541200173450ustar00rootroot00000000000000true: package(pyml) QuickChick-2.1.0/examples/pyml/extract.ml000066400000000000000000000003051476030541200203330ustar00rootroot00000000000000open Py;; initialize ();; let plus x y = let foo = import "foo" in let py_plus = Module.get_function foo (*!*) "plus" (*! "mult" *) in Int.to_int (py_plus [| Int.of_int x; Int.of_int y |]) QuickChick-2.1.0/examples/pyml/foo.py000066400000000000000000000000721476030541200174650ustar00rootroot00000000000000def plus (x,y): return x + y def mult (x,y): return x * y QuickChick-2.1.0/examples/pyml/plus.v000066400000000000000000000003351476030541200175040ustar00rootroot00000000000000From QuickChick Require Import QuickChick. QCInclude ".". Parameter plus' : nat -> nat -> nat. Extract Constant plus' => "Extract.plus". Definition plus_prop x y := plus' x y = x + y?. (*! QuickChick plus_prop. *) QuickChick-2.1.0/examples/python-io.t/000077500000000000000000000000001476030541200175405ustar00rootroot00000000000000QuickChick-2.1.0/examples/python-io.t/.gitignore000066400000000000000000000000041476030541200215220ustar00rootroot00000000000000Foo QuickChick-2.1.0/examples/python-io.t/Extract.ml000066400000000000000000000003601476030541200215030ustar00rootroot00000000000000open Unix;; let plus x y = let (ic, oc) = open_process "python3 foo.py" in output_string oc (string_of_int x ^ " " ^ string_of_int y); close_out oc; let str = input_line ic in ignore (close_process (ic, oc)); int_of_string str QuickChick-2.1.0/examples/python-io.t/Makefile000066400000000000000000000003241476030541200211770ustar00rootroot00000000000000COQMAKEFILE ?= Makefile.coq all: $(COQMAKEFILE) foo.py @$(MAKE) -f $< clean: $(COQMAKEFILE) $(MAKE) -f $^ $@ $(RM) $(COQMAKEFILE) $(COQMAKEFILE).conf $(COQMAKEFILE): _CoqProject @coq_makefile -o $@ -f $< QuickChick-2.1.0/examples/python-io.t/foo.py000066400000000000000000000000611476030541200206720ustar00rootroot00000000000000s = input().split() print(int(s[0]) + int(s[1])) QuickChick-2.1.0/examples/python-io.t/plus.v000066400000000000000000000003761476030541200207200ustar00rootroot00000000000000From QuickChick Require Import QuickChick. QCInclude ".". Parameter plus' : nat -> nat -> nat. Extract Constant plus' => "Extract.plus". Definition plus_prop x y := plus' x y = x + y?. Extract Constant defNumTests => "100". QuickChick plus_prop. QuickChick-2.1.0/examples/python-io.t/run.t000066400000000000000000000001141476030541200205250ustar00rootroot00000000000000Test Python call via OCaml $ coqc plus.v > log 2>&1 || (cat log ; exit 1) QuickChick-2.1.0/examples/stack-compiler/000077500000000000000000000000001476030541200202655ustar00rootroot00000000000000QuickChick-2.1.0/examples/stack-compiler/Exp.v000066400000000000000000000042131476030541200212100ustar00rootroot00000000000000From QuickChick Require Import QuickChick. (** * Arithmetic Expressions *) (** The code in the [stack-compiler] subdirectory consists of two modules, [Exp] and [Stack], each containing a number of definitions and properties. After some [Import]s at the top, it defines a little arithmetic language, consisting of natural literals, addition, subtraction and multiplication. *) Inductive exp : Type := | ANum : nat -> exp | APlus : exp -> exp -> exp | AMinus : exp -> exp -> exp | AMult : exp -> exp -> exp. Derive Show for exp. (* Print Showexp. *) (* Showexp = {| show := fun x : exp => let fix aux (x' : exp) : String.string := match x' with | ANum p0 => String.append "ANum " (smart_paren (show p0)) | APlus p0 p1 => String.append "APlus " (String.append (smart_paren (aux p0)) (String.append " " (smart_paren (aux p1)))) | AMinus p0 p1 => String.append "AMinus " (String.append (smart_paren (aux p0)) (String.append " " (smart_paren (aux p1)))) | AMult p0 p1 => String.append "AMult " (String.append (smart_paren (aux p0)) (String.append " " (smart_paren (aux p1)))) end in aux x |} : Show exp *) (* We can also derive a generator for expressions. *) Derive Arbitrary for exp. (* Sample (@arbitrary exp _). *) (* Let's define an evaluation function... *) Fixpoint eval (e : exp) : nat := match e with | ANum n => n | APlus e1 e2 => (eval e1) + (eval e2) | AMinus e1 e2 => (eval e1) - (eval e2) | AMult e1 e2 => (eval e1) * (eval e2) end. (* ...and perform a few optimizations: *) Fixpoint optimize (e : exp) : exp := match e with | ANum n => ANum n | APlus e (ANum 0) => optimize e (* TODO: FILL ME DURING TUTORIAL! *) | _ => ANum 0 end. (* We would expect that optimizations don't affect the evaluation result. *) Definition optimize_correct_prop (e : exp) := eval (optimize e) = eval e?. (* Does that hold? *) (*! QuickChick optimize_correct_prop. *) QuickChick-2.1.0/examples/stack-compiler/Makefile000066400000000000000000000004141476030541200217240ustar00rootroot00000000000000all: Makefile.coq $(MAKE) -f Makefile.coq Makefile.coq: coq_makefile -f _CoqProject -o Makefile.coq clean: Makefile.coq $(MAKE) -f Makefile.coq clean rm -rf ../_qc_$(shell basename $(CURDIR)).tmp *.bak Makefile.coq* test: clean quickChick -color -top Stack QuickChick-2.1.0/examples/stack-compiler/Stack.v000066400000000000000000000017661476030541200215330ustar00rootroot00000000000000From QuickChick Require Import QuickChick. Require Import Arith List. Import ListNotations. Require Import Stack.Exp. (* Instructions for our stack machine *) Inductive sinstr : Type := | SPush : nat -> sinstr | SPlus : sinstr | SMinus : sinstr | SMult : sinstr. (* Execution *) Fixpoint execute (stack : list nat) (prog : list sinstr) : list nat := match (prog, stack) with | (nil, _ ) => stack | (SPush n::prog', _ ) => execute (n::stack) prog' | (SPlus::prog', m::n::stack') => execute ((m+n)::stack') prog' | (SMinus::prog', m::n::stack') => execute ((m-n)::stack') prog' | (SMult::prog', m::n::stack') => execute ((m*n)::stack') prog' | (_::prog', _ ) => execute stack prog' end. (* Compilation... *) Fixpoint compile (e : exp) : list sinstr := match e with (* TODO: WRITE DURING TUTORIAL! *) | _ => nil end. Definition compile_correct (e : exp) := (execute [] (compile e)) = [eval e]?. (*! QuickChick compile_correct. *) QuickChick-2.1.0/examples/stack-compiler/Tutorial.v000066400000000000000000000055461476030541200222710ustar00rootroot00000000000000(** * Tutorial for QuickChick at POPL Tutorial Fest 2019 *) (** QuickChick is a clone of Haskell's QuickCheck, on steroids. *) From QuickChick Require Import QuickChick. Open Scope qc_scope. From Coq Require Import List ZArith. Import ListNotations. (** ** Introduction *) (** It is not uncommon during a verification effort to spend many hours attempting to prove a slightly false theorem, only to result in frustration when the mistake is realized and one needs to start over. Other theorem provers have testing tools to quickly raise one's confidence before embarking on the body of the proof; Isabelle has its own QuickCheck clone, as well as Nitpick, Sledgehammer and a variety of other tools; ACL2 has gone a step further using random testing to facilitate its automation. QuickChick is meant to fill this void for Coq. Consider the following short function [remove] that takes a natural number [x] and a list of nats [l] and proceeds to remove [x] from the list. While one might be tempted to pose the question "Is there a bug in this definition?", such a question has little meaning without an explicit specification. Here, [removeP] requires that after removing [x] from [l], the resulting list does not contain any occurences of [x]. *) Fixpoint remove (x : nat) (l : list nat) : list nat := match l with | [] => [] | h::t => if beq_nat h x then t else h :: remove x t end. Definition removeP (x : nat) (l : list nat) : bool := (negb (existsb (fun y => beq_nat y x) (remove x l))). (** For this simple example, it is not hard to "spot" the bug by inspection. We will use QuickChick to find out what is wrong. QuickChick provides a toplevel command [QuickChick] that receives as input an executable property and attempts to falsify it. *) (* QuickChick removeP. *) (** Internally, the code is extracted to OCaml, compiled and ran to obtain the output: << 0 [ 0, 0 ] Failed! After 17 tests and 12 shrinks >> The output signifies that if we use an input where [x] is [0] and [l] is the two element list containing two zeros, then our property fails. Indeed, we can now identify that the [then] branch of [remove] fails to make a recursive call, which means that only one occurence of each element will be deleted. The last line of the output states that it took 17 tests to identify some fault inducing input and 12 shrinks to reduce it to a minimal counterexample. Before we begin to explain exactly how QuickChick magically comes up with this result, it is important to point out the first (and arguably most important) limitation of this tool: it requires an *executable* specification. QuickChick needs to be able to "run" a property and decide whether it is true or not; a definition like [remove_spec] can't be QuickChecked! *) QuickChick-2.1.0/examples/stack-compiler/_CoqProject000066400000000000000000000000441476030541200224160ustar00rootroot00000000000000-Q . Stack Tutorial.v Exp.v Stack.v QuickChick-2.1.0/examples/stlc/000077500000000000000000000000001476030541200163155ustar00rootroot00000000000000QuickChick-2.1.0/examples/stlc/dune000066400000000000000000000001621476030541200171720ustar00rootroot00000000000000(coq.theory (name QuickChick.stlc) (theories QuickChick) (modules monad lambda test_progress verif )) QuickChick-2.1.0/examples/stlc/lambda.v000066400000000000000000000255451476030541200177370ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrbool eqtype. Require Import Arith List String Lia. Require Import Program Relations Wellfounded Lexicographic_Product. From QuickChick Require Import QuickChick. From QuickChick.stlc Require Import monad. Import ListNotations. Definition tvar := nat. Definition var := nat. Inductive type : Type := | N : type | Arrow : type -> type -> type. Definition type_eq_dec (t1 t2 : type) : {t1 = t2} + {t1 <> t2}. Proof. do 2 decide equality. Defined. Fixpoint type_size (tau : type) : nat := match tau with | N => 0 | Arrow tau1 tau2 => 1 + (type_size tau1 + type_size tau2) end. Definition lt_type (tau1 tau2 : type) : Prop := type_size tau1 < type_size tau2. Lemma wf_lt_type : well_founded lt_type. Proof. unfold lt_type. apply wf_inverse_image. apply lt_wf. Qed. Inductive term : Type := | Const : nat -> term | Id : var -> term | App : term -> term -> term | Abs : term -> term. (* Terms that do not have applications *) Inductive app_free : term -> Prop := | ConsNoApp : forall n, app_free (Const n) | IdNoApp : forall x, app_free (Id x) | AbsNoApp : forall (t : term), app_free t -> app_free (Abs t). (* Number of applications in a term *) Fixpoint app_no (t : term) : nat := match t with | Const _ | Id _ => 0 | Abs t => app_no t | App t1 t2 => 1 + (app_no t1 + app_no t2) end. Definition env := list type. Inductive bind : env -> nat -> type -> Prop := | BindNow : forall tau env, bind (tau :: env) 0 tau | BindLater : forall tau tau' x env, bind env x tau -> bind (tau' :: env) (S x) tau. Inductive typing (e : env) : term -> type -> Prop := | TId : forall x tau, nth_error e x = Some tau -> typing e (Id x) tau | TConst : forall n, typing e (Const n) N | TAbs : forall t tau1 tau2, typing (tau1 :: e) t tau2 -> typing e (Abs t) (Arrow tau1 tau2) | TApp : forall t1 t2 tau1 tau2, typing e t1 (Arrow tau1 tau2) -> typing e t2 tau1 -> typing e (App t1 t2) tau2. Inductive typing' (e : env) : term -> type -> Prop := | TId' : forall x tau, bind e x tau -> typing' e (Id x) tau | TConst' : forall n, typing' e (Const n) N | TAbs' : forall t tau1 tau2, typing' (tau1 :: e) t tau2 -> typing' e (Abs t) (Arrow tau1 tau2) | TApp' : forall t1 t2 tau1 tau2, typing' e t1 (Arrow tau1 tau2) -> typing' e t2 tau1 -> typing' e (App t1 t2) tau2. Derive Arbitrary for type. #[global] Instance dec_type (t1 t2 : type) : Dec (t1 = t2). Proof. dec_eq. Defined. Derive ArbitrarySizedSuchThat for (fun x => bind env x tau). Derive ArbitrarySizedSuchThat for (fun t => typing' env t tau). Inductive option_le : option nat -> option nat -> Prop := | opt_le_1 : option_le None None | opt_le_2 : forall n, option_le None (Some n) | opt_le_3 : forall n m : nat, n <= m -> option_le (Some n) (Some m). (* The following keeps track of the size of largest type that appears in a cut in the derivation tree. Needed for verification purposes *) Inductive typing_max_tau (e : env) : term -> type -> nat -> Prop := | TIdMax : forall x tau, nth_error e x = Some tau -> typing_max_tau e (Id x) tau 0 | TConstMax : forall n, typing_max_tau e (Const n) N 0 | TAbsMax : forall t tau1 tau2 m, typing_max_tau (tau1 :: e) t tau2 m -> typing_max_tau e (Abs t) (Arrow tau1 tau2) m | TAppMax : forall t1 t2 tau1 tau2 m1 m2, typing_max_tau e t1 (Arrow tau1 tau2) m1 -> typing_max_tau e t2 tau1 m2 -> typing_max_tau e (App t1 t2) tau2 (max (type_size tau1) (max m1 m2)). Lemma typing_max_tau_correct : forall e t tau, (exists m, typing_max_tau e t tau m) <-> typing e t tau. Proof. intros. split. - move => [maxt H]. induction H; econstructor; eauto. - move => H. induction H; (try now eexists; econstructor; eauto). destruct IHtyping as [m H']. exists m. constructor; auto. destruct IHtyping1 as [m1 H1]; destruct IHtyping2 as [m2 H2]. eexists. econstructor; eauto. Qed. Lemma typing_max_no_app : forall e t tau, app_free t -> typing e t tau -> typing_max_tau e t tau 0. Proof. intros e t tau H. generalize e tau. clear e tau. induction H; intros e tau H1; inversion H1; subst; constructor; auto. Qed. (* Small step CBV semantics *) Definition is_value (t : term) : bool := match t with | Const _ | Abs _ => true | _ => false end. Fixpoint subst (y : var) (t1 : term) (t2 : term) : term := match t2 with | Const n => Const n | Id x => if eq_nat_dec x y then t1 else t2 | App t t' => App (subst y t1 t) (subst y t1 t') | Abs t => subst (S y) t1 t end. Fixpoint step (t : term) : option term := match t with | Const _ | Id _ => None | Abs x => None | App t1 t2 => if is_value t1 then match t1 with | Abs t => if is_value t2 then ret (subst 0 t1 t) else t2' <- step t2;; ret (App t1 t2') | _ => None end else t1' <- step t1;; ret (App t1' t2) end. (* Generators *) Module DoNotation. Notation "'do!' X <- A ; B" := (bindGen A (fun X => B)) (at level 200, X ident, A at level 100, B at level 200). End DoNotation. Import DoNotation. (* Sized generator of simple types *) Fixpoint gen_type_size (n : nat) : G type := match n with | 0 => returnGen N | S n' => do! m <- choose (0, n'); liftGen2 Arrow (gen_type_size (n' - m)) (gen_type_size (n' - (n' - m))) end. (* Generator of simple types *) Definition gen_type : G type := bindGen arbitrary gen_type_size. (* Returns the list of bindings that have type tau in e *) Definition vars_with_type (e : env) (tau : type) : list term := map (fun p => Id (snd p)) (filter (fun p => proj1_sig (Sumbool.bool_of_sumbool (type_eq_dec tau (fst p)))) (combine e (seq 0 (List.length e)))). Definition sigT_of_prod {A B : Type} (p : A * B) : {_ : A & B} := let (a, b) := p in existT (fun _ : A => B) a b. Definition lt_pair (c1 c2 : (nat * type)) : Prop := lexprod nat (fun _ => type) lt (fun _ => lt_type) (sigT_of_prod c1) (sigT_of_prod c2). Lemma wf_lt_pair : well_founded lt_pair. Proof. unfold lt_pair. apply wf_inverse_image. apply wf_lexprod. now apply Wf_nat.lt_wf. intros _; now apply wf_lt_type. Qed. (* Generator of app-free well-typed terms of type tau *) Fixpoint gen_term_no_app (tau : type) (e : env) : G term := match vars_with_type e tau with | [] => match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (gen_term_no_app tau2 (tau1 :: e)) end | def :: vars => oneOf_ (returnGen def) [ match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (gen_term_no_app tau2 (tau1 :: e)) end; elems_ def (def :: vars)] end. (* Generator of well-typed terms of type tau. [fst p] is the maximum number of applications *) Program Fixpoint gen_term_size (p : nat * type) {wf lt_pair p} : env -> G term := fun (e : env) => (* apparently with this trick we get a more manageable term *) match p with | (0, tau) => gen_term_no_app tau e | (S n', tau) => match vars_with_type e tau with | [] => oneOf_ (gen_term_no_app tau e) [ (do! tau' <- gen_type; do! m <- choose (0, n'); do! m' <- choose (n' - m, n'); liftGen2 App (@gen_term_size (n' - m, (Arrow tau' tau)) _ e) (@gen_term_size (n' - m', tau') _ e)); (match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (@gen_term_size (S n', tau2) _ (tau1 :: e)) end)] | def :: vars => oneOf_ (gen_term_no_app tau e) [ (do! tau' <- gen_type; do! m <- choose (0, n'); do! m' <- choose (n' - m, n'); liftGen2 App (@gen_term_size (n' - m, (Arrow tau' tau)) _ e) (@gen_term_size (n' - m', tau') _ e)); (match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (@gen_term_size (S n', tau2) _ (tau1 :: e)) end); elems_ def (def :: vars) ] end end. Solve Obligations with try (program_simpl; unfold lt_pair; (apply left_lex + (apply right_lex; unfold lt_type; simpl)); lia). Next Obligation. unfold MR. apply wf_inverse_image. apply wf_lt_pair. Defined. Definition gen_term_size_unfold (p : nat * type) (e : env) : G term := match p with | (0, tau) => gen_term_no_app tau e | (S n', tau) => match vars_with_type e tau with | [] => oneOf_ (gen_term_no_app tau e) [ (do! tau' <- gen_type; do! m <- choose (0, n'); do! m' <- choose (n' - m, n'); liftGen2 App (gen_term_size (n' - m, (Arrow tau' tau)) e) (gen_term_size (n' - m', tau') e)); (match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (@gen_term_size (S n', tau2) (tau1 :: e)) end)] | def :: vars => oneOf_ (gen_term_no_app tau e) [ (do! tau' <- gen_type; do! m <- choose (0, n'); do! m' <- choose (n' - m, n'); liftGen2 App (gen_term_size (n' - m, (Arrow tau' tau)) e) (@gen_term_size (n' - m', tau') e)); (match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (gen_term_size (S n', tau2) (tau1 :: e)) end); elems_ def (def :: vars) ] end end. Import WfExtensionality. Lemma gen_term_size_eq (e : env) (p : nat * type) : gen_term_size p e = gen_term_size_unfold p e. Proof. unfold_sub gen_term_size (gen_term_size p e); simpl. destruct p as [[|n] [|]]; try reflexivity; destruct (vars_with_type e _) eqn:Heq; simpl; repeat (rewrite !Heq /=; apply f_equal; try reflexivity). Qed. Global Opaque gen_term_size. Definition gen_term (tau : type) := sized (fun s => gen_term_size (s, tau) []). Open Scope string. Fixpoint show_type (tau : type) := match tau with | N => "Nat" | Arrow tau1 tau2 => "(" ++ show_type tau1 ++ " -> " ++ show_type tau2 ++ ")" end. #[global] Instance showType : Show type := { show := show_type }. Fixpoint show_term (t : term) := match t with | Const n => show n | Id x => "Id" ++ show x | App t1 t2 => "(" ++ show_term t1 ++ " " ++ show_term t2 ++ ")" | Abs t => "λ.(" ++ show_term t ++ ")" end. Close Scope string. #[global] Instance showTerm : Show term := { show := show_term }. QuickChick-2.1.0/examples/stlc/monad.v000066400000000000000000000024751476030541200176120ustar00rootroot00000000000000Class monad (mon : Type -> Type) := { ret : forall {A : Type}, A -> mon A; bind : forall {A B : Type}, mon A -> (A -> mon B) -> mon B }. Declare Scope monad_scope. Delimit Scope monad_scope with monad. Notation "x >>= f" := (bind x f) (at level 50, left associativity) : monad_scope. Notation "x <- c1 ;; c2" := (bind c1 (fun x => c2)) (at level 100, c1 at next level, right associativity) : monad_scope. Open Scope monad. Definition liftM {M : Type -> Type} `{monad M} {A B : Type} (f : A -> B) (m1: M A) : M B := n1 <- m1 ;; ret (f n1). Definition liftM2 {M : Type -> Type} `{monad M} {A1 A2 B : Type} (f : A1 -> A2 -> B) (m1: M A1) (m2 : M A2) : M B := n1 <- m1 ;; n2 <- m2 ;; ret (f n1 n2). #[global] Instance optionMonad : monad option := { ret A x := Some x; bind A B x f := match x with | Some y => f y | None => None end }. Definition State (St : Type) (A: Type) := St -> (A * St)%type. #[global] Instance stateMonad {St : Type} : monad (State St) := { ret A x := fun s => (x, s); bind A B x f := fun s => let (y, s') := x s in f y s' }. Definition get {St} : State St St := fun st => (st, st). Definition set {St} (ns : St) : State St unit := fun _ => (tt, ns). QuickChick-2.1.0/examples/stlc/new.v000066400000000000000000000270261476030541200173040ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrbool eqtype. Require Import Arith List String Lia. Require Import Program Relations Wellfounded Lexicographic_Product. From QuickChick Require Import QuickChick. From QuickChick.stlc Require Import monad. Import ListNotations. Definition tvar := nat. Definition var := nat. Inductive type : Type := | N : type | Arrow : type -> type -> type. Definition type_eq_dec (t1 t2 : type) : {t1 = t2} + {t1 <> t2}. Proof. do 2 decide equality. Defined. Fixpoint type_size (tau : type) : nat := match tau with | N => 0 | Arrow tau1 tau2 => 1 + (type_size tau1 + type_size tau2) end. Definition lt_type (tau1 tau2 : type) : Prop := type_size tau1 < type_size tau2. Lemma wf_lt_type : well_founded lt_type. Proof. unfold lt_type. apply wf_inverse_image. apply lt_wf. Qed. Inductive term : Type := | Const : nat -> term | Id : var -> term | App : term -> term -> term | Abs : term -> term. (* Terms that do not have applications *) Inductive app_free : term -> Prop := | ConsNoApp : forall n, app_free (Const n) | IdNoApp : forall x, app_free (Id x) | AbsNoApp : forall (t : term), app_free t -> app_free (Abs t). (* Number of applications in a term *) Fixpoint app_no (t : term) : nat := match t with | Const _ | Id _ => 0 | Abs t => app_no t | App t1 t2 => 1 + (app_no t1 + app_no t2) end. Definition env := list type. Inductive bind : env -> nat -> type -> Prop := | BindNow : forall tau env, bind (tau :: env) 0 tau | BindLater : forall tau tau' x env, bind env x tau -> bind (tau' :: env) (S x) tau. Inductive typing (e : env) : term -> type -> Prop := | TId : forall x tau, nth_error e x = Some tau -> typing e (Id x) tau | TConst : forall n, typing e (Const n) N | TAbs : forall t tau1 tau2, typing (tau1 :: e) t tau2 -> typing e (Abs t) (Arrow tau1 tau2) | TApp : forall t1 t2 tau1 tau2, typing e t1 (Arrow tau1 tau2) -> typing e t2 tau1 -> typing e (App t1 t2) tau2. Inductive typing' (e : env) : term -> type -> Prop := | TId' : forall x tau, bind e x tau -> typing' e (Id x) tau | TConst' : forall n, typing' e (Const n) N | TAbs' : forall t tau1 tau2, typing' (tau1 :: e) t tau2 -> typing' e (Abs t) (Arrow tau1 tau2) | TApp' : forall t1 t2 tau1 tau2 tau12, typing' e t2 tau1 -> typing' e t1 tau12 -> tau12 = Arrow tau1 tau2 -> typing' e (App t1 t2) tau2. Derive Arbitrary for type. Instance dec_type (t1 t2 : type) : Dec (t1 = t2). Proof. dec_eq. Defined. Derive ArbitrarySizedSuchThat for (fun x => bind env x tau). Derive ArbitrarySizedSuchThat for (fun t => typing' env t tau). Instance ESST_A2 (t t1 : type) : EnumSizedSuchThat _ (fun t2 => t = Arrow t1 t2) := { enumSizeST := fun _ => match t with | Arrow t1' t2 => if t1 = t1'? then returnEnum (Some t2) else returnEnum None | _ => returnEnum None end }. Derive EnumSized for type. Derive EnumSizedSuchThat for (fun tau => bind env x tau). Derive EnumSizedSuchThat for (fun tau => typing' env t tau). Derive DecOpt for (bind env t tau). Derive DecOpt for (typing' env t tau). Inductive option_le : option nat -> option nat -> Prop := | opt_le_1 : option_le None None | opt_le_2 : forall n, option_le None (Some n) | opt_le_3 : forall n m : nat, n <= m -> option_le (Some n) (Some m). (* The following keeps track of the size of largest type that appears in a cut in the derivation tree. Needed for verification purposes *) Inductive typing_max_tau (e : env) : term -> type -> nat -> Prop := | TIdMax : forall x tau, nth_error e x = Some tau -> typing_max_tau e (Id x) tau 0 | TConstMax : forall n, typing_max_tau e (Const n) N 0 | TAbsMax : forall t tau1 tau2 m, typing_max_tau (tau1 :: e) t tau2 m -> typing_max_tau e (Abs t) (Arrow tau1 tau2) m | TAppMax : forall t1 t2 tau1 tau2 m1 m2, typing_max_tau e t1 (Arrow tau1 tau2) m1 -> typing_max_tau e t2 tau1 m2 -> typing_max_tau e (App t1 t2) tau2 (max (type_size tau1) (max m1 m2)). Lemma typing_max_tau_correct : forall e t tau, (exists m, typing_max_tau e t tau m) <-> typing e t tau. Proof. intros. split. - move => [maxt H]. induction H; econstructor; eauto. - move => H. induction H; (try now eexists; econstructor; eauto). destruct IHtyping as [m H']. exists m. constructor; auto. destruct IHtyping1 as [m1 H1]; destruct IHtyping2 as [m2 H2]. eexists. econstructor; eauto. Qed. Lemma typing_max_no_app : forall e t tau, app_free t -> typing e t tau -> typing_max_tau e t tau 0. Proof. intros e t tau H. generalize e tau. clear e tau. induction H; intros e tau H1; inversion H1; subst; constructor; auto. Qed. (* Small step CBV semantics *) Fixpoint is_value (t : term) : bool := match t with | Const _ | Abs _ => true | _ => false end. Fixpoint subst (y : var) (t1 : term) (t2 : term) : term := match t2 with | Const n => Const n | Id x => if eq_nat_dec x y then t1 else t2 | App t t' => App (subst y t1 t) (subst y t1 t') | Abs t => subst (S y) t1 t end. Fixpoint step (t : term) : option term := match t with | Const _ | Id _ => None | Abs x => None | App t1 t2 => if is_value t1 then match t1 with | Abs t => if is_value t2 then ret (subst 0 t1 t) else t2' <- step t2;; ret (App t1 t2') | _ => None end else t1' <- step t1;; ret (App t1' t2) end. (* Generators *) Module DoNotation. Notation "'do!' X <- A ; B" := (bindGen A (fun X => B)) (at level 200, X ident, A at level 100, B at level 200). End DoNotation. Import DoNotation. (* Sized generator of simple types *) Fixpoint gen_type_size (n : nat) : G type := match n with | 0 => returnGen N | S n' => do! m <- choose (0, n'); liftGen2 Arrow (gen_type_size (n' - m)) (gen_type_size (n' - (n' - m))) end. (* Generator of simple types *) Definition gen_type : G type := bindGen arbitrary gen_type_size. (* Returns the list of bindings that have type tau in e *) Definition vars_with_type (e : env) (tau : type) : list term := map (fun p => Id (snd p)) (filter (fun p => proj1_sig (Sumbool.bool_of_sumbool (type_eq_dec tau (fst p)))) (combine e (seq 0 (List.length e)))). Definition sigT_of_prod {A B : Type} (p : A * B) : {_ : A & B} := let (a, b) := p in existT (fun _ : A => B) a b. Definition lt_pair (c1 c2 : (nat * type)) : Prop := lexprod nat (fun _ => type) lt (fun _ => lt_type) (sigT_of_prod c1) (sigT_of_prod c2). Lemma wf_lt_pair : well_founded lt_pair. Proof. unfold lt_pair. apply wf_inverse_image. apply wf_lexprod. now apply Wf_nat.lt_wf. intros _; now apply wf_lt_type. Qed. (* Generator of app-free well-typed terms of type tau *) Fixpoint gen_term_no_app (tau : type) (e : env) : G term := match vars_with_type e tau with | [] => match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (gen_term_no_app tau2 (tau1 :: e)) end | def :: vars => oneOf_ (returnGen def) [ match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (gen_term_no_app tau2 (tau1 :: e)) end; elems_ def (def :: vars)] end. (* Generator of well-typed terms of type tau. [fst p] is the maximum number of applications *) Program Fixpoint gen_term_size (p : nat * type) {wf lt_pair p} : env -> G term := fun (e : env) => (* apparently with this trick we get a more manageable term *) match p with | (0, tau) => gen_term_no_app tau e | (S n', tau) => match vars_with_type e tau with | [] => oneOf_ (gen_term_no_app tau e) [ (do! tau' <- gen_type; do! m <- choose (0, n'); do! m' <- choose (n' - m, n'); liftGen2 App (@gen_term_size (n' - m, (Arrow tau' tau)) _ e) (@gen_term_size (n' - m', tau') _ e)); (match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (@gen_term_size (S n', tau2) _ (tau1 :: e)) end)] | def :: vars => oneOf_ (gen_term_no_app tau e) [ (do! tau' <- gen_type; do! m <- choose (0, n'); do! m' <- choose (n' - m, n'); liftGen2 App (@gen_term_size (n' - m, (Arrow tau' tau)) _ e) (@gen_term_size (n' - m', tau') _ e)); (match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (@gen_term_size (S n', tau2) _ (tau1 :: e)) end); elems_ def (def :: vars) ] end end. Solve Obligations with program_simpl; unfold lt_pair; apply left_lex; lia. Solve Obligations with program_simpl; unfold lt_pair; apply right_lex; unfold lt_type; simpl; lia. Next Obligation. unfold MR. apply wf_inverse_image. apply wf_lt_pair. Defined. Definition gen_term_size_unfold (p : nat * type) (e : env) : G term := match p with | (0, tau) => gen_term_no_app tau e | (S n', tau) => match vars_with_type e tau with | [] => oneOf_ (gen_term_no_app tau e) [ (do! tau' <- gen_type; do! m <- choose (0, n'); do! m' <- choose (n' - m, n'); liftGen2 App (gen_term_size (n' - m, (Arrow tau' tau)) e) (gen_term_size (n' - m', tau') e)); (match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (@gen_term_size (S n', tau2) (tau1 :: e)) end)] | def :: vars => oneOf_ (gen_term_no_app tau e) [ (do! tau' <- gen_type; do! m <- choose (0, n'); do! m' <- choose (n' - m, n'); liftGen2 App (gen_term_size (n' - m, (Arrow tau' tau)) e) (@gen_term_size (n' - m', tau') e)); (match tau with | N => liftGen Const arbitrary | Arrow tau1 tau2 => liftGen Abs (gen_term_size (S n', tau2) (tau1 :: e)) end); elems_ def (def :: vars) ] end end. Import WfExtensionality. Lemma gen_term_size_eq (e : env) (p : nat * type) : gen_term_size p e = gen_term_size_unfold p e. Proof. unfold_sub gen_term_size (gen_term_size p e); simpl. destruct p as [[|n] [|]]; try reflexivity; destruct (vars_with_type e _) eqn:Heq; simpl; repeat (rewrite !Heq /=; apply f_equal; try reflexivity). Qed. Global Opaque gen_term_size. Definition gen_term (tau : type) := sized (fun s => gen_term_size (s, tau) []). Open Scope string. Fixpoint show_type (tau : type) := match tau with | N => "Nat" | Arrow tau1 tau2 => "(" ++ show_type tau1 ++ " -> " ++ show_type tau2 ++ ")" end. Instance showType : Show type := { show := show_type }. Fixpoint show_term (t : term) := match t with | Const n => show n | Id x => "Id" ++ show x | App t1 t2 => "(" ++ show_term t1 ++ " " ++ show_term t2 ++ ")" | Abs t => "λ.(" ++ show_term t ++ ")" end. Close Scope string. Instance showTerm : Show term := { show := show_term }. QuickChick-2.1.0/examples/stlc/test_progress.v000066400000000000000000000036161476030541200214150ustar00rootroot00000000000000From QuickChick Require Import QuickChick. From mathcomp Require Import ssreflect ssrbool. From QuickChick.stlc Require Import monad lambda. (* Note : In general we would need a type checking/inferring function for this. Since our generator only generates well-typed terms this is not needed for this example. However, it would be nice to have one for other examples.*) Definition is_some {A} (o : option A) : bool := match o with | Some _ => true | None => false end. Definition has_progress (t : term) := is_value t || (is_some (step t)). Fixpoint term_size (t : term) : nat := match t with | Const _ | Id _ => 1 | Abs t => 1 + (term_size t) | App t1 t2 => 1 + (term_size t1 + term_size t2) end. (* Extract Constant Test.defNumTests => "1000000". *) QuickCheck (forAll gen_type (fun tau => forAll (gen_term tau) (fun t => (collect (append "size " (show (term_size t))) (has_progress t))))). Definition step_bug (t : term) : option term := match t with | Const _ | Id _ => None | Abs x => None | App t1 t2 => if is_value t1 then match t1 with | Abs t => if is_value t2 then ret (subst 0 t1 t) else None | _ => None end else t1' <- step t1;; ret (App t1' t2) end. Definition has_progress_bug (t : term) := is_value t || (is_some (step_bug t)). QuickCheck (forAll gen_type (fun tau => forAll (gen_term tau) has_progress_bug)). QuickCheck (forAll arbitrary (fun tau : type => forAll (genST (fun t => typing' nil t tau)) (fun mt => match mt with | Some t => has_progress_bug t | None => false end))). QuickChick-2.1.0/examples/stlc/verif.v000066400000000000000000000417571476030541200176350ustar00rootroot00000000000000Set Warnings "-notation-overridden". From mathcomp Require Import ssreflect ssrbool ssrnat eqtype. Require Import String. (* I don't know why we need this.. Probably I am forgetting something *) From QuickChick Require Import QuickChick. Require Import Arith List Lia. From QuickChick.stlc Require Import lambda. Require Import Wellfounded. Open Scope coq_nat. (* Note : Some tactic automation would improve our proofs *) (* This could be turned into a more generic lemma, but for now it works *) Lemma vars_with_type_shift: forall e x tau n, In (Id (S x)) (map (fun p : type * var => Id (snd p)) (filter (fun p : type * nat => proj1_sig (Sumbool.bool_of_sumbool (type_eq_dec tau (fst p)))) (combine e (seq (S n) (length e))))) <-> In (Id x) (map (fun p : type * var => Id (snd p)) (filter (fun p : type * nat => proj1_sig (Sumbool.bool_of_sumbool (type_eq_dec tau (fst p)))) (combine e (seq n (length e))))). Proof. move => e. induction e; intros x tau; simpl in *; split; auto; intros H; destruct (type_eq_dec tau a); subst; simpl in *; try (destruct H; try (inversion H; auto)); try right; apply IHe; auto. Qed. Lemma vars_with_type_le: forall e x tau n, In (Id x) (map (fun p : type * var => Id (snd p)) (filter (fun p : type * nat => proj1_sig (Sumbool.bool_of_sumbool (type_eq_dec tau (fst p)))) (combine e (seq n (length e))))) -> n <= x. Proof. move => e. induction e; intros x tau n H; simpl in *. now exfalso; auto. destruct (type_eq_dec tau a); subst; simpl in *. destruct H; solve [ inversion H; lia | eapply IHe in H; lia]. eapply IHe in H; lia. Qed. Lemma vars_with_type_le_length_aux: forall e x tau n, In (Id x) (map (fun p : type * var => Id (snd p)) (filter (fun p : type * nat => proj1_sig (Sumbool.bool_of_sumbool (type_eq_dec tau (fst p)))) (combine e (seq n (length e))))) -> x < n + (length e). Proof. move => e. induction e; intros x tau n H; simpl in *. now exfalso; auto. unfold addn, addn_rec in *. destruct (type_eq_dec tau a); subst; simpl in *. destruct H. inversion H; subst. lia. apply IHe in H. lia. eapply IHe in H; lia. Qed. Lemma vars_with_type_le_length: forall e x tau, In (Id x) (vars_with_type e tau) -> x < (length e). Proof. intros. apply vars_with_type_le_length_aux in H. unfold addn, addn_rec in *. lia. Qed. Lemma vars_with_type_Id : forall e tau t, In t (vars_with_type e tau) -> exists x, t = Id x. Proof. intros. rewrite /vars_with_type /= in H. apply in_map_iff in H. destruct H as [[tau' x] [H1 H2]]. eexists; eauto. Qed. Lemma type_var : forall e x tau, In (Id x) (vars_with_type e tau) <-> typing e (Id x) tau. Proof. induction e as [| tau e IHe]; move => x tau' /=. - split; intros H; solve [exfalso; auto | inversion H; subst; destruct x; simpl in *; discriminate ]. - split; rewrite /vars_with_type /=; intros H; destruct (type_eq_dec tau' tau); subst. + destruct x; simpl in *; auto. constructor; auto. inversion H as [H1 | H1]; try discriminate. setoid_rewrite vars_with_type_shift in H1. apply IHe in H1. inversion H1; subst. constructor; auto. + destruct x; simpl in *; auto. constructor; auto. apply vars_with_type_le in H. lia. setoid_rewrite vars_with_type_shift in H. apply IHe in H. inversion H; subst. constructor; auto. + destruct x; simpl in *; auto. right. rewrite vars_with_type_shift. apply IHe. inversion H. simpl in *. constructor; auto. + destruct x; simpl in *; auto. inversion H; subst. simpl in *. exfalso; auto. inversion H1; auto. rewrite vars_with_type_shift. apply IHe. inversion H; subst. constructor; auto. Qed. Lemma app_free_app_no_0 : forall (t : term), app_free t <-> app_no t = 0. Proof. elim => [n | x | t1 _ t2 _ | t IHt ]; split; intros H; solve [ inversion H; (try apply IHt); subst; auto | constructor; try apply IHt; auto ]. Qed. Inductive Const_leq (s : nat) : term -> Prop := | IdLe : forall x, Const_leq s (Id x) | ConstLe : forall n, n <= s -> Const_leq s (Const n) | AppLe : forall t1 t2, Const_leq s t1 -> Const_leq s t2 -> Const_leq s (App t1 t2) | AbsLe : forall t, Const_leq s t -> Const_leq s (Abs t). Fixpoint max_const (t : term) : nat := match t with | Id _ => 0 | Const n => n | App t1 t2 => max (max_const t1) (max_const t2) | Abs t => max_const t end. Lemma Const_leq_trans : forall t n1 n2, n1 <= n2 -> Const_leq n1 t -> Const_leq n2 t. Proof. intros. induction t; try (constructor; simpl; lia); inversion H0; subst; solve [ constructor; simpl; lia | constructor; eauto ]. Qed. Lemma max_const_Const_leq : forall t, Const_leq (max_const t) t. Proof. intros. induction t; try (constructor; simpl; lia); constructor; simpl; eapply Const_leq_trans; try eassumption; (try now apply PeanoNat.Nat.le_max_l); (try now apply PeanoNat.Nat.le_max_r); lia. Qed. (* Lemma gen_type_size_correctSize : forall (n s : nat), semGenSize (gen_type_size n) s <--> [set tau | type_size tau = n]. Proof. move => n s tau. elim : tau n s => [| tau1 IH1 tau2 IH2] n s. { split. - destruct n as [| n]; move => H //=. move : H => /semProdSize [m1 [/semChooseSize H1 H2]]. move : H2 => /semLiftGen2Size [[tau1 tau2] [[/= H3 H4] H]]. discriminate. - move => H. destruct n as [| n]; simpl. apply semReturnSize. reflexivity. discriminate. } { split. - destruct n as [| n]. + move => /semReturnSize <-. auto. + move => /semBindSize [m1 [/semChooseSize H1 H2]]. fold gen_type_size in H2. move : H2 => /semLiftGen2Size [[tau1' tau2'] [[/= H3 H4] Heq]]. rewrite /set1 in Heq. inversion Heq; subst. apply IH1 in H3. apply IH2 in H4. have Hle1 : type_size tau1 = (n - m1)%coq_nat by apply H3; lia. have Hle2 : type_size tau2 = (n - (n - m1)%coq_nat)%coq_nat by apply H4; lia. lia. - move => /= H. destruct n as [| n]; first by discriminate. apply semBindSize. exists (n - type_size tau1). split. apply semChooseSize; unfold leq, super, OrdNat in *. apply/leP. lia. apply/andP; split; apply /leP; lia. apply semLiftGen2Size. exists (tau1, tau2). split; last by reflexivity. split; fold gen_type_size; [ apply IH1 | apply IH2]; simpl; simpl in H; lia. } Qed. Lemma gen_type_correctSize : forall (s : nat), semGenSize gen_type s <--> [set tau | type_size tau <= s]. Proof. intros s. unfold gen_type. rewrite semBindSize => tau. split => H. - move : H => [n [/arbNat_correctSize H1 /gen_type_size_correctSize H2]]. lia. - exists (type_size tau). split. apply arbNat_correctSize; auto. apply gen_type_size_correctSize; auto. Qed. Lemma gen_term_no_app_correctSize : forall (tau : type) (e : env) (s: nat), semGenSize (gen_term_no_app tau e) s <--> [set t | typing e t tau /\ app_free t /\ Const_leq s t]. Proof. induction tau; intros e s; simpl. - destruct (vars_with_type e N) as [| x e'] eqn:Hvars. + rewrite semLiftGenSize. intros t'. split. * move => [n [/arbNat_correctSize Hnat <-]]. repeat split; constructor; auto. * move => [H [H' H'']]; subst. inversion H; subst; (try now inversion H'); inversion H''; subst. apply type_var in H. rewrite Hvars in H. inversion H. exists n. split; try reflexivity. now apply arbNat_correctSize. + rewrite semOneofSize. intros t'. split. * move => [gen [[H1 | [ H1 | // ]] H2]]; subst. move /semLiftGenSize : H2 => [n [/arbNat_correctSize Hnat <-]]. repeat split; constructor; auto. apply semElementsSize in H2. rewrite /seq_In -Hvars in H2. specialize (vars_with_type_Id _ _ _ H2); move => [x' ?]; subst. specialize (vars_with_type_le_length _ _ _ H2); move => H; subst. apply type_var in H2. repeat split; auto; constructor. * move => [H1 [H2 H3]]. inversion H1; subst. eexists. split. right; left; reflexivity. apply semElementsSize. rewrite /seq_In -Hvars. apply type_var; auto. eexists. split. left; reflexivity. apply semLiftGenSize. exists n; split; try reflexivity. apply arbNat_correctSize. inversion H3; auto. inversion H2. - destruct (vars_with_type e (Arrow tau1 tau2)) as [| x e'] eqn:Hvars. + rewrite semLiftGenSize. intros t'. split. * move => [t'' [/IHtau2 [H1 [H2 H3]] <-]]. repeat split; auto; constructor; auto. * move => [H1 [H2 H3]]. destruct t'; try now inversion H2. apply type_var in H1. rewrite Hvars in H1. inversion H1. eexists. split; last by reflexivity. apply IHtau2. inversion H1; subst. inversion H2; subst. repeat split; auto. inversion H3; auto. + rewrite semOneofSize. intros t. split. * move => [gen [[H1 | [H2 | //]] H]]; subst. move /semLiftGenSize: H => [t' [/IHtau2 [H1 [H2 H3]] <-]]. repeat split; constructor; auto. move /semElementsSize : H => H; subst. rewrite /seq_In -Hvars in H. destruct (vars_with_type_Id _ _ _ H) as [x' Heq]; subst. apply type_var in H. repeat split; auto; constructor. * intros [H1 [H2 H3]]. inversion H1; subst. eexists. split. right. left. reflexivity. apply semElementsSize. rewrite /seq_In -Hvars. apply type_var; auto. eexists. split. left; reflexivity. apply semLiftGenSize. eexists. split; last by reflexivity. apply IHtau2; repeat split; auto. inversion H2; auto. inversion H3; auto. inversion H2. Qed. Lemma gen_term_size_correct : forall (tau : type) (e : env) (n : nat) (s : nat), semGenSize (gen_term_size (n, tau) e) s <--> [set t | (exists maxtau, typing_max_tau e t tau maxtau /\ maxtau <= s) /\ Const_leq s t /\ (exists h, app_no t = h /\ h <= n)]. Proof. move => tau e n s t. replace tau with (snd (n, tau)); try reflexivity. have Heq : (exists h : nat, app_no t = h /\ h <= n) <-> (exists h : nat, app_no t = h /\ h <= fst (n, tau)) by simpl; split; auto. rewrite Heq. replace n with (fst (n, tau)) at 1; try reflexivity. generalize (n, tau) e s t. clear Heq n tau e s t. change (forall (p : nat * type), (fun p => forall (e : env) (s : nat) (t : term), semGenSize (gen_term_size (fst p, snd p) e) s t <-> (exists maxtau : nat, typing_max_tau e t (snd p) maxtau /\ maxtau <= s) /\ Const_leq s t /\ (exists h : nat, app_no t = h /\ h <= fst p)) p). apply well_founded_induction with (R := lt_pair); first by apply wf_lt_pair. intros [n tau] IH e s t; rewrite gen_term_size_eq. split. { destruct n as [| n]; simpl. - move => /gen_term_no_app_correctSize /= [H1 [H2 H3]]. repeat split; auto. exists 0. split; try lia. now apply typing_max_no_app. exists 0; split; try lia. apply app_free_app_no_0; auto. - destruct (vars_with_type e tau) eqn:Hvars; move /semOneofSize => [gen [[H1 | [H1 | //]] H2]]; subst; try (move : H2=> /semBindSize [tau' [ H2 /semBindSize [m [/semChooseSize H3 /semBindSize [m' [/semChooseSize H4 /semLiftGen2Size H5]]]]]]; move : H5 H2=> [[t1 t2] [[H5 H6] H7]] /gen_type_correctSize H2; rewrite /set1 in H7; subst; (apply (IH (n - m, Arrow tau' tau)) in H5; last by left; lia); (apply (IH (n - m', tau')) in H6; last by left; lia); move : H5 H6 => /= [[max1 [H5 Hle1]] [H6 [h1 [H7 H7']]]] [[max2 [H8 Hle2]] [H9 [h2 [H10 H10']]]]; subst; repeat (split; simpl; try now econstructor; eauto); [ exists (max (type_size tau') (max max1 max2)); (split; try econstructor; eauto); repeat (apply Max.max_lub; auto) | eexists; (split; first by reflexivity); unfold leq, super, OrdNat in H3, H4; (have /andP [_ /leP Hle] : 0 <= m <= n by auto); (have /andP [/leP Hle3 /leP Hle4] : (n - m)%coq_nat <= m' <= n by apply H4; apply/leP; lia); lia ]); try ( destruct tau; solve [ move /semLiftGenSize : H2 => [t' [/arbNat_correctSize H2 H3]]; rewrite /set1 in H3; subst; repeat split; try constructor; auto; exists 0; split; auto; try lia; constructor | move /semLiftGenSize : H2 => [t' [ H2 H3]]; rewrite /set1 in H3; subst; (apply (IH (n.+1, tau2)) in H2; last by right; unfold lt_type; simpl; lia); move : H2 => /= [[maxt [H1 Hle]] [H2 [h [H3 H4]]]]; (repeat split; try now econstructor); eauto; exists maxt; split; auto; constructor; auto ]). move : H2 => [H2 | //]; subst. move => /semElementsSize H. rewrite /seq_In -Hvars in H. specialize (vars_with_type_Id _ _ _ H); move => [x' ?]; subst. specialize (vars_with_type_le_length _ _ _ H); move => H1; subst. apply type_var in H. repeat split; auto. exists 0; split. constructor. inversion H; auto. lia. constructor. exists 0. split; try lia. constructor. } { move => /= [[maxt [H1 Hle1]] [H2 [h [H3 Hle2]]]]. destruct n. - apply gen_term_no_app_correctSize. destruct h; try lia. repeat (split; auto); solve [apply typing_max_tau_correct; eexists; eauto | apply app_free_app_no_0; auto]. - destruct (vars_with_type e tau) eqn:Hvars; inversion H1; subst; solve [ (have /type_var contra : (typing e(Id x) tau) by apply typing_max_tau_correct; eexists; eauto); rewrite Hvars in contra; now inversion contra | apply semOneofSize; eexists; (split; first by right; left; reflexivity); apply semLiftGenSize; eexists; (split; last by reflexivity); inversion H2; subst; apply arbNat_correctSize; lia | apply semOneofSize; eexists; (split; first by right; left; reflexivity); apply semLiftGenSize; eexists; (split; last by reflexivity); (apply (IH (n.+1, tau2)); first by right; unfold lt_type; simpl; lia); inversion H2; inversion H1; subst; (repeat split; auto); simpl; solve [eexists; split; eauto; simpl; eauto | eexists; (split; first by reflexivity); simpl; auto ] | apply semOneofSize; eexists; (split; first by left; reflexivity); apply semBindSize; exists tau1; (split; first by apply gen_type_correctSize; eapply Max.max_lub_l; eauto); simpl in Hle2; apply semBindSize; exists (n - (app_no t1)); (split; first by apply semChooseSize; auto; unfold leq, super, randomR, OrdNat; apply/andP; split; apply/leP; lia); apply semBindSize; exists (n - (app_no t2)); (split; first by apply semChooseSize; auto; unfold leq, super, randomR, OrdNat; try (apply/leP; lia); apply/andP; split; apply/leP; lia); apply semLiftGen2Size; exists (t1, t2); (split; last by reflexivity); split => /=; [ apply (IH (n - (n - app_no t1)%coq_nat, Arrow tau1 tau)) | apply (IH (n - (n - app_no t2)%coq_nat, tau1)) ]; try (left; lia); inversion H2; subst; repeat (split; auto); solve [ inversion H; subst; eexists; split; eauto; try lia; (try now eapply Max.max_lub_l; eapply Max.max_lub_r; eauto); try (now eapply Max.max_lub_r; eapply Max.max_lub_r; eauto) | eexists; split; eauto; simpl in Hle2; simpl; lia ] | apply semOneofSize; eexists; (split; first by right; right; left; reflexivity); apply semElementsSize; rewrite /seq_In -Hvars; apply type_var; apply typing_max_tau_correct; eexists; eauto ]. } Qed. Lemma gen_term_correct : forall (tau : type), semGen (gen_term tau) <--> [set t | typing nil t tau]. Proof. intros. unfold gen_term. rewrite semSized => t. split. - move => [s [H1 /gen_term_size_correct [[m [H2 Hle]] [H3 [H4 [H5 H6]]]]]]; subst. apply typing_max_tau_correct. eexists; eauto. - move => /typing_max_tau_correct [m Ht]. eexists (max m (max (app_no t) (max_const t))). split. reflexivity. apply gen_term_size_correct. repeat split. exists m. split; auto. apply Max.le_max_l. eapply Const_leq_trans; last by apply max_const_Const_leq. eapply PeanoNat.Nat.max_le_iff. right. apply Max.le_max_r. eexists; split. reflexivity. eapply PeanoNat.Nat.max_le_iff. right. apply Max.le_max_l. Qed. *) QuickChick-2.1.0/fuzz/000077500000000000000000000000001476030541200145305ustar00rootroot00000000000000QuickChick-2.1.0/fuzz/.gitignore000066400000000000000000000000111476030541200165100ustar00rootroot00000000000000foo main QuickChick-2.1.0/fuzz/C.ml000066400000000000000000000010001476030541200152330ustar00rootroot00000000000000let unlikely_branch = fun i -> if (0 < i) then if (i mod 100 == 0) then if (i mod 1000 == 0) then if (i mod 10000 == 0) then if (i mod 100000 == 0) then if (i mod 1000000 == 0) then if (i < 1000001) then failwith "bleh" else 0 else 0 else 0 else 0 else 0 else 0 else 0 QuickChick-2.1.0/fuzz/Fuzz.ml000066400000000000000000000011771476030541200160260ustar00rootroot00000000000000let map_size_pow2 = 16 let map_size = 1 lsl map_size_pow2 let trace_bits = Array.make map_size 0 external setup_shm_aux : unit -> unit = "setup_shm_prim_aux" external copy_trace_bits : int array -> unit = "copy_trace_bits" let count_ones arr = Array.iteri (fun i n -> if n != 0 then Printf.printf "%d: %d %b %b\n" i n (n != 0) (n == 0) else () ) arr let main = Printf.printf "Entering main\n"; setup_shm_aux (); Printf.printf "Aux setup complete\n"; count_ones trace_bits; let n = C.unlikely_branch 42 in Printf.printf "%d\n" n; copy_trace_bits trace_bits; count_ones trace_bits; QuickChick-2.1.0/fuzz/Main.ml000066400000000000000000000002551476030541200157500ustar00rootroot00000000000000external setup_shm : unit -> unit = "setup_shm_prim" let main = setup_shm (); Printf.printf "Calling %s...\n" Sys.argv.(1); Sys.command Sys.argv.(1); QuickChick-2.1.0/fuzz/SHM.c000066400000000000000000000156641476030541200153370ustar00rootroot00000000000000#include #include "alloc-inl.h" #include #include static s32 shm_id; /* ID of the SHM region */ u8* trace_bits; static u8 virgin_bits[MAP_SIZE]; /* Regions yet untouched by fuzzing */ #define MAP_SIZE_POW2 16 #define MAP_SIZE (1 << MAP_SIZE_POW2) static void remove_shm(void) { shmctl(shm_id, IPC_RMID, NULL); } void setup_shm(void) { u8* shm_str; // memset(virgin_tmout, 255, MAP_SIZE); // memset(virgin_crash, 255, MAP_SIZE); shm_id = shmget(IPC_PRIVATE, MAP_SIZE, IPC_CREAT | IPC_EXCL | 0600); if (shm_id < 0) PFATAL("shmget() failed"); atexit(remove_shm); shm_str = alloc_printf("%d", shm_id); /* If somebody is asking us to fuzz instrumented binaries in dumb mode, we don't want them to detect instrumentation, since we won't be sending fork server commands. This should be replaced with better auto-detection later on, perhaps? */ setenv(SHM_ENV_VAR, shm_str, 1); ck_free(shm_str); trace_bits = shmat(shm_id, NULL, 0); if (!trace_bits) PFATAL("shmat() failed"); } void setup_shm_aux(void) { // if (!in_bitmap) memset(virgin_bits, 255, MAP_SIZE); // printf("Init:\n"); // for (u32 j = 0; j < MAP_SIZE; j++){ // if (virgin_bits[j]) { // printf ("%d ", j); // } // } // printf("\n"); u8* shm_str; shm_str = getenv(SHM_ENV_VAR); if (shm_str == NULL) PFATAL("getenv() failed"); sscanf(shm_str, "%d", &shm_id); // shm_id = shmget(shm_str, MAP_SIZE, 0600); //ck_free(shm_str); trace_bits = shmat(shm_id, NULL, 0); if (!trace_bits) PFATAL("shmat() failed"); } CAMLprim value setup_shm_prim(value unit) { setup_shm(); //printf ("SHM Setup succesful!\n"); return Val_unit; } CAMLprim value setup_shm_prim_aux(value unit) { printf ("Preparing to setup aux...\n"); setup_shm_aux(); printf ("SHM Setup (aux) succesful!\n"); return Val_unit; } CAMLprim value copy_trace_bits( value ml_array ) { // printf("Entering copy_trace_bits....\n"); int i, len; len = Wosize_val(ml_array); printf("Size: %d\n", len); for (i=0; i < len; i++) { // *2 for some reason probably to do with ocaml encoding caml_modify(&Field(ml_array, i), Val_int (trace_bits[i])); } // printf("Returning from copy trace bits...\n"); return Val_unit ; } CAMLprim value reset_trace_bits(value unit) { // printf("Entering reset trace bits...\n"); fflush(stdout); int i; //TODO: memset for (i=0; i> 2); u32 ret = 0; while (i--) { u32 v = *(ptr++); /* This gets called on the inverse, virgin bitmap; optimize for sparse data. */ if (v == 0xffffffff) { ret += 32; continue; } v -= ((v >> 1) & 0x55555555); v = (v & 0x33333333) + ((v >> 2) & 0x33333333); ret += (((v + (v >> 4)) & 0xF0F0F0F) * 0x01010101) >> 24; } return ret; } #define FF(_b) (0xff << ((_b) << 3)) /* Count the number of bytes set in the bitmap. Called fairly sporadically, mostly to update the status screen or calibrate and examine confirmed new paths. */ static u32 count_bytes(u8* mem) { u32* ptr = (u32*)mem; u32 i = (MAP_SIZE >> 2); u32 ret = 0; while (i--) { u32 v = *(ptr++); if (!v) continue; if (v & FF(0)) ret++; if (v & FF(1)) ret++; if (v & FF(2)) ret++; if (v & FF(3)) ret++; } //printf("Counted Bytes: %d\n", ret); return ret; } CAMLprim value count_bytes_aux(void){ return Val_int(count_bytes(trace_bits)); } /* Count the number of non-255 bytes set in the bitmap. Used strictly for the status screen, several calls per second or so. */ static u32 count_non_255_bytes(u8* mem) { u32* ptr = (u32*)mem; u32 i = (MAP_SIZE >> 2); u32 ret = 0; while (i--) { u32 v = *(ptr++); /* This is called on the virgin bitmap, so optimize for the most likely case. */ if (v == 0xffffffff) continue; if ((v & FF(0)) != FF(0)) ret++; if ((v & FF(1)) != FF(1)) ret++; if ((v & FF(2)) != FF(2)) ret++; if ((v & FF(3)) != FF(3)) ret++; } return ret; } CAMLprim value count_non_virgin_bytes(void){ return Val_int(count_non_255_bytes(virgin_bits)); } /* Check if the current execution path brings anything new to the table. Update virgin bits to reflect the finds. Returns 1 if the only change is the hit-count for a particular tuple; 2 if there are new tuples seen. Updates the map, so subsequent calls will always return 0. This function is called after every exec() on a fairly large buffer, so it needs to be fast. We do this in 32-bit and 64-bit flavors. */ static inline u8 has_new_bits(u8* virgin_map) { // count_bytes(trace_bits); // count_non_255_bytes(virgin_bits); #ifdef __x86_64__ u64* current = (u64*)trace_bits; u64* virgin = (u64*)virgin_map; u32 i = (MAP_SIZE >> 3); #else u32* current = (u32*)trace_bits; u32* virgin = (u32*)virgin_map; u32 i = (MAP_SIZE >> 2); #endif /* ^__x86_64__ */ u8 ret = 0; // for (u32 j = 0; j < MAP_SIZE; j++){ // if (virgin_bits[j]) { // printf ("%d ", j); // } // } // printf("\n"); while (i--) { /* Optimize for (*current & *virgin) == 0 - i.e., no bits in current bitmap that have not been already cleared from the virgin map - since this will almost always be the case. */ if (unlikely(*current) && unlikely(*current & *virgin)) { if (likely(ret < 2)) { u8* cur = (u8*)current; u8* vir = (u8*)virgin; /* Looks like we have not found any new bytes yet; see if any non-zero bytes in current[] are pristine in virgin[]. */ #ifdef __x86_64__ if ((cur[0] && vir[0] == 0xff) || (cur[1] && vir[1] == 0xff) || (cur[2] && vir[2] == 0xff) || (cur[3] && vir[3] == 0xff) || (cur[4] && vir[4] == 0xff) || (cur[5] && vir[5] == 0xff) || (cur[6] && vir[6] == 0xff) || (cur[7] && vir[7] == 0xff)) ret = 2; else ret = 1; #else if ((cur[0] && vir[0] == 0xff) || (cur[1] && vir[1] == 0xff) || (cur[2] && vir[2] == 0xff) || (cur[3] && vir[3] == 0xff)) ret = 2; else ret = 1; #endif /* ^__x86_64__ */ } *virgin &= ~*current; } current++; virgin++; } // printf("After...\n"); // for (u32 j = 0; j < MAP_SIZE; j++){ // if (virgin_bits[j]) { // printf ("%d ", j); // } // } // printf("\n"); // if (ret && virgin_map == virgin_bits) bitmap_changed = 1; return ret; } CAMLprim value has_new_bits_aux(void) { return (Val_bool (has_new_bits(virgin_bits))); } QuickChick-2.1.0/fuzz/Stub.ml000066400000000000000000000111301476030541200157730ustar00rootroot00000000000000let map_size_pow2 = 16 let map_size = 1 lsl map_size_pow2 let havoc_max_mult = 16.0 let havoc_min = 5.0 let trace_bits = Array.make map_size 0 let total_bitmap_size = ref 0 let total_bitmap_cnt = ref 0 let total_time = ref 0 let total_time_cnt = ref 0 external setup_shm_aux : unit -> unit = "setup_shm_prim_aux" external copy_trace_bits : int array -> unit = "copy_trace_bits" external reset_trace_bits : unit -> unit = "reset_trace_bits" external has_new_bits : unit -> bool = "has_new_bits_aux" external count_bytes : unit -> int = "count_bytes_aux" external count_non_virgin_bytes : unit -> int = "count_non_virgin_bytes" let count_ones arr = Array.iteri (fun i n -> if n != 0 then Printf.printf "%d: %d %b %b\n" i n (n != 0) (n == 0) else () ) arr (* TODO: Measure time from beginning of generation. *) let calc_energy time size result = let energy0 = 100.0 in let avg_time = !total_time / !total_time_cnt in let avg_size = !total_bitmap_size / !total_bitmap_cnt in (* Adjust score based on execution speed of this path, compared to the global average. Multiplier ranges from 0.1x to 3x. Fast inputs are less expensive to fuzz, so we're giving them more air time. *) let op b = if b then (>) else (<) in let rec update_energy input average energy params = match params with | [] -> energy | ((im, am, b, mult) :: params') -> if (op b) (input * im) (average * am) then energy *. mult else update_energy input average energy params' in let time_params = [ (1, 10, true, 0.1) ; (1, 4, true, 0.25 ) ; (1, 2, true, 0.5 ) ; (3, 4, true, 0.75 ) ; (4, 1, false, 3.0) ; (3, 1, false, 2.0) ; (2, 1, false, 1.5) ] in let energy1 = update_energy time avg_time energy0 time_params in (* Adjust score based on bitmap size. The working theory is that better coverage translates to better targets. Multiplier from 0.25x to 3x. *) let size_params = [ (3, 10, true, 3.0) ; (1, 2, true, 2.0) ; (3, 4, true, 1.5) ; (3, 1, false, 0.25) ; (2, 1, false, 0.5) ; (3, 2, false, 0.75) ] in let energy2 = update_energy size avg_size energy1 size_params in (* TODO: /* Adjust score based on handicap. Handicap is proportional to how late in the game we learned about this path. Latecomers are allowed to run for a bit longer until they catch up with the rest. */ if (q->handicap >= 4) { perf_score *= 4; q->handicap -= 4; } else if (q->handicap) { perf_score *= 2; q->handicap--; } *) (* TODO: /* Final adjustment based on input depth, under the assumption that fuzzing deeper test cases is more likely to reveal stuff that can't be discovered with traditional fuzzers. */ switch (q->depth) { case 0 ... 3: break; case 4 ... 7: perf_score *= 2; break; case 8 ... 13: perf_score *= 3; break; case 14 ... 25: perf_score *= 4; break; default: perf_score *= 5; } *) (* If the result is discarded, fuzz less. *) let energy3 = match result with | Some _ -> energy2 | None -> energy2 *. 0.33 in (* Make sure that we don't go over limit. *) let energy_pre_cap = energy3 in let energy_capped_top = if energy_pre_cap > havoc_max_mult *. 100.0 then havoc_max_mult *. 100.0 else energy_pre_cap in let energy_capped_bot = if energy_capped_top < havoc_min then havoc_min else energy_capped_top in let multiplier = 100 in 10 * (Float.to_int energy_capped_bot) let withInstrumentation f = (* Reset the C-array bitmap. *) reset_trace_bits (); (* TODO: Convert to DEBUG *) (* print_endline "Executing..."; *) let cur_time = Sys.time () in let result = f () in let stop_time = Sys.time () in (* (match result with | Some b -> Printf.printf "%b\n" b; flush stdout | None -> Printf.printf "Discard\n"; flush stdout ); *) (* Update total time (in us) *) let time = Float.to_int ((stop_time -. cur_time) *. 1000000.0) in total_time := !total_time + time; incr total_time_cnt; (* Printf.printf "%d\n" (count_non_virgin_bytes ()); *) (* Check for new paths *) let new_paths = has_new_bits () in if new_paths then begin (* If new paths exist, update the bitmap size (for score) *) let size = count_bytes () in total_bitmap_size := !total_bitmap_size + size; incr total_bitmap_cnt; (* Calculate the energy for the new path *) let energy = calc_energy time size result in (result, (true, energy)) end else (result, (false, 0)) QuickChick-2.1.0/fuzz/alloc-inl.h000066400000000000000000000304251476030541200165570ustar00rootroot00000000000000/* american fuzzy lop - error-checking, memory-zeroing alloc routines ------------------------------------------------------------------ Written and maintained by Michal Zalewski Copyright 2013, 2014, 2015 Google Inc. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0 This allocator is not designed to resist malicious attackers (the canaries are small and predictable), but provides a robust and portable way to detect use-after-free, off-by-one writes, stale pointers, and so on. */ #ifndef _HAVE_ALLOC_INL_H #define _HAVE_ALLOC_INL_H #include #include #include #include "config.h" #include "types.h" #include "debug.h" /* User-facing macro to sprintf() to a dynamically allocated buffer. */ #define alloc_printf(_str...) ({ \ u8* _tmp; \ s32 _len = snprintf(NULL, 0, _str); \ if (_len < 0) FATAL("Whoa, snprintf() fails?!"); \ _tmp = ck_alloc(_len + 1); \ snprintf((char*)_tmp, _len + 1, _str); \ _tmp; \ }) /* Macro to enforce allocation limits as a last-resort defense against integer overflows. */ #define ALLOC_CHECK_SIZE(_s) do { \ if ((_s) > MAX_ALLOC) \ ABORT("Bad alloc request: %u bytes", (_s)); \ } while (0) /* Macro to check malloc() failures and the like. */ #define ALLOC_CHECK_RESULT(_r, _s) do { \ if (!(_r)) \ ABORT("Out of memory: can't allocate %u bytes", (_s)); \ } while (0) /* Magic tokens used to mark used / freed chunks. */ #define ALLOC_MAGIC_C1 0xFF00FF00 /* Used head (dword) */ #define ALLOC_MAGIC_F 0xFE00FE00 /* Freed head (dword) */ #define ALLOC_MAGIC_C2 0xF0 /* Used tail (byte) */ /* Positions of guard tokens in relation to the user-visible pointer. */ #define ALLOC_C1(_ptr) (((u32*)(_ptr))[-2]) #define ALLOC_S(_ptr) (((u32*)(_ptr))[-1]) #define ALLOC_C2(_ptr) (((u8*)(_ptr))[ALLOC_S(_ptr)]) #define ALLOC_OFF_HEAD 8 #define ALLOC_OFF_TOTAL (ALLOC_OFF_HEAD + 1) /* Allocator increments for ck_realloc_block(). */ #define ALLOC_BLK_INC 256 /* Sanity-checking macros for pointers. */ #define CHECK_PTR(_p) do { \ if (_p) { \ if (ALLOC_C1(_p) ^ ALLOC_MAGIC_C1) {\ if (ALLOC_C1(_p) == ALLOC_MAGIC_F) \ ABORT("Use after free."); \ else ABORT("Corrupted head alloc canary."); \ } \ if (ALLOC_C2(_p) ^ ALLOC_MAGIC_C2) \ ABORT("Corrupted tail alloc canary."); \ } \ } while (0) #define CHECK_PTR_EXPR(_p) ({ \ typeof (_p) _tmp = (_p); \ CHECK_PTR(_tmp); \ _tmp; \ }) /* Allocate a buffer, explicitly not zeroing it. Returns NULL for zero-sized requests. */ static inline void* DFL_ck_alloc_nozero(u32 size) { void* ret; if (!size) return NULL; ALLOC_CHECK_SIZE(size); ret = malloc(size + ALLOC_OFF_TOTAL); ALLOC_CHECK_RESULT(ret, size); ret += ALLOC_OFF_HEAD; ALLOC_C1(ret) = ALLOC_MAGIC_C1; ALLOC_S(ret) = size; ALLOC_C2(ret) = ALLOC_MAGIC_C2; return ret; } /* Allocate a buffer, returning zeroed memory. */ static inline void* DFL_ck_alloc(u32 size) { void* mem; if (!size) return NULL; mem = DFL_ck_alloc_nozero(size); return memset(mem, 0, size); } /* Free memory, checking for double free and corrupted heap. When DEBUG_BUILD is set, the old memory will be also clobbered with 0xFF. */ static inline void DFL_ck_free(void* mem) { if (!mem) return; CHECK_PTR(mem); #ifdef DEBUG_BUILD /* Catch pointer issues sooner. */ memset(mem, 0xFF, ALLOC_S(mem)); #endif /* DEBUG_BUILD */ ALLOC_C1(mem) = ALLOC_MAGIC_F; free(mem - ALLOC_OFF_HEAD); } /* Re-allocate a buffer, checking for issues and zeroing any newly-added tail. With DEBUG_BUILD, the buffer is always reallocated to a new addresses and the old memory is clobbered with 0xFF. */ static inline void* DFL_ck_realloc(void* orig, u32 size) { void* ret; u32 old_size = 0; if (!size) { DFL_ck_free(orig); return NULL; } if (orig) { CHECK_PTR(orig); #ifndef DEBUG_BUILD ALLOC_C1(orig) = ALLOC_MAGIC_F; #endif /* !DEBUG_BUILD */ old_size = ALLOC_S(orig); orig -= ALLOC_OFF_HEAD; ALLOC_CHECK_SIZE(old_size); } ALLOC_CHECK_SIZE(size); #ifndef DEBUG_BUILD ret = realloc(orig, size + ALLOC_OFF_TOTAL); ALLOC_CHECK_RESULT(ret, size); #else /* Catch pointer issues sooner: force relocation and make sure that the original buffer is wiped. */ ret = malloc(size + ALLOC_OFF_TOTAL); ALLOC_CHECK_RESULT(ret, size); if (orig) { memcpy(ret + ALLOC_OFF_HEAD, orig + ALLOC_OFF_HEAD, MIN(size, old_size)); memset(orig + ALLOC_OFF_HEAD, 0xFF, old_size); ALLOC_C1(orig + ALLOC_OFF_HEAD) = ALLOC_MAGIC_F; free(orig); } #endif /* ^!DEBUG_BUILD */ ret += ALLOC_OFF_HEAD; ALLOC_C1(ret) = ALLOC_MAGIC_C1; ALLOC_S(ret) = size; ALLOC_C2(ret) = ALLOC_MAGIC_C2; if (size > old_size) memset(ret + old_size, 0, size - old_size); return ret; } /* Re-allocate a buffer with ALLOC_BLK_INC increments (used to speed up repeated small reallocs without complicating the user code). */ static inline void* DFL_ck_realloc_block(void* orig, u32 size) { #ifndef DEBUG_BUILD if (orig) { CHECK_PTR(orig); if (ALLOC_S(orig) >= size) return orig; size += ALLOC_BLK_INC; } #endif /* !DEBUG_BUILD */ return DFL_ck_realloc(orig, size); } /* Create a buffer with a copy of a string. Returns NULL for NULL inputs. */ static inline u8* DFL_ck_strdup(u8* str) { void* ret; u32 size; if (!str) return NULL; size = strlen((char*)str) + 1; ALLOC_CHECK_SIZE(size); ret = malloc(size + ALLOC_OFF_TOTAL); ALLOC_CHECK_RESULT(ret, size); ret += ALLOC_OFF_HEAD; ALLOC_C1(ret) = ALLOC_MAGIC_C1; ALLOC_S(ret) = size; ALLOC_C2(ret) = ALLOC_MAGIC_C2; return memcpy(ret, str, size); } /* Create a buffer with a copy of a memory block. Returns NULL for zero-sized or NULL inputs. */ static inline void* DFL_ck_memdup(void* mem, u32 size) { void* ret; if (!mem || !size) return NULL; ALLOC_CHECK_SIZE(size); ret = malloc(size + ALLOC_OFF_TOTAL); ALLOC_CHECK_RESULT(ret, size); ret += ALLOC_OFF_HEAD; ALLOC_C1(ret) = ALLOC_MAGIC_C1; ALLOC_S(ret) = size; ALLOC_C2(ret) = ALLOC_MAGIC_C2; return memcpy(ret, mem, size); } /* Create a buffer with a block of text, appending a NUL terminator at the end. Returns NULL for zero-sized or NULL inputs. */ static inline u8* DFL_ck_memdup_str(u8* mem, u32 size) { u8* ret; if (!mem || !size) return NULL; ALLOC_CHECK_SIZE(size); ret = malloc(size + ALLOC_OFF_TOTAL + 1); ALLOC_CHECK_RESULT(ret, size); ret += ALLOC_OFF_HEAD; ALLOC_C1(ret) = ALLOC_MAGIC_C1; ALLOC_S(ret) = size; ALLOC_C2(ret) = ALLOC_MAGIC_C2; memcpy(ret, mem, size); ret[size] = 0; return ret; } #ifndef DEBUG_BUILD /* In non-debug mode, we just do straightforward aliasing of the above functions to user-visible names such as ck_alloc(). */ #define ck_alloc DFL_ck_alloc #define ck_alloc_nozero DFL_ck_alloc_nozero #define ck_realloc DFL_ck_realloc #define ck_realloc_block DFL_ck_realloc_block #define ck_strdup DFL_ck_strdup #define ck_memdup DFL_ck_memdup #define ck_memdup_str DFL_ck_memdup_str #define ck_free DFL_ck_free #define alloc_report() #else /* In debugging mode, we also track allocations to detect memory leaks, and the flow goes through one more layer of indirection. */ /* Alloc tracking data structures: */ #define ALLOC_BUCKETS 4096 struct TRK_obj { void *ptr; char *file, *func; u32 line; }; #ifdef AFL_MAIN struct TRK_obj* TRK[ALLOC_BUCKETS]; u32 TRK_cnt[ALLOC_BUCKETS]; # define alloc_report() TRK_report() #else extern struct TRK_obj* TRK[ALLOC_BUCKETS]; extern u32 TRK_cnt[ALLOC_BUCKETS]; # define alloc_report() #endif /* ^AFL_MAIN */ /* Bucket-assigning function for a given pointer: */ #define TRKH(_ptr) (((((u32)(_ptr)) >> 16) ^ ((u32)(_ptr))) % ALLOC_BUCKETS) /* Add a new entry to the list of allocated objects. */ static inline void TRK_alloc_buf(void* ptr, const char* file, const char* func, u32 line) { u32 i, bucket; if (!ptr) return; bucket = TRKH(ptr); /* Find a free slot in the list of entries for that bucket. */ for (i = 0; i < TRK_cnt[bucket]; i++) if (!TRK[bucket][i].ptr) { TRK[bucket][i].ptr = ptr; TRK[bucket][i].file = (char*)file; TRK[bucket][i].func = (char*)func; TRK[bucket][i].line = line; return; } /* No space available - allocate more. */ TRK[bucket] = DFL_ck_realloc_block(TRK[bucket], (TRK_cnt[bucket] + 1) * sizeof(struct TRK_obj)); TRK[bucket][i].ptr = ptr; TRK[bucket][i].file = (char*)file; TRK[bucket][i].func = (char*)func; TRK[bucket][i].line = line; TRK_cnt[bucket]++; } /* Remove entry from the list of allocated objects. */ static inline void TRK_free_buf(void* ptr, const char* file, const char* func, u32 line) { u32 i, bucket; if (!ptr) return; bucket = TRKH(ptr); /* Find the element on the list... */ for (i = 0; i < TRK_cnt[bucket]; i++) if (TRK[bucket][i].ptr == ptr) { TRK[bucket][i].ptr = 0; return; } WARNF("ALLOC: Attempt to free non-allocated memory in %s (%s:%u)", func, file, line); } /* Do a final report on all non-deallocated objects. */ static inline void TRK_report(void) { u32 i, bucket; fflush(0); for (bucket = 0; bucket < ALLOC_BUCKETS; bucket++) for (i = 0; i < TRK_cnt[bucket]; i++) if (TRK[bucket][i].ptr) WARNF("ALLOC: Memory never freed, created in %s (%s:%u)", TRK[bucket][i].func, TRK[bucket][i].file, TRK[bucket][i].line); } /* Simple wrappers for non-debugging functions: */ static inline void* TRK_ck_alloc(u32 size, const char* file, const char* func, u32 line) { void* ret = DFL_ck_alloc(size); TRK_alloc_buf(ret, file, func, line); return ret; } static inline void* TRK_ck_realloc(void* orig, u32 size, const char* file, const char* func, u32 line) { void* ret = DFL_ck_realloc(orig, size); TRK_free_buf(orig, file, func, line); TRK_alloc_buf(ret, file, func, line); return ret; } static inline void* TRK_ck_realloc_block(void* orig, u32 size, const char* file, const char* func, u32 line) { void* ret = DFL_ck_realloc_block(orig, size); TRK_free_buf(orig, file, func, line); TRK_alloc_buf(ret, file, func, line); return ret; } static inline void* TRK_ck_strdup(u8* str, const char* file, const char* func, u32 line) { void* ret = DFL_ck_strdup(str); TRK_alloc_buf(ret, file, func, line); return ret; } static inline void* TRK_ck_memdup(void* mem, u32 size, const char* file, const char* func, u32 line) { void* ret = DFL_ck_memdup(mem, size); TRK_alloc_buf(ret, file, func, line); return ret; } static inline void* TRK_ck_memdup_str(void* mem, u32 size, const char* file, const char* func, u32 line) { void* ret = DFL_ck_memdup_str(mem, size); TRK_alloc_buf(ret, file, func, line); return ret; } static inline void TRK_ck_free(void* ptr, const char* file, const char* func, u32 line) { TRK_free_buf(ptr, file, func, line); DFL_ck_free(ptr); } /* Aliasing user-facing names to tracking functions: */ #define ck_alloc(_p1) \ TRK_ck_alloc(_p1, __FILE__, __FUNCTION__, __LINE__) #define ck_alloc_nozero(_p1) \ TRK_ck_alloc(_p1, __FILE__, __FUNCTION__, __LINE__) #define ck_realloc(_p1, _p2) \ TRK_ck_realloc(_p1, _p2, __FILE__, __FUNCTION__, __LINE__) #define ck_realloc_block(_p1, _p2) \ TRK_ck_realloc_block(_p1, _p2, __FILE__, __FUNCTION__, __LINE__) #define ck_strdup(_p1) \ TRK_ck_strdup(_p1, __FILE__, __FUNCTION__, __LINE__) #define ck_memdup(_p1, _p2) \ TRK_ck_memdup(_p1, _p2, __FILE__, __FUNCTION__, __LINE__) #define ck_memdup_str(_p1, _p2) \ TRK_ck_memdup_str(_p1, _p2, __FILE__, __FUNCTION__, __LINE__) #define ck_free(_p1) \ TRK_ck_free(_p1, __FILE__, __FUNCTION__, __LINE__) #endif /* ^!DEBUG_BUILD */ #endif /* ! _HAVE_ALLOC_INL_H */ QuickChick-2.1.0/fuzz/cmdprefix.pl000077500000000000000000000006371476030541200170570ustar00rootroot00000000000000perl -i -0pe 's/let rec fuzzLoopAux fuel st favored discards favored_queue discard_queue randoms saved gen0 fuzz0 print prop =\n \(fun fO fS n -> if n=0 then fO \(\) else fS \(n-1\)\)\n \(fun _ -> giveUp st\)\n \(fun fuel\047 ->/let rec fuzzLoopAux fuel st favored discards favored_queue discard_queue randoms saved gen0 fuzz0 print prop =\n if fuel = 0 then giveUp st else let fuel\047 = fuel - 1 in/' $1 QuickChick-2.1.0/fuzz/cmdsuffix.pl000077500000000000000000000001331476030541200170550ustar00rootroot00000000000000perl -i -0pe 's/\)\n fuel\n\n\(\*\* val fuzzLoopWith /\n\n\(\*\* val fuzzLoopWith /' $1 QuickChick-2.1.0/fuzz/compile.sh000077500000000000000000000003161476030541200165170ustar00rootroot00000000000000#!/bin/bash ocamlopt -afl-instrument C.ml ocamlopt -ccopt -Wno-error=implicit-function-declaration C.cmx -o foo Fuzz.ml SHM.c ocamlopt -ccopt -Wno-error=implicit-function-declaration -o main Main.ml SHM.c QuickChick-2.1.0/fuzz/config.h000066400000000000000000000257201476030541200161540ustar00rootroot00000000000000/* american fuzzy lop - vaguely configurable bits ---------------------------------------------- Written and maintained by Michal Zalewski Copyright 2013, 2014, 2015, 2016 Google Inc. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0 */ #ifndef _HAVE_CONFIG_H #define _HAVE_CONFIG_H #include "types.h" /* Version string: */ #define VERSION "2.52b" /****************************************************** * * * Settings that may be of interest to power users: * * * ******************************************************/ /* Comment out to disable terminal colors (note that this makes afl-analyze a lot less nice): */ #define USE_COLOR /* Comment out to disable fancy ANSI boxes and use poor man's 7-bit UI: */ #define FANCY_BOXES /* Default timeout for fuzzed code (milliseconds). This is the upper bound, also used for detecting hangs; the actual value is auto-scaled: */ #define EXEC_TIMEOUT 1000 /* Timeout rounding factor when auto-scaling (milliseconds): */ #define EXEC_TM_ROUND 20 /* Default memory limit for child process (MB): */ #ifndef __x86_64__ # define MEM_LIMIT 25 #else # define MEM_LIMIT 50 #endif /* ^!__x86_64__ */ /* Default memory limit when running in QEMU mode (MB): */ #define MEM_LIMIT_QEMU 200 /* Number of calibration cycles per every new test case (and for test cases that show variable behavior): */ #define CAL_CYCLES 8 #define CAL_CYCLES_LONG 40 /* Number of subsequent timeouts before abandoning an input file: */ #define TMOUT_LIMIT 250 /* Maximum number of unique hangs or crashes to record: */ #define KEEP_UNIQUE_HANG 500 #define KEEP_UNIQUE_CRASH 5000 /* Baseline number of random tweaks during a single 'havoc' stage: */ #define HAVOC_CYCLES 256 #define HAVOC_CYCLES_INIT 1024 /* Maximum multiplier for the above (should be a power of two, beware of 32-bit int overflows): */ #define HAVOC_MAX_MULT 16 /* Absolute minimum number of havoc cycles (after all adjustments): */ #define HAVOC_MIN 16 /* Maximum stacking for havoc-stage tweaks. The actual value is calculated like this: n = random between 1 and HAVOC_STACK_POW2 stacking = 2^n In other words, the default (n = 7) produces 2, 4, 8, 16, 32, 64, or 128 stacked tweaks: */ #define HAVOC_STACK_POW2 7 /* Caps on block sizes for cloning and deletion operations. Each of these ranges has a 33% probability of getting picked, except for the first two cycles where smaller blocks are favored: */ #define HAVOC_BLK_SMALL 32 #define HAVOC_BLK_MEDIUM 128 #define HAVOC_BLK_LARGE 1500 /* Extra-large blocks, selected very rarely (<5% of the time): */ #define HAVOC_BLK_XL 32768 /* Probabilities of skipping non-favored entries in the queue, expressed as percentages: */ #define SKIP_TO_NEW_PROB 99 /* ...when there are new, pending favorites */ #define SKIP_NFAV_OLD_PROB 95 /* ...no new favs, cur entry already fuzzed */ #define SKIP_NFAV_NEW_PROB 75 /* ...no new favs, cur entry not fuzzed yet */ /* Splicing cycle count: */ #define SPLICE_CYCLES 15 /* Nominal per-splice havoc cycle length: */ #define SPLICE_HAVOC 32 /* Maximum offset for integer addition / subtraction stages: */ #define ARITH_MAX 35 /* Limits for the test case trimmer. The absolute minimum chunk size; and the starting and ending divisors for chopping up the input file: */ #define TRIM_MIN_BYTES 4 #define TRIM_START_STEPS 16 #define TRIM_END_STEPS 1024 /* Maximum size of input file, in bytes (keep under 100MB): */ #define MAX_FILE (1 * 1024 * 1024) /* The same, for the test case minimizer: */ #define TMIN_MAX_FILE (10 * 1024 * 1024) /* Block normalization steps for afl-tmin: */ #define TMIN_SET_MIN_SIZE 4 #define TMIN_SET_STEPS 128 /* Maximum dictionary token size (-x), in bytes: */ #define MAX_DICT_FILE 128 /* Length limits for auto-detected dictionary tokens: */ #define MIN_AUTO_EXTRA 3 #define MAX_AUTO_EXTRA 32 /* Maximum number of user-specified dictionary tokens to use in deterministic steps; past this point, the "extras/user" step will be still carried out, but with proportionally lower odds: */ #define MAX_DET_EXTRAS 200 /* Maximum number of auto-extracted dictionary tokens to actually use in fuzzing (first value), and to keep in memory as candidates. The latter should be much higher than the former. */ #define USE_AUTO_EXTRAS 50 #define MAX_AUTO_EXTRAS (USE_AUTO_EXTRAS * 10) /* Scaling factor for the effector map used to skip some of the more expensive deterministic steps. The actual divisor is set to 2^EFF_MAP_SCALE2 bytes: */ #define EFF_MAP_SCALE2 3 /* Minimum input file length at which the effector logic kicks in: */ #define EFF_MIN_LEN 128 /* Maximum effector density past which everything is just fuzzed unconditionally (%): */ #define EFF_MAX_PERC 90 /* UI refresh frequency (Hz): */ #define UI_TARGET_HZ 5 /* Fuzzer stats file and plot update intervals (sec): */ #define STATS_UPDATE_SEC 60 #define PLOT_UPDATE_SEC 5 /* Smoothing divisor for CPU load and exec speed stats (1 - no smoothing). */ #define AVG_SMOOTHING 16 /* Sync interval (every n havoc cycles): */ #define SYNC_INTERVAL 5 /* Output directory reuse grace period (minutes): */ #define OUTPUT_GRACE 25 /* Uncomment to use simple file names (id_NNNNNN): */ // #define SIMPLE_FILES /* List of interesting values to use in fuzzing. */ #define INTERESTING_8 \ -128, /* Overflow signed 8-bit when decremented */ \ -1, /* */ \ 0, /* */ \ 1, /* */ \ 16, /* One-off with common buffer size */ \ 32, /* One-off with common buffer size */ \ 64, /* One-off with common buffer size */ \ 100, /* One-off with common buffer size */ \ 127 /* Overflow signed 8-bit when incremented */ #define INTERESTING_16 \ -32768, /* Overflow signed 16-bit when decremented */ \ -129, /* Overflow signed 8-bit */ \ 128, /* Overflow signed 8-bit */ \ 255, /* Overflow unsig 8-bit when incremented */ \ 256, /* Overflow unsig 8-bit */ \ 512, /* One-off with common buffer size */ \ 1000, /* One-off with common buffer size */ \ 1024, /* One-off with common buffer size */ \ 4096, /* One-off with common buffer size */ \ 32767 /* Overflow signed 16-bit when incremented */ #define INTERESTING_32 \ -2147483648LL, /* Overflow signed 32-bit when decremented */ \ -100663046, /* Large negative number (endian-agnostic) */ \ -32769, /* Overflow signed 16-bit */ \ 32768, /* Overflow signed 16-bit */ \ 65535, /* Overflow unsig 16-bit when incremented */ \ 65536, /* Overflow unsig 16 bit */ \ 100663045, /* Large positive number (endian-agnostic) */ \ 2147483647 /* Overflow signed 32-bit when incremented */ /*********************************************************** * * * Really exotic stuff you probably don't want to touch: * * * ***********************************************************/ /* Call count interval between reseeding the libc PRNG from /dev/urandom: */ #define RESEED_RNG 10000 /* Maximum line length passed from GCC to 'as' and used for parsing configuration files: */ #define MAX_LINE 8192 /* Environment variable used to pass SHM ID to the called program. */ #define SHM_ENV_VAR "__AFL_SHM_ID" /* Other less interesting, internal-only variables. */ #define CLANG_ENV_VAR "__AFL_CLANG_MODE" #define AS_LOOP_ENV_VAR "__AFL_AS_LOOPCHECK" #define PERSIST_ENV_VAR "__AFL_PERSISTENT" #define DEFER_ENV_VAR "__AFL_DEFER_FORKSRV" /* In-code signatures for deferred and persistent mode. */ #define PERSIST_SIG "##SIG_AFL_PERSISTENT##" #define DEFER_SIG "##SIG_AFL_DEFER_FORKSRV##" /* Distinctive bitmap signature used to indicate failed execution: */ #define EXEC_FAIL_SIG 0xfee1dead /* Distinctive exit code used to indicate MSAN trip condition: */ #define MSAN_ERROR 86 /* Designated file descriptors for forkserver commands (the application will use FORKSRV_FD and FORKSRV_FD + 1): */ #define FORKSRV_FD 198 /* Fork server init timeout multiplier: we'll wait the user-selected timeout plus this much for the fork server to spin up. */ #define FORK_WAIT_MULT 10 /* Calibration timeout adjustments, to be a bit more generous when resuming fuzzing sessions or trying to calibrate already-added internal finds. The first value is a percentage, the other is in milliseconds: */ #define CAL_TMOUT_PERC 125 #define CAL_TMOUT_ADD 50 /* Number of chances to calibrate a case before giving up: */ #define CAL_CHANCES 3 /* Map size for the traced binary (2^MAP_SIZE_POW2). Must be greater than 2; you probably want to keep it under 18 or so for performance reasons (adjusting AFL_INST_RATIO when compiling is probably a better way to solve problems with complex programs). You need to recompile the target binary after changing this - otherwise, SEGVs may ensue. */ #define MAP_SIZE_POW2 16 #define MAP_SIZE (1 << MAP_SIZE_POW2) /* Maximum allocator request size (keep well under INT_MAX): */ #define MAX_ALLOC 0x40000000 /* A made-up hashing seed: */ #define HASH_CONST 0xa5b35705 /* Constants for afl-gotcpu to control busy loop timing: */ #define CTEST_TARGET_MS 5000 #define CTEST_CORE_TRG_MS 1000 #define CTEST_BUSY_CYCLES (10 * 1000 * 1000) /* Uncomment this to use inferior block-coverage-based instrumentation. Note that you need to recompile the target binary for this to have any effect: */ // #define COVERAGE_ONLY /* Uncomment this to ignore hit counts and output just one bit per tuple. As with the previous setting, you will need to recompile the target binary: */ // #define SKIP_COUNTS /* Uncomment this to use instrumentation data to record newly discovered paths, but do not use them as seeds for fuzzing. This is useful for conveniently measuring coverage that could be attained by a "dumb" fuzzing algorithm: */ // #define IGNORE_FINDS #endif /* ! _HAVE_CONFIG_H */ QuickChick-2.1.0/fuzz/debug.h000066400000000000000000000146561476030541200160030ustar00rootroot00000000000000/* american fuzzy lop - debug / error handling macros -------------------------------------------------- Written and maintained by Michal Zalewski Copyright 2013, 2014, 2015, 2016 Google Inc. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0 */ #ifndef _HAVE_DEBUG_H #define _HAVE_DEBUG_H #include #include "types.h" #include "config.h" /******************* * Terminal colors * *******************/ #ifdef USE_COLOR # define cBLK "\x1b[0;30m" # define cRED "\x1b[0;31m" # define cGRN "\x1b[0;32m" # define cBRN "\x1b[0;33m" # define cBLU "\x1b[0;34m" # define cMGN "\x1b[0;35m" # define cCYA "\x1b[0;36m" # define cLGR "\x1b[0;37m" # define cGRA "\x1b[1;90m" # define cLRD "\x1b[1;91m" # define cLGN "\x1b[1;92m" # define cYEL "\x1b[1;93m" # define cLBL "\x1b[1;94m" # define cPIN "\x1b[1;95m" # define cLCY "\x1b[1;96m" # define cBRI "\x1b[1;97m" # define cRST "\x1b[0m" # define bgBLK "\x1b[40m" # define bgRED "\x1b[41m" # define bgGRN "\x1b[42m" # define bgBRN "\x1b[43m" # define bgBLU "\x1b[44m" # define bgMGN "\x1b[45m" # define bgCYA "\x1b[46m" # define bgLGR "\x1b[47m" # define bgGRA "\x1b[100m" # define bgLRD "\x1b[101m" # define bgLGN "\x1b[102m" # define bgYEL "\x1b[103m" # define bgLBL "\x1b[104m" # define bgPIN "\x1b[105m" # define bgLCY "\x1b[106m" # define bgBRI "\x1b[107m" #else # define cBLK "" # define cRED "" # define cGRN "" # define cBRN "" # define cBLU "" # define cMGN "" # define cCYA "" # define cLGR "" # define cGRA "" # define cLRD "" # define cLGN "" # define cYEL "" # define cLBL "" # define cPIN "" # define cLCY "" # define cBRI "" # define cRST "" # define bgBLK "" # define bgRED "" # define bgGRN "" # define bgBRN "" # define bgBLU "" # define bgMGN "" # define bgCYA "" # define bgLGR "" # define bgGRA "" # define bgLRD "" # define bgLGN "" # define bgYEL "" # define bgLBL "" # define bgPIN "" # define bgLCY "" # define bgBRI "" #endif /* ^USE_COLOR */ /************************* * Box drawing sequences * *************************/ #ifdef FANCY_BOXES # define SET_G1 "\x1b)0" /* Set G1 for box drawing */ # define RESET_G1 "\x1b)B" /* Reset G1 to ASCII */ # define bSTART "\x0e" /* Enter G1 drawing mode */ # define bSTOP "\x0f" /* Leave G1 drawing mode */ # define bH "q" /* Horizontal line */ # define bV "x" /* Vertical line */ # define bLT "l" /* Left top corner */ # define bRT "k" /* Right top corner */ # define bLB "m" /* Left bottom corner */ # define bRB "j" /* Right bottom corner */ # define bX "n" /* Cross */ # define bVR "t" /* Vertical, branch right */ # define bVL "u" /* Vertical, branch left */ # define bHT "v" /* Horizontal, branch top */ # define bHB "w" /* Horizontal, branch bottom */ #else # define SET_G1 "" # define RESET_G1 "" # define bSTART "" # define bSTOP "" # define bH "-" # define bV "|" # define bLT "+" # define bRT "+" # define bLB "+" # define bRB "+" # define bX "+" # define bVR "+" # define bVL "+" # define bHT "+" # define bHB "+" #endif /* ^FANCY_BOXES */ /*********************** * Misc terminal codes * ***********************/ #define TERM_HOME "\x1b[H" #define TERM_CLEAR TERM_HOME "\x1b[2J" #define cEOL "\x1b[0K" #define CURSOR_HIDE "\x1b[?25l" #define CURSOR_SHOW "\x1b[?25h" /************************ * Debug & error macros * ************************/ /* Just print stuff to the appropriate stream. */ #ifdef MESSAGES_TO_STDOUT # define SAYF(x...) printf(x) #else # define SAYF(x...) fprintf(stderr, x) #endif /* ^MESSAGES_TO_STDOUT */ /* Show a prefixed warning. */ #define WARNF(x...) do { \ SAYF(cYEL "[!] " cBRI "WARNING: " cRST x); \ SAYF(cRST "\n"); \ } while (0) /* Show a prefixed "doing something" message. */ #define ACTF(x...) do { \ SAYF(cLBL "[*] " cRST x); \ SAYF(cRST "\n"); \ } while (0) /* Show a prefixed "success" message. */ #define OKF(x...) do { \ SAYF(cLGN "[+] " cRST x); \ SAYF(cRST "\n"); \ } while (0) /* Show a prefixed fatal error message (not used in afl). */ #define BADF(x...) do { \ SAYF(cLRD "\n[-] " cRST x); \ SAYF(cRST "\n"); \ } while (0) /* Die with a verbose non-OS fatal error message. */ #define FATAL(x...) do { \ SAYF(bSTOP RESET_G1 CURSOR_SHOW cRST cLRD "\n[-] PROGRAM ABORT : " \ cBRI x); \ SAYF(cLRD "\n Location : " cRST "%s(), %s:%u\n\n", \ __FUNCTION__, __FILE__, __LINE__); \ exit(1); \ } while (0) /* Die by calling abort() to provide a core dump. */ #define ABORT(x...) do { \ SAYF(bSTOP RESET_G1 CURSOR_SHOW cRST cLRD "\n[-] PROGRAM ABORT : " \ cBRI x); \ SAYF(cLRD "\n Stop location : " cRST "%s(), %s:%u\n\n", \ __FUNCTION__, __FILE__, __LINE__); \ abort(); \ } while (0) /* Die while also including the output of perror(). */ #define PFATAL(x...) do { \ fflush(stdout); \ SAYF(bSTOP RESET_G1 CURSOR_SHOW cRST cLRD "\n[-] SYSTEM ERROR : " \ cBRI x); \ SAYF(cLRD "\n Stop location : " cRST "%s(), %s:%u\n", \ __FUNCTION__, __FILE__, __LINE__); \ SAYF(cLRD " OS message : " cRST "%s\n", strerror(errno)); \ exit(1); \ } while (0) /* Die with FAULT() or PFAULT() depending on the value of res (used to interpret different failure modes for read(), write(), etc). */ #define RPFATAL(res, x...) do { \ if (res < 0) PFATAL(x); else FATAL(x); \ } while (0) /* Error-checking versions of read() and write() that call RPFATAL() as appropriate. */ #define ck_write(fd, buf, len, fn) do { \ u32 _len = (len); \ s32 _res = write(fd, buf, _len); \ if (_res != _len) RPFATAL(_res, "Short write to %s", fn); \ } while (0) #define ck_read(fd, buf, len, fn) do { \ u32 _len = (len); \ s32 _res = read(fd, buf, _len); \ if (_res != _len) RPFATAL(_res, "Short read from %s", fn); \ } while (0) #endif /* ! _HAVE_DEBUG_H */ QuickChick-2.1.0/fuzz/types.h000066400000000000000000000043641476030541200160540ustar00rootroot00000000000000/* american fuzzy lop - type definitions and minor macros ------------------------------------------------------ Written and maintained by Michal Zalewski Copyright 2013, 2014, 2015 Google Inc. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0 */ #ifndef _HAVE_TYPES_H #define _HAVE_TYPES_H #include #include typedef uint8_t u8; typedef uint16_t u16; typedef uint32_t u32; /* Ugh. There is an unintended compiler / glibc #include glitch caused by combining the u64 type an %llu in format strings, necessitating a workaround. In essence, the compiler is always looking for 'unsigned long long' for %llu. On 32-bit systems, the u64 type (aliased to uint64_t) is expanded to 'unsigned long long' in , so everything checks out. But on 64-bit systems, it is #ifdef'ed in the same file as 'unsigned long'. Now, it only happens in circumstances where the type happens to have the expected bit width, *but* the compiler does not know that... and complains about 'unsigned long' being unsafe to pass to %llu. */ #ifdef __x86_64__ typedef unsigned long long u64; #else typedef uint64_t u64; #endif /* ^__x86_64__ */ typedef int8_t s8; typedef int16_t s16; typedef int32_t s32; typedef int64_t s64; #ifndef MIN # define MIN(_a,_b) ((_a) > (_b) ? (_b) : (_a)) # define MAX(_a,_b) ((_a) > (_b) ? (_a) : (_b)) #endif /* !MIN */ #define SWAP16(_x) ({ \ u16 _ret = (_x); \ (u16)((_ret << 8) | (_ret >> 8)); \ }) #define SWAP32(_x) ({ \ u32 _ret = (_x); \ (u32)((_ret << 24) | (_ret >> 24) | \ ((_ret << 8) & 0x00FF0000) | \ ((_ret >> 8) & 0x0000FF00)); \ }) #ifdef AFL_LLVM_PASS # define AFL_R(x) (random() % (x)) #else # define R(x) (random() % (x)) #endif /* ^AFL_LLVM_PASS */ #define STRINGIFY_INTERNAL(x) #x #define STRINGIFY(x) STRINGIFY_INTERNAL(x) #define MEM_BARRIER() \ asm volatile("" ::: "memory") #define likely(_x) __builtin_expect(!!(_x), 1) #define unlikely(_x) __builtin_expect(!!(_x), 0) #endif /* ! _HAVE_TYPES_H */ QuickChick-2.1.0/plugin/000077500000000000000000000000001476030541200150305ustar00rootroot00000000000000QuickChick-2.1.0/plugin/META.coq-quickchick.in000066400000000000000000000004431476030541200210040ustar00rootroot00000000000000package "plugin" ( directory = "." requires = "coq-core.plugins.ltac coq-core.plugins.extraction" archive(byte) = "quickchick_plugin.cma" archive(native) = "quickchick_plugin.cmxa" plugin(byte) = "quickchick_plugin.cma" plugin(native) = "quickchick_plugin.cmxs" ) directory = "."QuickChick-2.1.0/plugin/arbitrarySized.ml000066400000000000000000000174371476030541200203740ustar00rootroot00000000000000open Util open GenericLib open GenLib let arbitrarySized_decl (types : (ty_ctr * ty_param list * ctr_rep list) list) : (ty_ctr -> var list -> coq_expr) * ((var * arg list * var * coq_expr * coq_expr) list) = let impl_function_names : (ty_ctr * var) list = List.map (fun (ty, _, _) -> let type_name = ty_ctr_to_string ty in let function_name = fresh_name ("arbitrarySized_impl_" ^ type_name) in (ty, function_name) ) types in let generate_arbitrarySized_function ((ty, ty_params, ctors) : (ty_ctr * ty_param list * ctr_rep list)) : var * arg list * var * coq_expr * coq_expr = let function_name = List.assoc ty impl_function_names in let coqTyParams = List.map gTyParam ty_params in let full_type = gApp ~explicit:true (gTyCtr ty) coqTyParams in let arg = fresh_name "size" in let arg_type = (gInject "Coq.Init.Datatypes.nat") in (* G ty *) let return_type = gApp (gInject "QuickChick.Generators.G") [full_type] in let find_ty_ctr = function | TyCtr (ty_ctr', _) -> List.assoc_opt ty_ctr' impl_function_names | _ -> None in (* a base branch is a constructor that doesn't require our ty_ctr to be used *) let is_base_branch ty = fold_ty' (fun b ty' -> b && (None = (find_ty_ctr ty'))) true ty in let base_branches = List.filter (fun (_, ty) -> is_base_branch ty) ctors in let create_for_branch size (ctr, ty) = let rec aux i acc ty : coq_expr = match ty with | Arrow (ty1, ty2) -> bindGen (match find_ty_ctr ty1 with | Some name -> gApp (gVar name) [gVar size] | None -> gInject "arbitrary") (Printf.sprintf "p%d" i) (fun pi -> aux (i+1) ((gVar pi) :: acc) ty2) | _ -> returnGen (gApp ~explicit:true (gCtr ctr) (coqTyParams @ List.rev acc)) in aux 0 [] ty in let body = gMatch (gVar arg) [ ( injectCtr "O", [], fun _ -> oneofThunked (List.map (create_for_branch arg) base_branches) ); ( injectCtr "S", ["size'"], fun [size'] -> frequencyThunked (List.map (fun (ctr, ty') -> (Weightmap.lookup_weight (is_base_branch ty') ctr size', create_for_branch size' (ctr, ty')) ) ctors) ) ] in debug_coq_expr body; (function_name, [gArg ~assumName:(gVar arg) ~assumType:arg_type ()], arg, return_type, body) in let functions = List.map generate_arbitrarySized_function types in (* returns {| arbitrarySized := @arbitrarySized_impl_... |} *) let instance_record ty_ctr ivars : coq_expr = let impl_function_name = List.assoc ty_ctr impl_function_names in let implicit_arguments = List.map gVar ivars in gRecord [ ("arbitrarySized", gApp ~explicit:true (gVar impl_function_name) implicit_arguments) ] in (instance_record, functions) let rec replace v x = function | [] -> [] | y::ys -> if y = v then x::ys else y::(replace v x ys) let shrink_decl (types : (ty_ctr * ty_param list * ctr_rep list) list) : (ty_ctr -> var list -> coq_expr) * ((var * arg list * var * coq_expr * coq_expr) list) = let impl_function_names : (ty_ctr * var) list = List.map (fun (ty, _, _) -> let type_name = ty_ctr_to_string ty in let function_name = fresh_name ("shrink_impl_" ^ type_name) in (ty, function_name) ) types in let generate_shrink_function ((ty, ty_params, ctors) : (ty_ctr * ty_param list * ctr_rep list)) : var * arg list * var * coq_expr * coq_expr = let function_name = List.assoc ty impl_function_names in let coqTyParams = List.map gTyParam ty_params in let full_type = gApp ~explicit:true (gTyCtr ty) coqTyParams in let arg = fresh_name "x" in let arg_type = full_type in (* full_type list *) let return_type = gApp (gInject "Coq.Init.Datatypes.list") [full_type] in let is_current_ty_crt = function | TyCtr (ty_ctr', _) -> ty = ty_ctr' | _ -> false in let find_ty_ctr = function | TyCtr (ty_ctr', _) -> List.assoc_opt ty_ctr' impl_function_names | _ -> None in let create_branch (ctr, ty) = ( ctr, generate_names_from_type "p" ty, fold_ty_vars (fun allParams v ty' -> let liftNth = gFun ["shrunk"] (fun [shrunk] -> gApp ~explicit:true (gCtr ctr) (coqTyParams @ (replace (gVar v) (gVar shrunk) (List.map gVar allParams)))) in lst_appends (match find_ty_ctr ty' with | Some name -> if is_current_ty_crt ty' (* [[v], List.map liftNth (name v)] *) then [ gList [gVar v] ; gApp (gInject "List.map") [liftNth; gApp (gVar name) [gVar v]] ] (* [List.map liftNth (name v)] *) else [ gApp (gInject "List.map") [liftNth; gApp (gVar name) [gVar v]] ] (* [List.map liftNth (shrink v)] *) | None -> [ gApp (gInject "List.map") [liftNth; gApp (gInject "shrink") [gVar v]] ])) lst_append list_nil ty ) in let body = gMatch (gVar arg) (List.map create_branch ctors) in debug_coq_expr body; (function_name, [gArg ~assumName:(gVar arg) ~assumType:arg_type ()], arg, return_type, body) in let functions = List.map generate_shrink_function types in (* returns {| shrink := @show_impl_... |} *) let instance_record ty_ctr ivars : coq_expr = let impl_function_name = List.assoc ty_ctr impl_function_names in let implicit_arguments = List.map gVar ivars in gRecord [ ("shrink", gApp ~explicit:true (gVar impl_function_name) implicit_arguments) ] in (instance_record, functions) let show_decl (types : (ty_ctr * ty_param list * ctr_rep list) list) : (ty_ctr -> var list -> coq_expr) * ((var * arg list * var * coq_expr * coq_expr) list) = let impl_function_names : (ty_ctr * var) list = List.map (fun (ty, _, _) -> let type_name = ty_ctr_to_string ty in let function_name = fresh_name ("show_impl_" ^ type_name) in (ty, function_name) ) types in let generate_show_function ((ty, ty_params, ctors) : (ty_ctr * ty_param list * ctr_rep list)) : var * arg list * var * coq_expr * coq_expr = let function_name = List.assoc ty impl_function_names in let coqTyParams = List.map gTyParam ty_params in let full_type = gApp ~explicit:true (gTyCtr ty) coqTyParams in let arg = fresh_name "x" in let arg_type = full_type in let return_type = gInject "Coq.Strings.String.string" in let find_ty_ctr = function | TyCtr (ty_ctr', _) -> List.assoc_opt ty_ctr' impl_function_names | _ -> None in let branch (ctr, ty) = ( ctr, generate_names_from_type "p" ty, fun vs -> match vs with | [] -> gStr (constructor_to_string ctr) | _ -> str_append (gStr (constructor_to_string ctr ^ " ")) (fold_ty_vars (fun _ v ty' -> smart_paren @@ gApp (match find_ty_ctr ty' with | Some name -> gVar name | _ -> gInject "show" ) [gVar v]) (fun s1 s2 -> if s2 = emptyString then s1 else str_appends [s1; gStr " "; s2]) emptyString ty vs) ) in (* match x with | Ctr p0 p1 ... pn -> "Ctr " ++ (...) ++ " " ++ (...) *) let body = gMatch (gVar arg) (List.map branch ctors) in (function_name, [gArg ~assumName:(gVar arg) ~assumType:arg_type ()], arg, return_type, body) in let functions = List.map generate_show_function types in (* returns {| show := show_impl_... |} *) let instance_record ty_ctr _ivars : coq_expr = let impl_function_name = List.assoc ty_ctr impl_function_names in gRecord [("show", gVar impl_function_name)] in (instance_record, functions)QuickChick-2.1.0/plugin/arbitrarySized.mli000066400000000000000000000015101476030541200205260ustar00rootroot00000000000000val arbitrarySized_decl : (GenericLib.ty_ctr * GenericLib.ty_param list * GenericLib.ctr_rep list) list -> (GenericLib.ty_ctr -> GenericLib.var list -> GenericLib.coq_expr) * ((GenericLib.var * GenericLib.arg list * GenericLib.var * GenericLib.coq_expr * GenericLib.coq_expr) list) val shrink_decl : (GenericLib.ty_ctr * GenericLib.ty_param list * GenericLib.ctr_rep list) list -> (GenericLib.ty_ctr -> GenericLib.var list -> GenericLib.coq_expr) * ((GenericLib.var * GenericLib.arg list * GenericLib.var * GenericLib.coq_expr * GenericLib.coq_expr) list) val show_decl : (GenericLib.ty_ctr * GenericLib.ty_param list * GenericLib.ctr_rep list) list -> (GenericLib.ty_ctr -> GenericLib.var list -> GenericLib.coq_expr) * ((GenericLib.var * GenericLib.arg list * GenericLib.var * GenericLib.coq_expr * GenericLib.coq_expr) list) QuickChick-2.1.0/plugin/arbitrarySizedST.ml000066400000000000000000000153461476030541200206400ustar00rootroot00000000000000open Pp open Util open GenericLib open CoqLib open GenLib open Error open UnifyQC (* arguments to handle_branch *) let fail_exp (dt : coq_expr) = returnGen (gApp ~explicit:true (gInject "None") [dt]) let not_enough_fuel_exp (dt : coq_expr) = returnGen (gApp ~explicit:true (gInject "None") [dt]) let ret_exp (dt : coq_expr) (c : coq_expr) = msg_debug (str "Returning...." ++ fnl ()); debug_coq_expr c; returnGen (gApp ~explicit:true (gInject "Some") [dt; c]) let ret_type (s : var) f = hole let instantiate_existential_method = (gInject "arbitrary") let instantiate_existential_methodST (n : int) (pred : coq_expr) = gApp ~explicit:true (gInject "arbitraryST") [ hole (* Implicit argument - type A *) ; pred ; hole (* Implicit instance *)] let rec_method (rec_name : coq_expr) (init_size : coq_expr) (size : coq_expr) (n : int) (letbinds : unknown list option) (l : coq_expr list) = (* TODO: use letbinds *) gApp rec_name (init_size :: size :: l) let bind (opt : bool) (m : coq_expr) (x : string) (f : var -> coq_expr) = (if opt then bindGenOpt else bindGen) m x f let stMaybe (opt : bool) (g : coq_expr) (x : string) (checks : ((coq_expr -> coq_expr) * int) list) = let rec sumbools_to_bool x lst = match lst with | [] -> gTrueb | (chk, _) :: lst' -> matchDec (chk (gVar x)) (fun heq -> gFalseb) (fun hneq -> sumbools_to_bool x lst') in let bool_pred = gFun [x] (fun [x] -> sumbools_to_bool x checks) in (gApp (gInject (if opt then "suchThatMaybeOpt" else "suchThatMaybe")) [ g (* Use the generator provided for base generator *) ; bool_pred ]) let ret_type_dec (s : var) (left : coq_expr) (right : coq_expr) = gMatch (gVar s) [ (injectCtr "left", ["eq"], fun _ -> left) ; (injectCtr "right", ["neq"], fun _ -> right) ] let check_expr (n : int) (scrut : coq_expr) (left : coq_expr) (right : coq_expr) (out_of_fuel : coq_expr) = gMatchReturn scrut "s" (* as clause *) (fun v -> ret_type v ret_type_dec) [ (injectCtr "Some", ["res_b" ] , fun [b] -> (* Why as clauses/returns? *) gMatch (gVar b) [ (injectCtr "true", [], fun _ -> left) ; (injectCtr "false", [], fun _ -> right) ]) ; (injectCtr "None", [], fun _ -> out_of_fuel) ] let match_inp (inp : var) (pat : matcher_pat) (left : coq_expr) (right : coq_expr) = msg_debug (str (Printf.sprintf "Calling match inp with %s %s\n" (var_to_string inp) (matcher_pat_to_string pat)) ++ fnl ()); let ret v left right = construct_match (gVar v) ~catch_all:(Some right) [(pat, left)] in let catch_case = match pat with | MatchCtr (c, ls) -> msg_debug (str (Printf.sprintf "In catch case: %s : %s\n" (matcher_pat_to_string pat) (string_of_int (num_of_ctrs c))) ++ fnl ()); (* Leo: This is a hack totality check for unary matches *) if num_of_ctrs c = 1 && List.for_all (fun x -> match x with MatchU _ -> true | MatchParameter _ -> true | MatchCtr (c',_) -> belongs_to_inductive c') ls then None else Some right | _ -> failwith "Toplevel match not a constructor?" in construct_match_with_return (gVar inp) ~catch_all:(catch_case) "s" (fun v -> ret_type v ret) [(pat,left)] type generator_kind = Base_gen | Ind_gen (* hoisting out base and ind gen to be able to call them from proof generation *) let construct_generators (kind : generator_kind) (init_size : coq_expr) (size : coq_expr) (full_gtyp : coq_expr) (gen_ctr : ty_ctr) (dep_type : dep_type) (ctrs : dep_ctr list) (rec_name : coq_expr) (input_ranges : range list) (init_umap : range UM.t) (init_tmap : dep_type UM.t) (result : Unknown.t) = (* partially applied handle_branch *) let handle_branch' = handle_branch ["GenSizedSuchThat"; "GenSuchThat"] dep_type init_size (fail_exp full_gtyp) (not_enough_fuel_exp full_gtyp) (ret_exp full_gtyp) instantiate_existential_method instantiate_existential_methodST bind (rec_method rec_name init_size size) bind stMaybe check_expr match_inp gLetIn gLetTupleIn gen_ctr init_umap init_tmap input_ranges result in let all_gens = List.map handle_branch' ctrs in let padNone = if List.exists (fun gb -> not (snd gb)) all_gens then [(not_enough_fuel_exp full_gtyp, true)] else [] in match kind with | Base_gen -> (List.filter snd all_gens) @ padNone | Ind_gen -> all_gens let base_gens = construct_generators Base_gen let ind_gens = construct_generators Ind_gen (* Advanced Generators *) let arbitrarySizedST (gen_ctr : ty_ctr) (ty_params : ty_param list) (ctrs : dep_ctr list) (dep_type : dep_type) (input_names : var list) (input_ranges : range list) (init_umap : range UM.t) (init_tmap : dep_type UM.t) (inputs : arg list) (result : Unknown.t) (rec_name : coq_expr) = (* type constructor *) let _coqTyCtr = gTyCtr gen_ctr in (* parameters of the type constructor *) let _coqTyParams = List.map gTyParam ty_params in (* The type we are generating for -- not the predicate! *) let full_gtyp = (gType ty_params (UM.find result init_tmap)) in (* The type of the dependent generator *) let gen_type = gGen (gOption full_gtyp) in let aux_arb rec_name init_size size vars = gMatch (gVar size) [ (injectCtr "O", [], fun _ -> let opts = base_gens init_size (gVar size) full_gtyp gen_ctr dep_type ctrs rec_name input_ranges init_umap init_tmap result in uniform_backtracking (List.map thunkify (List.map fst opts))) ; (injectCtr "S", ["size'"], fun [size'] -> let opts = ind_gens init_size (gVar size') full_gtyp gen_ctr dep_type ctrs rec_name input_ranges init_umap init_tmap result in let weights = List.map (fun ((c,_),(_,b)) -> Weightmap.lookup_weight b c size') (List.combine ctrs opts) in backtracking (List.combine weights (List.map thunkify (List.map fst opts)))) ] in let generator_body : coq_expr = gRecFunInWithArgs ~assumType:(gen_type) "aux_arb" (gArg ~assumName:(gVar (fresh_name "init_size")) () :: gArg ~assumName:(gVar (fresh_name "size")) () :: inputs) (fun (rec_name, init_size::size::vars) -> aux_arb (gVar rec_name) (gVar init_size) size vars) (fun rec_name -> gFun ["size"] (fun [size] -> gApp (gVar rec_name) (gVar size :: gVar size :: List.map (fun i -> gVar (arg_to_var i)) inputs) )) in msg_debug (fnl () ++ fnl () ++ str "`Final body produced:" ++ fnl ()); debug_coq_expr generator_body; msg_debug (fnl ()); gRecord [("arbitrarySizeST", generator_body)] QuickChick-2.1.0/plugin/arbitrarySizedST.mli000066400000000000000000000052461476030541200210070ustar00rootroot00000000000000val fail_exp : GenericLib.coq_expr -> GenericLib.coq_expr val not_enough_fuel_exp : GenericLib.coq_expr -> GenericLib.coq_expr val ret_exp : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val ret_type : GenericLib.var -> 'a -> GenericLib.coq_expr val instantiate_existential_method : GenericLib.coq_expr val instantiate_existential_methodST : int -> GenericLib.coq_expr -> GenericLib.coq_expr val rec_method : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> int -> UnifyQC.unknown list option -> GenericLib.coq_expr list -> GenericLib.coq_expr val bind : bool -> GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val stMaybe : bool -> GenericLib.coq_expr -> string -> ((GenericLib.coq_expr -> GenericLib.coq_expr) * int) list -> GenericLib.coq_expr val ret_type_dec : GenericLib.var -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val check_expr : int -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val match_inp : GenericLib.var -> GenericLib.matcher_pat -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr type generator_kind = Base_gen | Ind_gen val construct_generators : generator_kind -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.ty_ctr -> GenericLib.dep_type -> GenericLib.dep_ctr list -> GenericLib.coq_expr -> UnifyQC.range list -> UnifyQC.range UnifyQC.UM.t -> GenericLib.dep_type UnifyQC.UM.t -> UnifyQC.Unknown.t -> (GenericLib.coq_expr * bool) list val base_gens : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.ty_ctr -> GenericLib.dep_type -> GenericLib.dep_ctr list -> GenericLib.coq_expr -> UnifyQC.range list -> UnifyQC.range UnifyQC.UM.t -> GenericLib.dep_type UnifyQC.UM.t -> UnifyQC.Unknown.t -> (GenericLib.coq_expr * bool) list val ind_gens : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.ty_ctr -> GenericLib.dep_type -> GenericLib.dep_ctr list -> GenericLib.coq_expr -> UnifyQC.range list -> UnifyQC.range UnifyQC.UM.t -> GenericLib.dep_type UnifyQC.UM.t -> UnifyQC.Unknown.t -> (GenericLib.coq_expr * bool) list val arbitrarySizedST : GenericLib.ty_ctr -> GenericLib.ty_param list -> GenericLib.dep_ctr list -> GenericLib.dep_type -> GenericLib.var list -> UnifyQC.range list -> UnifyQC.range UnifyQC.UM.t -> GenericLib.dep_type UnifyQC.UM.t -> GenericLib.arg list -> UnifyQC.Unknown.t -> GenericLib.coq_expr -> GenericLib.coq_expr QuickChick-2.1.0/plugin/checkerSizedST.ml000066400000000000000000000156031476030541200202410ustar00rootroot00000000000000open Pp open Util open GenericLib open CoqLib open GenLib open Error open UnifyQC (* arguments to handle_branch *) let fail_exp (dt : coq_expr) : coq_expr = gSome dt g_false let not_enough_fuel_exp (dt : coq_expr) : coq_expr = gNone dt let ret_exp (dt : coq_expr) (c : coq_expr) = gSome dt c let ret_type (s : var) f = hole let instantiate_existential_method = (gInject "enum") let instantiate_existential_methodST (n : int) (pred : coq_expr) = gApp ~explicit:true (gInject "enumSuchThat") [ hole (* Implicit argument - type A *) ; pred ; hole (* Implicit instance *)] let rec_method (rec_name : coq_expr) (init_size : coq_expr) (size : coq_expr) (n : int) (letbinds : unknown list option) (l : coq_expr list) = gApp rec_name (init_size :: size :: l) (* For checkers, ignore the opt argument *) let rec_bind (opt : bool) (m : coq_expr) (x : string) (f : var -> coq_expr) : coq_expr = gMatch m [ (injectCtr "Some", ["res_b" ] , fun [b] -> (* Why as clauses/returns? *) gMatch (gVar b) [ (injectCtr "true", [], fun _ -> f b) ; (injectCtr "false", [], fun _ -> fail_exp hole) ]) ; (injectCtr "None", [], fun _ -> gNone hole ) ] let exist_bind (init_size : coq_expr) (opt : bool) (m : coq_expr) (x : string) (f : var -> coq_expr) : coq_expr = enumCheckerOpt m x f init_size (* (if opt then enumCheckerOpt else enumChecker) m x f init_size *) let stMaybe (opt : bool) (g : coq_expr) (x : string) (checks : ((coq_expr -> coq_expr) * int) list) = let rec sumbools_to_bool x lst = match lst with | [] -> gTrueb | (chk, _) :: lst' -> matchDec (chk (gVar x)) (fun heq -> gFalseb) (fun hneq -> sumbools_to_bool x lst') in let bool_pred = gFun [x] (fun [x] -> sumbools_to_bool x checks) in (gApp (gInject (if opt then "suchThatMaybeOpt" else "suchThatMaybe")) [ g (* Use the generator provided for base generator *) ; bool_pred ]) let ret_type_dec (s : var) (left : coq_expr) (right : coq_expr) = gMatch (gVar s) [ (injectCtr "left", ["eq"], fun _ -> left) ; (injectCtr "right", ["neq"], fun _ -> right) ] let check_expr (n : int) (scrut : coq_expr) (left : coq_expr) (right : coq_expr) (out_of_fuel : coq_expr) = gMatchReturn scrut "s" (* as clause *) (fun v -> ret_type v ret_type_dec) [ (injectCtr "Some", ["res_b" ] , fun [b] -> (* Why as clauses/returns? *) gMatch (gVar b) [ (injectCtr "true", [], fun _ -> left) ; (injectCtr "false", [], fun _ -> right) ]) ; (injectCtr "None", [], fun _ -> out_of_fuel) ] let match_inp (inp : var) (pat : matcher_pat) (left : coq_expr) (right : coq_expr) = let ret v left right = construct_match (gVar v) ~catch_all:(Some right) [(pat, left)] in let catch_case = match pat with | MatchCtr (c, ls) -> (* Leo: This is a hack totality check for unary matches *) if num_of_ctrs c = 1 && List.for_all (fun x -> match x with MatchU _ -> true | MatchCtr _ -> false) ls then None else Some right | _ -> failwith "Toplevel match not a constructor?" in construct_match_with_return (gVar inp) ~catch_all:(catch_case) "s" (fun v -> ret_type v ret) [(pat,left)] type generator_kind = Base_gen | Ind_gen (* hoisting out base and ind gen to be able to call them from proof generation *) let construct_generators (kind : generator_kind) (init_size : coq_expr) (size : coq_expr) (full_gtyp : coq_expr) (gen_ctr : ty_ctr) (dep_type : dep_type) (ctrs : dep_ctr list) (rec_name : coq_expr) (input_ranges : range list) (init_umap : range UM.t) (init_tmap : dep_type UM.t) (result : Unknown.t) = msg_debug (str "Beginning checker construction" ++ fnl()); (* partially applied handle_branch *) let handle_branch' : dep_ctr -> coq_expr * bool = handle_branch ["EnumSizedSuchThat"; "EnumSuchThat"] dep_type init_size (fail_exp full_gtyp) (not_enough_fuel_exp full_gtyp) (ret_exp full_gtyp) instantiate_existential_method instantiate_existential_methodST (exist_bind init_size) (rec_method rec_name init_size size) rec_bind stMaybe check_expr match_inp gLetIn gLetTupleIn gen_ctr init_umap init_tmap input_ranges result in let all_gens = List.map handle_branch' ctrs in let padNone = if List.exists (fun gb -> not (snd gb)) all_gens then [gNone gBool] else [] in match kind with | Base_gen -> List.map fst (List.filter snd all_gens) @ padNone | Ind_gen -> List.map fst ((List.filter snd all_gens) @ (List.filter (fun x -> not (snd x)) all_gens)) let base_gens = construct_generators Base_gen let ind_gens = construct_generators Ind_gen (* Advanced Generators *) let checkerSizedST (gen_ctr : ty_ctr) (ty_params : ty_param list) (ctrs : dep_ctr list) (dep_type : dep_type) (input_names : var list) (input_ranges : range list) (init_umap : range UM.t) (init_tmap : dep_type UM.t) (inputs : arg list) (result : Unknown.t) (rec_name : coq_expr) = (* type constructor *) let coqTyCtr = gTyCtr gen_ctr in (* parameters of the type constructor *) let coqTyParams = List.map gTyParam ty_params in (* Unused, not exported... *) (* Fully applied type constructor *) let _full_dt = gApp ~explicit:true coqTyCtr coqTyParams in (* The type we are generating for -- not the predicate! *) let full_gtyp = (gType ty_params (UM.find result init_tmap)) in (* The type of the derived checker *) let gen_type = (gOption full_gtyp) in let aux_arb rec_name init_size size vars = gMatch (gVar size) [ (injectCtr "O", [], fun _ -> checker_backtracking (base_gens init_size (gVar size) full_gtyp gen_ctr dep_type ctrs rec_name input_ranges init_umap init_tmap result)) ; (injectCtr "S", ["size'"], fun [size'] -> checker_backtracking (ind_gens init_size (gVar size') full_gtyp gen_ctr dep_type ctrs rec_name input_ranges init_umap init_tmap result)) ] in let generator_body : coq_expr = (* This might cause things to break *) let sizeVar = fresh_name "size" in gRecFunInWithArgs ~structRec:(Some sizeVar) ~assumType:(gen_type) "aux_arb" (gArg ~assumName:(gVar (fresh_name "init_size")) () :: gArg ~assumName:(gVar sizeVar) () :: inputs) (fun (rec_name, init_size::size::vars) -> aux_arb (gVar rec_name) (gVar init_size) size vars) (fun rec_name -> gFun ["size"] (fun [size] -> gApp (gVar rec_name) (gVar size :: gVar size :: List.map (fun i -> gVar (arg_to_var i)) inputs) )) in msg_debug (fnl () ++ fnl () ++ str "`Final body produced:" ++ fnl ()); debug_coq_expr generator_body; msg_debug (fnl ()); gRecord [("decOpt", generator_body)] QuickChick-2.1.0/plugin/checkerSizedST.mli000066400000000000000000000054451476030541200204150ustar00rootroot00000000000000val fail_exp : GenericLib.coq_expr -> GenericLib.coq_expr val not_enough_fuel_exp : GenericLib.coq_expr -> GenericLib.coq_expr val ret_exp : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val ret_type : GenericLib.var -> 'a -> GenericLib.coq_expr val instantiate_existential_method : GenericLib.coq_expr val instantiate_existential_methodST : int -> GenericLib.coq_expr -> GenericLib.coq_expr val rec_method : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> int -> UnifyQC.unknown list option -> GenericLib.coq_expr list -> GenericLib.coq_expr val rec_bind : bool -> GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val exist_bind : GenericLib.coq_expr -> bool -> GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val stMaybe : bool -> GenericLib.coq_expr -> string -> ((GenericLib.coq_expr -> GenericLib.coq_expr) * int) list -> GenericLib.coq_expr val ret_type_dec : GenericLib.var -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val check_expr : int -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val match_inp : GenericLib.var -> GenericLib.matcher_pat -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr type generator_kind = Base_gen | Ind_gen val construct_generators : generator_kind -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.ty_ctr -> GenericLib.dep_type -> GenericLib.dep_ctr list -> GenericLib.coq_expr -> UnifyQC.range list -> UnifyQC.range UnifyQC.UM.t -> GenericLib.dep_type UnifyQC.UM.t -> UnifyQC.Unknown.t -> GenericLib.coq_expr list val base_gens : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.ty_ctr -> GenericLib.dep_type -> GenericLib.dep_ctr list -> GenericLib.coq_expr -> UnifyQC.range list -> UnifyQC.range UnifyQC.UM.t -> GenericLib.dep_type UnifyQC.UM.t -> UnifyQC.Unknown.t -> GenericLib.coq_expr list val ind_gens : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.ty_ctr -> GenericLib.dep_type -> GenericLib.dep_ctr list -> GenericLib.coq_expr -> UnifyQC.range list -> UnifyQC.range UnifyQC.UM.t -> GenericLib.dep_type UnifyQC.UM.t -> UnifyQC.Unknown.t -> GenericLib.coq_expr list val checkerSizedST : GenericLib.ty_ctr -> GenericLib.ty_param list -> GenericLib.dep_ctr list -> GenericLib.dep_type -> GenericLib.var list -> UnifyQC.range list -> UnifyQC.range UnifyQC.UM.t -> GenericLib.dep_type UnifyQC.UM.t -> GenericLib.arg list -> UnifyQC.Unknown.t -> GenericLib.coq_expr -> GenericLib.coq_expr QuickChick-2.1.0/plugin/coqLib.ml000066400000000000000000000075451476030541200166060ustar00rootroot00000000000000open GenericLib let gExIntro_impl (witness : coq_expr) (proof : coq_expr) : coq_expr = gApp (gInject "ex_intro") [hole; witness; proof] let gExIntro (x : string) (pred : var -> coq_expr) (witness : coq_expr) (proof : coq_expr) : coq_expr = gApp (gInject "ex_intro") [(gFun [x] (fun [x] -> pred x)); witness; proof] let gEx (x : string) (pred : var -> coq_expr) : coq_expr = gApp (gInject "ex") [(gFun [x] (fun [x] -> pred x))] let gConjIntro p1 p2 = gApp (gInject "conj") [p1; p2] let gEqType e1 e2 = gApp (gInject "eq") [e1; e2] let gConj p1 p2 = gApp (gInject "and") [p1; p2] let gProjL p = gApp ~explicit:true (gInject "Logic.proj1") [hole; hole; p] let gProjR p = gApp ~explicit:true (gInject "Logic.proj2") [hole; hole; p] let gImpl p1 p2 = gApp (gInject "Basics.impl") [p1; p2] let gForall typ f = gApp ~explicit:true (gInject "Nat_util.all") [typ; f] let gProd e1 e2 = gApp (gInject "Coq.Init.Datatypes.prod") [e1; e2] let gLeq e1 e2 = gApp (gInject "leq") [e1; e2] let gLe e1 e2 = gApp (gInject "le") [e1; e2] let gIsTrueLeq e1 e2 = gApp (gInject "is_true") [gApp (gInject "leq") [e1; e2]] let gOrIntroL p = gApp (gInject "or_introl") [p] let gOrIntroR p = gApp (gInject "or_intror") [p] let gEqRefl p = gApp (gInject "Logic.eq_refl") [p] let gI = gInject "I" let gTrueb = gInject "true" let gFalseb = gInject "false" let gT = gInject "True" let gTrue = gInject "True" let gFalse = gInject "False" let gTt = gInject "tt" let gIff p1 p2 = gApp (gInject "iff") [p1; p2] let gIsTrue x = gApp (gInject "is_true") [x] let gIsTrueTrue = gApp (gInject "is_true") [gInject "true"] let false_ind x1 x2 = gApp (gInject "False_ind") [x1; x2] (* TODO extend gMatch to write the return type? *) let discriminate h = false_ind hole (gMatch h [(injectCtr "Logic.eq_refl", [], fun [] -> gI)]) let rewrite pred h hin = gApp ~explicit:true (gInject "eq_ind") [hole; hole; pred; hin; hole; h] (* gMatch h [(injectCtr "erefl", [], fun [] -> hin)] *) let rewrite_sym typ h hin = gApp (gInject "eq_ind_r") [typ; hin; h] let lt0_False hlt = gApp (gInject "lt0_False") [hlt] let nat_ind ret_type base_case ind_case = gApp (gInject "nat_ind") [ret_type; base_case; ind_case] let appn fn n arg = gApp (gInject "appn") [fn; n; arg] let matchDec c left right = gMatch c [ (injectCtr "left" , ["eq" ], left) ; (injectCtr "right", ["neq"], right) ] let matchDecOpt c left right = gMatch c [ (injectCtr "left" , ["eq" ], left) ; (injectCtr "right", ["neq"], right) ] let plus x y = gApp (gInject "Nat.add") [x;y] let plus_leq_compat_l p = gApp ~explicit:true (gInject "plus_leq_compat_l") [hole; hole; hole; p] let leq_addl n1 n2 = gApp (gInject "leq_addl") [n1; n2] (* Leo, can we have a real gProp? *) let gProp = gInject "prop" let succ_neq_zero x = gApp ~explicit:true (gInject "PeanoNat.Nat.neq_succ_0") [x] let succ_neq_zero_app x h = gApp ~explicit:true (gInject "PeanoNat.Nat.neq_succ_0") [x; h] let isSome x = gApp (gInject "isSome") [x] let isSomeSome x = gApp ~explicit:true (gInject "isSomeSome") [hole; x] let diff_false_true h = gApp (gInject "Bool.diff_false_true") [h] let gSnd x = gApp ~explicit:true (gInject "snd") [hole; hole; x] let gFst x = gApp ~explicit:true (gInject "fst") [hole; hole; x] let is_true b = gApp ~explicit:true (gInject "is_true") [b] let forall_nil typ = gApp ~explicit:true (gInject "List.Forall_nil") [typ; hole] let forall_cons typ pleq p = gApp ~explicit:true (gInject "List.Forall_cons") [typ; hole; hole; hole; pleq; p] let ltnOSn = gApp ~explicit:true (gInject "ltn0Sn") [hole] let ltnOSn_pair = gApp ~explicit:true (gInject "ltn0Sn_pair") [hole; hole; hole] (* let le_S_n hleq = gApp (gInject "le_S_n") [hole; hole; hleq] let nle_succ_0 hleq = gApp (gInject "PeanoNat.Nat.nle_succ_0") [hole; hleq] *) QuickChick-2.1.0/plugin/coqLib.mli000066400000000000000000000071331476030541200167500ustar00rootroot00000000000000val gExIntro_impl : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gExIntro : string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gEx : string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val gConjIntro : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gEqType : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gConj : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gProjL : GenericLib.coq_expr -> GenericLib.coq_expr val gProjR : GenericLib.coq_expr -> GenericLib.coq_expr val gImpl : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gForall : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gProd : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gLe : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gLeq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gIsTrueLeq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gOrIntroL : GenericLib.coq_expr -> GenericLib.coq_expr val gOrIntroR : GenericLib.coq_expr -> GenericLib.coq_expr val gEqRefl : GenericLib.coq_expr -> GenericLib.coq_expr val gTt : GenericLib.coq_expr val gI : GenericLib.coq_expr val gT : GenericLib.coq_expr val gTrueb : GenericLib.coq_expr val gFalseb : GenericLib.coq_expr val gTrue : GenericLib.coq_expr val gFalse : GenericLib.coq_expr val gIff : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gIsTrue : GenericLib.coq_expr -> GenericLib.coq_expr val gIsTrueTrue : GenericLib.coq_expr val false_ind : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val discriminate : GenericLib.coq_expr -> GenericLib.coq_expr val rewrite : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val rewrite_sym : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val lt0_False : GenericLib.coq_expr -> GenericLib.coq_expr val nat_ind : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val appn : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val matchDec : GenericLib.coq_expr -> (GenericLib.var list -> GenericLib.coq_expr) -> (GenericLib.var list -> GenericLib.coq_expr) -> GenericLib.coq_expr val matchDecOpt : GenericLib.coq_expr -> (GenericLib.var list -> GenericLib.coq_expr) -> (GenericLib.var list -> GenericLib.coq_expr) -> GenericLib.coq_expr val plus : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val plus_leq_compat_l : GenericLib.coq_expr -> GenericLib.coq_expr val leq_addl : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val gProp : GenericLib.coq_expr val succ_neq_zero : GenericLib.coq_expr -> GenericLib.coq_expr val succ_neq_zero_app : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val isSome : GenericLib.coq_expr -> GenericLib.coq_expr val isSomeSome : GenericLib.coq_expr -> GenericLib.coq_expr val diff_false_true : GenericLib.coq_expr -> GenericLib.coq_expr val gSnd : GenericLib.coq_expr -> GenericLib.coq_expr val gFst : GenericLib.coq_expr -> GenericLib.coq_expr val is_true : GenericLib.coq_expr -> GenericLib.coq_expr val forall_nil : GenericLib.coq_expr -> GenericLib.coq_expr val forall_cons : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val ltnOSn : GenericLib.coq_expr val ltnOSn_pair : GenericLib.coq_expr QuickChick-2.1.0/plugin/depDriver.ml.cppo000066400000000000000000000502071476030541200202520ustar00rootroot00000000000000open Pp open Libnames open Util open Constrexpr open GenericLib open ArbitrarySizedST open EnumSizedST open CheckerSizedST open Error open UnifyQC (** Derivable classes *) type derivable = | DecOpt | GenSizedSuchThat | EnumSizedSuchThat let derivable_to_string = function | DecOpt -> "DecOpt" | GenSizedSuchThat -> "GenSizedSuchThat" | EnumSizedSuchThat -> "EnumSizedSuchThat" (** Name of the instance to be generated *) let mk_instance_name der tn = var_to_string (fresh_name ((derivable_to_string der) ^ tn)) let derive_dependent (class_name : derivable) (constructor : constr_expr) (umap : range UM.t) (tmap : dep_type UM.t) (input_names : var list) (input_ranges : range list) (ty_ctr, ty_params, ctrs, dep_type) (letbinds : var list option) (result : unknown) = let ctr_name = match constructor with | { CAst.v = CRef (r,_); _ } -> string_of_qualid r in let instance_name = mk_instance_name class_name ctr_name in (* type constructor *) let coqTyCtr = gTyCtr ty_ctr in (* parameters of the type constructor *) let coqTyParams = List.map gTyParam ty_params in (* Fully applied type constructor *) let full_dt = gApp ~explicit:true coqTyCtr coqTyParams in (* Type parameters as arguments *) (* TODO: Needed? let params = List.map (fun tp -> gArg ~assumName:(gTyParam tp) ~assumType:gType0 ()) ty_params in *) (* List of input unknowns *) let actual_input_list = List.filter (fun u -> UM.find u umap == FixedInput) input_names in (* Inputs as arguments *) let actual_input_args = List.map (fun u -> gArg ~assumName:(gVar u) ~assumType:(gType ty_params (UM.find u tmap)) ()) actual_input_list in (* Typeclass arguments - depends on the class *) let param_class_names = match class_name with | DecOpt -> ["Dec_Eq"; "Enum"] | EnumSizedSuchThat -> ["Dec_Eq"; "Enum"] | GenSizedSuchThat -> ["Dec_Eq"; "Gen"; "Enum"] in let typeclass_args = List.concat (List.map (fun tp -> ((gArg ~assumName:tp ~assumImplicit:true ()) :: (List.map (fun name -> gArg ~assumType:(gApp (gInject name) [tp]) ~assumGeneralized:true ()) param_class_names)) ) coqTyParams) in (* The type we are generating for -- not the predicate! *) let _full_gtyp = gType ty_params (UM.find result tmap) in let _gen_needed = [] in let _dec_needed = [] in (* The dependent generator *) let gen () = arbitrarySizedST ty_ctr ty_params ctrs dep_type input_names input_ranges umap tmap actual_input_args result coqTyCtr in (* Generate typeclass constraints. For each type parameter "A" we need `{_ : A} *) (* TODO: Params? *) let instance_arguments = match class_name with | DecOpt -> (* params @ *) typeclass_args @ actual_input_args | EnumSizedSuchThat -> (* params @ *) typeclass_args @ actual_input_args | GenSizedSuchThat -> (* params @ *) typeclass_args @ actual_input_args in (* Fully applied predicate (parameters and constructors) *) let full_pred inputs = match letbinds with | None -> gFun [Unknown.to_string result] (fun _ -> gApp (full_dt) (List.map gVar inputs)) | Some letbinds -> gFun [Unknown.to_string result] (fun [result_var] -> gLetTupleIn result_var letbinds (gApp (gInject ctr_name) (List.map gVar inputs))) in (* TODO: Easy solution : add Arbitrary/DecOpt as a requirement for all type parameters. *) (* let self_dec = [] in (* (* Maybe somethign about type paramters here *) if !need_dec then [gArg ~assumType:(gApp (gInject (Printf.sprintf "DepDec%n" (dep_type_len dep_type))) [gTyCtr ty_ctr]) ~assumGeneralized:true ()] else [] in *) (* The type of the dependent generator *) let gen_type = gGen (gOption full_gtyp) in (* Generate arbitrary parameters *) let arb_needed = let rec extract_params = function | DTyParam tp -> ArbSet.singleton (DTyParam tp) | DTyVar _ -> ArbSet.empty | DTyCtr (_, dts) -> List.fold_left (fun acc dt -> ArbSet.union acc (extract_params dt)) ArbSet.empty dts | _ -> failwith "Unhandled / arb_needed" in let tps = ArbSet.fold (fun dt acc -> ArbSet.union acc (extract_params dt)) !arbitraries ArbSet.empty in ArbSet.fold (fun dt acc -> (gArg ~assumType:(gApp (gInject "Arbitrary") [gType ty_params dt]) ~assumGeneralized:true ()) :: acc ) tps [] in (* Generate typeclass constraints. For each type parameter "A" we need `{_ : A} *) let instance_arguments = match cn with | ArbitrarySizedSuchThat -> params @ gen_needed @ dec_needed @ self_dec @ arb_needed @ inputs | GenSizedSuchThatMonotonicOpt -> params | SizedProofEqs -> params @ inputs | GenSizedSuchThatCorrect -> params @ inputs | GenSizedSuchThatSizeMonotonicOpt -> params @ inputs in *) (* The instance type *) let instance_type iargs = match class_name with | GenSizedSuchThat -> gApp (gInject (derivable_to_string class_name)) [gType ty_params (UM.find result tmap); full_pred input_names] | EnumSizedSuchThat -> gApp (gInject (derivable_to_string class_name)) [gType ty_params (UM.find result tmap); full_pred input_names] | DecOpt -> gApp (gInject (derivable_to_string class_name)) [ gApp (full_dt) (List.map gVar input_names) ] in let instance_record iargs = match class_name with | GenSizedSuchThat -> gen () | EnumSizedSuchThat -> enumSizedST ty_ctr ty_params ctrs dep_type input_names input_ranges umap tmap actual_input_args result coqTyCtr | DecOpt -> checkerSizedST ty_ctr ty_params ctrs dep_type input_names input_ranges umap tmap actual_input_args result coqTyCtr in msg_debug (str "Instance Type: " ++ fnl ()); debug_coq_expr (instance_type [gInject "input0"; gInject "input1"]); declare_class_instance instance_arguments instance_name instance_type instance_record ;; (* Creates the initial t and u maps. *) let create_t_and_u_maps explicit_args dep_type actual_args : (range UM.t * dep_type UM.t) = msg_debug (str ("create_t_u_maps for: " ^ dep_type_to_string dep_type) ++ fnl ()); (* Local references - the maps to be generated *) let umap = ref UM.empty in let tmap = ref explicit_args in let rec populate_maps dep_type args = (* Recurse down the unnamed arrow arguments *) match dep_type,args with | DProd ((_, dt1), dt2), arg::args' | DArrow (dt1, dt2), arg::args' -> msg_debug (str ("populating with: " ^ dep_type_to_string dt1) ++ fnl ()); begin match arg with | ({ CAst.v = CRef (r,_); _ }, _) -> begin let current_r = Unknown.from_string (string_of_qualid r ^ "_") in (* Lookup if the reference is meant to be generated *) try begin match UM.find current_r !tmap with | None -> (* First occurence, update tmap and umap *) tmap := UM.add current_r (Some dt1) !tmap; umap := UM.add current_r (Undef dt1) !umap | Some dt' -> (* Check if the existing binding still typechecks *) if not (dt1 == dt') then qcfail "Ill-typed application in derivation" end with Not_found -> (* Logging the type in the tmap is ok, because we don't update the umap in the "Some dt'" case above *) tmap := UM.add current_r (Some dt1) !tmap; umap := UM.add current_r FixedInput !umap; end (* TODO: If this is constructor applications, we need more type-checking machinery here *) | _ -> qcfail "Non-variable patterns not implemented" end; populate_maps dt2 args' (* Not an arrow -> Finalizer (TODO: add explicit fail?) *) | _ -> () in populate_maps dep_type actual_args; (* Remove the option from the type map and ensure all are exercised *) let tmap'= UM.mapi (fun u mt -> match mt with | Some t -> t | None -> failwith (Printf.sprintf "Pattern not exercised: %s\n" (var_to_string u)) ) !tmap in (!umap, tmap') (* Assumption: - generator-based classes include a "fun x => P ...." or "fun x => let (x1,x2,...) := x in P ..." where "..." are bound names (to be generated), unbound names (implicitly quantified arguments) or Constructors applied to such stuff. - checker-based classes only include the name of the predicate "P". All arguments to P will be considered Fixed inputs *) let dep_dispatch ind class_name : unit = match ind with #if COQ_VERSION >= (8, 20, 0) | { CAst.v = CLambdaN ([CLocalAssum ([{ CAst.v = Names.Name id; CAst.loc = _loc2 }], _, _kind, _type)], body); _ } -> (* {CAst.v = CApp ((_flag, constructor), args) }) } -> *) #else | { CAst.v = CLambdaN ([CLocalAssum ([{ CAst.v = Names.Name id; CAst.loc = _loc2 }], _kind, _type)], body); _ } -> (* {CAst.v = CApp ((_flag, constructor), args) }) } -> *) #endif let idu = Unknown.from_string (Names.Id.to_string id ^ "_") in (* Extract (x1,x2,...) if any, P and arguments *) let (letbindsM, constructor, args) = match body with | { CAst.v = CApp (constructor, args); _ } -> (None, constructor, args) | { CAst.v = CLetTuple (name_list, _, _shouldbeid, { CAst.v = CApp (constructor, args); _ } ); _} -> ( Some (List.map (function { CAst.v = name; _ } -> name ) name_list), constructor, args ) in (* Parse the constructor's information into the more convenient generic-lib representation *) (* let (ty_ctr, ty_params, ctrs, dep_type) : (ty_ctr * (ty_param list) * (dep_ctr list) * dep_type) = *) let dt : (ty_ctr * (ty_param list) * (dep_ctr list) * dep_type) = match coerce_reference_to_dep_dt constructor with | Some dt -> msg_debug (str (dep_dt_to_string dt) ++ fnl()); dt | None -> failwith "Not supported type" in let (ty_ctr, ty_params, ctrs, dep_type) = dt in let (letbinds, init_umap, init_tmap) : (unknown list option * range UM.t * dep_type UM.t) = (* Create a temporary typing map for either the let binds/variable to be generated *) let letbinds = match letbindsM with | Some binds -> Some (List.map (fun (Names.Name id) -> Unknown.from_string (Names.Id.to_string id ^ "_")) binds) | None -> None in let explicit_args = match letbinds with | Some binds -> List.fold_left (fun map u -> UM.add u None map) UM.empty binds | None -> UM.singleton idu None in (* Call the actual creation function *) let (umap, tmap) = create_t_and_u_maps explicit_args dep_type args in (* Update with the toplevel variable as necessary *) match letbinds with | Some binds -> (* Still need to package together the tuple *) let bind_types = List.map (fun u -> try UM.find u tmap with Not_found -> failwith "All patterns should be exercised" ) binds in let tmap' = UM.add idu (dtTupleType bind_types) tmap in let umap' = let pair_ctr = injectCtr "Coq.Init.Datatypes.pair" in let range = listToPairAux (fun (r1, r2) -> Ctr (pair_ctr, [RangeHole; RangeHole; r1; r2])) (List.map (fun u -> Unknown u) binds) in UM.add idu range umap in (letbinds, umap', tmap') | None -> (letbinds, umap, tmap) in (* Print map *) msg_debug (str "Initial map: " ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) init_umap; let umap = ref init_umap in let tmap = ref init_tmap in (* Rewrite the function applications in constructors. *) let rewrite_ct ct = let new_eqs = ref [] in (* Check if a datatype contains an application *) let rec contains_app dt = match dt with | DApp _ -> true | DCtr (ctr, dts) -> List.exists contains_app dts | _ -> false in (* Rewrite the datatypes *) let rec traverse_and_rewrite dts top_dt : dep_type list = msg_debug (str (String.concat " " (List.map dep_type_to_string dts) ^ " vs " ^ (dep_type_to_string top_dt)) ++ fnl ()); match dts, top_dt with | (DTyParam _)::dts', _ -> traverse_and_rewrite dts' top_dt | [], _ -> [] | dt::dts', DArrow (dt1,dt2) when not (contains_app dt) -> dt :: (traverse_and_rewrite dts' dt2) | dt::dts', DProd ((_,dt1),dt2) when not (contains_app dt) -> dt :: (traverse_and_rewrite dts' dt2) | dt::dts', DProd ((_,dt1),dt2) when (contains_app dt) -> begin (* Create a fresh name *) let x = make_up_name () in new_eqs := (dt, x, dt1) :: !new_eqs; (* tmap := UM.add x dt1 !tmap; umap := UM.add x (Undef dt1) !umap; *) DTyVar x :: (traverse_and_rewrite dts' dt2) end | dt::dts', DArrow (dt1,dt2) when (contains_app dt) -> begin (* Create a fresh name *) let x = make_up_name () in new_eqs := (dt, x, dt1) :: !new_eqs; (* tmap := UM.add x dt1 !tmap; umap := UM.add x (Undef dt1) !umap; *) DTyVar x :: (traverse_and_rewrite dts' dt2) end | _, _ -> failwith (String.concat " " (List.map dep_type_to_string dts) ^ " vs " ^ (dep_type_to_string top_dt)) in let rec construct_eqs eqs dt = match eqs with | [] -> dt | (dteq, x, dtx)::eqs' -> DArrow (DTyCtr (ctr_to_ty_ctr (injectCtr "eq"), [DHole; dteq; DTyVar x]), construct_eqs eqs' dt) in (* - Find the result of the constructor - Traverse its arguments, rewriting if necessary *) let rec recurse_to_result ct = match ct with | DProd ((x, ct1), ct2) -> DProd ((x, ct1), recurse_to_result ct2) | DArrow (ct1, ct2) -> DArrow (ct1, recurse_to_result ct2) | DTyCtr (ty_ctr, dts) -> (* TODO: While recursing dts need top level dep-type for map. *) let dts' = traverse_and_rewrite dts dep_type in construct_eqs !new_eqs (DTyCtr (ty_ctr, dts')) | _ -> failwith ("Not a result: " ^ dep_type_to_string ct) in let rec add_bindings ct eqs = msg_debug (str "Adding bindings..." ++ fnl ()); match eqs with | [] -> ct | (_,x,dt)::eqs' -> DProd ((x,dt), add_bindings ct eqs') in let rewritten_result = recurse_to_result ct in let rewritten = add_bindings rewritten_result !new_eqs in msg_debug (str ("Rewritten from: " ^ dep_type_to_string ct ^ " to " ^ dep_type_to_string rewritten) ++ fnl ()); rewritten in let ctrs = List.map (fun (ctr, ct) -> (ctr, rewrite_ct ct)) ctrs in (* When we add constructors to the ranges, this needs to change *) let input_names = List.map (fun ({CAst.v = CRef (r, _); _},_) -> fresh_name (string_of_qualid r ^ "_")) args in let input_ranges = List.map (fun v -> Unknown v) input_names in (* Call the derivation dispatcher *) derive_dependent class_name constructor !umap !tmap (* init_umap init_tmap *) input_names input_ranges (ty_ctr, ty_params, ctrs, dep_type) letbinds idu | { CAst.v = CApp (constructor, args); _ } -> msg_debug (str "Parsing constructor information for checker" ++ fnl ()); (* Parse the constructor's information into the more convenient generic-lib representation *) let (ty_ctr, ty_params, ctrs, dep_type) : (ty_ctr * (ty_param list) * (dep_ctr list) * dep_type) = match coerce_reference_to_dep_dt constructor with | Some dt -> msg_debug (str (dep_dt_to_string dt) ++ fnl()); dt | None -> failwith "Not supported type" in (* When we add constructors to the ranges, this needs to change *) let input_names = List.map (fun ({CAst.v = CRef (r, _); _},_) -> fresh_name (string_of_qualid r ^ "_")) args in let input_ranges = List.map (fun v -> Unknown v) input_names in (* Call the actual creation function *) let explicit_args = UM.empty (* No arguments to be generated *) in let (umap, tmap) = create_t_and_u_maps explicit_args dep_type args in let result = fresh_name "_result_bool" in let umap = ref (UM.add result (Ctr (injectCtr "Coq.Init.Datatypes.true", [])) umap) in let tmap = ref (UM.add result (DTyCtr (ctr_to_ty_ctr (injectCtr "Coq.Init.Datatypes.bool"), [])) tmap) in (* let umap = ref init_umap in let tmap = ref init_tmap in *) (* Rewrite the function applications in constructors. *) let rewrite_ct ct = let new_eqs = ref [] in (* Check if a datatype contains an application *) let rec contains_app dt = match dt with | DApp _ -> true | DCtr (ctr, dts) -> List.exists contains_app dts | _ -> false in (* Rewrite the datatypes *) let rec traverse_and_rewrite dts top_dt : dep_type list = match dts, top_dt with | (DTyParam _)::dts', _ -> traverse_and_rewrite dts' top_dt | [], _ -> [] | dt::dts', DArrow (dt1,dt2) when not (contains_app dt) -> dt :: (traverse_and_rewrite dts' dt2) | dt::dts', DProd ((_,dt1),dt2) when not (contains_app dt) -> dt :: (traverse_and_rewrite dts' dt2) | dt::dts', DProd ((_,dt1),dt2) when (contains_app dt) -> begin (* Create a fresh name *) let x = make_up_name () in new_eqs := (dt, x, dt1) :: !new_eqs; (* tmap := UM.add x dt1 !tmap; umap := UM.add x (Undef dt1) !umap; *) DTyVar x :: (traverse_and_rewrite dts' dt2) end | dt::dts', DArrow (dt1,dt2) when (contains_app dt) -> begin (* Create a fresh name *) let x = make_up_name () in new_eqs := (dt, x, dt1) :: !new_eqs; (* tmap := UM.add x dt1 !tmap; umap := UM.add x (Undef dt1) !umap; *) DTyVar x :: (traverse_and_rewrite dts' dt2) end in let rec construct_eqs eqs dt = match eqs with | [] -> dt | (dteq, x, _)::eqs' -> DArrow (DTyCtr (ctr_to_ty_ctr (injectCtr "eq"), [DHole; dteq; DTyVar x]), construct_eqs eqs' dt) in (* - Find the result of the constructor - Traverse its arguments, rewriting if necessary *) let rec recurse_to_result ct = match ct with | DProd ((x, ct1), ct2) -> DProd ((x, ct1), recurse_to_result ct2) | DArrow (ct1, ct2) -> DArrow (ct1, recurse_to_result ct2) | DTyCtr (ty_ctr, dts) -> (* TODO: While recursing dts need top level dep-type for map. *) let dts' = traverse_and_rewrite dts dep_type in construct_eqs !new_eqs (DTyCtr (ty_ctr, dts')) | _ -> failwith ("Not a result: " ^ dep_type_to_string ct) in let rec add_bindings ct eqs = msg_debug (str "Adding bindings..." ++ fnl ()); match eqs with | [] -> ct | (_,x,dt)::eqs' -> DProd ((x,dt), add_bindings ct eqs') in let rewritten_result = recurse_to_result ct in let rewritten = add_bindings rewritten_result !new_eqs in msg_debug (str ("Rewritten from: " ^ dep_type_to_string ct ^ " to " ^ dep_type_to_string rewritten) ++ fnl ()); rewritten in let ctrs = List.map (fun (ctr, ct) -> (ctr, rewrite_ct ct)) ctrs in derive_dependent class_name constructor !umap !tmap input_names input_ranges (ty_ctr, ty_params, ctrs, dep_type) None result | _ -> qcfail "wrongformat/driver.mlg" QuickChick-2.1.0/plugin/depDriver.mli000066400000000000000000000014221476030541200174560ustar00rootroot00000000000000type derivable = DecOpt | GenSizedSuchThat | EnumSizedSuchThat val derivable_to_string : derivable -> string val mk_instance_name : derivable -> string -> string val derive_dependent : derivable -> Constrexpr.constr_expr -> UnifyQC.range UnifyQC.UM.t -> GenericLib.dep_type UnifyQC.UM.t -> GenericLib.var list -> UnifyQC.range list -> GenericLib.ty_ctr * GenericLib.ty_param list * GenericLib.dep_ctr list * GenericLib.dep_type -> GenericLib.var list option -> UnifyQC.unknown -> unit val create_t_and_u_maps : GenericLib.dep_type option UnifyQC.UM.t -> GenericLib.dep_type -> (Constrexpr.constr_expr_r CAst.t * 'a) list -> UnifyQC.range UnifyQC.UM.t * GenericLib.dep_type UnifyQC.UM.t val dep_dispatch : Constrexpr.constr_expr_r CAst.t -> derivable -> unit QuickChick-2.1.0/plugin/driver.mlg000066400000000000000000000111471476030541200170300ustar00rootroot00000000000000DECLARE PLUGIN "coq-quickchick.plugin" { open Libnames open Util open Constrexpr open Names open Stdarg open Error type derivation = SimpleDer of SimplDriver.derivable list | DepDer of DepDriver.derivable let simpl_dispatch ind classes name1 name2 = List.iter (fun cn -> SimplDriver.derive cn ind name1 name2) classes let class_assoc_opts = [ ("GenSized" , SimpleDer [SimplDriver.GenSized]) ; ("EnumSized" , SimpleDer [SimplDriver.EnumSized]) ; ("Shrink" , SimpleDer [SimplDriver.Shrink]) ; ("Arbitrary" , SimpleDer [SimplDriver.GenSized; SimplDriver.Shrink]) ; ("Show" , SimpleDer [SimplDriver.Show]) ; ("Sized" , SimpleDer [SimplDriver.Sized]) ; ("DecOpt" , DepDer DepDriver.DecOpt) ; ("ArbitrarySizedSuchThat" , DepDer DepDriver.GenSizedSuchThat) ; ("GenSizedSuchThat" , DepDer DepDriver.GenSizedSuchThat) ; ("EnumSizedSuchThat" , DepDer DepDriver.EnumSizedSuchThat) ; ("Generator" , DepDer DepDriver.GenSizedSuchThat) ; ("Enumerator" , DepDer DepDriver.EnumSizedSuchThat) ; ("Checker" , DepDer DepDriver.DecOpt) ] let class_assoc_table = let h = Hashtbl.create (List.length class_assoc_opts) in List.iter (fun (kwd, tok) -> Hashtbl.add h kwd tok) class_assoc_opts; h let dispatch cn ind name1 name2 = let convert_reference_to_string c = match c with | {CAst.v = CRef (r, _) ; _} -> string_of_qualid r | _ -> failwith "Usage: Derive for OR Derive (, ... , ) for " in let ss = match cn.CAst.v with | CNotation (_, _, ([a],[b],_,_)) -> let c = convert_reference_to_string a in let cs = List.map convert_reference_to_string b in c :: cs | _ -> [convert_reference_to_string cn] in let get_class_names s = try Hashtbl.find class_assoc_table s with Not_found -> begin (* TODO: Figure out how to pretty print in a failwith... *) failwith ( "Not a valid class name. Expected one of : " ^ (String.concat " , " (List.map fst class_assoc_opts))) end in let class_names = match ss with | s::ss -> List.fold_left (fun der s -> match der, get_class_names s with | SimpleDer ds1, SimpleDer ds2 -> SimpleDer (ds1 @ ds2) | DepDer ds1, DepDer ds2 -> qcfail "Implement dependent derive for multiple classes" ) (get_class_names s) ss | _ -> qcfail "At least one class name expected" in match class_names with | SimpleDer classes -> simpl_dispatch ind classes name1 name2 | DepDer class_name -> DepDriver.dep_dispatch ind class_name ;; let merge ind1 ind2 ind3 = MergeTypes.merge ind1 ind2 ind3 let merge_test ind1 = MergeTypes.merge_test ind1 } VERNAC COMMAND EXTEND Merge CLASSIFIED AS SIDEFF | ["Merge" constr(ind1) "With" constr(ind2) "As" constr(ind)] -> { merge ind1 ind2 ind } END VERNAC COMMAND EXTEND MergeTest CLASSIFIED AS SIDEFF | ["MergeTest" constr(ind1)] -> { merge_test ind1 } END VERNAC COMMAND EXTEND QuickChickDerive CLASSIFIED AS SIDEFF | ["Derive" constr(class_name) "for" constr(inductive)] -> { dispatch class_name inductive "" "" } | ["Derive" constr(class_name) "for" constr(inductive) "using" ident(genInst)] -> { dispatch class_name inductive (Id.to_string genInst) ""} | ["Derive" constr(class_name) "for" constr(inductive) "using" ident(genInst) "and" ident(monInst) ] -> { dispatch class_name inductive (Id.to_string genInst) (Id.to_string monInst)} END (* To disambiguate from Derive in other plugins like Equations *) VERNAC COMMAND EXTEND QCDerive CLASSIFIED AS SIDEFF | ["QCDerive" constr(class_name) "for" constr(inductive)] -> { dispatch class_name inductive "" "" } | ["QCDerive" constr(class_name) "for" constr(inductive) "using" ident(genInst)] -> { dispatch class_name inductive (Id.to_string genInst) ""} | ["QCDerive" constr(class_name) "for" constr(inductive) "using" ident(genInst) "and" ident(monInst) ] -> { dispatch class_name inductive (Id.to_string genInst) (Id.to_string monInst)} END QuickChick-2.1.0/plugin/driver.mli000066400000000000000000000000001476030541200170140ustar00rootroot00000000000000QuickChick-2.1.0/plugin/dune000066400000000000000000000042241476030541200157100ustar00rootroot00000000000000(library (name quickchick_plugin) (public_name coq-quickchick.plugin) (flags :standard -rectypes -warn-error -3 -w -8-27+40) (modules :standard \ genSTCorrect genSizedSTMonotonic genSizedSTSizeMonotonic) (libraries unix str (select void_for_linking-plugin-extraction from (coq-core.plugins.extraction -> void_for_linking-plugin-extraction.empty) (coq.plugins.extraction -> void_for_linking-plugin-extraction.empty)) (select void_for_linking-plugin-ltac from (coq-core.plugins.ltac -> void_for_linking-plugin-ltac.empty) (coq.plugins.ltac -> void_for_linking-plugin-ltac.empty)) )) (rule (targets driver.ml) (deps (:pp-file driver.mlg)) (action (run coqpp %{pp-file}))) (rule (targets quickChick.ml) (deps (:pp-file quickChick.mlg)) (action (run coqpp %{pp-file}))) (rule (targets tactic_quickchick.ml) (deps (:pp-file tactic_quickchick.mlg)) (action (run coqpp %{pp-file}))) (rule (targets weightmap.ml) (deps (:pp-file weightmap.mlg)) (action (run coqpp %{pp-file}))) (rule (action (write-file void_for_linking-plugin-extraction.empty ""))) (rule (action (write-file void_for_linking-plugin-ltac.empty ""))) (rule (alias compat) (target depDriver.ml) (action (run sh %{dep:../scripts/mycppo} %{dep:depDriver.ml.cppo} %{target}))) (rule (alias compat) (target genericLib.ml) (action (run sh %{dep:../scripts/mycppo} %{dep:genericLib.ml.cppo} %{target}))) (rule (alias compat) (target mergeTypes.ml) (action (run sh %{dep:../scripts/mycppo} %{dep:mergeTypes.ml.cppo} %{target}))) (rule (alias compat) (target quickChick.mlg) (action (run sh %{dep:../scripts/mycppo} %{dep:quickChick.mlg.cppo} %{target}))) (rule (alias compat) (target tactic_quickchick.mlg) (action (run sh %{dep:../scripts/mycppo} %{dep:tactic_quickchick.mlg.cppo} %{target}))) (rule (alias compat) (target unifyQC.ml) (action (run sh %{dep:../scripts/mycppo} %{dep:unifyQC.ml.cppo} %{target}))) (rule (alias compat) (target unifyQC.mli) (action (run sh %{dep:../scripts/mycppo} %{dep:unifyQC.mli.cppo} %{target}))) (rule (alias compat) (target weightmap.mlg) (action (run sh %{dep:../scripts/mycppo} %{dep:weightmap.mlg.cppo} %{target}))) QuickChick-2.1.0/plugin/enumSized.ml000066400000000000000000000052401476030541200173260ustar00rootroot00000000000000open Util open GenericLib open GenLib let enumSized_decl (types : (ty_ctr * ty_param list * ctr_rep list) list) : (ty_ctr -> var list -> coq_expr) * ((var * arg list * var * coq_expr * coq_expr) list) = let impl_function_names : (ty_ctr * var) list = List.map (fun (ty, _, _) -> let type_name = ty_ctr_to_string ty in let function_name = fresh_name ("enumSized_impl_" ^ type_name) in (ty, function_name) ) types in let generate_enumSized_function ((ty, ty_params, ctors) : (ty_ctr * ty_param list * ctr_rep list)) : var * arg list * var * coq_expr * coq_expr = let function_name = List.assoc ty impl_function_names in let coqTyParams = List.map gTyParam ty_params in let full_type = gApp ~explicit:true (gTyCtr ty) coqTyParams in let arg = fresh_name "size" in let arg_type = (gInject "Coq.Init.Datatypes.nat") in (* E ty *) let return_type = gApp (gInject "QuickChick.Enumerators.E") [full_type] in let find_ty_ctr = function | TyCtr (ty_ctr', _) -> List.assoc_opt ty_ctr' impl_function_names | _ -> None in (* a base branch is a constructor that doesn't require our ty_ctr to be used *) let is_base_branch ty = fold_ty' (fun b ty' -> b && (None = (find_ty_ctr ty'))) true ty in let base_branches = List.filter (fun (_, ty) -> is_base_branch ty) ctors in let create_for_branch size (ctr, ty) = let rec aux i acc ty : coq_expr = match ty with | Arrow (ty1, ty2) -> bindEnum (match find_ty_ctr ty1 with | Some name -> gApp (gVar name) [gVar size] | None -> gInject "enum") (Printf.sprintf "p%d" i) (fun pi -> aux (i+1) ((gVar pi) :: acc) ty2) | _ -> returnEnum (gApp ~explicit:true (gCtr ctr) (coqTyParams @ List.rev acc)) in aux 0 [] ty in let body = gMatch (gVar arg) [ ( injectCtr "O", [], fun _ -> oneof (List.map (create_for_branch arg) base_branches) ); ( injectCtr "S", ["size'"], fun [size'] -> oneof (List.map (create_for_branch size') ctors) ) ] in debug_coq_expr body; (function_name, [gArg ~assumName:(gVar arg) ~assumType:arg_type ()], arg, return_type, body) in let functions = List.map generate_enumSized_function types in (* returns {| enumSized := enumSized_impl_... |} *) let instance_record ty_ctr ivars : coq_expr = let impl_function_name = List.assoc ty_ctr impl_function_names in let implicit_arguments = List.map gVar ivars in gRecord [ ("enumSized", gApp ~explicit:true (gVar impl_function_name) implicit_arguments) ] in (instance_record, functions) QuickChick-2.1.0/plugin/enumSizedST.ml000066400000000000000000000145651476030541200176070ustar00rootroot00000000000000open Pp open Util open GenericLib open GenLib open Error open UnifyQC (* arguments to handle_branch *) let fail_exp (dt : coq_expr) = failEnum (gOption dt) let not_enough_fuel_exp (dt : coq_expr) = returnEnum (gApp ~explicit:true (gInject "None") [dt]) let ret_exp (dt : coq_expr) (c : coq_expr) = msg_debug (str "Returning...." ++ fnl ()); debug_coq_expr c; returnEnum (gApp ~explicit:true (gInject "Some") [dt; c]) let ret_type (s : var) f = hole let instantiate_existential_method = (gInject "enum") let instantiate_existential_methodST (n : int) (pred : coq_expr) = gApp ~explicit:true (gInject "enumSuchThat") [ hole (* Implicit argument - type A *) ; pred ; hole (* Implicit instance *)] let rec_method (rec_name : coq_expr) (init_size : coq_expr) (size : coq_expr) (n : int) (letbinds : unknown list option) (l : coq_expr list) = (* TODO: use letbinds *) gApp rec_name (init_size :: size :: l) let bind (opt : bool) (m : coq_expr) (x : string) (f : var -> coq_expr) = bindEnumOpt m x f (* (if opt then bindEnumOpt else bindEnum) m x f *) let stMaybe (opt : bool) (g : coq_expr) (x : string) (checks : ((coq_expr -> coq_expr) * int) list) = failwith "Implement stMaybe for enum" (* let rec sumbools_to_bool x lst = match lst with | [] -> gTrueb | (chk, _) :: lst' -> matchDec (chk (gVar x)) (fun heq -> gFalseb) (fun hneq -> sumbools_to_bool x lst') in let bool_pred = gFun [x] (fun [x] -> sumbools_to_bool x checks) in (gApp (gInject (if opt then "suchThatMaybeOpt" else "suchThatMaybe")) [ g (* Use the generator provided for base generator *) ; bool_pred ]) *) let ret_type_dec (s : var) (left : coq_expr) (right : coq_expr) = gMatch (gVar s) [ (injectCtr "left", ["eq"], fun _ -> left) ; (injectCtr "right", ["neq"], fun _ -> right) ] let check_expr (n : int) (scrut : coq_expr) (left : coq_expr) (right : coq_expr) (out_of_fuel : coq_expr) = gMatchReturn scrut "s" (* as clause *) (fun v -> ret_type v ret_type_dec) [ (injectCtr "Some", ["res_b" ] , fun [b] -> (* Why as clauses/returns? *) gMatch (gVar b) [ (injectCtr "true", [], fun _ -> left) ; (injectCtr "false", [], fun _ -> right) ]) ; (injectCtr "None", [], fun _ -> out_of_fuel) ] let match_inp (inp : var) (pat : matcher_pat) (left : coq_expr) (right : coq_expr) = let ret v left right = construct_match (gVar v) ~catch_all:(Some right) [(pat, left)] in let catch_case = match pat with | MatchCtr (c, ls) -> (* Leo: This is a hack totality check for unary matches *) if num_of_ctrs c = 1 && List.for_all (fun x -> match x with MatchU _ -> true | MatchCtr _ -> false) ls then None else Some right | _ -> failwith "Toplevel match not a constructor?" in construct_match_with_return (gVar inp) ~catch_all:(catch_case) "s" (fun v -> ret_type v ret) [(pat,left)] type generator_kind = Base_gen | Ind_gen (* hoisting out base and ind gen to be able to call them from proof generation *) let construct_generators (kind : generator_kind) (init_size : coq_expr) (size : coq_expr) (full_gtyp : coq_expr) (gen_ctr : ty_ctr) (dep_type : dep_type) (ctrs : dep_ctr list) (rec_name : coq_expr) (input_ranges : range list) (init_umap : range UM.t) (init_tmap : dep_type UM.t) (result : Unknown.t) = (* partially applied handle_branch *) let handle_branch' = handle_branch ["EnumSizedSuchThat"; "EnumSuchThat"] dep_type init_size (fail_exp full_gtyp) (not_enough_fuel_exp full_gtyp) (ret_exp full_gtyp) instantiate_existential_method instantiate_existential_methodST bind (rec_method rec_name init_size size) bind stMaybe check_expr match_inp gLetIn gLetTupleIn gen_ctr init_umap init_tmap input_ranges result in let all_gens = List.map handle_branch' ctrs in let padNone = if List.exists (fun gb -> not (snd gb)) all_gens then [not_enough_fuel_exp full_gtyp] else [] in match kind with | Base_gen -> List.map fst (List.filter snd all_gens) @ padNone | Ind_gen -> List.map fst all_gens let base_gens = construct_generators Base_gen let ind_gens = construct_generators Ind_gen (* Advanced Generators *) let enumSizedST (gen_ctr : ty_ctr) (ty_params : ty_param list) (ctrs : dep_ctr list) (dep_type : dep_type) (input_names : var list) (input_ranges : range list) (init_umap : range UM.t) (init_tmap : dep_type UM.t) (inputs : arg list) (result : Unknown.t) (rec_name : coq_expr) = (* type constructor *) let _coqTyCtr = gTyCtr gen_ctr in (* parameters of the type constructor *) let _coqTyParams = List.map gTyParam ty_params in (* The type we are generating for -- not the predicate! *) let full_gtyp = (gType ty_params (UM.find result init_tmap)) in (* The type of the dependent generator *) let gen_type = gEnum (gOption full_gtyp) in let aux_arb rec_name init_size size vars = gMatch (gVar size) [ (injectCtr "O", [], fun _ -> enumerating (base_gens init_size (gVar size) full_gtyp gen_ctr dep_type ctrs rec_name input_ranges init_umap init_tmap result)) ; (injectCtr "S", ["size'"], fun [size'] -> (* let weights = List.map (fun (c,_) -> Weightmap.lookup_weight c size') ctrs in *) enumerating (ind_gens init_size (gVar size') full_gtyp gen_ctr dep_type ctrs rec_name input_ranges init_umap init_tmap result)) ] in let generator_body : coq_expr = let sizeVar = fresh_name "size" in gRecFunInWithArgs ~structRec:(Some sizeVar) ~assumType:(gen_type) "aux_arb" (gArg ~assumName:(gVar (fresh_name "init_size")) () :: gArg ~assumName:(gVar sizeVar) () :: inputs) (fun (rec_name, init_size::size::vars) -> aux_arb (gVar rec_name) (gVar init_size) size vars) (fun rec_name -> gFun ["size"] (fun [size] -> gApp (gVar rec_name) (gVar size :: gVar size :: List.map (fun i -> gVar (arg_to_var i)) inputs) )) in msg_debug (fnl () ++ fnl () ++ str "`Final body produced:" ++ fnl ()); debug_coq_expr generator_body; msg_debug (fnl ()); gRecord [("enumSizeST", generator_body)] QuickChick-2.1.0/plugin/error.ml000066400000000000000000000003161476030541200165130ustar00rootroot00000000000000let flag_debug = Summary.ref ~name:"QC_flag_debug" false let qcfail s = failwith (Printf.sprintf "Internal QuickChick Error : %s" s) let msg_debug s = if !flag_debug then Feedback.msg_debug s else () QuickChick-2.1.0/plugin/error.mli000066400000000000000000000001211476030541200166560ustar00rootroot00000000000000val flag_debug : bool ref val qcfail : string -> 'a val msg_debug : Pp.t -> unit QuickChick-2.1.0/plugin/genLib.ml000066400000000000000000000042641476030541200165700ustar00rootroot00000000000000open Util open GenericLib (* Gen combinators *) let gGen c = gApp (gInject "G") [c] let returnGen c = gApp (gInject "returnGen") [c] let bindGen cg xn cf = gApp (gInject "bindGen") [cg; gFun [xn] (fun [x] -> cf x)] let bindGenOpt cg xn cf = gApp (gInject "bindOpt") [cg; gFun [xn] (fun [x] -> cf x)] (* Gen combinators *) let gEnum c = gApp (gInject "E") [c] let returnEnum c = gApp (gInject "returnEnum") [c] let bindEnum cg xn cf = gApp (gInject "bindEnum") [cg; gFun [xn] (fun [x] -> cf x)] let failEnum c = gApp ~explicit:true (gInject "failEnum") [c] let bindEnumOpt cg xn cf = gApp (gInject "bindOpt") [cg; gFun [xn] (fun [x] -> cf x)] let enumChecker cg xn cf sz = gApp (gInject "enumerating") [cg; gFun [xn] (fun [x] -> cf x); sz] let enumCheckerOpt cg xn cf sz = gApp (gInject "enumeratingOpt") [cg; gFun [xn] (fun [x] -> cf x); sz] let thunkify g = gApp (gInject "thunkGen") [gFun ["tt"] (fun [_] -> g)] let oneof l = match l with | [] -> failwith "oneof used with empty list" | [c] -> c | c::cs -> gApp (gInject "oneOf_") [c; gList l] let oneofThunked l = match l with | [] -> failwith "oneof used with empty list" | [c] -> c | c::cs -> gApp (gInject "oneOf_") [c; gList (List.map thunkify l)] let frequency l = match l with | [] -> failwith "frequency used with empty list" | [(_,c)] -> c | (_,c)::cs -> gApp (gInject "freq_") [c; gList (List.map gPair l)] let frequencyThunked l = match l with | [] -> failwith "frequency used with empty list" | [(_,c)] -> c | (_,c)::cs -> gApp (gInject "freq_") [c; gList (List.map (fun (w,g) -> gPair (w, thunkify g)) l)] let enumerating l = gApp (gInject "enumerate") [gList l] let backtracking l = gApp (gInject "backtrack") [gList (List.map gPair l)] let uniform_backtracking l = backtracking (List.combine (List.map (fun _ -> gInt 1) l) l) let checker_backtracking l = gApp (gInject "checker_backtrack") [gList (List.map (fun opt -> gFun ["_unit"] (fun _ -> opt)) l)] (* Map from inductives to maps of constructor weights *) module TyCtrMap = Map.Make(Ord_ty_ctr) module CtrMap = Map.Make(Ord_ctr) (* let weight_map : int CtrMap.t TyCtrMap.t = ref *) QuickChick-2.1.0/plugin/genLib.mli000066400000000000000000000036461476030541200167440ustar00rootroot00000000000000val gGen : GenericLib.coq_expr -> GenericLib.coq_expr val returnGen : GenericLib.coq_expr -> GenericLib.coq_expr val bindGen : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val bindGenOpt : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val gEnum : GenericLib.coq_expr -> GenericLib.coq_expr val returnEnum : GenericLib.coq_expr -> GenericLib.coq_expr val bindEnum : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val bindEnumOpt : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val failEnum : GenericLib.coq_expr -> GenericLib.coq_expr val enumChecker : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr -> GenericLib.coq_expr val enumCheckerOpt : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr -> GenericLib.coq_expr val thunkify : GenericLib.coq_expr -> GenericLib.coq_expr val oneof : GenericLib.coq_expr list -> GenericLib.coq_expr val oneofThunked : GenericLib.coq_expr list -> GenericLib.coq_expr val frequency : (GenericLib.coq_expr * GenericLib.coq_expr) list -> GenericLib.coq_expr val frequencyThunked : (GenericLib.coq_expr * GenericLib.coq_expr) list -> GenericLib.coq_expr val backtracking : (GenericLib.coq_expr * GenericLib.coq_expr) list -> GenericLib.coq_expr val enumerating : (GenericLib.coq_expr) list -> GenericLib.coq_expr val uniform_backtracking : GenericLib.coq_expr list -> GenericLib.coq_expr val checker_backtracking : GenericLib.coq_expr list -> GenericLib.coq_expr module TyCtrMap : CMap.ExtS with type key = GenericLib.Ord_ty_ctr.t and module Set := Set.Make(GenericLib.Ord_ty_ctr) module CtrMap : CMap.ExtS with type key = GenericLib.Ord_ctr.t and module Set := Set.Make(GenericLib.Ord_ctr) QuickChick-2.1.0/plugin/genSTCorrect.ml000066400000000000000000000455231476030541200177350ustar00rootroot00000000000000open Pp open Loc open Names open Tacmach.Old open Entries open Declarations open Declare open Libnames open Util open Constrintern open Topconstr open Constrexpr open Constrexpr_ops open Decl_kinds open GenericLib open SetLib open CoqLib open GenLib open SemLib open UnifyQC open ArbitrarySizedST open Feedback open Extraction_plugin.Extract_env let appinst mthd inst s inps = gApp ~explicit:true (gInject mthd) [hole; hole; gApp inst inps; s] (* arguments for completeness *) type btyp = (coq_expr * coq_expr * coq_expr * coq_expr * coq_expr) type atyp = (coq_expr * coq_expr * coq_expr * coq_expr * coq_expr) let fail_exp (dt : coq_expr) : btyp = ( (* set *) set_empty, (* gen *) returnGen (gNone dt), (* mon *) returnGenSizeMonotonicOpt (gNone dt), (* comp *) gFun ["x"; "Hx"] (fun [x; hx] -> false_ind hole (imset_set0_incl hole hole (gVar hx))), (* sound *) gFun ["x"; "Hx"] (fun [x; hx] -> gOrIntroR (rewrite_set_l (semReturn hole) (gVar hx))) ) let ret_exp (dt : coq_expr) (c : coq_expr) : btyp = ( (* set *) set_singleton c, (* gen *) returnGen (gSome dt c), (* mon *) returnGenSizeMonotonicOpt (gSome dt c), (* comp *) gFun ["x"; "Hx"] (fun [x; hx] -> rewrite hole (imset_singl_incl hole hole hole (gVar hx)) (rewrite_set_r (semReturn hole) (gEqRefl hole))), (* sound *) gFun ["x"; "Hx"] (fun [x; hx] -> gOrIntroL (gExIntro_impl hole (gConjIntro (gEqRefl hole) (rewrite_set_l (semReturn hole) (gVar hx))))) ) let class_method : atyp = let proof = gInject "arbitraryCorrect" in ( (* set *) set_full, (* gen *) gInject "arbitrary", (* mon *) hole, (* comp *) set_eq_set_incl_r proof, (* soundness *) set_eq_set_incl_l proof ) let class_methodST (n : int) (pred : coq_expr) : atyp = let cproof = gApp ~explicit:true (gInject "STCorrect") [hole; pred; hole; hole] in let comp = set_eq_isSome_complete cproof in let sound = set_eq_isSome_sound cproof in let gen = gApp ~explicit:true (gInject "arbitraryST") [ hole (* Implicit argument - type A *) ; pred ; hole (* Implicit instance *)] in (pred, gen, hole, comp, sound) let rec_method (inputs : arg list) (setinst : coq_expr) (generator_body : coq_expr) (moninst : coq_expr) (ih : var) (size : coq_expr) (n : int) (l : coq_expr list) : atyp = let iter_body args : coq_expr = appinst "DependentClasses.iter" setinst size args in let gen_body args : coq_expr = gApp generator_body (size :: args) in let gmon = gApp moninst (size :: l) in let proof = gApp (gVar ih) l in (iter_body l, gen_body l, gmon, proof, proof) let bind (opt : bool) (m : atyp) (x : string) (f : var -> btyp) : btyp = let (set, gen, mon, comp, sound) = m in let setf x = let (set, _, _, _, _) = f x in set in let genf x = let (_, gen, _, _, _) = f x in gen in let monf x = let (_, _, mon, _, _) = f x in mon in let compf x = let (_, _, _, pr, _) = f x in pr in let soundf x = let (_, _, _, _, pr) = f x in pr in let hxc = "Hc_" ^ x in let hx = "H_" ^ x in let hcur' = "Hl_" ^ x in ( (* set *) set_bigcup x set setf, (* gen *) (if opt then bindGenOpt else bindGen) gen x genf, (* mon *) (if opt then bindOptMonotonicOpt else bindMonotonicOpt) mon x monf, (* comp *) (let bind = (if opt then semBindOptSizeMonotonicIncl_l else semBindSizeMonotonicIncl_l) gen (gFun [x] (fun [x] -> genf x)) set (gFun [x] (fun [x] -> setf x)) mon (gFun [x] (fun [x] -> monf x)) in bind comp (gFun [x] (fun [x] -> compf x))), (* sound *) (let bind = (if opt then semBindOptSizeMonotonicIncl_r else semBindSizeMonotonicIncl_r) gen (gFun [x] (fun [x] -> genf x)) set (gFun [x] (fun [x] -> setf x)) (* mon (gFun [x] (fun [x] -> monf x)) *) in bind sound (gFun [x] (fun [x] -> soundf x))) ) let ret_comp matcher1 matcher2 = set_incl (imset (gInject "Some") matcher1) (semGen matcher2) let ret_sound matcher1 matcher2 = set_incl (semGen matcher2) (set_union (imset (gInject "Some") matcher1) (set_singleton (gNone hole))) let ret_type_dec (ret : coq_expr -> coq_expr -> coq_expr) (s : var) (left1 : coq_expr) (right1 : coq_expr) (left2 : coq_expr) (right2 : coq_expr) = ret (gMatch (gVar s) [ (injectCtr "left", ["eq"], fun _ -> left1) ; (injectCtr "right", ["neq"], fun _ -> right1) ]) (gMatch (gVar s) [ (injectCtr "left", ["eq"], fun _ -> left2) ; (injectCtr "right", ["neq"], fun _ -> right2) ]) let ret_mon matcher = gApp (gInject "SizeMonotonicOpt") [matcher] let ret_type_mon (s : var) = let matcher = gMatch (gVar s) [ (injectCtr "left", ["eq"], fun _ -> hole) ; (injectCtr "right", ["neq"], fun _ -> hole) ] in ret_mon matcher let check_expr (n : int) (scrut : coq_expr) (left : btyp) (right : btyp) = let (lset, lgen, lmon, lcomp, lsound) = left in let (rset, rgen, rmon, rcomp, rsound) = right in let namecur = Printf.sprintf "Hc%d" n in ( (* set *) gMatchReturn scrut "v" (* as clause *) (fun v -> hole) [ (injectCtr "left", ["eq" ] , fun _ -> lset) ; (injectCtr "right", ["neq"], fun _ -> rset) ], (* gen *) gMatchReturn scrut "v" (* as clause *) (fun v -> ret_type v ret_type_dec) [ (injectCtr "left", ["eq" ] , fun _ -> lgen) ; (injectCtr "right", ["neq"], fun _ -> rgen) ], (* mon *) gMatchReturn scrut "v" (* as clause *) (fun v -> ret_type_mon v) [ (injectCtr "left", ["eq" ] , fun _ -> lmon) ; (injectCtr "right", ["neq"], fun _ -> rmon) ], (* compl *) gMatchReturn scrut "v" (* as clause *) (fun v -> ret_type_dec ret_comp v lset rset lgen rgen) [ (injectCtr "left", ["eq"] , fun _ -> lcomp) ; (injectCtr "right", ["neq"], fun _ -> rcomp) ], (* sound *) gMatchReturn scrut "v" (* as clause *) (fun v -> ret_type_dec ret_sound v lset rset lgen rgen) [ (injectCtr "left", ["eq"], fun _ -> lsound) ; (injectCtr "right", ["neq"], fun _ -> rsound) ]) let match_inp (inp : var) (pat : matcher_pat) (left : btyp) (right : btyp) = let (lset, lgen, lmon, lcomp, lsound) = left in let (rset, rgen, rmon, rcomp, rsound) = right in let mon_typ v = ret_mon (construct_match (gVar v) ~catch_all:(Some hole) [(pat, hole)]) in let proof_typ ret v = ret (construct_match (gVar v) ~catch_all:(Some rset) [(pat, lset)]) (construct_match (gVar v) ~catch_all:(Some rgen) [(pat, lgen)]) in ( (* set *) construct_match_with_return (gVar inp) ~catch_all:(Some rset) "v" (fun v -> hole) [(pat, lset)], (* gen *) construct_match_with_return (gVar inp) ~catch_all:(Some rgen) "v" (fun v -> hole) [(pat, lgen)], (* mon *) construct_match_with_return (gVar inp) ~catch_all:(Some rmon) "v" mon_typ [(pat, lmon)], (* comp *) construct_match_with_return (gVar inp) ~catch_all:(Some rcomp) "v" (proof_typ ret_comp) [(pat, lcomp)], (* sound *) construct_match_with_return (gVar inp) ~catch_all:(Some rsound) "v" (proof_typ ret_sound) [(pat, lsound)] ) let stMaybe (opt : bool) (exp : atyp) (x : string) (checks : ((coq_expr -> coq_expr) * int) list) = let (set, gen, mon, comp, sound) = exp in let rec sumbools_to_bool x lst e fail = match lst with | [] -> e | (chk, _) :: lst' -> matchDec (chk (gVar x)) (fun heq -> fail) (fun hneq -> sumbools_to_bool x lst' e fail) in let bool_pred checks = gFun [x] (fun [x] -> sumbools_to_bool x checks gTrueb gFalseb) in let hxs = "H_" ^ x in let ret_comp matcher1 matcher2 = gImpl matcher1 (gConj hole matcher2) in let ret_sound matcher1 matcher2 = gImpl (gConj hole matcher2) matcher1 in let rec sumbools_to_bool_comp (x : var) hx lst : coq_expr = match lst with | [] -> gConjIntro (gVar hx) (gEqRefl hole) | (chk, n) :: lst' -> let set d = gMatchReturn (gVar d) "s" (fun v -> gProp) [ (injectCtr "left" , ["eq" ], fun _ -> gFalse) ; (injectCtr "right", ["neq"], fun _ -> sumbools_to_bool x lst' (gApp set [gVar x]) gFalse) ] in let pred d = gIsTrue (matchDec (gVar d) (fun heq -> gFalseb) (fun hneq -> sumbools_to_bool x lst' gTrueb gFalseb)) in gApp (gMatchReturn (chk (gVar x)) "v" (* as clause *) (fun v -> ret_comp (set v) (pred v)) [ (injectCtr "left", ["heq"], fun [heq] -> gFun [hxs] (fun [hx] -> false_ind hole (gVar hx))) ; (injectCtr "right", ["hneq"], fun [hneq] -> gFun [hxs] (fun [hx] -> sumbools_to_bool_comp x hx lst')) ]) [gVar hx] in let rec sumbools_to_bool_sound (x : var) hx lst : coq_expr = match lst with | [] -> gMatch (gVar hx) [(injectCtr "conj", ["hl"; "hr"], (fun [hl; hr] -> (gVar hl)))] | (chk, n) :: lst' -> let set d = gMatchReturn (gVar d) "s" (fun v -> gProp) [ (injectCtr "left" , ["eq" ], fun _ -> gFalse) ; (injectCtr "right", ["neq"], fun _ -> sumbools_to_bool x lst' (gApp set [gVar x]) gFalse) ] in let pred d = gIsTrue (matchDec (gVar d) (fun heq -> gFalseb) (fun hneq -> sumbools_to_bool x lst' gTrueb gFalseb)) in gApp (gMatchReturn (chk (gVar x)) "v" (* as clause *) (fun v -> ret_sound (set v) (pred v)) [ (injectCtr "left", ["heq"], fun [heq] -> gFun [hxs] (fun [hx] -> gMatch (gVar hx) [(injectCtr "conj", ["hl"; "hr"], (fun [hl; hr] -> false_ind hole (diff_false_true (gVar hr))))] )) ; (injectCtr "right", ["hneq"], fun [hneq] -> gFun [hxs] (fun [hx] -> sumbools_to_bool_sound x hx lst')) ]) [gVar hx] in ( (* set *) gFun [x] (fun [x] -> sumbools_to_bool x checks (gApp set [gVar x]) gFalse), (* gen *) gApp (gInject (if opt then "suchThatMaybeOpt" else "suchThatMaybe")) [ gen (* Use the generator provided for base generator *) ; bool_pred checks ], (* mon *) (if opt then suchThatMaybeOptMonotonicOpt else suchThatMaybeMonotonicOpt) mon (bool_pred checks), (* comp *) set_incl_trans (imset_incl (gFun [x; hxs] (fun [x; hx] -> sumbools_to_bool_comp x hx checks))) ((if opt then semSuchThatMaybeOpt_complete else semSuchThatMaybe_complete) gen (bool_pred checks) hole mon comp), (* sound *) set_incl_trans ((if opt then semSuchThatMaybeOpt_sound else semSuchThatMaybe_sound) gen (bool_pred checks) hole sound) (setU_set_subset_compat (imset_incl (gFun [x; hxs] (fun [x; hx] -> sumbools_to_bool_sound x hx checks))) set_incl_refl) ) let genSizedSTCorr_body (class_name : string) (gen_ctr : ty_ctr) (ty_params : ty_param list) (ctrs : dep_ctr list) (dep_type : dep_type) (input_names : string list) (inputs : arg list) (n : int) (register_arbitrary : dep_type -> unit) (moninst : coq_expr) (geninst : coq_expr) (setinst : coq_expr) = (* type constructor *) let coqTyCtr = gTyCtr gen_ctr in (* parameters of the type constructor *) let coqTyParams = List.map gTyParam ty_params in (* Fully applied type constructor *) let full_dt = gApp ~explicit:true coqTyCtr coqTyParams in (* The type we are generating for -- not the predicate! *) let full_gtyp = (gType ty_params (nthType n dep_type)) in (* The type of the dependent generator *) let gen_type = gGen (gOption full_gtyp) in (* Fully applied predicate (parameters and constructors) *) let full_pred inputs = gFun ["_forGen"] (fun [fg] -> gApp (full_dt) (list_insert_nth (gVar fg) inputs (n-1))) in let base_gens (input_names : var list) (rec_name : coq_expr) = base_gens (gInt 0) full_gtyp gen_ctr dep_type ctrs input_names n register_arbitrary rec_name in let ind_gens (input_names : var list) (size : var) (rec_name : coq_expr) = ind_gens (gVar size) full_gtyp gen_ctr dep_type ctrs input_names n register_arbitrary rec_name in let aux_arb (rec_name : coq_expr) size vars = gMatch (gVar size) [ (injectCtr "O", [], fun _ -> uniform_backtracking (base_gens vars rec_name)) ; (injectCtr "S", ["size'"], fun [size'] -> uniform_backtracking (ind_gens vars size' rec_name)) ] in let generator_body : coq_expr = (* gInject "gen" *) gRecFunInWithArgs ~assumType:(gen_type) "aux_arb" (gArg ~assumName:(gVar (fresh_name "size")) () :: inputs) (fun (rec_name, size::vars) -> aux_arb (gVar rec_name) size vars) (fun rec_name -> gVar rec_name) in let add_freq gens = List.map gPair (List.combine (List.map (fun _ -> gInt 1) gens) gens) in let handle_branch' (ih : var) (size : coq_expr) (ins : var list) = handle_branch n dep_type ins (fail_exp full_gtyp) (ret_exp full_gtyp) class_method class_methodST (rec_method inputs setinst generator_body moninst ih size) bind stMaybe check_expr match_inp (failwith "zoe fix me!") gen_ctr (fun _ -> ()) in let some_proof hc = gMatch (in_imset hole hole hole hc) [(injectCtr "ex_intro", ["z"; "Heqz"], fun [z; heq] -> rewrite_sym (gFun ["x"] (fun [x] -> isSome (gVar x))) (gVar heq) (isSomeSome hole))] in let base_case = gFunWithArgs inputs (fun inputs -> let (cases : coq_expr) = List.fold_right (fun (c : dep_ctr) (exp : coq_expr) -> let ((_, _, _, p, _), b) = handle_branch' (make_up_name ()) (gInt 0) inputs c in if b then imset_bigcup_setI_cons_subset_r (gProd hole hole) hole (succ_neq_zero hole) (setI_set_incl (imset_isSome hole) p) exp else exp ) ctrs imset_set0_subset in set_incl_trans cases (* (setU_subset_l hole cases) *) (semBacktrack_complete (gList (add_freq (base_gens inputs generator_body))))) in let ind_case = gFun ["size"; "IHs"] (fun [s; ih] -> gFunWithArgs inputs (fun inputs -> let cases = List.fold_right (fun (c : dep_ctr) (exp : coq_expr) -> let ((_, _, _, p, _), b) = handle_branch' ih (gVar s) inputs c in imset_bigcup_setI_cons_subset_r (gProd hole hole) hole (succ_neq_zero hole) (setI_set_incl (imset_isSome hole) p) exp) ctrs imset_set0_subset in set_incl_trans cases (semBacktrack_complete (gList (add_freq (ind_gens inputs s generator_body)))))) in let ret_type = gFun ["size"] (fun [s] -> gProdWithArgs inputs (fun inputs -> let inps = List.map gVar inputs in set_incl (* (imset (gInject "Some") (gApp (gInject "aux_iter") ((gVar s) :: inps))) *) (imset (gInject "Some") (appinst "DependentClasses.iter" setinst (gVar s) inps)) (* (semGen (appinst "arbitrarySizeST" geninst (gVar s) inps)) *) (semGen (gApp generator_body ((gVar s) :: inps))) )) in let input_vars = List.map fresh_name input_names in let com_proof = gFun ["size"] (fun [s] -> gApp (gInject "nat_ind") ([ret_type; base_case; ind_case; gVar s] @ (List.map gVar input_vars))) in let base_case_sound = gFunWithArgs inputs (fun inputs -> let cases = List.fold_right (fun (c : dep_ctr) (exp : (coq_expr -> coq_expr) -> coq_expr) -> fun proof -> let ((_, _, _, _, p), b) = handle_branch' (make_up_name ()) (gInt 0) inputs c in if b then bigcup_cons_subset (gProd hole hole) hole (set_incl_setI_r (proof p)) (exp (fun e -> lift_subset_pres_r (proof e))) else exp proof) ctrs (fun e -> bigcup_nil_subset) lift_subset_pres_l in set_incl_trans (semBacktrack_sound (gList (add_freq (base_gens inputs generator_body)))) (set_incl_setU_l (bigcup_set_I_l cases) (set_incl_setI_l (setU_subset_r hole set_incl_refl)) )) in let ind_case_sound = gFun ["size"; "IHs"] (fun [s; ih] -> gFunWithArgs inputs (fun inputs -> let cases = List.fold_right (fun (c : dep_ctr) (exp : (coq_expr -> coq_expr) -> coq_expr) -> fun proof -> let ((_, _, _, _, p), b) = handle_branch' ih (gVar s) inputs c in bigcup_cons_subset (gProd hole hole) hole (set_incl_setI_r (proof p)) (exp (fun e -> lift_subset_pres_r (proof e)))) ctrs (fun e -> bigcup_nil_subset) lift_subset_pres_l in set_incl_trans (semBacktrack_sound (gList (add_freq (ind_gens inputs s generator_body)))) (set_incl_setU_l (bigcup_set_I_l cases) (set_incl_setI_l (setU_subset_r hole set_incl_refl)) ))) in let ret_type_sound = gFun ["size"] (fun [s] -> gProdWithArgs inputs (fun inputs -> let inps = List.map gVar inputs in set_incl (semGen (gApp generator_body ((gVar s) :: inps))) (* (set_union (imset (gInject "Some") (gApp (gInject "aux_iter") ((gVar s) :: inps))) ((set_singleton (gNone hole)))) *) (set_union (imset (gInject "Some") (appinst "DependentClasses.iter" setinst (gVar s) inps)) ((set_singleton (gNone hole)))) )) in let sound_proof = gFun ["size"] (fun [s] -> gApp (gInject "nat_ind") ([ret_type_sound; base_case_sound; ind_case_sound; gVar s] @ (List.map gVar input_vars))) in let correct = gFun ["s"] (fun [s] -> isSome_set_eq (gApp sound_proof [gVar s]) (gApp com_proof [gVar s])) in msg_debug (str "compl"); debug_coq_expr com_proof; msg_debug (str "sound"); debug_coq_expr sound_proof; gRecord [ ("sizedSTCorrect", correct) ] QuickChick-2.1.0/plugin/genSTCorrect.mli000066400000000000000000000000001476030541200200630ustar00rootroot00000000000000QuickChick-2.1.0/plugin/genSizedSTMonotonic.ml000066400000000000000000000140761476030541200212770ustar00rootroot00000000000000open Pp open Util open GenericLib open SetLib open CoqLib open GenLib open SemLib open UnifyQC open ArbitrarySizedST open Error (* arguments to handle_branch *) let fail_exp = returnGenSizeMonotonicOpt (gNone hole) let ret_exp (c : coq_expr) = returnGenSizeMonotonicOpt (gSome hole c) let ret_type (s : var) (match_expr : var -> coq_expr -> coq_expr -> coq_expr) = gApp (gInject "SizeMonotonicOpt") [match_expr s hole hole] (* These should be inferred automatically *) let class_method = hole let class_methodST (n : int) (pred : coq_expr) = hole let rec_method (ih : var) (n : int) (l : coq_expr list) = gApp (gVar ih) l let bind (opt : bool) (m : coq_expr) (x : string) (f : var -> coq_expr) = (if opt then bindOptMonotonicOpt else bindMonotonicOpt) m x f let stMaybe (opt : bool) (g : coq_expr) (x : string) (checks : ((coq_expr -> coq_expr) * int) list) = let rec sumbools_to_bool x lst = match lst with | [] -> gTrueb | (chk, _) :: lst' -> matchDec (chk (gVar x)) (fun heq -> gFalseb) (fun hneq -> sumbools_to_bool x lst') in let bool_pred = gFun [x] (fun [x] -> sumbools_to_bool x checks) in (if opt then suchThatMaybeOptMonotonicOpt else suchThatMaybeMonotonicOpt) g bool_pred let ret_type_dec (s : var) (left : coq_expr) (right : coq_expr) = gMatch (gVar s) [ (injectCtr "left", ["eq"], fun _ -> left) ; (injectCtr "right", ["neq"], fun _ -> right) ] let check_expr (n : int) (scrut : coq_expr) (left : coq_expr) (right : coq_expr) = gMatchReturn scrut "s" (* as clause *) (fun v -> ret_type v ret_type_dec) [ (injectCtr "left", ["eq" ] , fun _ -> left) ; (injectCtr "right", ["neq"], fun _ -> right) ] let match_inp (inp : var) (pat : matcher_pat) (left : coq_expr) (right : coq_expr) = let ret v left right = construct_match (gVar v) ~catch_all:(Some right) [(pat, left)] in construct_match_with_return (gVar inp) ~catch_all:(Some right) "s" (fun v -> ret_type v ret) [(pat,left)] let genSizedSTMon_body (class_name : string) (gen_ctr : ty_ctr) (ty_params : ty_param list) (ctrs : dep_ctr list) (dep_type : dep_type) (input_names : string list) (inputs : arg list) (n : int) (register_arbitrary : dep_type -> unit) = (* type constructor *) let coqTyCtr = gTyCtr gen_ctr in (* parameters of the type constructor *) let coqTyParams = List.map gTyParam ty_params in (* Fully applied type constructor *) let full_dt = gApp ~explicit:true coqTyCtr coqTyParams in (* The type we are generating for -- not the predicate! *) let full_gtyp = (gType ty_params (nthType n dep_type)) in (* The type of the dependent generator *) let gen_type = gGen (gOption full_gtyp) in (* Fully applied predicate (parameters and constructors) *) let full_pred inputs = gFun ["_forGen"] (fun [fg] -> gApp (full_dt) (list_insert_nth (gVar fg) inputs (n-1))) in let base_gens (input_names : var list) (rec_name : coq_expr) = base_gens (gInt 0) full_gtyp gen_ctr dep_type ctrs input_names n register_arbitrary rec_name in let ind_gens (input_names : var list) (size : var) (rec_name : coq_expr) = ind_gens (gVar size) full_gtyp gen_ctr dep_type ctrs input_names n register_arbitrary rec_name in let aux_arb (input_names : var list) (rec_name : coq_expr) size vars = gMatch (gVar size) [ (injectCtr "O", [], fun _ -> uniform_backtracking (base_gens input_names rec_name)) ; (injectCtr "S", ["size'"], fun [size'] -> uniform_backtracking (ind_gens input_names size' rec_name)) ] in let generator_body (input_names : var list) : coq_expr = gRecFunInWithArgs ~assumType:(gen_type) "aux_arb" (gArg ~assumName:(gVar (fresh_name "size")) () :: inputs) (fun (rec_name, size::vars) -> aux_arb input_names (gVar rec_name) size vars) (fun x -> gVar x) in let add_freq gens = List.map gPair (List.combine (List.map (fun _ -> gInt 1) gens) gens) in let base_case = let handle_branch' (inputs : var list) = handle_branch n dep_type inputs fail_exp ret_exp class_method class_methodST (rec_method (make_up_name ())) bind stMaybe check_expr match_inp gLetIn gen_ctr (fun _ -> ()) in gFunWithArgs inputs (fun inputs -> backtrackSizeMonotonicOpt (gList (add_freq (base_gens inputs (generator_body inputs)))) (List.fold_right (fun (c : dep_ctr) (exp : coq_expr) -> let (p, b) : coq_expr * bool = handle_branch' inputs c in if b then cons_subset hole hole hole p exp else exp ) ctrs (nil_subset hole))) in (* gen_ctr dep_type gen_type ctrs input_names inputs n register_arbitrary *) (* class_name full_gtyp full_pred inputs base_gen ind_gen = *) let ind_case = let handle_branch' (ih : var) (size : var) (inputs : var list) = handle_branch n dep_type inputs fail_exp ret_exp class_method class_methodST (rec_method ih) bind stMaybe check_expr match_inp (failwith "zoe fix me!") gen_ctr (fun _ -> ()) in gFun ["size"; "IHs"] (fun [size; ihs] -> gFunWithArgs inputs (fun inputs -> backtrackSizeMonotonicOpt (gList (add_freq (ind_gens inputs size (generator_body inputs)))) (List.fold_right (fun c exp -> let (p, b) = handle_branch' ihs size inputs c in cons_subset hole hole hole p exp ) ctrs (nil_subset hole)))) in let ret_type = gFun ["s"] (fun [s] -> gProdWithArgs inputs (fun inputs -> gApp (gInject class_name) [gApp ~explicit:true (gInject "arbitrarySizeST") [full_gtyp; full_pred (List.map gVar inputs); hole; gVar s]])) in let mon_proof = gApp (gInject "nat_ind") [ret_type; base_case; ind_case] in msg_debug (str "mon term"); debug_coq_expr mon_proof; mon_proof QuickChick-2.1.0/plugin/genSizedSTMonotonic.mli000066400000000000000000000000001476030541200214260ustar00rootroot00000000000000QuickChick-2.1.0/plugin/genSizedSTSizeMonotonic.ml000066400000000000000000000273361476030541200221350ustar00rootroot00000000000000open Pp open Util open GenericLib open SetLib open CoqLib open GenLib open SemLib open UnifyQC open ArbitrarySizedST open Feedback type btyp = ((coq_expr -> coq_expr) * coq_expr) type atyp = ((coq_expr -> coq_expr) * coq_expr) let fail_exp (dt : coq_expr) : btyp = ( (* gen *) (fun s -> returnGen (gNone dt)), (* mon *) gFun ["s"] (fun _ -> set_incl_refl) ) let ret_exp (dt : coq_expr) (c : coq_expr) : btyp = ( (* gen *) (fun s -> returnGen (gSome dt c)), (* mon *) gFun ["s"] (fun _ -> set_incl_refl) ) let class_method : atyp = ( (* gen *) (fun s -> gInject "arbitrary"), (* mon *) gFun ["s"] (fun _ -> set_incl_refl) ) let class_methodST (n : int) (pred : coq_expr) : atyp = let gen = gApp ~explicit:true (gInject "arbitraryST") [ hole (* Implicit argument - type A *) ; pred ; hole (* Implicit instance *)] in ( (* gen *) (fun s -> gen), (* mon *) gFun ["s"] (fun _ -> set_incl_refl) ) let rec_method (generator_body : coq_expr) (hleq : var) (ih : var) (s2 : coq_expr) (n : int) (l : coq_expr list) : atyp = let gen_body (size : coq_expr) (args : coq_expr list) = gApp generator_body (size :: args) in let mon = gApp (gVar ih) ((s2 :: l) @ [gVar hleq]) in (* Unused! *) let proof = gApp (gVar ih) l in ( (* gen *) (fun s -> gen_body s l), (* mon *) mon ) let bind (opt : bool) (m : atyp) (x : string) (f : var -> btyp) : btyp = let (gen, mon) = m in let genf s x = let (gen, _) = f x in gen s in let monf x = let (_, mon) = f x in mon in ( (* gen *) (fun s -> (if opt then bindGenOpt else bindGen) (gen s) x (genf s)), (* mon *) (if opt then semBindOptSizeOpt_subset_compat else semBindSizeOpt_subset_compat) mon (gFun [x] (fun [x] -> monf x)) ) let ret_mon s matcher1 matcher2 = set_incl (set_int (isSomeSet hole) (semGenSize matcher1 (gVar s))) (set_int (isSomeSet hole) (semGenSize matcher2 (gVar s))) let eta g = gSnd (gPair (gInt 1, g)) let ret_type_dec (s : var) (v : var) (left1 : coq_expr) (right1 : coq_expr) (left2 : coq_expr) (right2 : coq_expr) = ret_mon s (gMatch (gVar v) [ (injectCtr "left", ["eq"], fun _ -> left1) ; (injectCtr "right", ["neq"], fun _ -> right1) ]) (gMatch (gVar v) [ (injectCtr "left", ["eq"], fun _ -> left2) ; (injectCtr "right", ["neq"], fun _ -> right2) ]) let check_expr (s1 : coq_expr) (s2 : coq_expr) (n : int) (scrut : coq_expr) (left : btyp) (right : btyp) = let (lgen, lmon) = left in let (rgen, rmon) = right in ( (* gen *) (fun s -> gMatchReturn scrut "v" (* as clause *) (fun v -> hole) [ (injectCtr "left", ["eq" ] , fun _ -> lgen s) ; (injectCtr "right", ["neq"], fun _ -> rgen s) ]), (* mon *) gFun ["s"] (fun [s] -> gMatchReturn scrut "v" (* as clause *) (fun v -> ret_type_dec s v (lgen s1) (rgen s1) (lgen s2) (rgen s2)) [ (injectCtr "left", ["eq"] , fun _ -> gApp lmon [gVar s]) ; (injectCtr "right", ["neq"], fun _ -> gApp rmon [gVar s]) ])) let match_inp (s1 : coq_expr) (s2 : coq_expr) (inp : var) (pat : matcher_pat) (left : btyp) (right : btyp) = let (lgen, lmon) = left in let (rgen, rmon) = right in let proof_typ s v = ret_mon s (construct_match (gVar v) ~catch_all:(Some (rgen s1)) [(pat, lgen s1)]) (construct_match (gVar v) ~catch_all:(Some (rgen s2)) [(pat, lgen s2)]) in ( (* gen *) (fun s -> construct_match_with_return (gVar inp) ~catch_all:(Some (rgen s)) "v" (fun v -> hole) [(pat, lgen s)]), (* mon *) gFun ["s"] (fun [s] -> construct_match_with_return (gVar inp) ~catch_all:(Some (gApp rmon [gVar s])) "v" (proof_typ s) [(pat, (gApp lmon [gVar s]))] )) let stMaybe (opt : bool) (exp : atyp) (x : string) (checks : ((coq_expr -> coq_expr) * int) list) = let (gen, mon) = exp in let rec sumbools_to_bool x lst e fail = match lst with | [] -> e | (chk, _) :: lst' -> matchDec (chk (gVar x)) (fun heq -> fail) (fun hneq -> sumbools_to_bool x lst' e fail) in let bool_pred checks = gFun [x] (fun [x] -> sumbools_to_bool x checks gTrueb gFalseb) in ( (* gen *) (fun s -> gApp (gInject (if opt then "suchThatMaybeOpt" else "suchThatMaybe")) [ gen s (* Use the generator provided for base generator *) ; bool_pred checks ]), (* mon *) (if opt then suchThatMaybeOpt_subset_compat else suchThatMaybe_subset_compat) (bool_pred checks) mon ) let bigcupf s = gFun ["x"] (fun [x] -> set_int (isSomeSet hole) (semGenSize (gSnd (gVar x)) s)) let genSizedSTSMon_body (class_name : string) (gen_ctr : ty_ctr) (ty_params : ty_param list) (ctrs : dep_ctr list) (dep_type : dep_type) (input_names : string list) (inputs : arg list) (n : int) (register_arbitrary : dep_type -> unit) = (* type constructor *) let coqTyCtr = gTyCtr gen_ctr in (* parameters of the type constructor *) let coqTyParams = List.map gTyParam ty_params in (* Fully applied type constructor *) let full_dt = gApp ~explicit:true coqTyCtr coqTyParams in (* The type we are generating for -- not the predicate! *) let full_gtyp = (gType ty_params (nthType n dep_type)) in (* The type of the dependent generator *) let gen_type = gGen (gOption full_gtyp) in (* Unused, not exported! *) (* Fully applied predicate (parameters and constructors) *) let full_pred inputs = gFun ["_forGen"] (fun [fg] -> gApp (full_dt) (list_insert_nth (gVar fg) inputs (n-1))) in let base_gens (input_names : var list) (rec_name : coq_expr) = base_gens (gInt 0) full_gtyp gen_ctr dep_type ctrs input_names n register_arbitrary rec_name in let ind_gens (input_names : var list) (size : coq_expr) (rec_name : coq_expr) = ind_gens size full_gtyp gen_ctr dep_type ctrs input_names n register_arbitrary rec_name in let aux_arb (rec_name : coq_expr) size vars = gMatch (gVar size) [ (injectCtr "O", [], fun _ -> uniform_backtracking (base_gens vars rec_name)) ; (injectCtr "S", ["size'"], fun [size'] -> uniform_backtracking (ind_gens vars (gVar size') rec_name)) ] in let generator_body : coq_expr = (* gInject "arb_aux" *) gRecFunInWithArgs ~assumType:(gen_type) "aux_arb" (gArg ~assumName:(gVar (fresh_name "size")) () :: inputs) (fun (rec_name, size::vars) -> aux_arb (gVar rec_name) size vars) (fun rec_name -> gVar rec_name) in let add_freq gens = List.map gPair (List.combine (List.map (fun _ -> gInt 1) gens) gens) in let handle_branch' s1 s2 hleq ih (ins : var list) = handle_branch n dep_type ins (fail_exp full_gtyp) (ret_exp full_gtyp) class_method class_methodST (rec_method generator_body hleq ih s2) bind stMaybe (check_expr s1 s2) (match_inp s1 s2) (failwith "zoe fix me!") gen_ctr (fun _ -> ()) in let base_case s2 hleq inputs = let cases = List.fold_right (fun (c : dep_ctr) (exp : coq_expr) -> (* let b = false in *) (* let p = hole in *) let ((_, p), b) = handle_branch' (gInt 0) (gVar s2) hleq (make_up_name ()) inputs c in if b then bigcup_cons_setI_subset_compat_backtrack_weak p exp else bigcup_cons_setI_subset_pres_backtrack_weak exp ) ctrs (gFun ["s"] (fun [s] -> bigcup_nil_setI hole hole hole)) in gFun ["s"] (fun [s] -> subset_respects_set_eq (setI_set_eq_r (semBacktrackSize (gList (add_freq (base_gens inputs generator_body))) (gVar s))) (setI_set_eq_r (semBacktrackSize (gList (add_freq (ind_gens inputs (gVar s2) generator_body))) (gVar s))) (isSome_subset (setI_subset_compat set_incl_refl (gApp cases [gVar s])))) in let ind_case s1 s2 hleq ih (inputs : var list) = let cases = List.fold_right (fun (c : dep_ctr) (exp : coq_expr) -> let ((_, p), b) = handle_branch' (gVar s1) (gVar s2) hleq ih inputs c in bigcup_cons_setI_subset_compat_backtrack_weak p exp ) ctrs (gFun ["s"] (fun [s] -> bigcup_nil_setI (bigcupf (gVar s)) hole hole)) in gFun ["s"] (fun [s] -> subset_respects_set_eq (setI_set_eq_r (semBacktrackSize (gList (add_freq (ind_gens inputs (gVar s1) generator_body))) (gVar s))) (setI_set_eq_r (semBacktrackSize (gList (add_freq (ind_gens inputs (gVar s2) generator_body))) (gVar s))) (isSome_subset (setI_subset_compat set_incl_refl (gApp cases [gVar s])))) in let input_vars = List.map fresh_name input_names in let ret_type s1 s2 = gProdWithArgs inputs (fun inps -> let inps = (List.map gVar inps) in gImpl (gLeq s1 s2) (gProdWithArgs [gArg ~assumName:(gVar (fresh_name "s")) ()] (fun [s] -> let s = gVar s in(set_incl (set_int (isSomeSet hole) (semGenSize (gApp generator_body (s1 :: inps)) s)) (set_int (isSomeSet hole) (semGenSize (gApp generator_body (s2 :: inps)) s)))))) in let out_type = gFun ["s1"] (fun [s1] -> gProdWithArgs [(gArg ~assumName:(gVar (fresh_name "s2")) ())] (fun [s2] -> ret_type (gVar s1) (gVar s2)) ) in let in_type s1 = gFun ["s2"] (fun [s2] -> ret_type s1 (gVar s2)) in let mon_proof = gFun ["s"; "s1"; "s2"; "Hleq"] (fun [s; s1; s2; hleq] -> gApp (nat_ind (* outer induction *) (* return type *) out_type (* base case -- inner induction *) (nat_ind (* inner type *) (in_type (gInt 0)) (* reflexivity *) (gFunWithArgs inputs (fun inps -> gFun ["Hleq"; "s"] (fun [hleq; s] -> set_incl_refl)) ) (gFun ["s2"; "IHs2"] (fun [s2; _] -> gFunWithArgs inputs (fun inps -> gFun ["Hleq"] (fun [hleq] -> base_case s2 hleq inps) )) ) ) (* inductive case -- inner induction *) (gFun ["s1"; "IHs1"] (fun [s1; ihs1] -> nat_ind (* inner type *) (in_type (gSucc (gVar s1))) (* contradiction *) (gFunWithArgs inputs (fun inps -> gFun ["Hleq"] (fun [hleq] -> false_ind hole (lt0_False (gVar hleq)))) ) (* inductive case *) (gFun ["s2"; "IHs2"] (fun [s2; _] -> gFunWithArgs inputs (fun inps -> gFun ["Hleq"] (fun [hleq] -> ind_case s1 s2 hleq ihs1 inps))) ) ) ) ) ((gVar s1) :: (gVar s2) :: (List.map gVar input_vars) @ [(gVar hleq); (gVar s)]) ) in msg_debug (str "size mon"); debug_coq_expr mon_proof; gRecord [ ("sizeMonotonicOpt", mon_proof) ] QuickChick-2.1.0/plugin/genSizedSTSizeMonotonic.mli000066400000000000000000000000001476030541200222610ustar00rootroot00000000000000QuickChick-2.1.0/plugin/genericLib.ml.cppo000066400000000000000000001756431476030541200204050ustar00rootroot00000000000000open Entries open Pp open Constr open Names open Declarations open Libnames open Util open Constrexpr open Constrexpr_ops open Ppconstr open Context open Error open Pattern let cnt = ref 0 let fresh_name n : Id.t = let base = Id.of_string n in (* [is_visible_name id] returns [true] if [id] is already used on the Coq side. *) let is_visible_name id = try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true with Not_found -> false in (* Safe fresh name generation. *) Namegen.next_ident_away_from base is_visible_name let make_up_name () : Id.t = let id = fresh_name (Printf.sprintf "mu%d_" (!cnt)) in cnt := !cnt + 1; id #if COQ_VERSION >= (8, 19, 0) let hole = CAst.make @@ CHole None #elif COQ_VERSION >= (8, 18, 0) let hole = CAst.make @@ CHole (None, Namegen.IntroAnonymous) #else let hole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) #endif let id_of_name n = match n with | Name x -> x | Anonymous -> failwith "id_of_name called with anonymous" (* Everything marked "Opaque" should have its implementation be hidden in the .mli *) type coq_expr = constr_expr (* Opaque *) let interp_open_coq_expr env evd e = fst (Constrintern.interp_constr env evd e) let debug_coq_expr (c : coq_expr) : unit = let env = Global.env () in let sigma = Evd.from_env env in msg_debug (pr_constr_expr env sigma c) let debug_constr env sigma (c : constr) : unit = msg_debug (Printer.safe_pr_constr_env env sigma c ++ fnl ()) (* Non-dependent version *) type var = Id.t (* Opaque *) let var_of_id x = x let id_of_var x = x let var_to_string = Id.to_string let gVar (x : var) : coq_expr = CAst.make @@ CRef (qualid_of_ident x,None) let inject_var (s : string) : var = Id.of_string s let qualid_to_coq_expr q = mkRefC q (* Maybe this should do checks? *) let gInject s = if s = "" then failwith "Called gInject with empty string"; CAst.make @@ CRef (qualid_of_string s, None) #if COQ_VERSION >= (8, 20, 0) let gType0 = CAst.make @@ CSort Constrexpr_ops.expr_Type_sort #elif COQ_VERSION >= (8, 19, 0) let gType0 = CAst.make @@ CSort (Glob_term.UAnonymous {rigid = UState.UnivRigid}) #else let gType0 = CAst.make @@ CSort (Glob_term.UAnonymous {rigid = true}) #endif type ty_param = Id.t (* Opaque *) let ty_param_to_string (x : ty_param) = Id.to_string x let inject_ty_param (s : string) : ty_param = Id.of_string s let gTyParam = mkIdentC type ty_ctr = qualid (* Opaque *) let ty_ctr_to_string (x : ty_ctr) = string_of_qualid x let gInjectTyCtr s = if s = "" then failwith "Called gInjectTyCtr with empty string"; qualid_of_string s let gTyCtr = qualid_to_coq_expr let tyCtrToQualid x = x type arg = local_binder_expr let gArg ?assumName:(an=hole) ?assumType:(at=hole) ?assumImplicit:(ai=false) ?assumGeneralized:(ag=false) _ = let n = match an with | { CAst.v = CRef (qid, _); loc } -> (loc,Name (qualid_basename qid)) | { CAst.v = CHole _; loc } -> (loc,Anonymous) | _a -> failwith "This expression should be a name" in let max_implicit = Glob_term.MaxImplicit in CLocalAssum ( [CAst.make ?loc:(fst n) @@ snd n], #if COQ_VERSION >= (8, 20, 0) None, #endif (if ag then Generalized (max_implicit, false) else if ai then Default max_implicit else Default Glob_term.Explicit), at ) let arg_to_var (x : arg) = match x with #if COQ_VERSION >= (8, 20, 0) | CLocalAssum ([{CAst.v = id; _}], _, _ ,_ ) -> id_of_name id #else | CLocalAssum ([{CAst.v = id; _}], _ ,_ ) -> id_of_name id #endif | _ -> qcfail "arg_to_var must be named" let str_lst_to_string sep (ss : string list) = List.fold_left (fun acc s -> acc ^ sep ^ s) "" ss type coq_type = | Arrow of coq_type * coq_type | TyCtr of ty_ctr * coq_type list | TyParam of ty_param let rec coq_type_size ct = match ct with | Arrow (_,ct') -> 1 + coq_type_size ct' | _ -> 0 let rec coq_type_to_string ct = match ct with | Arrow (c1, c2) -> Printf.sprintf "%s -> %s" (coq_type_to_string c1) (coq_type_to_string c2) | TyCtr (ty_ctr, cs) -> ty_ctr_to_string ty_ctr ^ " " ^ str_lst_to_string " " (List.map coq_type_to_string cs) | TyParam tp -> ty_param_to_string tp type constructor = qualid (* Opaque *) let constructor_to_string (x : constructor) = string_of_qualid x let gCtr id = qualid_to_coq_expr id let injectCtr s = if s = "" then failwith "Called gInject with empty string"; qualid_of_string s let ty_ctr_to_ctr x = x let ctr_to_ty_ctr x = x let num_of_ctrs (c : constructor) = let env = Global.env () in let glob_ref = Nametab.global c in let ((mind,n),_) = Globnames.destConstructRef glob_ref in let mib = Environ.lookup_mind mind env in Array.length (mib.mind_packets.(n).mind_consnames) let belongs_to_inductive (c : constructor) = (* let env = Global.env () in *) let glob_ref = Nametab.global c in Globnames.isIndRef glob_ref module type Ord_ty_ctr_type = sig type t = ty_ctr val compare : t -> t -> int end module type Ord_ctr_type = sig type t = constructor val compare : t -> t -> int end module Ord_ty_ctr = struct type t = ty_ctr let compare x y = Stdlib.compare (string_of_qualid x) (string_of_qualid y) end module Ord_ctr = struct type t = constructor let compare x y = Stdlib.compare (string_of_qualid x) (string_of_qualid y) end type ctr_rep = constructor * coq_type let ctr_rep_to_string (ctr, ct) = Printf.sprintf "%s : %s" (constructor_to_string ctr) (coq_type_to_string ct) type sdt_rep = ty_ctr * ty_param list * ctr_rep list type dt_rep = sdt_rep list let sdt_rep_to_string (ty_ctr, ty_params, ctrs) = Printf.sprintf "%s %s :=\n%s" (ty_ctr_to_string ty_ctr) (str_lst_to_string " " (List.map ty_param_to_string ty_params)) (str_lst_to_string "\n" (List.map ctr_rep_to_string ctrs)) let dt_rep_to_string r = String.concat "\n" (List.map sdt_rep_to_string r) (* Supertype of coq_type handling potentially dependent stuff - TODO : merge *) type dep_type = | DArrow of dep_type * dep_type (* Unnamed arrows *) | DProd of (var * dep_type) * dep_type (* Binding arrows *) | DTyParam of ty_param (* Type parameters - for simplicity *) | DTyCtr of ty_ctr * dep_type list (* Type Constructor *) | DCtr of constructor * dep_type list (* Regular Constructor (for dependencies) *) | DTyVar of var (* Use of a previously captured type variable *) | DApp of dep_type * dep_type list (* Type-level function applications *) | DNot of dep_type (* Negation pushed up a level *) | DHole module OrdDepType = struct type t = dep_type let compare = Stdlib.compare end let rec dep_type_to_string dt = match dt with | DArrow (d1, d2) -> Printf.sprintf "%s -> %s" (dep_type_to_string d1) (dep_type_to_string d2) | DProd ((x,d1), d2) -> Printf.sprintf "(%s : %s) -> %s" (var_to_string x) (dep_type_to_string d1) (dep_type_to_string d2) | DTyCtr (ty_ctr, ds) -> ty_ctr_to_string ty_ctr ^ " " ^ str_lst_to_string " " (List.map dep_type_to_string ds) | DCtr (ctr, ds) -> constructor_to_string ctr ^ " " ^ str_lst_to_string " " (List.map dep_type_to_string ds) | DTyParam tp -> Printf.sprintf "(Param : %s)" (ty_param_to_string tp) | DTyVar tv -> var_to_string tv | DApp (d, ds) -> Printf.sprintf "(%s $ %s)" (dep_type_to_string d) (str_lst_to_string " " (List.map dep_type_to_string ds)) | DNot d -> Printf.sprintf "~ ( %s )" (dep_type_to_string d) | DHole -> "_" type dep_ctr = constructor * dep_type let dep_ctr_to_string (ctr, dt) = Printf.sprintf "%s : %s" (constructor_to_string ctr) (dep_type_to_string dt) type dep_dt = ty_ctr * ty_param list * dep_ctr list * dep_type let dep_dt_to_string (ty_ctr, ty_params, ctrs, dep_type) = Printf.sprintf "%s %s :=\n%s\n%s" (ty_ctr_to_string ty_ctr) (str_lst_to_string " " (List.map ty_param_to_string ty_params)) (str_lst_to_string "\n" (List.map dep_ctr_to_string ctrs)) (dep_type_to_string dep_type) let rec nthType1 i dt = match i, dt with | 1, DArrow (dt1, _) | 1, DProd ((_, dt1), _) -> dt1 | 1, _ -> failwith "Insufficient arrows" | _, DArrow (_, dt) | _, DProd (_, dt) -> nthType1 (i-1) dt | _, _ -> failwith "Insufficient arrows" let nthType i dt = let msg = "type: " ^ dep_type_to_string dt ^ "\n" ^ (Printf.sprintf "n: %n\n" i) in msg_debug (str msg); nthType1 i dt let rec dep_result_type dt = match dt with | DArrow (_, dt') -> dep_result_type dt' | DProd (_, dt') -> dep_result_type dt' | _ -> dt let rec dep_type_len = function | DArrow (_, dt') | DProd (_, dt') -> 1 + dep_type_len dt' | _ -> 0 (* Option monad *) let option_map f ox = match ox with | Some x -> Some (f x) | None -> None let (>>=) m f = match m with | Some x -> f x | None -> None let isSome m = match m with | Some _ -> true | None -> false let rec cat_maybes = function | [] -> [] | (Some x :: mxs) -> x :: cat_maybes mxs | None :: mxs -> cat_maybes mxs let foldM f b l = List.fold_left (fun accm x -> accm >>= fun acc -> f acc x ) b l let sequenceM f l = (foldM (fun acc x -> f x >>= fun x' -> Some (x' :: acc)) (Some []) l) >>= fun l -> Some (List.rev l) let parse_type_params arity_ctxt = let param_names = foldM (fun acc decl -> match Rel.Declaration.get_name decl with | Name id -> Some (id :: acc) | _ -> CErrors.user_err (str "Unnamed type parameter?" ++ fnl ()) ) (Some []) arity_ctxt in param_names (* For /trunk Rel.fold_inside (fun accm decl -> accm >>= fun acc -> match Rel.Declaration.get_name decl with | Name id -> Some (id :: acc) | Anonymous -> msgerr (str "Unnamed type parameter?" ++ fnl ()); None ) [] arity_ctxt in param_names *) let rec arrowify terminal l = match l with | [] -> terminal | x::xs -> Arrow (x, arrowify terminal xs) let qualid_to_mib (r : qualid) : mutual_inductive_body = let (mind, _) = Nametab.global_inductive r in let env = Global.env () in let mib = Environ.lookup_mind mind env in mib (* Receives number of type parameters and one_inductive_body. -> Possibly ty_param list as well? Returns list of constructor representations *) let parse_constructors nparams param_names result_ty oib : ctr_rep list option = let parse_constructor (branch : constructor * constr) = let (ctr_id, ty_ctr) = branch in let (_, ty) = Term.decompose_prod_n nparams ty_ctr in let ctr_pats = if isConst ty then [] else fst (Term.decompose_prod ty) in let _, pat_types = List.split (List.rev ctr_pats) in msg_debug (str (string_of_qualid ctr_id) ++ fnl ()); let rec aux i ty = if isRel ty then begin msg_debug (int (i + nparams) ++ str " Rel " ++ int (destRel ty) ++ fnl ()); let db = destRel ty in if i + nparams = db then (* Current inductive, no params *) Some (TyCtr (qualid_of_ident oib.mind_typename, [])) else (* [i + nparams - db]th parameter *) try Some (TyParam (List.nth param_names (i + nparams - db - 1))) with _ -> CErrors.user_err (str "nth failed: " ++ int (i + nparams - db - 1) ++ fnl ()) end else if isApp ty then begin #if COQ_VERSION >= (8, 18, 0) let (ctr, tms) = decompose_app_list ty in #else let (ctr, tms) = decompose_app ty in #endif foldM (fun acc ty -> aux i ty >>= fun ty' -> Some (ty' :: acc) ) (Some []) tms >>= fun tms' -> begin match aux i ctr with | Some (TyCtr (c, _)) -> Some (TyCtr (c, List.rev tms')) (* | Some (TyParam p) -> Some (TyCtr (p, tms')) *) | None -> CErrors.user_err (str "Aux failed?" ++ fnl ()) | _ -> failwith "aux failed to return a TyCtr" end end else if isInd ty then begin let ((mind, i), _) = destInd ty in let mib = qualid_to_mib @@ qualid_of_ident (Label.to_id (MutInd.label mind)) in let oib = mib.mind_packets.(i) in Some (TyCtr (qualid_of_ident @@ (oib.mind_typename), [])) end else if isConst ty then begin let (c,_) = destConst ty in (* TODO: Rethink this for constants? *) Some (TyCtr (qualid_of_ident (Label.to_id (Constant.label c)), [])) end else CErrors.user_err (str "Case Not Handled" ++ fnl()) in sequenceM (fun x -> x) (List.mapi aux (List.map (Vars.lift (-1)) pat_types)) >>= fun types -> Some (ctr_id, arrowify result_ty types) in let (cns : qualid list) = List.map qualid_of_ident (Array.to_list oib.mind_consnames) in let map (ctx, t) = Term.it_mkProd_or_LetIn t ctx in let lc = Array.map_to_list map oib.mind_nf_lc in sequenceM parse_constructor (List.combine cns lc) (* Convert mutual_inductive_body to this representation, if possible *) let dt_rep_from_mib (mib : mutual_inductive_body) : dt_rep option = let dt_rep_from_oib (oib : one_inductive_body) : sdt_rep option = let ty_ctr = oib.mind_typename in parse_type_params oib.mind_arity_ctxt >>= fun ty_params -> let result_ctr = TyCtr (qualid_of_ident ty_ctr, List.map (fun x -> TyParam x) ty_params) in parse_constructors mib.mind_nparams ty_params result_ctr oib >>= fun ctr_reps -> Some (qualid_of_ident ty_ctr, ty_params, ctr_reps) in Array.fold_left (fun dt oib -> dt >>= fun (dt : sdt_rep list) -> dt_rep_from_oib oib >>= fun (sdt : sdt_rep) -> Some (sdt::dt)) (Some []) mib.mind_packets let qualid_to_mib r = let env = Global.env () in let glob_ref = Nametab.global r in let (mind,_) = Globnames.destIndRef glob_ref in let mib = Environ.lookup_mind mind env in mib (* Legacy dt_rep_from_mib that fails on mutually inductive definitions *) let sdt_rep_from_mib (mib : mutual_inductive_body) : sdt_rep option = if Array.length mib.mind_packets > 1 then CErrors.user_err (str "Mutual inductive types not supported yet." ++ fnl()) else dt_rep_from_mib mib >>= fun dt -> Some (List.hd dt) let coerce_reference_to_dt_rep (c : constr_expr) : dt_rep option = let r = match c with | { CAst.v = CRef (r,_);_ } -> r | _ -> failwith "Not a reference" in let mib : mutual_inductive_body = qualid_to_mib r in dt_rep_from_mib mib (* Dependent derivations - lots of code reuse *) (* Input : arity_ctxt [Name, Body (option) {expected None}, Type] In reverse order. ASSUME: all type parameters are first Output: all type parameters (named arguments of type : Type) in correct order *) let dep_parse_type_params arity_ctxt = let param_names = foldM (fun acc decl -> match Rel.Declaration.get_name decl with | Name id -> (* Actual parameters are named of type Type with some universe *) if is_Type (Rel.Declaration.get_type decl) then Some (id :: acc) else Some acc | _ -> (* Ignore *) Some acc ) (Some []) arity_ctxt in param_names let rec dep_arrowify terminal names types = match names, types with | [], [] -> terminal | (Name x)::ns , t::ts -> DProd ((x,t), dep_arrowify terminal ns ts) | Anonymous::ns, t::ts -> DArrow (t, dep_arrowify terminal ns ts) | _, _ -> failwith "Invalid argument to dep_arrowify" (* parse a type into a dep_type option i : index of product (for DeBruijn) nparams : number of parameters in the beginning arg_names : argument names (type parameters, pattern specific variables *) let parse_dependent_type_internal i nparams ty oibopt arg_names = let rec aux i ty = let env = Global.env () in let sigma = Evd.from_env env in msg_debug (str "Calling aux with: " ++ int i ++ str " " ++ Printer.pr_constr_env env sigma ty ++ fnl()); if isRel ty then begin (* msgerr (int (i + nparams) ++ str " Rel " ++ int (destRel ty) ++ fnl ()); *) let db = destRel ty in if i + nparams = db then (* Current inductive, no params *) Some (DTyCtr (qualid_of_ident (let Some oib = oibopt in oib.mind_typename), [])) else begin (* [i + nparams - db]th parameter *) msg_debug (str (Printf.sprintf "Non-self-rel: %s" (dep_type_to_string (List.nth arg_names (i + nparams - db - 1)))) ++ fnl ()); try Some (List.nth arg_names (i + nparams - db - 1)) with _ -> CErrors.user_err (str "nth failed: " ++ int i ++ str " " ++ int nparams ++ str " " ++ int db ++ str " " ++ int (i + nparams - db - 1) ++ fnl ()) end end else if isApp ty then begin #if COQ_VERSION >= (8, 18, 0) let (ctr, tms) = decompose_app_list ty in #else let (ctr, tms) = decompose_app ty in #endif foldM (fun acc ty -> aux i ty >>= fun ty' -> Some (ty' :: acc) ) (Some []) tms >>= fun tms' -> match aux i ctr with | Some (DTyCtr (c, _)) -> Some (DTyCtr (c, List.rev tms')) | Some (DCtr (c, _)) -> Some (DCtr (c, List.rev tms')) | Some (DTyVar x) -> let xs = var_to_string x in if xs = "Coq.Init.Logic.not" || xs = "not" then match tms' with | [c] -> Some (DNot c) | _ -> failwith "Not a valid negation" else Some (DApp (DTyVar x, List.rev tms')) | Some wat -> CErrors.user_err (str ("WAT: " ^ dep_type_to_string wat) ++ fnl ()) | None -> CErrors.user_err (str "Aux failed?" ++ fnl ()) end else if isInd ty then begin let ((mind, midx),_) = destInd ty in let mib = Environ.lookup_mind mind env in let id = mib.mind_packets.(midx).mind_typename in (* msg_debug (str (Printf.sprintf "LOOK HERE: %s - %s - %s" (MutInd.to_string mind) (Label.to_string (MutInd.label mind)) (Id.to_string (Label.to_id (MutInd.label mind)))) ++ fnl ());*) Some (DTyCtr (qualid_of_ident id, [])) end else if isConstruct ty then begin let (((mind, midx), idx),_) = destConstruct ty in (* Lookup the inductive *) let env = Global.env () in let mib = Environ.lookup_mind mind env in (* let (mp, _dn, _) = MutInd.repr3 mind in *) (* HACKY: figure out better way to qualify constructors *) let names = String.split_on_char '.' (MutInd.to_string mind) in let prefix = List.rev (List.tl (List.rev names)) in let qual = String.concat "." prefix in msg_debug (str (Printf.sprintf "CONSTR: %s %s" qual (DirPath.to_string (Lib.cwd ()))) ++ fnl ()); (* Constructor name *) let cname = Id.to_string (mib.mind_packets.(midx).mind_consnames.(idx - 1)) in let cid = qualid_of_string (if (qual = "") || (qual = DirPath.to_string (Lib.cwd ())) then cname else qual ^ "." ^ cname) in Some (DCtr (cid, [])) end else if isProd ty then begin let (n, t1, t2) = destProd ty in (* Are the 'i's correct? *) aux i t1 >>= fun t1' -> aux i t2 >>= fun t2' -> Some (DProd ((id_of_name n.binder_name, t1'), t2')) end (* Rel, App, Ind, Construct, Prod *) else if isConst ty then begin let (x,_) = destConst ty in Some (DTyVar (Label.to_id (Constant.label x))) end else ( let env = Global.env() in let sigma = Evd.from_env env in CErrors.user_err (str "Dep Case Not Handled: " ++ Printer.pr_constr_env env sigma ty ++ fnl()) ) in aux i ty let parse_dependent_type ty = let (ctr_pats, result) = if isConst ty then ([],ty) else Term.decompose_prod ty in let pat_names, pat_types = List.split (List.rev ctr_pats) in let pat_names = List.map (fun n -> n.binder_name) pat_names in let arg_names = List.map (fun n -> match n with | Name x -> DTyVar x | Anonymous -> DTyVar (make_up_name ()) (* Make up a name, but probably can't be used *) ) pat_names in parse_dependent_type_internal (1 + (List.length ctr_pats)) 0 result None arg_names >>= fun result_ty -> sequenceM (fun x -> x) (List.mapi (fun i ty -> parse_dependent_type_internal i 0 ty None arg_names) (List.map (Vars.lift (-1)) pat_types)) >>= fun types -> Some (dep_arrowify result_ty pat_names types) let dep_parse_type nparams param_names arity_ctxt oib = let len = List.length arity_ctxt in (* Only type parameters can be used - no dependencies on the types *) let arg_names = List.map (fun x -> DTyParam x) param_names in foldM (fun acc (i, decl) -> let n = Rel.Declaration.get_name decl in let t = Rel.Declaration.get_type decl in let env = Global.env () in let sigma = Evd.from_env env in debug_constr env sigma t; match n with | Name id -> (* Check if it is a parameter to add its type / name *) if is_Type t then Some acc else parse_dependent_type_internal i nparams t (Some oib) arg_names >>= fun dt -> Some ((n,dt) :: acc) | _ -> parse_dependent_type_internal i nparams t (Some oib) arg_names >>= fun dt -> Some ((n,dt) :: acc) ) (Some []) (List.mapi (fun i x -> (len - nparams - i, x)) arity_ctxt) >>= fun nts -> let (names, types) = List.split nts in Some (dep_arrowify (DTyCtr (injectCtr "Prop", [])) names types) (* Dependent version: nparams is numver of Type parameters param_names are type parameters (length = nparams) Returns list of constructor representations *) let dep_parse_constructors nparams param_names oib : dep_ctr list option = let parse_constructor branch : dep_ctr option = let (ctr_id, ty_ctr) = branch in let (_, ty) = Term.decompose_prod_n nparams ty_ctr in let (ctr_pats, result) = if isConst ty then ([],ty) else Term.decompose_prod ty in let pat_names, pat_types = List.split (List.rev ctr_pats) in let pat_names = List.map (fun n -> n.binder_name) pat_names in let arg_names = List.map (fun x -> DTyParam x) param_names @ List.map (fun n -> match n with | Name x -> DTyVar x | Anonymous -> DTyVar (make_up_name ()) (* Make up a name, but probably can't be used *) ) pat_names in (* msgerr (str "Calculating result type" ++ fnl ()); *) parse_dependent_type_internal (1 + (List.length ctr_pats)) nparams result (Some oib) arg_names >>= fun result_ty -> (* msgerr (str "Calculating types" ++ fnl ()); *) sequenceM (fun x -> x) (List.mapi (fun i ty -> parse_dependent_type_internal i nparams ty (Some oib) arg_names) (List.map (Vars.lift (-1)) pat_types)) >>= fun types -> Some (ctr_id, dep_arrowify result_ty pat_names types) in let cns = List.map qualid_of_ident (Array.to_list oib.mind_consnames) in let map (ctx, t) = Term.it_mkProd_or_LetIn t ctx in let lc = Array.map_to_list map oib.mind_nf_lc in sequenceM parse_constructor (List.combine cns lc) let dep_dt_from_mib mib = if Array.length mib.mind_packets > 1 then begin CErrors.user_err (str "Mutual inductive types not supported yet." ++ fnl()) end else let oib = mib.mind_packets.(0) in let ty_ctr = oib.mind_typename in dep_parse_type_params oib.mind_arity_ctxt >>= fun ty_params -> List.iter (fun tp -> msg_debug (str (ty_param_to_string tp) ++ fnl ())) ty_params; dep_parse_constructors (List.length ty_params) ty_params oib >>= fun ctr_reps -> dep_parse_type (List.length ty_params) ty_params oib.mind_arity_ctxt oib >>= fun result_ty -> Some (qualid_of_ident ty_ctr, ty_params, ctr_reps, result_ty) let coerce_reference_to_dep_dt c = let r = match c with | { CAst.v = CRef (r,_); _ } -> r | _ -> failwith "Not a reference" in let env = Global.env () in let glob_ref = Nametab.global r in let (mind,_) = Globnames.destIndRef glob_ref in let mib = Environ.lookup_mind mind env in dep_dt_from_mib mib let gApp ?explicit:(expl=false) c cs = if expl then let f c = match c with | CRef (r,_) -> Constrexpr.CAppExpl((r, None), cs) | _ -> failwith "invalid argument to gApp" in CAst.map f c else mkAppC (c, cs) let gProdWithArgs args f_body = #if COQ_VERSION >= (8, 20, 0) let xvs = List.map (fun (CLocalAssum ([{CAst.v = n;_}], _, _, _)) -> #else let xvs = List.map (fun (CLocalAssum ([{CAst.v = n;_}], _, _)) -> #endif match n with | Name x -> x | _ -> make_up_name () ) args in let fun_body = f_body xvs in mkCProdN args fun_body let gFunWithArgs args f_body = #if COQ_VERSION >= (8, 20, 0) let xvs = List.map (fun (CLocalAssum ([{CAst.v = n;_}], _, _, _)) -> #else let xvs = List.map (fun (CLocalAssum ([{CAst.v = n;_}], _, _)) -> #endif match n with | Name x -> x | _ -> make_up_name () ) args in let fun_body = f_body xvs in mkCLambdaN args fun_body let gIf b t f = CAst.make @@ CIf (b, (None, None) , t, f) let gFun xss (f_body : var list -> coq_expr) = match xss with | [] -> f_body [] | _ -> let xvs = List.map (fun x -> fresh_name x) xss in (* TODO: optional argument types for xss *) #if COQ_VERSION >= (8, 20, 0) let binder_list = List.map (fun x -> CLocalAssum ([CAst.make @@ Name x], None, Default Glob_term.Explicit, hole)) xvs in #else let binder_list = List.map (fun x -> CLocalAssum ([CAst.make @@ Name x], Default Glob_term.Explicit, hole)) xvs in #endif let fun_body = f_body xvs in mkCLambdaN binder_list fun_body let gFunTyped xts (f_body : var list -> coq_expr) = match xts with | [] -> f_body [] | _ -> let xvs = List.map (fun (x,t) -> (fresh_name x,t)) xts in (* TODO: optional argument types for xss *) #if COQ_VERSION >= (8, 20, 0) let binder_list = List.map (fun (x,t) -> CLocalAssum ([CAst.make @@ Name x], None, Default Glob_term.Explicit, t)) xvs in #else let binder_list = List.map (fun (x,t) -> CLocalAssum ([CAst.make @@ Name x], Default Glob_term.Explicit, t)) xvs in #endif let fun_body = f_body (List.map fst xvs) in mkCLambdaN binder_list fun_body (* with Explicit/Implicit annotations *) let gRecFunInWithArgs ?structRec:(rec_id=None) ?assumType:(typ=hole) (fs : string) args (f_body : (var * var list) -> coq_expr) (let_body : var -> coq_expr) = let fv = fresh_name fs in #if COQ_VERSION >= (8, 20, 0) let xvs = List.map (fun (CLocalAssum ([{CAst.v = n;_}], _, _, _)) -> #else let xvs = List.map (fun (CLocalAssum ([{CAst.v = n;_}], _, _)) -> #endif match n with | Name x -> x | _ -> make_up_name () ) args in let fix_body = f_body (fv, xvs) in let rec_wf = match rec_id with | None -> None | Some id -> Some (CAst.make @@ CStructRec (CAst.make id)) in CAst.make @@ CLetIn (CAst.make @@ Name fv, #if COQ_VERSION >= (8, 20, 0) CAst.make @@ CFix(CAst.make fv,[(CAst.make fv, None, rec_wf, args, typ, fix_body)]), None, #else CAst.make @@ CFix(CAst.make fv,[(CAst.make fv, rec_wf, args, typ, fix_body)]), None, #endif let_body fv) let gRecFunIn ?structRec:(rec_id=None) ?assumType:(typ = hole) (fs : string) (xss : string list) (f_body : (var * var list) -> coq_expr) (let_body : var -> coq_expr) = let xss' = List.map (fun s -> fresh_name s) xss in gRecFunInWithArgs ~structRec:rec_id ~assumType:typ fs (List.map (fun x -> gArg ~assumName:(gVar x) ()) xss') f_body let_body let gLetIn (x : string) (e : coq_expr) (body : var -> coq_expr) = let fx = fresh_name x in CAst.make @@ CLetIn (CAst.make @@ Name fx, e, None, body fx) let gLetTupleIn (x : var) (xs : var list) (body : coq_expr) = CAst.make @@ CLetTuple (List.map (fun x -> CAst.make @@ Names.Name x) xs, (None, None), gVar x, body) let gMatch discr ?catchAll:(body=None) ?params:(holes=0) (branches : (constructor * string list * (var list -> coq_expr)) list) : coq_expr = CAst.make @@ CCases (RegularStyle, None (* return *), [(discr, None, None)], (* single discriminee, no as/in *) (List.map (fun (c, cs, bf) -> let cvs : Id.t list = List.map fresh_name cs in CAst.make ([[CAst.make @@ CPatCstr (c, None, List.init holes (fun _ -> CAst.make @@ CPatAtom None) @ List.map (fun s -> CAst.make @@ CPatAtom (Some (qualid_of_ident s))) cvs (* Constructor applied to patterns *) ) ]], bf cvs) ) branches) @ match body with | None -> [] | Some c' -> [CAst.make ([[CAst.make @@ CPatAtom None]], c')]) let gMatchReturn (discr : coq_expr) ?catchAll:(body=None) (as_id : string) (ret : var -> coq_expr) (branches : (constructor * string list * (var list -> coq_expr)) list) : coq_expr = let as_id' = fresh_name as_id in CAst.make @@ CCases (RegularStyle, Some (ret as_id'), (* return *) [(discr, Some (CAst.make (Name as_id')), None)], (* single discriminee, no in *) (List.map (fun (c, cs, bf) -> let cvs : Id.t list = List.map fresh_name cs in CAst.make ([[CAst.make @@ CPatCstr (c, None, List.map (fun s -> CAst.make @@ CPatAtom (Some (qualid_of_ident s))) cvs (* Constructor applied to patterns *) )]], bf cvs) ) branches) @ (match body with | None -> [] | Some c' -> [CAst.make ([([CAst.make @@ CPatAtom None])], c')]) ) let gRecord names_and_bodies = CAst.make @@ CRecord (List.map (fun (n,b) -> (qualid_of_ident @@ Id.of_string n, b)) names_and_bodies) let gAnnot (p : coq_expr) (tau : coq_expr) = #if COQ_VERSION >= (8, 18, 0) CAst.make @@ CCast (p, Some DEFAULTcast, tau) #elif COQ_VERSION >= (8, 15, 0) CAst.make @@ CCast (p, DEFAULTcast, tau) #else CAst.make @@ CCast (p, Glob_term.CastConv tau) #endif (* Convert types back into coq *) let gType ty_params dep_type = let rec aux dt : coq_expr = match dt with | DArrow (dt1, dt2) -> let t1 = aux dt1 in let t2 = aux dt2 in gFunWithArgs [gArg ~assumType:t1 ()] (fun _ -> t2) | DProd ((x,dt1), dt2) -> let t1 = aux dt1 in let t2 = aux dt2 in gProdWithArgs [gArg ~assumName:(gVar x) ~assumType:t1 ()] (fun _ -> t2) | DTyParam tp -> gTyParam tp | DTyCtr (c,dts) -> gApp (gTyCtr c) (List.map aux dts) | DCtr (c, dts) -> gApp (gCtr c) (List.map aux dts) | DTyVar x -> gVar x | DApp (c, dts) -> gApp (aux c) (List.map aux dts) | DHole -> hole | DNot dt -> gApp (gInject "Coq.Init.Datatypes.negb") [aux dt] in aux dep_type let gType' ty_params dep_type = msg_debug (str "Calling gType' with: " ++ str (dep_type_to_string dep_type) ++ fnl ()); let rec aux dt : coq_expr = match dt with | DArrow (dt1, dt2) -> let t1 = aux dt1 in let t2 = aux dt2 in gFunWithArgs [gArg ~assumType:t1 ()] (fun _ -> t2) | DProd ((x,dt1), dt2) -> let t1 = aux dt1 in let t2 = aux dt2 in gProdWithArgs [gArg ~assumName:(gVar x) ~assumType:t1 ()] (fun _ -> t2) | DTyParam tp -> gTyParam tp | DTyCtr (c,dts) -> gApp ~explicit:true (gTyCtr c) (List.map aux dts) | DCtr (c, dts) -> gApp (gCtr c) (List.map aux dts) | DTyVar x -> gVar x | DApp (c, dts) -> gApp (aux c) (List.map aux dts) | DHole -> hole | DNot dt -> gApp (gInject "Coq.Init.Logic.not") [aux dt] in debug_coq_expr (aux dep_type); aux dep_type (* match ty_params with | [] -> aux dep_type | _ -> gProdWithArgs (List.map (fun x -> gArg ~assumName:(gTyParam x) ()) ty_params) (fun _ -> aux dep_type) *) (* let locate_constant c = match Nametab.locate c with GlobRef.ConstRef x -> x | _ -> failwith ("loc_const: " ^ string_of_qualid c) *) let locate_ind c = begin try begin match Nametab.locate c with | GlobRef.IndRef x -> x | _ -> failwith ("loc_ind: " ^ string_of_qualid c) end with Not_found -> failwith ("Locate_ind: " ^ string_of_qualid c) end let locate_constant_of_id (c : Id.t) : Constant.t option = begin begin try match Nametab.locate (qualid_of_ident c) with | GlobRef.ConstRef x -> Some x | _ -> None with Not_found -> None (* failwith ("locate constant: " ^ (Id.to_string c))*) end end let locate_constructor c = try (match Nametab.locate c with GlobRef.ConstructRef x -> x | _ -> failwith ("loc_constr: " ^ string_of_qualid c)) with Not_found -> failwith ("locate constr: " ^ string_of_qualid c) (* Convert types back into constr *) let constr_of_type name ty_params dep_type = let rec find_param (x : Id.t) i j params = msg_debug (str "Finding param: " ++ str (Id.to_string x) ++ str " " ++ int i ++ str " " ++ int j ++ fnl ()); match params with | [] -> failwith "Param not found" | p::ps -> if p = x then Constr.mkRel (i - j) else find_param x i (j+1) ps in let rec find_index (x : Id.t) i j vars params = msg_debug (str "Finding index: " ++ str (Id.to_string x) ++ str " " ++ int i ++ str " " ++ int j ++ fnl ()); match vars with | [] -> begin match locate_constant_of_id x with | Some c -> Constr.mkConst c | None -> find_param x (List.length params + i) 1 params end (* TODO: Find DeBruijn equation *) | y::ys -> if x = y then Constr.mkRel (i - j) else find_index x i (j-1) ys params in let rec aux vars ty_params i dt : Constr.t = msg_debug (str "Calling aux with: " ++ str (dep_type_to_string dt) ++ str " " ++ int i ++ fnl ()); List.iter (fun v -> msg_debug (str (var_to_string v) ++ str " ")) vars; msg_debug (fnl ()); List.iter (fun v -> msg_debug (str (var_to_string v) ++ str " ")) ty_params; msg_debug (fnl ()); msg_debug (str "End preamble aux" ++ fnl ()); match dt with | DArrow (dt1, dt2) -> begin msg_debug (str "In DArrow" ++ fnl ()); let t1 = aux vars ty_params i dt1 in let t2 = aux (make_up_name () :: vars) ty_params (i+1) dt2 in Constr.mkProd (Context.anonR, t1, t2) end | DProd ((x,dt1), dt2) -> begin msg_debug (str "In DProd" ++ fnl ()); let t1 = aux vars ty_params i dt1 in let t2 = aux (x :: vars) ty_params (i+1) dt2 in Constr.mkProd (Context.nameR x, t1, t2) end | DTyParam tp -> begin msg_debug (str "In DTyParam" ++ fnl ()); msg_debug (str "Finding ty_param: " ++ str (ty_param_to_string tp) ++ str " with i: " ++ int i ++ fnl ()); find_param tp i 1 ty_params end | DTyCtr (c,dts) -> begin msg_debug (str "In DTyCtr" ++ fnl ()); let cname = string_of_qualid c in let c' = if cname = "Prop" then Constr.mkProp else if cname = "Type" then Constr.mkType Univ.Universe.type1 else if cname = name then Constr.mkRel i else Constr.mkInd (locate_ind c) in Constr.mkApp (c', Array.of_list (List.map (aux vars ty_params i) dts)) end | DCtr (c,dts) -> begin msg_debug (str "In DCtr" ++ fnl ()); Constr.mkApp (Constr.mkConstruct (locate_constructor c), Array.of_list (List.map (aux vars ty_params i) dts)) end | DTyVar x -> begin msg_debug (str "In DTyVar" ++ fnl ()); find_index x (i - List.length ty_params) (List.length vars) (vars) ty_params end | DApp (c, dts) -> begin msg_debug (str "In DApp" ++ fnl ()); Constr.mkApp (aux vars ty_params i c, Array.of_list (List.map (aux vars ty_params i) dts)) end | DNot dt -> failwith "Not" (* Constr.mkApp (Constr.mkVar (Id.of_string "negb"), [| aux dt |])*) | _ -> failwith "No holes allowed in constr_of_type" (* | DHole -> hole *) in let rec handle_ty_params ty_ps dt = match ty_ps with | [] -> dt | p::ps -> Constr.mkProd (Context.nameR p, Constr.mkType (Univ.Universe.type1), handle_ty_params ps dt) in handle_ty_params ty_params (aux [] ty_params (List.length ty_params + 1) dep_type) (* let cexpr = gType ty_params dep_type in let env = Global.env () in let evd = Evd.from_env env in let _,_ec = Constrintern.interp_open_constr env evd cexpr in failwith "Reaching here" *) (* EConstr.Unsafe.to_constr es *) (* Lookup the type of an identifier *) let get_type (id : Id.t) = msg_debug (str ("Trying to global:" ^ Id.to_string id) ++ fnl ()); let glob_ref = Nametab.global (qualid_of_ident id) in let open GlobRef in match glob_ref with | VarRef _ -> msg_debug (str "Var" ++ fnl ()) | ConstRef _ -> msg_debug (str "Constant" ++ fnl ()) | IndRef _ -> msg_debug (str "Inductive" ++ fnl ()) | ConstructRef _ -> msg_debug (str "Constructor" ++ fnl ()) let is_inductive c = let glob_ref = Nametab.global c in match glob_ref with | GlobRef.IndRef _ -> true | _ -> false let is_inductive_dt dt = match dt with | DTyCtr (c, dts) -> is_inductive c | _ -> false (* Specialized match *) type matcher_pat = | MatchCtr of constructor * matcher_pat list | MatchU of var | MatchParameter of ty_param (* Should become hole in pattern, so no binding *) let rec matcher_pat_to_string = function | MatchU u -> var_to_string u | MatchCtr (c, ms) -> constructor_to_string c ^ " " ^ str_lst_to_string " " (List.map matcher_pat_to_string ms) | MatchParameter p -> ty_param_to_string p let construct_match c ?catch_all:(mdef=None) alts = let rec aux = function | MatchU u' -> begin CAst.make @@ CPatAtom (Some (qualid_of_ident u')) end | MatchCtr (c, ms) -> begin if is_inductive c then CAst.make @@ CPatAtom None else CAst.make @@ CPatCstr (c, Some (List.map (fun m -> aux m) ms), []) end | MatchParameter p -> CAst.make @@ CPatAtom None in CAst.make @@ CCases (RegularStyle, None (* return *), [ (c, None, None)], (* single discriminee, no as/in *) List.map (fun (m, body) -> CAst.make @@ ([[aux m]], body)) alts @ (match mdef with | Some body -> [(CAst.make @@ ([[CAst.make @@ CPatAtom None]], body))] | _ -> [] ) ) let construct_match_with_return c ?catch_all:(mdef=None) (as_id : string) (ret : var -> coq_expr) (alts : (matcher_pat * coq_expr) list) = let as_id' = fresh_name as_id in let rec aux = function | MatchU u' -> begin CAst.make @@ CPatAtom (Some (qualid_of_ident u')) end | MatchCtr (c, ms) -> begin if is_inductive c then begin CAst.make @@ CPatAtom None end else begin CAst.make @@ CPatCstr (c, Some (List.map (fun m -> aux m) ms), []) end end | MatchParameter p -> CAst.make @@ CPatAtom None in let main_opts = List.map (fun (m, body) -> CAst.make @@ ([[aux m]], body)) alts in let default = match mdef with | Some body -> [CAst.make ([[CAst.make @@ CPatAtom None]], body)] | _ -> [] in CAst.make @@ CCases (RegularStyle, Some (ret as_id') (* return *), [ (c, Some (CAst.make @@ Name as_id'), None)], (* single discriminee, no as/in *) main_opts @ default ) (* Generic List Manipulations *) let list_nil = gInject "Coq.Lists.List.nil" let lst_append c1 c2 = gApp (gInject "Coq.Lists.List.app") [c1; c2] let rec lst_appends = function | [] -> list_nil | c::cs -> lst_append c (lst_appends cs) let gCons x xs = gApp (gInject "Coq.Lists.List.cons") [x; xs] let rec gList = function | [] -> gInject "Coq.Lists.List.nil" | x::xs -> gCons x (gList xs) (* Generic String Manipulations *) #if COQ_VERSION >= (8, 19, 0) let string_scope ast = CAst.make @@ CDelimiters (DelimUnboundedScope, "string", ast) #else let string_scope ast = CAst.make @@ CDelimiters ("string", ast) #endif let gStr s = string_scope (CAst.make @@ CPrim (String s)) let emptyString = gInject "Coq.Strings.String.EmptyString" let str_append c1 c2 = gApp (gInject "Coq.Strings.String.append") [c1; c2] let rec str_appends cs = match cs with | [] -> emptyString | [c] -> c | c1::cs' -> str_append c1 (str_appends cs') let smart_paren c = gApp (gInject "QuickChick.Show.smart_paren") [c] (* Pair *) let gPair (c1, c2) = gApp (gInject "Coq.Init.Datatypes.pair") [c1;c2] let gProd (c1, c2) = gApp (gInject "Coq.Init.Datatypes.prod") [c1;c2] let listToPairAux (f : ('a *'b) -> 'a) (l : 'b list) : 'a = match l with | [] -> qcfail "listToPair called with empty list" | c :: cs' -> let rec go (l : 'a list) (acc : 'a) : 'a = match l with | [] -> acc | x :: xs -> go xs (f (acc, x)) in go cs' c (* let gTupleAux f cs = match cs with | [] -> qcfail "gTuple called with empty list" (* Should this be unit? *) | c :: cs' -> let rec go l acc = match l with | [] -> acc | x :: xs -> go xs (f (acc, x)) in go cs' cx *) let gTuple = listToPairAux gPair let gTupleType = listToPairAux gProd let dtTupleType = listToPairAux (fun (acc,x) -> DTyCtr (injectCtr "Coq.Init.Datatypes.prod", [acc;x])) (* match dts with | [] -> qcfail "dtTuple called with empty list" | dt :: dts' -> let rec go l acc = match l with | [] -> acc | x :: xs -> go xs (DTyCtr (injectCtr "Coq.Init.Datatypes.Prod", [acc; x])) in go dts' dt *) (* Int *) #if COQ_VERSION >= (8, 19, 0) let nat_scope ast = CAst.make @@ CDelimiters (DelimUnboundedScope, "nat", ast) #else let nat_scope ast = CAst.make @@ CDelimiters ("nat", ast) #endif let gInt n = let number = Number (NumTok.Signed.of_int_string (string_of_int n)) in nat_scope (CAst.make @@ CPrim number) let gSucc x = gApp (gInject "Coq.Init.Datatypes.S") [x] let rec maximum = function | [] -> failwith "maximum called with empty list" | [c] -> c | (c::cs) -> gApp (gInject "Coq.Init.Peano.max") [c; maximum cs] let gle x y = gApp (gInject "mathcomp.ssreflect.ssrnat.leq") [x; y] let glt x y = gle (gApp (gInject "Coq.Init.Datatypes.S") [x]) y let gEq x y = gApp (gInject "Coq.Init.Logic.eq") [x; y] (* option type in Coq *) let gNone typ = gApp ?explicit:(Some true) (gInject "Coq.Init.Datatypes.None") [typ] let gSome typ c = gApp ?explicit:(Some true) (gInject "Coq.Init.Datatypes.Some") [typ; c] let gNone' = gInject "Coq.Init.Datatypes.None" let gSome' c = gApp (gInject "Coq.Init.Datatypes.Some") [c] let gOption c = gApp (gInject "Coq.Init.Datatypes.option") [c] (* Boolean *) let g_true = gInject "Coq.Init.Datatypes.true" let g_false = gInject "Coq.Init.Datatypes.false" let gNot c = gApp (gInject "Coq.Init.Datatypes.negb") [c] let gBool = gInject "Coq.Init.Datatypes.bool" let decToBool c = gMatch c [ (injectCtr "Coq.Init.Specif.left" , ["eq" ], fun _ -> g_true ) ; (injectCtr "Coq.Init.Specif.right", ["neq"], fun _ -> g_false) ] let decOptToBool c = gMatch c [ (injectCtr "Coq.Init.Datatypes.Some", ["res"], fun [res] -> gVar res) ; (injectCtr "Coq.Init.Datatypes.None", [], fun [] -> g_false) ] (* Unit *) let gUnit = gInject "Coq.Init.Datatypes.unit" let gTT = gInject "Coq.Init.Datatypes.tt" (* dec *) let g_dec typ = gApp ?explicit:(Some true) (gInject "QuickChick.Decidability.dec") [typ] let g_decOpt typ n = gApp ?explicit:(Some true) (gInject "QuickChick.Decidability.decOpt") [typ; hole; n] let g_dec_decOpt = gInject "QuickChick.Decidability.dec_decOpt" (* checker *) let g_checker toCheck = gApp (gInject "QuickChick.Checker.checker") [toCheck] (* Gen combinators *) let g_forAll gen prop = gApp (gInject "QuickChick.Checker.forAll") [gen; prop] let g_arbitrary = gInject "QuickChick.Classes.arbitrary" let g_quickCheck p = gApp (gInject "QuickChick.Test.quickCheck") [p] let g_show typ = gApp (gInject "QuickChick.Show.show") [typ] (* Recursion combinators / fold *) (* fold_ty : ( a -> coq_type -> a ) -> ( ty_ctr * coq_type list -> a ) -> ( ty_param -> a ) -> coq_type -> a *) let rec fold_ty arrow_f ty_ctr_f ty_param_f ty = match ty with | Arrow (ty1, ty2) -> let acc = fold_ty arrow_f ty_ctr_f ty_param_f ty2 in arrow_f acc ty1 | TyCtr (ctr, tys) -> ty_ctr_f (ctr, tys) | TyParam tp -> ty_param_f tp let fold_ty' arrow_f base ty = fold_ty arrow_f (fun _ -> base) (fun _ -> base) ty let rec dep_fold_ty arrow_f prod_f ty_ctr_f ctr_f ty_param_f var_f ty = match ty with | DArrow (ty1, ty2) -> let acc = dep_fold_ty arrow_f prod_f ty_ctr_f ctr_f ty_param_f var_f ty2 in arrow_f acc ty1 | DProd ((x,ty1), ty2) -> let acc = dep_fold_ty arrow_f prod_f ty_ctr_f ctr_f ty_param_f var_f ty2 in prod_f acc x ty1 | DTyCtr (ctr, tys) -> ty_ctr_f (ctr, tys) | DCtr (ctr, tys) -> ctr_f (ctr, tys) | DTyParam tp -> ty_param_f tp | DTyVar tp -> var_f tp (* Generate Type Names *) let generate_names_from_type base_name ty = List.rev (snd (fold_ty' (fun (i, names) _ -> (i+1, (Printf.sprintf "%s%d" base_name i) :: names)) (0, []) ty)) (* a := var list -> var -> a *) let fold_ty_vars (f : var list -> var -> coq_type -> 'a) (mappend : 'a -> 'a -> 'a) (base : 'a) ty : var list -> 'a = fun allVars -> fold_ty' (fun acc ty -> fun (v::vs) -> mappend (f allVars v ty) (acc vs)) (fun _ -> base) ty allVars (* Declarations *) (* LEO : There used to be defineConstant stuff here. WHY? *) (* let defineTypedConstant s c typ = let id = fresh_name s in (* TODO: DoDischarge or NoDischarge? *) let v = Constrintern.interp_constr (Global.env()) (Evd.from_env (Global.env())) e in (* Borrowed from CIW tutorial *) *) (* Declare an instance *) let create_names_for_anon a = match a with #if COQ_VERSION >= (8, 20, 0) | CLocalAssum ([{CAst.v = n; loc}], r, x, y) -> #else | CLocalAssum ([{CAst.v = n; loc}], x, y) -> #endif begin match n with | Name x -> (x, a) | Anonymous -> let n = make_up_name () in #if COQ_VERSION >= (8, 20, 0) (n, CLocalAssum ([CAst.make ?loc:loc @@ Names.Name n], r, x, y)) #else (n, CLocalAssum ([CAst.make ?loc:loc @@ Names.Name n], x, y)) #endif end | _ -> failwith "Non RawAssum in create_names" let declare_class_instance ?(global=true) ?(priority=42) instance_arguments instance_name instance_type instance_record = msg_debug (str "Declaring class instance..." ++ fnl ()); msg_debug (str (Printf.sprintf "Total arguments: %d" (List.length instance_arguments)) ++ fnl ()); let (vars,iargs) = List.split (List.map create_names_for_anon instance_arguments) in let instance_type_vars = instance_type vars in msg_debug (str "Calculated instance_type_vars" ++ fnl ()); let instance_record_vars = instance_record vars in msg_debug (str "Calculated instance_record_vars" ++ fnl ()); let cid = Classes.new_instance #if COQ_VERSION >= (8, 15, 0) ~locality:(if global then Hints.SuperGlobal else Hints.Local) #elif COQ_VERSION >= (8, 14, 0) ~locality:(if global then Goptions.OptGlobal else Goptions.OptLocal) #else ~global #endif ~poly:false (CAst.make @@ Name (Id.of_string instance_name), None) iargs instance_type_vars (true, instance_record_vars) (* TODO: true or false? *) { Typeclasses.hint_priority = Some priority; hint_pattern = None } in #if COQ_VERSION >= (9, 1, 0) let cid = cid.CAst.v in #endif msg_debug (str (Id.to_string cid) ++ fnl ()) let define_new_inductive (ty_ctr, ty_params, ctrs, typ) = let me_typename = Id.of_string (string_of_qualid ty_ctr) in msg_debug (str "constr_of_type: " ++ str (dep_type_to_string typ) ++ fnl ()); msg_debug (str "me_arity ty_ctr: " ++ str (string_of_qualid ty_ctr) ++ fnl ()); let me_arity = constr_of_type (string_of_qualid ty_ctr) ty_params typ in let oie = { mind_entry_typename = me_typename ; mind_entry_arity = me_arity ; mind_entry_consnames = List.map (fun (c,_) -> Id.of_string (string_of_qualid c)) ctrs ; mind_entry_lc = List.map (fun (_, t) -> constr_of_type (string_of_qualid ty_ctr) ty_params t) ctrs } in msg_debug (str "oie done" ++ fnl ()); let entry = { mind_entry_record = None ; mind_entry_finite = Declarations.Finite ; mind_entry_params = [] ; mind_entry_inds = [ oie ] ; mind_entry_universes = Entries.Monomorphic_ind_entry ; mind_entry_variance = None ; mind_entry_private = None } in let env = Global.env () in let evd = Evd.from_env env in let uentry = Evd.univ_entry ~poly:false evd in let impls = [] in Flags.quiet := false; msg_debug (str "About to declare: " ++ fnl ()); msg_debug (str "me_arity: " ++ Constr.debug_print oie.mind_entry_arity ++ fnl ()); List.iteri (fun i c -> msg_debug (str "me_consname: " ++ int i ++ Constr.debug_print c ++ fnl ())) oie.mind_entry_lc; ignore (DeclareInd.declare_mutual_inductive_with_eliminations entry uentry impls) (* Declares a new Fixpoint function. functions is a list of tuples that are, in this order: - the function name - the list of arguments - the function argument to use to prove that the function terminates - the return type - the function body *) let define_new_fixpoint (functions : (var * arg list * var * coq_expr * coq_expr) list) = let open Vernacexpr in let fixpoint_exprs = List.map (fun (name, arguments, structural_wf_variable, return, body) -> { #if COQ_VERSION < (9, 0, 0) rec_order = Some (CAst.make @@ CStructRec (CAst.make @@ structural_wf_variable)); #endif fname = CAst.make name; univs = None; binders = arguments; rtype = return; body_def = Some body; notations = [] } ) functions in #if COQ_VERSION >= (9, 0, 0) let rec_orders = List.map (fun (_, _, structural_wf_variable, _, _) -> Some (CAst.make @@ CStructRec (CAst.make @@ structural_wf_variable))) functions in let kind = Decls.(IsDefinition Fixpoint) in ignore (ComFixpoint.do_mutually_recursive ~poly:false ~kind ~program_mode:false (CFixRecOrder rec_orders, fixpoint_exprs)) #elif COQ_VERSION >= (8, 20, 0) ignore (ComFixpoint.do_fixpoint ~poly:false fixpoint_exprs) #elif COQ_VERSION >= (8, 16, 0) ComFixpoint.do_fixpoint ~poly:false fixpoint_exprs #else let default_scope = Locality.Global Locality.ImportDefaultBehavior in ComFixpoint.do_fixpoint ~scope:default_scope ~poly:false fixpoint_exprs #endif (* List Utils. Probably should move to a util file instead *) let list_last l = List.nth l (List.length l - 1) let list_init l = List.rev (List.tl (List.rev l)) let list_drop_every n l = let rec aux i = function | [] -> [] | x::xs -> if i == n then aux 1 xs else x::aux (i+1) xs in aux 1 l let rec take_last l acc = match l with | [x] -> (List.rev acc, x) | x :: l' -> take_last l' (x :: acc) let rec list_insert_nth x l n = match n, l with | 0, _ | _, [] -> x :: l | _, h::t -> h :: list_insert_nth x t (n-1) (* Leo: Where should these util functions live? *) let sameTypeCtr c_ctr = function | TyCtr (ty_ctr', _) -> c_ctr = ty_ctr' | _ -> false let isBaseBranch ty_ctr ty = fold_ty' (fun b ty' -> b && not (sameTypeCtr ty_ctr ty')) true ty (* Look for typeclass instances *) let debug_pattern s p = match p with | PMeta _ -> failwith (s ^ "META") | PRef _ -> failwith (s ^ "REF") | PRel _ -> failwith (s ^ "REL") | PVar _ -> failwith (s ^ "VAR") | PEvar _ -> failwith (s ^ "EVAR") | PLetIn _ -> failwith (s ^ "LET") | PSort _ -> failwith (s ^ "SORT") | PInt _ -> failwith (s ^ "INT") | PFloat _ -> failwith (s ^ "FLOAT") | PApp _ -> failwith (s ^ "APP") | PSoApp _ -> failwith (s ^ "SOAPP") | PLambda _ -> failwith (s ^ "LAMBDA") | PProj _ -> failwith (s ^ "PROJ") | PIf _ -> failwith (s ^ "IF") | PCase _ -> failwith (s ^ "CASE") | PFix _ -> failwith (s ^ "FIX") | PCoFix _ -> failwith (s ^ "COFIX") | PArray _ -> failwith (s ^ "ARRAY") | PProd _ -> failwith (s ^ "PROD") let find_typeclass_bindings typeclass_name ctr = msg_debug (str ("Finding typeclass bindings for:" ^ string_of_qualid ctr) ++ fnl()); let env = Global.env () in let evd = Evd.from_env env in let db = Hints.searchtable_map "typeclass_instances" in let result = ref [] in let prod_check i = String.equal (MutInd.to_string (fst i)) ("QuickChick.DependentClasses." ^ typeclass_name) in let dec_check i = String.equal (MutInd.to_string (fst i)) ("QuickChick.Decidability." ^ typeclass_name) in let type_of_hint h = (* Go from the hint to the type of its constant *) let (_,ec) = Hints.hint_as_term h in let c = EConstr.to_constr evd ec in let cst = Constr.destConst c in let (typ,_constraints) = Environ.constant_type env cst in typ in (* Find the conclusion of a type *) let rec find_concl typ = if Constr.isLambda typ then let (_binder,_binder_type,typ') = Constr.destLambda typ in find_concl typ' else if Constr.isProd typ then let (_binder,_binder_type,typ') = Constr.destProd typ in find_concl typ' else if Constr.isApp typ then typ else failwith "FindConcl" in let handle_producer_hint lambda = if Constr.isLambda lambda then ( msg_debug (str "Entering producer lambda" ++ fnl ()); let (_binder, _binder_type, typ') = Constr.destLambda lambda in if Constr.isApp typ' then ( let (cln, clargs) = Constr.destApp typ' in msg_debug (str "Found a hint for: " ++ Constr.debug_print cln ++ fnl ()); if Constr.isInd cln then ( (* TODO: Search for Mutual inductives properly *) let ((mind,_),_) = Constr.destInd cln in let mind_id = Label.to_id (MutInd.label mind) in let ctr_id = qualid_basename ctr in if Id.equal mind_id ctr_id then ( msg_debug (str "Producer Match Found: " ++ Id.print ctr_id ++ fnl ()); let standard = ref true in (* Calculate mode as list of booleans: *) let res = List.map (fun arg -> if Constr.isMeta arg then false (* Check not equal id name *) else if Constr.isRef arg then false (* Bound by the last lambda means it's output *) else if Constr.isRelN 1 arg then true else if Constr.isRel arg then false else if Constr.isApp arg then begin standard := false; true end else failwith "New FTB/0" ) (Array.to_list clargs) in if !standard then begin List.iter (fun b -> msg_debug (bool b ++ str " ")) res; msg_debug (fnl ()); result := res :: !result end else msg_debug (str "not standard/producer" ++ fnl ()) ) else msg_debug (str "Not equal: " ++ Id.print ctr_id ++ str " " ++ Id.print mind_id ++ fnl ())) else msg_debug (str "Not Ind" ++ fnl ()) ) else msg_debug (str "First arg not lambda" ++ fnl ()) ) in let handle_checker_hint app = if Id.to_string (qualid_basename ctr) = "eq" then () else if isApp app then ( msg_debug (str "Entering checker app" ++ fnl ()); let (cln, clargs) = Constr.destApp app in (* TODO: Search for Mutual inductives properly *) let ((mind,_),_) = Constr.destInd cln in let mind_id = Label.to_id (MutInd.label mind) in let ctr_id = qualid_basename ctr in msg_debug (str "In checker/app for: " ++ Id.print ctr_id ++ str " " ++ Id.print mind_id ++ fnl ()); if Id.equal mind_id ctr_id then ( msg_debug (str "Checker Match Found: " ++ Id.print ctr_id ++ fnl ()); let standard = ref true in (* Calculate mode as list of booleans: *) (* For checking, mode is alsways false *) let res = List.map (fun arg -> if Constr.isMeta arg then false (* Check not equal id name *) else if Constr.isRef arg then false else if Constr.isRel arg then false else if Constr.isApp arg then begin standard := false; true end else failwith "New FTB/0" ) (Array.to_list clargs) in if !standard then begin List.iter (fun b -> msg_debug (bool b ++ str " ")) res; msg_debug (fnl ()); result := res :: !result end else msg_debug (str "not standard/checker" ++ fnl ()) ) else msg_debug (str "not equal/checker/isApp" ++ fnl ()); ) else msg_debug (str "not isApp 0" ++ fnl ()) in let handle_hint_repr b h = let typ = type_of_hint h in let (typ_cl, typ_args) = Constr.destApp (find_concl typ) in msg_debug (str "Conclusion of current hint is: " ++ fnl ()); msg_debug (Constr.debug_print (find_concl typ)); try if b then (* For producer, check the second argument (the first is the type of the lambda) *) handle_producer_hint typ_args.(1) else (* For checker, check the first argument. *) handle_checker_hint typ_args.(0) with _ -> msg_debug (str "exception?" ++ fnl ()) in let handle_hint b hint = msg_debug (str "Processing... (" ++ str typeclass_name ++ str ")" ++ Hints.FullHint.print env evd hint ++ fnl ()); begin match Hints.FullHint.repr hint with | Hints.Res_pf h -> handle_hint_repr b h | Hints.Give_exact h -> handle_hint_repr b h (* TODO: Replicate pattern-based behavior from below in constr form *) | Hints.Extern (Some (PApp (PRef g, args)), _) -> (* begin match Hints.FullHint.pattern hint with | Some (PApp (PRef g, args)) -> *) begin let arg_index = if b then 1 else 0 in (* msg_debug (str ("Hint for :" ^ (string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty g))) ++ fnl ()); msg_debug (str (Printf.sprintf "Arg Length: %d. Arg index: %d\n" (Array.length args) arg_index) ++ fnl ());*) match args.(arg_index) with | PLambda (name, t, PApp (PRef gctr, res_args)) -> let gctr_qualid = Nametab.shortest_qualid_of_global Id.Set.empty gctr in if qualid_eq gctr_qualid ctr then begin msg_debug (str "Found a match!" ++ fnl ()); msg_debug (str ("Conclusion is Application of:" ^ (string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty gctr))) ++ fnl ()); let standard = ref true in let res = List.map (fun p -> match p with | PMeta (Some id) -> if not (Name.equal (Name id) name) then false else failwith "FTB/How is this true" | PRef _ -> false | PRel _ -> true | PApp _ -> standard := false; true | _ -> debug_pattern "FTB/0" p ) (Array.to_list res_args) in if !standard then result := res :: !result else () end else () | PApp (PRef gctr, res_args) -> let gctr_qualid = Nametab.shortest_qualid_of_global Id.Set.empty gctr in if qualid_eq gctr_qualid ctr then begin msg_debug (str "Found a match!" ++ fnl ()); msg_debug (str ("Conclusion is Application of:" ^ (string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty gctr))) ++ fnl ()); let standard = ref true in let res = List.map (fun p -> match p with | PMeta (Some id) -> false | PRef _ -> false | PRel _ -> true | PApp _ -> standard := false; true | _ -> debug_pattern "FTB/00" p ) (Array.to_list res_args) in if !standard then result := res :: !result else () end else () | PLambda (name, t, PCase (_, arr, _, [n, ns, PApp (PRef gctr, res_args)])) -> let gctr_qualid = Nametab.shortest_qualid_of_global Id.Set.empty gctr in if qualid_eq gctr_qualid ctr then begin msg_debug (str "Found a match!" ++ fnl ()); msg_debug (str ("Conclusion is Application of:" ^ (string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty gctr))) ++ fnl ()); let standard = ref true in let res = List.map (fun p -> match p with | PMeta (Some id) -> false (* if not (Name.equal (Name id) name) then false else failwith "FTB/How is this true" *) | PRef _ -> false | PRel _ -> true | PApp _ -> standard := false; true | _ -> debug_pattern "FTB/0" p ) (Array.to_list res_args) in if !standard then result := res :: !result else () end else () | PMeta (Some id) -> () (* failwith (Id.to_string id) *) | PProd _ -> () | _ -> debug_pattern "FTB/1" args.(arg_index) end | Hints.Extern _ -> failwith "FTB/Apply" | Hints.ERes_pf _ -> failwith "FTB/EApply" | Hints.Res_pf_THEN_trivial_fail _ -> failwith "FTB/Imm" | Hints.Unfold_nth _ -> failwith "FTB/Unf" end in Hints.Hint_db.iter (fun go hm hints -> begin match go with | Some (GlobRef.IndRef i) when prod_check i -> List.iter (handle_hint true ) hints | Some (GlobRef.IndRef i) when dec_check i -> if Id.to_string (qualid_basename ctr) = "eq" then result := [[false; false; false]] else List.iter (handle_hint false) hints | _ -> () end ) db; !result QuickChick-2.1.0/plugin/genericLib.mli000066400000000000000000000233651476030541200176070ustar00rootroot00000000000000open Names open Declarations open Constrexpr type coq_expr val interp_open_coq_expr : Environ.env -> Evd.evar_map -> coq_expr -> EConstr.constr val hole : coq_expr val debug_coq_expr : coq_expr -> unit type var val var_of_id : Id.t -> var val id_of_var : var -> Id.t val var_to_string : var -> string val inject_var : string -> var val gVar : var -> coq_expr val gInject : string -> coq_expr val gType0 : coq_expr type ty_param val ty_param_to_string : ty_param -> string val inject_ty_param : string -> ty_param val gTyParam : ty_param -> coq_expr type ty_ctr val ty_ctr_to_string : ty_ctr -> string val gInjectTyCtr : string -> ty_ctr val gTyCtr : ty_ctr -> coq_expr val tyCtrToQualid : ty_ctr -> Libnames.qualid type arg val gArg : ?assumName:coq_expr -> ?assumType:coq_expr -> ?assumImplicit:bool -> ?assumGeneralized:bool -> unit -> arg val arg_to_var : arg -> var val str_lst_to_string : string -> string list -> string type coq_type = | Arrow of coq_type * coq_type | TyCtr of ty_ctr * coq_type list | TyParam of ty_param val coq_type_size : coq_type -> int val coq_type_to_string : coq_type -> string type constructor val constructor_to_string : constructor -> string val gCtr : constructor -> coq_expr val injectCtr : string -> constructor val ty_ctr_to_ctr : ty_ctr -> constructor val ctr_to_ty_ctr : constructor -> ty_ctr module type Ord_ty_ctr_type = sig type t = ty_ctr val compare : t -> t -> int end module Ord_ty_ctr : Ord_ty_ctr_type module type Ord_ctr_type = sig type t = constructor val compare : t -> t -> int end module Ord_ctr : Ord_ctr_type val num_of_ctrs : constructor -> int val belongs_to_inductive : constructor -> bool type ctr_rep = constructor * coq_type val ctr_rep_to_string : ctr_rep -> string (* single dt_rep *) type sdt_rep = ty_ctr * ty_param list * ctr_rep list type dt_rep = sdt_rep list val sdt_rep_to_string : sdt_rep -> string val dt_rep_to_string : dt_rep -> string (* Supertype of coq_type handling potentially dependent stuff - TODO : merge *) type dep_type = | DArrow of dep_type * dep_type (* Unnamed arrows *) | DProd of (var * dep_type) * dep_type (* Binding arrows *) | DTyParam of ty_param (* Type parameters - for simplicity *) | DTyCtr of ty_ctr * dep_type list (* Type Constructor *) | DCtr of constructor * dep_type list (* Type Constructor *) | DTyVar of var (* Use of a previously captured type variable *) | DApp of dep_type * dep_type list (* Type-level function applications *) | DNot of dep_type (* Negation as a toplevel *) | DHole (* For adding holes *) module OrdDepType : sig type t = dep_type val compare : t -> t -> int end val dep_type_to_string : dep_type -> string type dep_ctr = constructor * dep_type val dep_ctr_to_string : dep_ctr -> string type dep_dt = ty_ctr * ty_param list * dep_ctr list * dep_type val dep_dt_to_string : dep_dt -> string val constr_of_type : string -> ty_param list -> dep_type -> Constr.t val gType : ty_param list -> dep_type -> coq_expr val gType' : ty_param list -> dep_type -> coq_expr val get_type : Id.t -> unit val is_inductive : constructor -> bool val is_inductive_dt : dep_type -> bool val nthType : int -> dep_type -> dep_type val dep_type_len : dep_type -> int val dep_result_type : dep_type -> dep_type (* option type helpers *) val option_map : ('a -> 'b) -> 'a option -> 'b option val (>>=) : 'a option -> ('a -> 'b option) -> 'b option val isSome : 'a option -> bool val cat_maybes : 'a option list -> 'a list val foldM : ('b -> 'a -> 'b option) -> 'b option -> 'a list -> 'b option val sequenceM : ('a -> 'b option) -> 'a list -> 'b list option (* legacy function which fails on mutually inductive definitions *) val sdt_rep_from_mib : mutual_inductive_body -> sdt_rep option val qualid_to_mib : Libnames.qualid -> mutual_inductive_body val dt_rep_from_mib : mutual_inductive_body -> dt_rep option val coerce_reference_to_dt_rep : constr_expr -> dt_rep option val parse_dependent_type : Constr.constr -> dep_type option val dep_dt_from_mib : mutual_inductive_body -> dep_dt option val coerce_reference_to_dep_dt : constr_expr -> dep_dt option val fresh_name : string -> var val make_up_name : unit -> var (* Generic Combinators *) val gApp : ?explicit:bool -> coq_expr -> coq_expr list -> coq_expr val gFun : string list -> (var list -> coq_expr) -> coq_expr val gRecFunIn : ?structRec:(var option) -> ?assumType:coq_expr -> string -> string list -> ((var * var list) -> coq_expr) -> (var -> coq_expr) -> coq_expr val gLetIn : string -> coq_expr -> (var -> coq_expr) -> coq_expr (* TODO: HOAS-ify *) val gLetTupleIn : var -> var list -> coq_expr -> coq_expr val gMatch : coq_expr -> ?catchAll:(coq_expr option) -> ?params:(int) -> ((constructor * string list * (var list -> coq_expr)) list) -> coq_expr val gMatchReturn : coq_expr -> ?catchAll:(coq_expr option) -> string -> (var -> coq_expr) -> ((constructor * string list * (var list -> coq_expr)) list) -> coq_expr val gRecord : (string * coq_expr) list -> coq_expr val gAnnot : coq_expr -> coq_expr -> coq_expr val gFunTyped : (string * coq_expr) list -> (var list -> coq_expr) -> coq_expr val gFunWithArgs : arg list -> ((var list) -> coq_expr) -> coq_expr val gRecFunInWithArgs : ?structRec:(var option) -> ?assumType:coq_expr -> string -> arg list -> ((var * var list) -> coq_expr) -> (var -> coq_expr) -> coq_expr val gProdWithArgs : arg list -> ((var list) -> coq_expr) -> coq_expr (* Specialized Pattern Matching *) type matcher_pat = | MatchCtr of constructor * matcher_pat list | MatchU of var | MatchParameter of ty_param (* Should become hole in pattern, so no binding *) val matcher_pat_to_string : matcher_pat -> string val construct_match : coq_expr -> ?catch_all:(coq_expr option) -> (matcher_pat * coq_expr) list -> coq_expr val construct_match_with_return : coq_expr -> ?catch_all:(coq_expr option) -> string -> (var -> coq_expr) -> (matcher_pat * coq_expr) list -> coq_expr (* Generic List Manipulations *) val list_nil : coq_expr val lst_append : coq_expr -> coq_expr -> coq_expr val lst_appends : coq_expr list -> coq_expr val gCons : coq_expr -> coq_expr -> coq_expr val gList : coq_expr list -> coq_expr (* Generic String Manipulations *) val gStr : string -> coq_expr val emptyString : coq_expr val str_append : coq_expr -> coq_expr -> coq_expr val str_appends : coq_expr list -> coq_expr val smart_paren : coq_expr -> coq_expr (* Pair *) val gPair : coq_expr * coq_expr -> coq_expr val gProd : coq_expr * coq_expr -> coq_expr val listToPairAux : (('a *'a) -> 'a) -> ('a list) -> 'a val gTuple : coq_expr list -> coq_expr val gTupleType : coq_expr list -> coq_expr val dtTupleType : dep_type list -> dep_type (* Int *) val gInt : int -> coq_expr val gSucc : coq_expr -> coq_expr val maximum : coq_expr list -> coq_expr val glt : coq_expr -> coq_expr -> coq_expr val gle : coq_expr -> coq_expr -> coq_expr (* Eq *) val gEq : coq_expr -> coq_expr -> coq_expr (* Maybe *) val gOption : coq_expr -> coq_expr val gNone : coq_expr -> coq_expr val gSome : coq_expr -> coq_expr -> coq_expr val gNone' : coq_expr val gSome' : coq_expr -> coq_expr (* boolean *) val gNot : coq_expr -> coq_expr val g_true : coq_expr val g_false : coq_expr val decToBool : coq_expr -> coq_expr val decOptToBool : coq_expr -> coq_expr val gBool : coq_expr val gIf : coq_expr -> coq_expr -> coq_expr -> coq_expr (* list *) (* unit *) val gUnit : coq_expr val gTT : coq_expr (* dec *) val g_dec : coq_expr -> coq_expr val g_decOpt : coq_expr -> coq_expr -> coq_expr val g_dec_decOpt : coq_expr (* checker *) val g_checker : coq_expr -> coq_expr (* (\* Gen combinators *\) *) val g_forAll : coq_expr -> coq_expr -> coq_expr val g_arbitrary : coq_expr val g_quickCheck : coq_expr -> coq_expr val g_show : coq_expr -> coq_expr (* val gGen : coq_expr -> coq_expr *) (* val returnGen : coq_expr -> coq_expr *) (* val bindGen : coq_expr -> string -> (var -> coq_expr) -> coq_expr *) (* val bindGenOpt : coq_expr -> string -> (var -> coq_expr) -> coq_expr *) (* val oneof : coq_expr list -> coq_expr *) (* val frequency : (coq_expr * coq_expr) list -> coq_expr *) (* val backtracking : (coq_expr * coq_expr) list -> coq_expr *) (* val uniform_backtracking : coq_expr list -> coq_expr *) (* Recursion combinators / fold *) val fold_ty : ('a -> coq_type -> 'a) -> (ty_ctr * coq_type list -> 'a) -> (ty_param -> 'a) -> coq_type -> 'a val fold_ty' : ('a -> coq_type -> 'a) -> 'a -> coq_type -> 'a val dep_fold_ty : ('a -> dep_type -> 'a) -> ('a -> var -> dep_type -> 'a) -> (ty_ctr * dep_type list -> 'a) -> (constructor * dep_type list -> 'a) -> (ty_param -> 'a) -> (var -> 'a) -> dep_type -> 'a (* Generate Type Names *) val generate_names_from_type : string -> coq_type -> string list val fold_ty_vars : (var list -> var -> coq_type -> 'a) -> ('a -> 'a -> 'a) -> 'a -> coq_type -> var list -> 'a (* val defineConstant : string -> coq_expr -> var val defineTypedConstant : string -> coq_expr -> coq_expr -> var *) val declare_class_instance : ?global:bool -> ?priority:int -> arg list -> string -> (var list -> coq_expr) -> (var list -> coq_expr) -> unit val define_new_inductive : dep_dt -> unit val define_new_fixpoint : (var * arg list * var * coq_expr * coq_expr) list -> unit (* List utils *) val list_last : 'a list -> 'a val list_init : 'a list -> 'a list val list_drop_every : int -> 'a list -> 'a list val take_last : 'a list -> 'a list -> ('a list * 'a) val list_insert_nth : 'a -> 'a list -> int -> 'a list val sameTypeCtr : ty_ctr -> coq_type -> bool val isBaseBranch : ty_ctr -> coq_type -> bool val find_typeclass_bindings : string -> ty_ctr -> (bool list) list QuickChick-2.1.0/plugin/mergeTypes.ml.cppo000066400000000000000000000760721476030541200204620ustar00rootroot00000000000000open Constrexpr open Error open GenericLib open Pp open Libnames open UnifyQC type rec_arg = dep_type list * dep_type (*arguments to a recursive call. Separate term is the shared parameter*) type ctr_data = (var * dep_type) list (*forall variables*) * rec_arg list (*recursive calls*) (* * (ty_ctr * dep_type list) list (*nonrecursive calls*) *) * dep_type list (*nonrecursive calls*) * rec_arg (*output parameters*) (* Separate out the shared parameter from a list of parameters *) let rec separate_shared (terms : 'a list) (param_pos : int) : 'a list * 'a = match terms with | term :: terms -> if param_pos = 0 then (terms, term) else let (ts, t) = separate_shared terms (param_pos - 1) in (term :: ts, t) | [] -> failwith ("shouldn't get here: param_pos invalid in separate_shared. Param_pos is: " ^ (string_of_int param_pos)) (* The reverse of separate_shared. param_pos should be the position where shared will end up in the resulting output list. *) let rec replace_shared ((terms, shared) : 'a list * 'a) (param_pos : int) : 'a list = if param_pos = 0 then shared :: terms else match terms with (term :: terms) -> term :: replace_shared (terms, shared) (param_pos - 1) let convertConstructor (me : ty_ctr) (ctr : dep_type) (param_pos : int) : ctr_data = let rec convertConstructorAux (ctr : dep_type) (me : ty_ctr) vs rs os : ctr_data = match ctr with | DProd ((v, dt1), dt2) -> convertConstructorAux dt2 me ((v , dt1) :: vs) rs os | DTyCtr (tc, dts) -> (vs , rs , os , separate_shared dts param_pos) (* The output of the constructor *) | DArrow (DTyCtr (c , dts), dt2) -> if c = me then (* Parse an argument to constructor, which could be recursive *) convertConstructorAux dt2 me vs (separate_shared dts param_pos :: rs) os (* recursive *) else convertConstructorAux dt2 me vs rs (DTyCtr (c , dts) :: os) (* nonrecursive *) | DArrow (t, dt2) -> convertConstructorAux dt2 me vs rs (t :: os) (* Parse an argument of any form, definitely nonrecursive *) | _ -> failwith ("in convertConstructor, constructor contains unsupported thing: " ^ dep_type_to_string ctr) (* | DNot dt -> | DTyParam tp -> | DCtr (c, dts) -> | DTyVar v -> | DApp (dt, dts) -> | DHole -> *) in convertConstructorAux ctr me [] [] [] let convertBack (me : ty_ctr) ((vs , rs , os , outs) : ctr_data) (param_pos : int) : dep_type = let rec convertVars vs ty : dep_type = match vs with | [] -> ty | (v :: vs) -> convertVars vs (DProd (v , ty)) in let rec convertRecCalls rs ty : dep_type = match rs with | [] -> ty | (r :: rs) -> convertRecCalls rs (DArrow ((DTyCtr (me , replace_shared r param_pos)), ty)) in let rec convertOtherCalls os ty : dep_type = match os with | [] -> ty | (t :: os) -> convertOtherCalls os (DArrow (t, ty)) in convertVars vs (convertOtherCalls os (convertRecCalls rs (DTyCtr (me, replace_shared outs param_pos)))) (* Variable unification *) module IdMap = Map.Make(UnknownOrd) type sub = dep_type IdMap.t let rec sub_term (s : sub) (t : dep_type) : dep_type = match t with | DTyCtr (tc, dts) -> DTyCtr (tc, List.map (sub_term s) dts) | DArrow (dt1, dt2) -> DArrow (sub_term s dt1, sub_term s dt2) | DProd ((v, dt1), dt2) -> DProd ((v , sub_term s dt1), sub_term s dt2) | DCtr (c, dts) -> DCtr (c, List.map (sub_term s) dts) | DTyVar v -> (match IdMap.find_opt v s with | None -> DTyVar v | Some t -> t) | DTyParam v -> DTyParam v | DApp (dt, dts) -> DApp (sub_term s dt, List.map (sub_term s) dts) | DNot dt -> DNot (sub_term s dt) | DHole -> DHole let compose_sub (sub1 : sub) (sub2 : sub) : sub = IdMap.union (fun _ _ _ -> failwith "shouldn't get here") (IdMap.map (sub_term sub1) sub2) sub1 let rec occurs (v : var) (t : dep_type) : bool = match t with | DTyCtr (tc, dts) -> List.exists (occurs v) dts | DArrow (dt1, dt2) -> occurs v dt1 || occurs v dt2 | DProd ((_, dt1), dt2) -> occurs v dt1 || occurs v dt2 | DTyParam tp -> false | DCtr (c, dts) -> List.exists (occurs v) dts | DTyVar v' -> v = v' | DApp (dt, dts) -> occurs v dt || (List.exists (occurs v) dts) | DNot dt -> occurs v dt | DHole -> false (*merge_disjoint from stackoverflow:*) let merge_disjoint m1 m2 = IdMap.merge (fun k x0 y0 -> match x0, y0 with None, None -> None | None, Some v | Some v, None -> Some v | _, _ -> invalid_arg "merge_disjoint: maps are not disjoint") m1 m2 let rec unify (t1 : dep_type) (t2 : dep_type) : sub option = match t1, t2 with | DTyVar v, _ -> if t2 = DTyVar v then Some IdMap.empty else if occurs v t2 then None else Some (IdMap.singleton v t2) | t, DTyVar v -> unify (DTyVar v) t | DTyCtr (tc, dts), DTyCtr (tc', dts') -> if tc = tc' then unifys dts dts' else None | DArrow (dt1, dt2), DArrow (dt1', dt2') -> Option.bind (unify dt1 dt1') (fun sub1 -> Option.bind (unify (sub_term sub1 dt2) (sub_term sub1 dt2')) (fun sub2 -> Some (compose_sub sub1 sub2))) | DProd ((v, dt1), dt2), DProd ((v', dt1'), dt2') -> Option.bind (unify dt1 dt1') (fun sub1 -> Option.bind (unify (sub_term sub1 dt2) (sub_term sub1 dt2')) (fun sub2 -> Some (compose_sub sub1 sub2))) | DTyParam tp, DTyParam tp' -> Some IdMap.empty | DCtr (c, dts), DCtr (c', dts') -> if not (constructor_to_string c = constructor_to_string c') then None else unifys dts dts' | DApp (dt, dts), DApp (dt', dts') -> Option.bind (unify dt dt') (fun sub1 -> Option.bind (unifys (List.map (sub_term sub1) dts) (List.map (sub_term sub1) dts')) (fun sub2 -> Some (compose_sub sub1 sub2))) | DNot dt, DNot dt' -> unify dt dt' | DHole, DHole -> Some IdMap.empty | _, _ -> None and unifys (t1s : dep_type list) (t2s : dep_type list) : sub option = match t1s, t2s with | [], [] -> Some IdMap.empty | (t1 :: t1s), (t2 :: t2s) -> Option.bind (unify t1 t2) (fun s -> Option.bind (unifys (List.map (sub_term s) t1s) (List.map (sub_term s) t2s)) (fun s2 -> Some (merge_disjoint s s2))) | _, _ -> failwith "error, shouldn't get here!" (* This function appends the string to the end of all parameter names in the term *) let rec postfix_all_params (postfix : string) (t : dep_type) : dep_type = let recurse = postfix_all_params postfix in match t with | DTyCtr (tc, dts) -> DTyCtr (tc, List.map recurse dts) | DArrow (dt1, dt2) -> DArrow (recurse dt1, recurse dt2) | DProd ((v, dt1), dt2) -> DProd ((v , recurse dt1), recurse dt2) | DCtr (c, dts) -> DCtr (c, List.map recurse dts) | DTyParam v -> DTyParam (inject_ty_param ((ty_param_to_string v) ^ postfix)) | DTyVar v -> DTyVar v | DApp (dt, dts) -> DApp (recurse dt, List.map recurse dts) | DNot dt -> DNot (recurse dt) | DHole -> DHole (* Param unification *) module UnknownOrd2 = struct type t = ty_param let compare x y = compare (ty_param_to_string x) (ty_param_to_string y) end module IdMap_param = Map.Make(UnknownOrd2) type sub_param = dep_type IdMap_param.t let rec sub_term_param (s : sub_param) (t : dep_type) : dep_type = match t with | DTyCtr (tc, dts) -> DTyCtr (tc, List.map (sub_term_param s) dts) | DArrow (dt1, dt2) -> DArrow (sub_term_param s dt1, sub_term_param s dt2) | DProd ((v, dt1), dt2) -> DProd ((v , sub_term_param s dt1), sub_term_param s dt2) | DCtr (c, dts) -> DCtr (c, List.map (sub_term_param s) dts) | DTyParam v -> (match IdMap_param.find_opt v s with | None -> DTyParam v | Some t -> t) | DTyVar v -> DTyVar v | DApp (dt, dts) -> DApp (sub_term_param s dt, List.map (sub_term_param s) dts) | DNot dt -> DNot (sub_term_param s dt) | DHole -> DHole let compose_sub_param (sub1 : sub_param) (sub2 : sub_param) : sub_param = IdMap_param.union (fun _ _ _ -> failwith "shouldn't get here") (IdMap_param.map (sub_term_param sub1) sub2) sub1 let rec occurs_param (v : ty_param) (t : dep_type) : bool = match t with | DTyCtr (tc, dts) -> List.exists (occurs_param v) dts | DArrow (dt1, dt2) -> occurs_param v dt1 || occurs_param v dt2 | DProd ((_, dt1), dt2) -> occurs_param v dt1 || occurs_param v dt2 | DTyParam tp -> tp == v | DCtr (c, dts) -> List.exists (occurs_param v) dts | DTyVar v -> false | DApp (dt, dts) -> occurs_param v dt || (List.exists (occurs_param v) dts) | DNot dt -> occurs_param v dt | DHole -> false (*merge_disjoint from stackoverflow:*) let merge_disjoint_param m1 m2 = IdMap_param.merge (fun k x0 y0 -> match x0, y0 with None, None -> None | None, Some v | Some v, None -> Some v | _, _ -> invalid_arg "merge_disjoint_param: maps are not disjoint") m1 m2 let rec unify_param (t1 : dep_type) (t2 : dep_type) : sub_param option = match t1, t2 with | DTyParam v, _ -> if t2 = DTyParam v then Some IdMap_param.empty else if occurs_param v t2 then None else Some (IdMap_param.singleton v t2) | t, DTyParam v -> unify_param (DTyParam v) t | DTyCtr (tc, dts), DTyCtr (tc', dts') -> if tc = tc' then unifys_param dts dts' else None | DArrow (dt1, dt2), DArrow (dt1', dt2') -> Option.bind (unify_param dt1 dt1') (fun sub1 -> Option.bind (unify_param (sub_term_param sub1 dt2) (sub_term_param sub1 dt2')) (fun sub2 -> Some (compose_sub_param sub1 sub2))) | DProd ((v, dt1), dt2), DProd ((v', dt1'), dt2') -> Option.bind (unify_param dt1 dt1') (fun sub1 -> Option.bind (unify_param (sub_term_param sub1 dt2) (sub_term_param sub1 dt2')) (fun sub2 -> Some (compose_sub_param sub1 sub2))) | DTyVar tp, DTyVar tp' -> Some IdMap_param.empty | DCtr (c, dts), DCtr (c', dts') -> if not (constructor_to_string c = constructor_to_string c') then None else unifys_param dts dts' | DApp (dt, dts), DApp (dt', dts') -> Option.bind (unify_param dt dt') (fun sub1 -> Option.bind (unifys_param (List.map (sub_term_param sub1) dts) (List.map (sub_term_param sub1) dts')) (fun sub2 -> Some (compose_sub_param sub1 sub2))) | DNot dt, DNot dt' -> unify_param dt dt' | DHole, DHole -> Some IdMap_param.empty | _, _ -> None and unifys_param (t1s : dep_type list) (t2s : dep_type list) : sub_param option = match t1s, t2s with | [], [] -> Some IdMap_param.empty | (t1 :: t1s), (t2 :: t2s) -> Option.bind (unify_param t1 t2) (fun s -> Option.bind (unifys_param (List.map (sub_term_param s) t1s) (List.map (sub_term_param s) t2s)) (fun s2 -> Some (merge_disjoint_param s s2))) | _, _ -> failwith "error, shouldn't get here!" (* TODO: move the type to be used in def of ctr_data *) (* If a is in l, returns l with a removed *) let rec remove (l : rec_arg list) (shared_param_match : dep_type) : (rec_arg * rec_arg list) option = match l with | [] -> None | ((params, shared_param) :: xs) -> if shared_param = shared_param_match then Some ((params, shared_param) , xs) else Option.bind (remove xs shared_param_match) (fun (arg, l) -> Some (arg, ((params, shared_param) :: l))) (* Inputs two sets of recursive arguments, and outputs three lists of arguments: combined arguments, arguments from 1 which were unmatched, and arguments from 2 which were unmatched respectively.*) let merge_recs (rs1 : rec_arg list) (rs2 : rec_arg list) : (rec_arg list * rec_arg list * rec_arg list) = List.fold_left (fun (both, just1, rs2) (params1, shared_1) -> match remove rs2 shared_1 with | None -> (both, (params1, shared_1) :: just1, rs2) | Some ((params2, _), rs2') -> ((params1 @ params2, shared_1) :: both, just1, rs2') ) ([],[], rs2) rs1 (*returns a renaming for variables in vs2 which maps to names distinct from names in vs1*) let generate_distinct_names (vs1 : (var * dep_type) list) (vs2 : (var * dep_type) list) : var IdMap.t = let names = List.map (fun (v, _) -> var_to_string v) vs1 in let rec name_starting_with (s : string) : string = if List.mem s names then name_starting_with (s ^ "'") else s in (* List.map (fun (v, ty) -> (inject_var (name_starting_with (var_to_string v)), ty)) vs2 *) let pairs = List.map (fun (v, ty) -> (v, inject_var (name_starting_with (var_to_string v)))) vs2 in IdMap.of_seq (List.to_seq pairs) let merge_ctrs (name1 : ty_ctr) (name2 : ty_ctr) (vs1, rs1, os1, (as1, t1) : ctr_data) (vs2, rs2, os2, (as2, t2) : ctr_data) (param_pos1 : int) (param_pos2 : int) (params1 : dep_type list) (params2 : dep_type list) : ctr_data option = (* Get a renaming for variables in vs2. vs1 and vs2 should already be unique within themselves, but we can't have names clash between them. *) let var_renaming = generate_distinct_names vs1 vs2 in let ren = fun v -> IdMap.find v var_renaming in let var_sub = IdMap.map (fun t -> DTyVar t) var_renaming in (* apply variable renaming to everything from second relation *) let vs2 = List.map (fun (v, t) -> (ren v, t)) vs2 in let rs2 = List.map (fun (params, shared_param) -> (List.map (sub_term var_sub) params, sub_term var_sub shared_param)) rs2 in let os2 = List.map (sub_term var_sub) os2 in let as2 = List.map (sub_term var_sub) as2 in let t2 = sub_term var_sub t2 in (* split output parameters into shared value and others *) (* Check if shared parameter of both constructors unify *) Option.bind (unify t1 t2) (fun sub -> (* In the case where they do unify, apply the resulting substitution to everything: *) let s = sub_term sub in let rs1' = List.map (fun (params, sh_param) -> (List.map s params, s sh_param)) rs1 in let rs2' = List.map (fun (params, sh_param) -> (List.map s params, s sh_param)) rs2 in let os1' = List.map s os1 in let os2' = List.map s os2 in (* Build the pieces of the resulting constructor by combining pieces from the two input constructors: *) let t = s t1 in (*this should be equal to s t2*) let as_ = List.append (List.map s as1) (List.map s as2) in (* Any recursive arguments which match up should be combined, and other should be left as is: *) let (rs, more_os1, more_os2) = merge_recs rs1' rs2' in (* Collect the other non-recursive arguments: *) let os = os1' @ os2' @ (List.map (fun args -> DTyCtr (name1, params1 @ (replace_shared args param_pos1))) more_os1) @ (List.map (fun args -> DTyCtr (name2, params2 @ (replace_shared args param_pos2))) more_os2) in (* Collect new list of forall bound variables, which is the union of the lists of the inputs except with variables which got substituted during unification removed *) let was_subbed = fun v -> not (IdMap.mem v sub) in let vs = List.filter (fun (v, _) -> was_subbed v) vs1 @ List.filter (fun (v, _) -> was_subbed v) vs2 in Some (vs, rs, os, (as_, t)) ) (*Note: I need to deal with if two constructors happen to have a forall bound variable of the same name.*) let rec convert_type (ty : dep_type) : dep_type list = match ty with | DArrow (a, b) -> a :: convert_type b | out -> [] let rec convert_type_back (params : dep_type list) : dep_type = match params with | [] -> DTyCtr (gInjectTyCtr "Prop", []) | param :: params -> DArrow (param, convert_type_back params) (* an inductive relation, but with the parameters free *) type relation' = ty_ctr (* The name of the relation *) * dep_ctr list (* A list of constructors. Each constructor is a pair (name, type) *) * dep_type (* The type of the relation *) let map_over_relation' ((ty_ctr, ctrs, typ) : relation') (f : dep_type -> dep_type) : relation' = ( ty_ctr , List.map (fun (n, t) -> (n, f t)) ctrs, f typ ) let range (n : int) : int list = let rec range_aux (n : int) (so_far : int list) : int list = if n = 0 then so_far else range_aux (n - 1) (n :: so_far) in range_aux n [] (* inputs constructors from one type, and two parameters which tell it how to position the parameters in the output type: other_type_num_params is how many parameters the other type to be merged with has, and left_or_right is false if this type's params go on the left, or true if they go on the right. Outputs (unchanged constructors, irrelevant constructors adjusted for output type)*) let rec irrelevant_constructor_pass (name_postfix : string) (ctrs : (GenericLib.constructor * ctr_data) list) (other_type_params : dep_type list) (left_or_right : bool) : ((GenericLib.constructor * ctr_data) list * (GenericLib.constructor * ctr_data) list) = let ctr_irrelevant_try ((vs, rs, os, (params_out, shared_out)) : ctr_data) : ctr_data option = if List.length rs = 1 then let (r_params, r_shared) = List.nth rs 0 in if r_shared = shared_out then let new_vars = List.map (fun s -> inject_var ("x_generated_" ^ string_of_int s)) (range (List.length other_type_params)) in let new_vars_terms = List.map (fun v -> DTyVar v) new_vars in let new_r_params = if left_or_right then new_vars_terms @ r_params else r_params @ new_vars_terms in let new_params_out = if left_or_right then new_vars_terms @ params_out else params_out @ new_vars_terms in Some (vs @ (List.combine new_vars other_type_params), [ new_r_params, r_shared ], os, (new_params_out, shared_out)) else None else None in match ctrs with | [] -> ([], []) | ((name, ctr) :: rest) -> let (normal, irrelevant) = irrelevant_constructor_pass name_postfix rest other_type_params left_or_right in match ctr_irrelevant_try ctr with | None -> ((name, ctr) :: normal, irrelevant) | Some out_ctr -> (normal, (injectCtr ((constructor_to_string name) ^ name_postfix), out_ctr) :: irrelevant) (* Merges the two relations *) let merge_relations ((tyctr1, ctrs1, ty1) : relation') (param_pos1 : int) ((tyctr2, ctrs2, ty2) : relation') (param_pos2 : int) tyctr (params1 : ty_param list) (params2 : ty_param list) : relation' * sub_param = (* Separate out the shared parameter to be merged *) let converted_ty1 = separate_shared (convert_type ty1) param_pos1 in let converted_ty2 = separate_shared (convert_type ty2) param_pos2 in let ty = (convert_type_back ((fst converted_ty1) @ (fst converted_ty2) @ [ snd converted_ty1 ])) in (* Unify the shared types *) let param_sub = match unify_param (snd converted_ty1) (snd converted_ty2) with | None -> failwith "Shared parameters don't unify" | Some sub -> sub in msg_debug (str "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO"); IdMap_param.iter (fun param t -> msg_debug (str ("in param_sub, params " ^ (ty_param_to_string param) ^ " subbed for " ^ (dep_type_to_string t)))) param_sub; (* Apply the parameter substitution to everything *) let s = sub_term_param param_sub in let converted_ty1 = (List.map s (fst converted_ty1), s (snd converted_ty1)) in let converted_ty2 = (List.map s (fst converted_ty2), s (snd converted_ty2)) in let ctrs1 = List.map (fun (n, t) -> (n, s t)) ctrs1 in let ctrs2 = List.map (fun (n, t) -> (n, s t)) ctrs2 in let ty = s ty in let params1 = List.map (fun p -> s (DTyParam p)) params1 in let params2 = List.map (fun p -> s (DTyParam p)) params2 in (* First identify the constructors which don't change the parameter, for the irrelevant constructor pass *) let (ctrs1_regular, ctrs1_irrelevant) = irrelevant_constructor_pass ("'1" ^ ty_ctr_to_string tyctr1 ^ ty_ctr_to_string tyctr2) (List.map (fun (name, ctr) -> (name, convertConstructor tyctr1 ctr param_pos1)) ctrs1) (fst converted_ty2) false in let (ctrs2_regular, ctrs2_irrelevant) = irrelevant_constructor_pass ("'2" ^ ty_ctr_to_string tyctr2 ^ ty_ctr_to_string tyctr2) (List.map (fun (name, ctr) -> (name, convertConstructor tyctr2 ctr param_pos2)) ctrs2) (fst converted_ty1) true in let param_pos = (List.length (convert_type ty) - 1) in (* Merge each pair of remaining constructors *) let ctrs_regular = List.fold_left (fun acc (name1, ctr1) -> (List.fold_left (fun acc (name2, ctr2) -> match merge_ctrs tyctr1 tyctr2 ctr1 ctr2 param_pos1 param_pos2 params1 params2 with | Some ctr -> let new_ctr = convertBack tyctr ctr param_pos in (*TODO: think here later*) let new_name = (injectCtr (constructor_to_string name1 ^ constructor_to_string name2)) in (new_name, new_ctr) :: acc | None -> acc ) acc ctrs2_regular)) [] ctrs1_regular in let ctrs = (List.map (fun (name, ctr) -> (name, convertBack tyctr ctr param_pos)) ctrs1_irrelevant) @ (List.map (fun (name, ctr) -> (name, convertBack tyctr ctr param_pos)) ctrs2_irrelevant) @ ctrs_regular in ((tyctr, ctrs, ty) , param_sub) (* This represents an inductive relation in coq, e.g. "Inductive IsSorted (t : Type) : list t -> Prop := ...". This tuple is the representation returned by leo's wrapper around the coq internals, in genericLib. *) type relation = ty_ctr (* The name of the relation (e.g. IsSorted) *) * ty_param list (* The list of type parameters (e.g. "t" in IsSorted) *) * dep_ctr list (* A list of constructors. Each constructor is a pair (name, type) *) * dep_type (* The type of the overall relation (e.g. "list t -> Prop") *) (* let print_relation ((ty_ctr, ) : relation) = msg_debug (str "printing a relation -------------------------------------------" ++ fnl ()) ; List.iter (fun param -> msg_debug (str (ty_param_to_string param) ++ fnl ())) ty_params; msg_debug (str "constr_of_type: " ++ str (dep_type_to_string typ) ++ fnl ()); (* msg_debug (str "me_arity ty_ctr: " ++ str (string_of_qualid ty_ctr) ++ fnl ()); *) List.iter (fun (c, t) -> msg_debug (str "ctr: " ++ str (dep_ctr_to_string (c,t)) ++ fnl ())) ctrs; () *) let extract_relation ind : relation * int = match ind with #if COQ_VERSION >= (8, 20, 0) | { CAst.v = CLambdaN ([CLocalAssum ([{ CAst.v = Names.Name id1; CAst.loc = _loc2 }], _, _kind, _type)], body1); _ } -> #else | { CAst.v = CLambdaN ([CLocalAssum ([{ CAst.v = Names.Name id1; CAst.loc = _loc2 }], _kind, _type)], body1); _ } -> #endif (* Extract (x1,x2,...) if any, P and arguments *) let (p1, args1) = match body1 with | { CAst.v = CApp (p, args); _ } -> (p, args) | _ -> qcfail "Merge/Not App" in let rec find f lst = (*from stackoverflow*) match lst with | [] -> raise (failwith "Parameter bound parameter not in argument list") | h :: t -> if f h then 0 else 1 + find f t in (* Find position of id1 in args1 to get parameter position *) let param_pos = find (function | ({CAst.v = CRef (id,_) ; _} , _) -> qualid_basename id = id1) args1 in match coerce_reference_to_dep_dt p1 with | Some dt -> msg_debug (str (dep_dt_to_string dt) ++ fnl()); (* let num_named_params = match dt with (_ , params , _ , _) -> List.length params in *) dt , param_pos (* - num_named_params *) | None -> failwith "Not supported type" let extract_tyctr ind : ty_ctr = match ind with | { CAst.v = CRef (r,_) ; _ } -> gInjectTyCtr (string_of_qualid r) (* The following six functions provide an extra step that separates type parameters from a relation to make the relation (and the parameters) easier to work with. In case I come back and am confused by this code later, a type parameter is e.g. "t" in Inductive list (t : Type) : Type := ... *) (* let rec removeOuterForalls (ty : dep_type) (numToRemove : int) : dep_type = if numToRemove = 0 then ty else match ty with | DProd ((v, dt1), dt2) -> removeOuterForalls dt2 (numToRemove - 1) | _ -> failwith "if this is printed its a bug 1" *) let rec removeFirstArgsOfVar (var : ty_ctr) (num : int) (term : dep_type) = let rec drop n l = if n = 0 then l else (drop (n - 1) (List.tl l)) in let recurse = removeFirstArgsOfVar var num in match term with | DArrow (d1, d2) -> DArrow (recurse d1, recurse d2) | DProd ((x,d1), d2) -> DProd ((x, recurse d1), recurse d2) | DTyCtr (ty_ctr, ds) -> if ty_ctr = var then DTyCtr (ty_ctr, drop num ds) else DTyCtr (ty_ctr, ds) | DCtr (ctr, ds) -> DCtr (ctr, List.map recurse ds) | DTyParam tp -> DTyParam tp | DTyVar tv -> DTyVar tv | DApp (d, ds) -> DApp (recurse d, List.map recurse ds) | DNot d -> DNot (recurse d) | DHole -> DHole (* Inputs a dependent relation as outputted by genericLib, and removes the type parameters from all parts of the relation, so that they can be worked with as merely free variables. Specifically, this 1) removes foralls from the front of ty 2) removes foralls from the front of each constructor in ctrs 3) removes the parameter arguments in each recursive reference to the relation in the constructors *) let removeTypeParameters ((ty_ctr, params, ctrs, ty) : relation) : relation' * ty_param list = let num_params = List.length params in ((ty_ctr , List.map (fun (name, ty) -> (* (name, removeFirstArgsOfVar ty_ctr num_params (removeOuterForalls ty num_params))) *) (* (name, removeOuterForalls ty num_params)) *) (* (name, ty)) *) (name, removeFirstArgsOfVar ty_ctr num_params ty)) ctrs (* , removeOuterForalls ty num_params) *) , ty) , params) (* let rec replaceOuterForalls (ty : dep_type) (names : ty_param list) = match names with | [] -> ty | name :: names -> DProd (((inject_var (ty_param_to_string name)) ,(DTyCtr (gInjectTyCtr "Type", []))), replaceOuterForalls ty names) *) (* DTyCtr (injectCtr "Prop", []) *) let rec replaceFirstArgsOfVar (var : ty_ctr) (names : ty_param list) (term : dep_type) = let recurse = replaceFirstArgsOfVar var names in let names_as_vars = List.map (fun name -> DTyVar (inject_var (ty_param_to_string name))) names in match term with | DArrow (d1, d2) -> DArrow (recurse d1, recurse d2) | DProd ((x,d1), d2) -> DProd ((x, recurse d1), recurse d2) | DTyCtr (ty_ctr, ds) -> if ty_ctr = var then DTyCtr (ty_ctr, names_as_vars @ ds) else DTyCtr (ty_ctr, ds) | DCtr (ctr, ds) -> DCtr (ctr, List.map recurse ds) | DTyParam tp -> DTyParam tp | DTyVar tv -> DTyVar tv | DApp (d, ds) -> DApp (recurse d, List.map recurse ds) | DNot d -> DNot (recurse d) | DHole -> DHole (* This function does the reverse of removeTypeParameters. It adds the foralls back onto the constructors and the type, as well as adding the parameters back as arguments to each recursive reference. *) let insertTypeParameters ((ty_ctr, ctrs, ty) : relation') (params : ty_param list) : relation = (ty_ctr , params (* , [] *) , List.map (fun (name, ty) -> (* (name, replaceOuterForalls (replaceFirstArgsOfVar ty_ctr params ty) params)) *) (name, replaceFirstArgsOfVar ty_ctr params ty)) ctrs (* , replaceOuterForalls ty params) *) , ty) (* , ty) *) (* let rec applyVarToTerms (var : ty_ctr) (terms : dep_type list) (term : dep_type) = let recurse = applyVarToTerms var terms in match term with | DArrow (d1, d2) -> DArrow (recurse d1, recurse d2) | DProd ((x,d1), d2) -> DProd ((x, recurse d1), recurse d2) | DTyCtr (ty_ctr, ds) -> if ty_ctr = var then DTyCtr (ty_ctr, terms @ ds) else DTyCtr (ty_ctr, ds) | DCtr (ctr, ds) -> DCtr (ctr, List.map recurse ds) | DTyParam tp -> DTyParam tp | DTyVar tv -> DTyVar tv | DApp (d, ds) -> DApp (recurse d, List.map recurse ds) | DNot d -> DNot (recurse d) | DHole -> DHole let applyFunToRelation ((ty_ctr, params, ctrs, ty) : relation) (f : dep_type -> dep_type) : relation = (ty_ctr , params , List.map (fun (name, ty) -> (name, f ty)) ctrs , f ty) let name_of_rel ((name, _, _, _) : relation) : ty_ctr = name *) let merge ind1 ind2 ind = let rel1, param_pos1 = extract_relation ind1 in msg_debug (str "------------ First relation inputted: --------------------"); msg_debug (str (dep_dt_to_string rel1)); msg_debug (str "--------------------------------"); let rel2, param_pos2 = extract_relation ind2 in let rel1', params1 = removeTypeParameters rel1 in let rel2', params2 = removeTypeParameters rel2 in (* Do renanmings of parameters to avoid name collisions *) let postfix1 = "_generated1_" in let postfix2 = "_generated2_" in let params1 = List.map (fun s -> inject_ty_param ((ty_param_to_string s) ^ postfix1)) params1 in let params2 = List.map (fun s -> inject_ty_param ((ty_param_to_string s) ^ postfix2)) params2 in let rel1' = map_over_relation' rel1' (postfix_all_params postfix1) in let rel2' = map_over_relation' rel2' (postfix_all_params postfix2) in (* Perform the merge *) let rel, param_sub = merge_relations rel1' param_pos1 rel2' param_pos2 (extract_tyctr ind) params1 params2 in (* Get rid of substituted parameters *) let params = List.filter (fun param -> not (IdMap_param.mem param param_sub)) (params1 @ params2) in (* Re-insert the parameters *) (* let params1subbed = List.map (fun param -> sub_term_param param_sub (DTyParam param)) params1 in let params2subbed = List.map (fun param -> sub_term_param param_sub (DTyParam param)) params2 in *) let rel = insertTypeParameters rel params in (* let rel = applyFunToRelation rel (applyVarToTerms (name_of_rel rel1) params1subbed) in *) (* let rel = applyFunToRelation rel (applyVarToTerms (name_of_rel rel2) params2subbed) in *) (* BUG TO STILL FIX: if P = Q, then they have the same name. Instead, I should probably keep the parameters in from the beggining and let them get subbed with everything else??? *) msg_debug (str "------------ Relation to be outputted: --------------------"); msg_debug (str (dep_dt_to_string rel)); msg_debug (str "--------------------------------"); define_new_inductive rel (* P : c1 es | .... => P_ : c1_ es* .... *) let renamer (ty_ctr, ty_params, ctrs, typ) : dep_dt = let ty_ctr' = gInjectTyCtr ((ty_ctr_to_string ty_ctr) ^ "_") in let rec rename_dt = function | DTyCtr (tc, dts) -> if tc = ty_ctr then DTyCtr (ty_ctr', List.map rename_dt dts) else DTyCtr (tc, List.map rename_dt dts) | DArrow (dt1, dt2) -> DArrow (rename_dt dt1, rename_dt dt2) | DProd ((v, dt1), dt2) -> DProd ((v, rename_dt dt1), rename_dt dt2) | DTyParam tp -> DTyParam tp | DCtr (c, dts) -> DCtr (c, List.map rename_dt dts) | DTyVar v -> DTyVar v | DApp (dt, dts) -> DApp (rename_dt dt, List.map rename_dt dts) | DNot dt -> DNot (rename_dt dt) | DHole -> DHole in let rename_dep_ctr (c, dt) : dep_ctr = let c' = injectCtr (constructor_to_string c ^ "_") in (c', rename_dt dt) in let ctrs' = List.map rename_dep_ctr ctrs in let typ' = rename_dt typ in (ty_ctr', ty_params, ctrs', typ') let merge_test ind = let rel, param = extract_relation ind in define_new_inductive (renamer rel) (* TODO still: 4) Generate the mappings back and forth P as x /\ Q bs x <-> PQ as bs x 8) Add error checks with useful error messages for - shared parameter types are different - number of arguments is not same as number that the type family actually takes *) (* The plan: - Inductive type - Inductive type with free vars instead of type parameters function removeTypeParameters - - removes first n foralls from contructors - removes first n arguments from any recursive call function insertTypeParameters - - insert n foralls with correct names on each constructor - insert n args on each recursive call *) QuickChick-2.1.0/plugin/mergeTypes.mli000066400000000000000000000003511476030541200176560ustar00rootroot00000000000000val merge : Constrexpr.constr_expr_r CAst.t -> Constrexpr.constr_expr_r CAst.t -> Constrexpr.constr_expr_r CAst.t -> unit val merge_test : Constrexpr.constr_expr_r CAst.t -> unit QuickChick-2.1.0/plugin/quickChick.mlg.cppo000066400000000000000000000730131476030541200205530ustar00rootroot00000000000000DECLARE PLUGIN "coq-quickchick.plugin" { open Pp open Names open Declare open Libnames open Util open Constrintern open Constrexpr open Error open Stdarg let mk_ref s = CAst.make @@ CRef (qualid_of_string s, None) (* Names corresponding to QuickChick's .v files *) let show = mk_ref "QuickChick.Show.show" let quickCheck = mk_ref "QuickChick.Test.quickCheck" let quickCheckWith = mk_ref "QuickChick.Test.quickCheckWith" let mutateCheck = mk_ref "QuickChick.MutateCheck.mutateCheck" let mutateCheckWith = mk_ref "QuickChick.MutateCheck.mutateCheckWith" let mutateCheckMany = mk_ref "QuickChick.MutateCheck.mutateCheckMany" let mutateCheckManyWith = mk_ref "QuickChick.MutateCheck.mutateCheckManyWith" let sample = mk_ref "QuickChick.Generators.sampleGen" let sample1 = mk_ref "QuickChick.Generators.sample1" (* Handle extra ocaml directory to be copied *) let empty_slist : string list = [] let extra_dir : string list ref = Summary.ref ~name:"QC_ocaml_dir" empty_slist let add_extra_dir s = extra_dir := s :: !extra_dir let extra_pkg : string list ref = Summary.ref ~name:"QC_ocaml_pkg" ["zarith"] let add_extra_pkg s = extra_pkg := s :: !extra_pkg let extract_dir : string option ref = Summary.ref ~name:"QC_extract_dir" None let set_extract_dir s = extract_dir := Some s let dune_file : string option ref = Summary.ref ~name:"QC_dune_file" None let set_dune_file s = dune_file := Some s let modules_to_open : string list ref = Summary.ref ~name:"QC_modules_to_open" empty_slist let add_module_to_open s = modules_to_open := s :: !modules_to_open (* [mkdir -p]: recursively make the parent directories if they do not exist. *) let rec mkdir_ dname = let cmd () = Unix.mkdir dname 0o755 in try cmd () with | Unix.Unix_error (Unix.EEXIST, _, _) -> () | Unix.Unix_error (Unix.ENOENT, _, _) -> (* If the parent directory doesn't exist, try making it first. *) mkdir_ (Filename.dirname dname); cmd () (* Interface with OCaml compiler *) let temp_dirname () = match !extract_dir with | None -> let dname = Filename.(concat (get_temp_dir_name ()) "QuickChick") in mkdir_ dname; dname | Some s -> mkdir_ s; s (* Rewrite a file line by line *) let sed_file file f = let src = open_in file in let tmpfile = file ^ ".tmp" in let tmp = open_out tmpfile in let rec go () = match input_line src with | line -> output_string tmp (f line); output_char tmp '\n'; go () | exception End_of_file -> close_in src; close_out tmp; Sys.rename tmpfile file in go () let read_all chan = let buf = Buffer.create 1024 in let rec go () = match Buffer.add_channel buf chan 1024 with | () -> go () | exception End_of_file -> Buffer.contents buf in go () let read_file file = let h = open_in file in let s = read_all h in close_in h; s let fresh_name n = let base = Id.of_string n in (* [is_visible_name id] returns [true] if [id] is already used on the Coq side. *) let is_visible_name id = try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true with Not_found -> false in (* Safe fresh name generation. *) Namegen.next_ident_away_from base is_visible_name (** [define c] introduces a fresh constant name for the term [c]. *) let define c env evd = let (evd,_) = Typing.type_of env evd c in let univs = Evd.univ_entry ~poly:true evd in let fn = fresh_name "quickchick" in (* TODO: Maxime - which of the new internal flags should be used here? The names aren't as clear :) *) let _ : Constant.t = declare_constant ~name:fn ~kind:Decls.(IsDefinition Definition) (DefinitionEntry (definition_entry ~univs (EConstr.to_constr ~abort_on_undefined_evars:false evd c))) in fn (* [$TMP/QuickChick/$TIME/QuickChick.ml], where [$TIME] is the current time in format [HHMMSS]. *) let new_ml_file () : string = let tm = Unix.localtime (Unix.time ()) in let ts = Printf.sprintf "%02d%02d%02d_" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in let base_tmp_dir = temp_dirname () in let temp_dir = CUnix.mktemp_dir ~temp_dir:base_tmp_dir ts "" in mkdir_ temp_dir; Filename.temp_file ~temp_dir "QuickChick" ".ml" let tmp_int_re = Str.regexp "type int =[ ]*int" #if COQ_VERSION >= (8, 20, 0) let define_and_run ~opaque_access c env evd = #else let define_and_run c env evd = #endif (* Extract the term and its dependencies *) let main = define c env evd in let mlf : string = new_ml_file () in let execn : string = Filename.chop_extension mlf ^ ".native" in let mlif : string = Filename.chop_extension mlf ^ ".mli" in let dir : string = Filename.dirname mlf in let warnings = CWarnings.get_flags () in let mute_extraction = warnings ^ (if warnings = "" then "" else ",") ^ "-extraction-opaque-accessed" in CWarnings.set_flags mute_extraction; #if COQ_VERSION >= (8, 20, 0) Flags.silently (Extraction_plugin.Extract_env.full_extraction ~opaque_access (Some mlf)) [qualid_of_ident main]; #else Flags.silently (Extraction_plugin.Extract_env.full_extraction (Some mlf)) [qualid_of_ident main]; #endif CWarnings.set_flags warnings; (* Add a main function to get some output *) let oc = open_out_gen [Open_append;Open_text] 0o666 mlf in let for_output = "\nlet _ = print_string (\n" ^ "let l = (" ^ (Id.to_string main) ^ ") in\n"^ "let s = Bytes.create (List.length l) in\n" ^ "let rec copy i = function\n" ^ "| [] -> s\n" ^ "| c :: l -> Bytes.set s i c; copy (i+1) l\n" ^ "in Bytes.to_string (copy 0 l))" in Printf.fprintf oc "%s" for_output; close_out oc; (* Add any modules that have been marked "open" *) let open_cmd s = Printf.sprintf "awk -v n=1 -v s=\"open %s\" 'NR == n {print s} {print}' %s > %s/__qc_tmp && mv %s/__qc_tmp %s" s mlf dir dir mlf in List.iter (fun s -> ignore (Sys.command (open_cmd s))) !modules_to_open; (* Before compiling, fix stupid cyclic dependencies like "type int = int". Introduced by "Definition int := int." possibly inside a module, so just removing it might break other definitions that depend on it. TODO: Generalize (.) \g1\b or something *) sed_file mlf (fun line -> if Str.string_match tmp_int_re line 0 then "type tmptmptmp = int;; type int = tmptmptmp" else line); (* Compile the extracted code *) (* Extraction sometimes produces ML code that does not implement its interface. We circumvent this problem by erasing the interface. **) Sys.remove mlif; (* TODO: Maxime, thoughts? *) (* LEO: However, sometimes the inferred types are too abstract. So we touch the .mli to close the weak types. **) let _exit_code = Sys.command ("touch " ^ mlif) in (* msg_debug (str "Extracted ML file: " ++ str mlf); msg_debug (str "Compile command: " ++ str (comp_ml_cmd mlf execn)); Printf.printf "Extracted ML file: %s\n" mlf; Printf.printf "Compile command: %s\n" (comp_ml_cmd mlf execn); flush_all (); *) (* Compile the (empty) .mli *) (* if Sys.command (comp_mli_cmd mlif) <> 0 then CErrors.user_err (str "Could not compile mli file" ++ fnl ()); if Sys.command (comp_ml_cmd mlf execn) <> 0 then CErrors.user_err (str "Could not compile test program" ++ fnl ()) *) (* Copy over the contents of the ocaml directory *) let ocaml_dir_cps = List.map (fun s -> Printf.sprintf "cp -rL %s %s" s dir) !extra_dir in List.iter print_endline ocaml_dir_cps; List.iter (fun cmd -> ignore (Sys.command cmd)) ocaml_dir_cps; let packages = match !extra_pkg with | [] -> "" | x -> "-pkgs '" ^ (String.concat "," x) ^ "'" in let exec_command = match !dune_file with | None -> "cd " ^ dir ^ " && ocamlbuild -use-ocamlfind " ^ packages ^ " -lib unix -cflags \"-w -3\" " ^ Filename.basename execn ^ " -quiet > build.log 2> build.err" | Some s -> (* Modify the dune file to add the executable name and put it in the output dir *) let awk_cmd = Printf.sprintf "awk -v n=2 -v s=\" (name %s)\" 'NR == n {print s} {print}' %s > %s" (Filename.chop_extension (Filename.basename mlf)) s (dir ^ "/" ^ s) in (* let sed_cmd = Printf.sprintf "sed '2i (name %s)' %s > %s" (Filename.chop_extension (Filename.basename mlf)) s (dir ^ "/" ^ s) in *) ignore (Sys.command awk_cmd); (* The command is just dune build *) Printf.sprintf "cd %s && dune build --root=. --display=quiet > build.log 2> build.err" dir in (* Overwrite execn in case of dune *) let execn = let () = Filename.concat in match !dune_file with | None -> Filename.dirname execn "_build" Filename.basename execn | Some _ -> dir ^ "/_build/default/" ^ (Filename.chop_extension (Filename.basename execn)) ^ ".exe" in if Sys.command exec_command <> 0 then let build_log = read_file (dir ^ "/build.log") in let build_err = read_file (dir ^ "/build.err") in let msg = str "Could not compile test program: " ++ str mlf ++ fnl () in let msg = if build_log = "" then msg else msg ++ fnl () ++ str "Build stdout:" ++ fnl () ++ str build_log ++ fnl () in let msg = if build_err = "" then msg else msg ++ fnl () ++ str "Build stderr:" ++ fnl () ++ str build_err ++ fnl () in CErrors.user_err msg (* Run the test *) else let execn = "time " ^ execn in (* Should really be shared across this and the tool *) (* let (p_out, _, p_err) as process = Unix.open_process_full execn (Unix.environment ()) in let rec process_otl_aux () = let e = input_line p_out in Feedback.msg_notice (Pp.str e); process_otl_aux() in try process_otl_aux () with End_of_file -> let err_msg = read_all p_err in let err descr = CErrors.user_err (str (execn ^ ": " ^ descr) ++ fnl () ++ fnl () ++ str err_msg ++ fnl ()) in let stat = Unix.close_process_full process in begin match stat with | Unix.WEXITED 0 -> () | Unix.WEXITED i -> err (Printf.sprintf "Exited with status %d" i) | Unix.WSIGNALED i -> err (Printf.sprintf "Killed (%d)" i) | Unix.WSTOPPED i -> err (Printf.sprintf "Stopped (%d)" i) end *) let start = Unix.gettimeofday () in let (p_out, _, p_err) as process = Unix.open_process_full execn (Unix.environment ()) in let process_out () = (* let rec process_err_aux () = let e = input_line p_err in Feedback.msg_notice (Pp.str e); process_err_aux() in *) let rec process_otl_aux () = let e = input_line p_out in Feedback.msg_notice (Pp.str e); process_otl_aux() in try process_otl_aux () with End_of_file -> let stop = Unix.gettimeofday () in let timeElapsed = stop -. start in Feedback.msg_notice (Pp.str (Printf.sprintf "Time Elapsed: %fs\n" timeElapsed)); (* try process_err_aux () with End_of_file -> *) let err_msg = read_all p_err in let err descr = CErrors.user_err (str (execn ^ ": " ^ descr) ++ fnl () ++ fnl () ++ str err_msg ++ fnl ()) in let stat = Unix.close_process_full process in begin match stat with | Unix.WEXITED 0 -> () | Unix.WEXITED i -> err (Printf.sprintf "Exited with status %d" i) | Unix.WSIGNALED i -> err (Printf.sprintf "Killed (%d)" i) | Unix.WSTOPPED i -> err (Printf.sprintf "Stopped (%d)" i) end in process_out () (* (** If we want to print the time spent in tests *) (* let execn = "time " ^ execn in *) if Sys.command execn <> 0 then CErrors.user_err (str "Could not run test" ++ fnl ()) *) ;; (* TODO: clean leftover files *) #if COQ_VERSION >= (8, 20, 0) let runTest ~opaque_access c env evd : unit = #else let runTest c env evd : unit = #endif (* [c] is a constr_expr representing the test to run, so we first build a new constr_expr representing show c **) let c = CAst.make @@ CApp (show, [(c, None)]) in (* Build the kernel term from the const_expr *) (* Printf.printf "Before interp constr\n"; flush stdout; *) let (c,_evd) = interp_constr env evd c in (* Printf.printf "So far so good?\n"; flush stdout; *) #if COQ_VERSION >= (8, 20, 0) define_and_run ~opaque_access c env evd #else define_and_run c env evd #endif let rec last = function | [] -> None | x :: [] -> Some x | _ :: xs -> last xs #if COQ_VERSION >= (8, 20, 0) let run ~opaque_access f args = #else let run f args = #endif let env = Global.env () in let evd = Evd.from_env env in begin match last args with | Some qc_text -> let msg = "QuickChecking " ^ Pp.string_of_ppcmds (Ppconstr.pr_constr_expr env evd qc_text) in Feedback.msg_notice (Pp.str msg) | None -> failwith "run called with no arguments" end; let args = List.map (fun x -> (x,None)) args in let c = CAst.make @@ CApp (f, args) in #if COQ_VERSION >= (8,20, 0) runTest ~opaque_access c env evd #else runTest c env evd #endif let set_debug_flag (flag_name : string) (mode : string) = let toggle = match mode with | "On" -> true | "Off" -> false in let reference = match flag_name with | "Debug" -> flag_debug (* | "Warn" -> flag_warn | "Error" -> flag_error *) in reference := toggle let extract_manually : qualid list ref = Summary.ref ~name:"QC_manual_extracts" [] let add_manual_extract cs = let convert_reference_to_qualid c : qualid = match c with | {CAst.v = CRef (r, _) ; _ } -> r | _ -> failwith "Usage: Extract Manually failed." in let refs : qualid list = match cs with | { CAst.v = CNotation (_,_,([a],[b],_,_)) ; _ } -> begin let q = convert_reference_to_qualid a in let qs = List.map convert_reference_to_qualid b in q :: qs end | _ -> [convert_reference_to_qualid cs] in extract_manually := refs @ !extract_manually #if COQ_VERSION >= (8, 20, 0) let extract_prop_and_deps ~opaque_access prop = #else let extract_prop_and_deps prop = #endif let env = Global.env () in let evd = Evd.from_env env in let (prop_expr, evd') = interp_constr env evd prop in let prop_def = define prop_expr env evd in let prop_mlf = new_ml_file () in let temp_dir = Filename.dirname prop_mlf in let execn = Filename.chop_extension prop_mlf in let prop_mlif = execn ^ ".mli" in let warnings = CWarnings.get_flags () in let mute_extraction = warnings ^ (if warnings = "" then "" else ",") ^ "-extraction-opaque-accessed" in CWarnings.set_flags mute_extraction; #if COQ_VERSION >= (8, 20, 0) Flags.silently (Extraction_plugin.Extract_env.full_extraction ~opaque_access (Some prop_mlf)) [qualid_of_ident prop_def]; #else Flags.silently (Extraction_plugin.Extract_env.full_extraction (Some prop_mlf)) [qualid_of_ident prop_def]; #endif CWarnings.set_flags warnings; (prop_def, temp_dir, execn, prop_mlf, prop_mlif, warnings) #if COQ_VERSION >= (8, 20, 0) let qcFuzz_main ~opaque_access prop_def temp_dir execn prop_mlf prop_mlif warnings prop fuzzLoop = #else let qcFuzz_main prop_def temp_dir execn prop_mlf prop_mlif warnings prop fuzzLoop = #endif (* Override extraction to use the new, instrumented property *) let qualify s = Printf.sprintf "%s.%s" (Filename.basename execn) s in let prop_name = qualify (Id.to_string prop_def) in let prop_ref = match prop with | { CAst.v = CRef (r,_) ; _ } -> r | _ -> failwith "Not a reference" in Extraction_plugin.Table.extract_constant_inline false prop_ref [] prop_name; (* List.iter (fun x -> print_endline (string_of_qualid ((match qualid_of_reference x with {CAst.v = q; _} -> q)))) !extract_manually; *) List.iter (fun r -> match GenericLib.sdt_rep_from_mib (GenericLib.qualid_to_mib r) with | Some (ty_ctr, ty_params, ctrs) -> begin (* print_endline "Extracting inductive..."; *) let ty_ctr_name = qualify (String.uncapitalize_ascii (GenericLib.ty_ctr_to_string ty_ctr)) in (* print_endline ty_ctr_name; *) let ctr_names = match ctrs with | [ctr,ctr_ty] -> if GenericLib.coq_type_size ctr_ty = 1 then [""] else [qualify (GenericLib.constructor_to_string ctr)] | _ -> List.map (fun (ctr,_) -> qualify (GenericLib.constructor_to_string ctr)) ctrs in (* List.iter print_endline ctr_names; *) Extraction_plugin.Table.extract_inductive (GenericLib.tyCtrToQualid ty_ctr) ty_ctr_name ctr_names None end | None -> failwith "Can't be represented..." ) !extract_manually; (* Define fuzzLoop applied appropriately *) let unit_type = CAst.make @@ CRef (qualid_of_string "Coq.Init.Datatypes.unit", None) in let unit_arg = #if COQ_VERSION >= (8, 20, 0) CLocalAssum ( [ CAst.make (Name (fresh_name "x")) ], None, Default Glob_term.Explicit, unit_type ) in #else CLocalAssum ( [ CAst.make (Name (fresh_name "x")) ], Default Glob_term.Explicit, unit_type ) in #endif let pair_ctr = CAst.make @@ CRef (qualid_of_string "Coq.Init.Datatypes.pair", None) in let show_expr cexpr = CAst.make @@ CApp (show, [(cexpr,None)]) in let show_and_c_fun : constr_expr = Constrexpr_ops.mkCLambdaN [unit_arg] (let fx = fresh_name "_qc_res" in let fx_expr = (CAst.make @@ CRef (qualid_of_ident fx,None)) in CAst.make @@ CLetIn (CAst.make @@ Name fx, fuzzLoop, None, CAst.make @@ CApp (pair_ctr, [(fx_expr, None); (show_expr fx_expr, None)]))) in (* Build the kernel term from the const_expr *) let env = Global.env () in let evd = Evd.from_env env in let (show_and_c_fun, evd') = interp_constr env evd show_and_c_fun in let show_and_c_fun_def = define show_and_c_fun env evd in let mlf = Filename.temp_file ~temp_dir "QuickChick" ".ml" in let execn = Filename.chop_extension mlf in let mlif = execn ^ ".mli" in let mute_extraction = warnings ^ (if warnings = "" then "" else ",") ^ "-extraction-opaque-accessed" in CWarnings.set_flags mute_extraction; #if COQ_VERSION >= (8, 20, 0) Flags.silently (Extraction_plugin.Extract_env.full_extraction ~opaque_access (Some mlf)) [qualid_of_ident show_and_c_fun_def]; #else Flags.silently (Extraction_plugin.Extract_env.full_extraction (Some mlf)) [qualid_of_ident show_and_c_fun_def]; #endif (* Add a main function to get some output *) let oc = open_out_gen [Open_append;Open_text] 0o666 mlf in Printf.fprintf oc "let _ = \n\ Printf.printf \"Entering main of qc_exec\\n\"; flush stdout;\n\ setup_shm_aux ();\n\ (* Printexc.record_backtrace true; *)\n\ let toStr l = \n\ let s = Bytes.create (List.length l) in\n\ let rec copy i = function\n\ | [] -> s\n\ | c :: l -> Bytes.set s i c; copy (i+1) l\n\ in Bytes.to_string (copy 0 l) in\n\ print_string (toStr (snd ((%s) ()))); flush stdout;\n" (Id.to_string show_and_c_fun_def); close_out oc; (* Append the appropriate definitions in the beginning *) let user_contrib = "$(opam var lib)/coq/user-contrib/QuickChick" in (* Add preamble *) let echo_cmd = Printf.sprintf "cat %s/Stub.ml | cat - %s > temp && mv temp %s" user_contrib mlf mlf in print_endline echo_cmd; ignore (Sys.command echo_cmd); (* HORRIBLE. HORRIBLE. Perl hack to ensure tail recursion... *) (* First copy them over from contrib... *) ignore (Sys.command (Printf.sprintf "cp %s/cmdprefix.pl %s" user_contrib temp_dir)); ignore (Sys.command (Printf.sprintf "cp %s/cmdsuffix.pl %s" user_contrib temp_dir)); (* ... then execute them ... *) ignore (Sys.command (Printf.sprintf "%s/cmdprefix.pl %s" temp_dir mlf)); ignore (Sys.command (Printf.sprintf "%s/cmdsuffix.pl %s" temp_dir mlf)); (* Copy fuzz-related files to temp directory *) ignore (Sys.command (Printf.sprintf "cp %s/alloc-inl.h %s" user_contrib temp_dir)); ignore (Sys.command (Printf.sprintf "cp %s/debug.h %s" user_contrib temp_dir)); ignore (Sys.command (Printf.sprintf "cp %s/types.h %s" user_contrib temp_dir)); ignore (Sys.command (Printf.sprintf "cp %s/config.h %s" user_contrib temp_dir)); ignore (Sys.command (Printf.sprintf "cp %s/SHM.c %s" user_contrib temp_dir)); (* Compile. Prop with instrumentation, rest without *) (* let path = Lazy.force path in let link_files = List.map (Filename.concat path) link_files in let link_files = String.concat " " link_files in let afl_path = eval_command "opam config var lib" ^ "/afl-persistent/" in let afl_link = afl_path ^ "afl-persistent.cmxa" in let extra_link_files = String.concat " " (List.map (fun (s : string * string) -> temp_dir ^ "/" ^ fst s) !extra_files) in print_endline ("Extra: " ^ extra_link_files); *) let zarith = "-I $(opam var lib)/zarith $(opam var lib)/zarith/zarith.cmxa" in let ocamlopt = "ocamlopt -ccopt -Wno-error=implicit-function-declaration" in let comp_mli_cmd instr_flag fn = Printf.sprintf "%s %s unix.cmxa %s -rectypes -w a -I %s %s" ocamlopt instr_flag zarith (Filename.dirname fn) fn in let comp_prop_ml_cmd fn = Printf.sprintf "%s -afl-instrument unix.cmxa str.cmxa %s -rectypes -w a -I %s %s" ocamlopt zarith (Filename.dirname fn) fn in let comp_exec_ml_cmd fn prop_fn execn = Printf.sprintf "%s unix.cmxa str.cmxa %s -rectypes -w a -I %s %s -o %s %s %s/SHM.c" ocamlopt zarith (Filename.dirname fn) (Filename.chop_extension prop_fn ^ ".cmx") execn fn temp_dir in (* let comp_mli_cmd instr_flag fn = Printf.sprintf "%s %s unix.cmxa %s -rectypes -w a -I %s -I %s %s %s" ocamlopt instr_flag afl_link (Filename.dirname fn) path link_files fn in let comp_prop_ml_cmd fn = Printf.sprintf "%s -afl-instrument unix.cmxa str.cmxa %s -rectypes -w a -I %s -I %s -I %s %s %s %s" ocamlopt afl_link (Filename.dirname fn) afl_path path link_files extra_link_files fn in let comp_exec_ml_cmd fn prop_fn execn = Printf.sprintf "%s unix.cmxa str.cmxa %s -rectypes -w a -I %s -I %s -I %s %s %s %s -o %s %s %s/SHM.c" ocamlopt afl_link (Filename.dirname fn) afl_path path link_files extra_link_files (Filename.chop_extension prop_fn ^ ".cmx") execn fn temp_dir in *) (* Compile the .mli *) if Sys.command (comp_mli_cmd "-afl-instrument" prop_mlif) <> 0 then CErrors.user_err (str "Could not compile mli file: " ++ str (comp_mli_cmd "-afl-instrument" prop_mlif) ++ fnl ()); (* Compile the instrumented property .ml *) if Sys.command (comp_prop_ml_cmd prop_mlf) <> 0 then (CErrors.user_err (str "Could not compile test program: " ++ str (comp_prop_ml_cmd prop_mlf) ++ fnl ())); (* Compile the executable .mli, no instrumentation *) if Sys.command (comp_mli_cmd " " mlif) <> 0 then CErrors.user_err (str "Could not compile exec mli file" ++ fnl ()); (* Compile the actual executable *) let cmp_cmd = comp_exec_ml_cmd mlf prop_mlf (temp_dir ^ "/qc_exec") in Printf.printf "Compile Command: %s\n" cmp_cmd; flush stdout; if Sys.command (cmp_cmd) <> 0 then (CErrors.user_err (str "Could not compile exec program" ++ fnl ())); (* Copy over the main file that actually sets up the shm... *) ignore (Sys.command (Printf.sprintf "cp %s/Main.ml %s" user_contrib temp_dir)); let comp_main_cmd fn execn : string = Printf.sprintf "%s unix.cmxa str.cmxa -rectypes -w a -I %s -o %s %s %s/SHM.c" ocamlopt (Filename.dirname fn) execn fn temp_dir in let cmp_cmd_main = comp_main_cmd (temp_dir ^ "/Main.ml") (temp_dir ^ "/main_exec") in Printf.printf "Compile Main Command: %s\n" cmp_cmd_main; if (Sys.command cmp_cmd_main <> 0) then (CErrors.user_err (str "Could not compile main program" ++ fnl ())); (* Run the FuzzQC command, parse the output, search for "Passed" or "Failed" *) let found_result = ref (None : bool option) in let run_and_show_output command = let chan = Unix.open_process_in command in let res = ref ([] : string list) in let str_success = Str.regexp_string "Passed" in let str_failure = Str.regexp_string "Failed" in let contains r s = try let ix = Str.search_forward r s 0 in ix >= 0 with _ -> false in let rec process_otl_aux () = let e = input_line chan in res := e::!res; if contains str_success e then found_result := Some true; if contains str_failure e then found_result := Some false; process_otl_aux() in try process_otl_aux () with End_of_file -> let stat = Unix.close_process_in chan in let result = match stat with Unix.WEXITED 0 -> List.rev !res | Unix.WEXITED i -> List.rev (Printf.sprintf "Exited with status %d" i :: !res) | Unix.WSIGNALED i -> List.rev (Printf.sprintf "Killed (%d)" i :: !res) | Unix.WSTOPPED i -> List.rev (Printf.sprintf "Stopped (%d)" i :: !res) in List.iter (fun s -> (print_string s; print_newline())) result | _ -> failwith "LOL" in run_and_show_output ("time " ^ temp_dir ^ "/main_exec " ^ temp_dir ^ "/qc_exec"); print_endline (match !found_result with | Some true -> "Found success!" | Some false -> "Found failure!" | _ -> "Found nothing..." ); !found_result (* open linked ocaml files List.iter (fun (s : string * string) -> let (fn, c) = s in let sed_cmd = (Printf.sprintf "sed -i '1s;^;open %s\\n;' %s" c mlf) in print_endline ("Sed cmd: " ^ sed_cmd); ignore (Sys.command sed_cmd); ignore (Sys.command (Printf.sprintf "cp %s %s" fn temp_dir)); ) !extra_files; *) #if COQ_VERSION >= (8, 20, 0) let qcFuzz ~opaque_access prop fuzzLoop = let (prop_def, temp_dir, execn, prop_mlf, prop_mlif, warnings) = extract_prop_and_deps ~opaque_access prop in qcFuzz_main ~opaque_access prop_def temp_dir execn prop_mlf prop_mlif warnings prop fuzzLoop #else let qcFuzz prop fuzzLoop = let (prop_def, temp_dir, execn, prop_mlf, prop_mlif, warnings) = extract_prop_and_deps prop in qcFuzz_main prop_def temp_dir execn prop_mlf prop_mlif warnings prop fuzzLoop #endif } #if COQ_VERSION >= (8, 20, 0) VERNAC COMMAND EXTEND QuickCheck CLASSIFIED AS SIDEFF STATE opaque_access #else VERNAC COMMAND EXTEND QuickCheck CLASSIFIED AS SIDEFF #endif | ["QuickCheck" constr(c)] -> {run quickCheck [c]} | ["QuickCheckWith" constr(c1) constr(c2)] -> {run quickCheckWith [c1;c2]} END #if COQ_VERSION >= (8, 20, 0) VERNAC COMMAND EXTEND QuickChick CLASSIFIED AS SIDEFF STATE opaque_access #else VERNAC COMMAND EXTEND QuickChick CLASSIFIED AS SIDEFF #endif | ["QuickChick" constr(c)] -> {run quickCheck [c]} | ["QuickChickWith" constr(c1) constr(c2)] -> {run quickCheckWith [c1;c2]} END #if COQ_VERSION >= (8, 20, 0) VERNAC COMMAND EXTEND MutateCheck CLASSIFIED AS SIDEFF STATE opaque_access #else VERNAC COMMAND EXTEND MutateCheck CLASSIFIED AS SIDEFF #endif | ["MutateCheck" constr(c1) constr(c2)] -> {run mutateCheck [c1;c2]} | ["MutateCheckWith" constr(c1) constr(c2) constr(c3)] -> {run mutateCheckWith [c1;c2;c3]} END #if COQ_VERSION >= (8, 20, 0) VERNAC COMMAND EXTEND MutateChick CLASSIFIED AS SIDEFF STATE opaque_access #else VERNAC COMMAND EXTEND MutateChick CLASSIFIED AS SIDEFF #endif | ["MutateChick" constr(c1) constr(c2)] -> {run mutateCheck [c1;c2]} | ["MutateChickWith" constr(c1) constr(c2) constr(c3)] -> {run mutateCheckWith [c1;c2;c3]} END #if COQ_VERSION >= (8, 20, 0) VERNAC COMMAND EXTEND MutateCheckMany CLASSIFIED AS SIDEFF STATE opaque_access #else VERNAC COMMAND EXTEND MutateCheckMany CLASSIFIED AS SIDEFF #endif | ["MutateCheckMany" constr(c1) constr(c2)] -> {run mutateCheckMany [c1;c2]} | ["MutateCheckManyWith" constr(c1) constr(c2) constr(c3)] -> {run mutateCheckManyWith [c1;c2;c3]} END #if COQ_VERSION >= (8, 20, 0) VERNAC COMMAND EXTEND MutateChickMany CLASSIFIED AS SIDEFF STATE opaque_access #else VERNAC COMMAND EXTEND MutateChickMany CLASSIFIED AS SIDEFF #endif | ["MutateChickMany" constr(c1) constr(c2)] -> {run mutateCheckMany [c1;c2]} | ["MutateChickManyWith" constr(c1) constr(c2) constr(c3)] -> {run mutateCheckManyWith [c1;c2;c3]} END VERNAC COMMAND EXTEND QuickChickDebug CLASSIFIED AS SIDEFF | ["QuickChickDebug" ident(s1) ident(s2)] -> { let s1' = Id.to_string s1 in let s2' = Id.to_string s2 in set_debug_flag s1' s2' } END #if COQ_VERSION >= (8, 20, 0) VERNAC COMMAND EXTEND Sample CLASSIFIED AS SIDEFF STATE opaque_access #else VERNAC COMMAND EXTEND Sample CLASSIFIED AS SIDEFF #endif | ["Sample" constr(c)] -> {run sample [c]} END #if COQ_VERSION >= (8, 20, 0) VERNAC COMMAND EXTEND Sample1 CLASSIFIED AS SIDEFF STATE opaque_access #else VERNAC COMMAND EXTEND Sample1 CLASSIFIED AS SIDEFF #endif | ["Sample1" constr(c)] -> {run sample1 [c]} END VERNAC COMMAND EXTEND QCInclude CLASSIFIED AS SIDEFF | ["QCInclude" string(s)] -> { add_extra_dir s } END VERNAC COMMAND EXTEND QCOpen CLASSIFIED AS SIDEFF | ["QCOpen" string(s)] -> { add_module_to_open s } END VERNAC COMMAND EXTEND QCPackage CLASSIFIED AS SIDEFF | ["QCPackage" string(s)] -> { add_extra_pkg s } END VERNAC COMMAND EXTEND QCdune CLASSIFIED AS SIDEFF | ["QCDune" string(s)] -> { set_dune_file s } END VERNAC COMMAND EXTEND ManualExtract CLASSIFIED AS SIDEFF | ["ManualExtract" constr(inductives) ] -> { add_manual_extract inductives } END #if COQ_VERSION >= (8, 20, 0) VERNAC COMMAND EXTEND FuzzQC CLASSIFIED AS SIDEFF STATE opaque_access | ["FuzzChick" constr(prop) constr(fuzzLoop) ] -> { fun ~opaque_access -> ignore (qcFuzz prop ~opaque_access fuzzLoop) } END #else VERNAC COMMAND EXTEND FuzzQC CLASSIFIED AS SIDEFF | ["FuzzChick" constr(prop) constr(fuzzLoop) ] -> { ignore (qcFuzz prop fuzzLoop) } END #endif VERNAC COMMAND EXTEND QCExtractDir CLASSIFIED AS SIDEFF | ["QCExtractDir" string(s)] -> { set_extract_dir s } END QuickChick-2.1.0/plugin/quickChick.mli.cppo000066400000000000000000000005071476030541200205530ustar00rootroot00000000000000val quickCheck : Constrexpr.constr_expr_r CAst.t val show : Constrexpr.constr_expr_r CAst.t #if COQ_VERSION >= (8, 20, 0) val define_and_run : opaque_access:Global.indirect_accessor -> EConstr.constr -> Environ.env -> Evd.evar_map -> unit #else val define_and_run : EConstr.constr -> Environ.env -> Evd.evar_map -> unit #endif QuickChick-2.1.0/plugin/quickchick_plugin.mlpack000066400000000000000000000003311476030541200217120ustar00rootroot00000000000000Error GenericLib GenLib CoqLib SemLib SetLib UnifyQC Weightmap ArbitrarySized EnumSized ArbitrarySizedST EnumSizedST SizeUtils Sized SimplDriver CheckerSizedST DepDriver MergeTypes Driver QuickChick Tactic_quickchick QuickChick-2.1.0/plugin/semLib.ml000066400000000000000000000115601476030541200166000ustar00rootroot00000000000000open GenericLib (* open CoqLib *) let semGenSize gen size = gApp (gInject "semGenSize") [gen; size] let semGen gen = gApp (gInject "semGen") [gen] let semReturn x = gApp (gInject "semReturn") [x] let arbitrarySize size = gApp (gInject "arbitrarySize") [size] let oneOf_freq p1 p2 p3 = gApp ~explicit:true (gInject "oneOf_freq") [hole; p1; p2; p3] let semFreqSize g gs size hall = gApp ~explicit:true (gInject "semFreqSize") [hole; g; gs; size; hall] let semFreq g gs hall = gApp ~explicit:true (gInject "semFreq") [hole; g; gs; hall] let semBindSize g f size = gApp (gInject "semBindSize") [g; f; size] let semBindSizeMon g f gMon fMon = gApp ~explicit:true (gInject "semBindSizeMonotonic") [hole; hole; g; f; gMon; fMon] let backtrackSizeMonotonic lst proof = gApp (gInject "backtrackSizeMonotonic") [lst; proof] let backtrackSizeMonotonicOpt lst proof = gApp (gInject "backtrackSizeMonotonicOpt") [lst; proof] let semBacktrack_sound g = gApp ~explicit:true (gInject "semBacktrack_sound") [hole; g] let semBacktrack_complete g = gApp ~explicit:true (gInject "semBacktrack_complete") [hole; g] let semBacktrackSize g s = gApp ~explicit:true (gInject "semBacktrackSize") [hole; g; s] let returnGenSizeMonotonic x = gApp (gInject "returnGenSizeMonotonic") [x] let returnGenSizeMonotonicOpt x = gApp (gInject "returnGenSizeMonotonicOpt") [x] let bindMonotonic p s fp = gApp ~explicit:true (gInject "bindMonotonic") [hole; hole; hole; hole; p; gFun [s] (fun [x] -> fp x)] let bindMonotonicOpt p s fp = gApp ~explicit:true (gInject "bindMonotonicOpt") [hole; hole; hole; hole; p; gFun [s] (fun [x] -> fp x)] let bindOptMonotonic p s fp = gApp ~explicit:true (gInject "bindOptMonotonic") [hole; hole; hole; hole; p; gFun [s] (fun [x] -> fp x)] let bindOptMonotonicOpt p s fp = gApp ~explicit:true (gInject "bindOptMonotonicOpt") [hole; hole; hole; hole; p; gFun [s] (fun [x] -> fp x)] (* let suchThatMaybeMonotonic p pred = *) (* gApp ~explicit:true *) (* (gInject "suchThatMaybeMonotonic") [hole; hole; pred; p] *) (* let suchThatMaybeOptMonotonic p pred = *) (* gApp ~explicit:true *) (* (gInject "suchThatMaybeOptMonotonic") [hole; hole; pred; p] *) let suchThatMaybeMonotonicOpt p pred = gApp ~explicit:true (gInject "suchThatMaybeMonotonicOpt") [hole; hole; pred; p] let suchThatMaybeOptMonotonicOpt p pred = gApp ~explicit:true (gInject "suchThatMaybeOptMonotonicOpt") [hole; hole; pred; p] let semBindOptSizeMonotonicIncl_r g f s sf hg hf = gApp ~explicit:true (gInject "semBindOptSizeMonotonicIncl_r") [hole; hole; g; f; s; sf; hg; hf] let semBindSizeMonotonicIncl_r g f s sf hg hf = gApp ~explicit:true (gInject "semBindSizeMonotonicIncl_r") [hole; hole; g; f; s; sf; hg; hf] let semBindOptSizeMonotonicIncl_l g f s sf mon monf hg hf = gApp ~explicit:true (gInject "semBindOptSizeMonotonicIncl_l") [hole; hole; g; f; s; sf; mon; monf; hg; hf] let semBindSizeMonotonicIncl_l g f s sf mon monf hg hf = gApp ~explicit:true (gInject "semBindSizeMonotonicIncl_l") [hole; hole; g; f; s; sf; mon; monf; hg; hf] let semSuchThatMaybe_complete g f s mon h = gApp ~explicit:true (gInject "semSuchThatMaybe_complete") [hole; g; f; s; mon; h] let semSuchThatMaybeOpt_complete g f s mon h = gApp ~explicit:true (gInject "semSuchThatMaybeOpt_complete") [hole; g; f; s; mon; h] let semSuchThatMaybe_sound g f s h = gApp ~explicit:true (gInject "semSuchThatMaybe_sound") [hole; g; f; s; h] let semSuchThatMaybeOpt_sound g f s h = gApp ~explicit:true (gInject "semSuchThatMaybeOpt_sound") [hole; g; f; s; h] let semBindSizeOpt_subset_compat h1 h2 = gApp ~explicit:true (gInject "semBindSizeOpt_subset_compat") [hole; hole; hole; hole; hole; hole; h1; h2] let semBindOptSizeOpt_subset_compat h1 h2 = gApp ~explicit:true (gInject "semBindOptSizeOpt_subset_compat") [hole; hole; hole; hole; hole; hole; h1; h2] let suchThatMaybe_subset_compat p h = gApp ~explicit:true (gInject "suchThatMaybe_subset_compat") [hole; p; hole; hole; h] let suchThatMaybeOpt_subset_compat p h = gApp ~explicit:true (gInject "suchThatMaybeOpt_subset_compat") [hole; p; hole; hole; h] let nat_set_ind typ ginst sinst cinst hb hi x = gApp ~explicit:true (gInject "nat_set_ind") [typ; ginst; sinst; cinst; hb; hi; x] (* (* Checker proofs *) let destruct_match_true_r (h : coq_expr) (k : coq_expr) = gApp ~explicit:true (gInject "destruct_match_true_r") [hole; hole; h; k] let destruct_match_true_l (h : coq_expr) = gApp ~explicit:true (gInject "destruct_match_true_l") [hole; hole; h] let checker_backtrack_spec_l (gens : coq_expr) (h : coq_expr) = let heq = gApp ~explicit:true (gInject "checker_backtrack_spec") [gens] in gApp (gProjL heq) [h] let checker_backtrack_spec_r (gens : coq_expr) (h : coq_expr) = let heq = gApp ~explicit:true (gInject "checker_backtrack_spec") [gens] in gApp (gProjR heq) [h] *) QuickChick-2.1.0/plugin/semLib.mli000066400000000000000000000103421476030541200167460ustar00rootroot00000000000000val semGenSize : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semGen : GenericLib.coq_expr -> GenericLib.coq_expr val semReturn : GenericLib.coq_expr -> GenericLib.coq_expr val arbitrarySize : GenericLib.coq_expr -> GenericLib.coq_expr val oneOf_freq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semFreqSize : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semFreq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semBindSize : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semBindSizeMon : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val backtrackSizeMonotonic : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val backtrackSizeMonotonicOpt : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semBacktrack_sound : GenericLib.coq_expr -> GenericLib.coq_expr val semBacktrack_complete : GenericLib.coq_expr -> GenericLib.coq_expr val semBacktrackSize : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val returnGenSizeMonotonic : GenericLib.coq_expr -> GenericLib.coq_expr val returnGenSizeMonotonicOpt : GenericLib.coq_expr -> GenericLib.coq_expr val bindMonotonic : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val bindMonotonicOpt : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val bindOptMonotonic : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val bindOptMonotonicOpt : GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val suchThatMaybeMonotonicOpt : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val suchThatMaybeOptMonotonicOpt : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semBindOptSizeMonotonicIncl_r : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semBindSizeMonotonicIncl_r : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semBindOptSizeMonotonicIncl_l : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semBindSizeMonotonicIncl_l : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semSuchThatMaybe_complete : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semSuchThatMaybeOpt_complete : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semSuchThatMaybe_sound : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semSuchThatMaybeOpt_sound : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semBindSizeOpt_subset_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val semBindOptSizeOpt_subset_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val suchThatMaybe_subset_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val suchThatMaybeOpt_subset_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val nat_set_ind : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr QuickChick-2.1.0/plugin/setLib.ml000066400000000000000000000203771476030541200166150ustar00rootroot00000000000000open GenericLib let set_singleton (c : coq_expr) : coq_expr = gApp (gInject "set1") [c] let set_empty : coq_expr = gInject "set0" let set_full : coq_expr = gInject "setT" let set_bigcup (x : string) (p : coq_expr) (c : var -> coq_expr) : coq_expr = gApp (gInject "bigcup") [p; gFun [x] (fun [x] -> c x)] let set_suchThat (x : string) (t : coq_expr) (p : var -> coq_expr) : coq_expr = gFunTyped [("x", t)] (fun [x] -> p x) let set_eq c1 c2 = gApp (gInject "set_eq") [c1;c2] let set_incl c1 c2 = gApp (gInject "set_incl") [c1;c2] let set_union c1 c2 = gApp (gInject "setU") [c1;c2] let set_int c1 c2 = gApp (gInject "setI") [c1;c2] let imset f s = gApp (gInject "imset") [f; s] let sub0set = gApp ~explicit:true (gInject "sub0set") [hole; hole] let imset_set0_subset = gApp ~explicit:true (gInject "imset_set0_subset") [hole; hole; hole; hole] let rec set_unions = function | [] -> failwith "empty set unions" | [x] -> x | x::xs -> set_union x (set_unions xs) let set_eq_refl x = gApp (gInject "set_eq_refl") [x] let set_incl_refl = gApp ~explicit:true (gInject "subset_refl") [hole; hole] let _incl_subset l1 l2 p = gApp (gInject "incl_subset") [l1; l2; p] let incl_refl = gApp (gInject "incl_refl") [hole] let incl_hd_same p = gApp ~explicit:true (gInject "incl_hd_same") [hole; hole; hole; hole; p] let incl_tl p = gApp (gInject "incl_tl") [hole; p] let setU_set_eq_compat x1 x2 = gApp (gInject "setU_set_eq_compat") [x1; x2] let setU_set0_r x1 x2 = gApp (gInject "setU_set0_r") [x1; x2] let set_eq_trans x1 x2 = gApp (gInject "set_eq_trans") [x1; x2] let set_incl_trans x1 x2 = gApp (gInject "subset_trans") [x1; x2] let setU_set0_l x1 x2 = gApp (gInject "setU_set0_l") [x1; x2] let setU_set0_neut_eq x1 x2 = gApp (gInject "setU_set0_neut_eq") [x1; x2] let eq_bigcupl x1 x2 p = gApp (gInject "eq_bigcupl") [x1; x2; p] let cons_set_eq x l = gApp (gInject "cons_set_eq") [x; l] let singl_set_eq a x = gApp ~explicit:true (gInject "singl_set_eq") [a; x] let bigcup_setU_l x1 x2 x3 = gApp (gInject "bigcup_setU_l") [x1; x2; x3] let bigcup_set1 x1 x2 = gApp (gInject "bigcup_set1") [x1 ; x2] let subset_respects_set_eq_l p1 p2 = gApp (gInject "subset_respects_set_eq_l") [p1; p2] let subset_respects_set_eq_r p1 p2 = gApp (gInject "subset_respects_set_eq_r") [p1; p2] let subset_respects_set_eq p1 p2 p3 = gApp ~explicit:true (gInject "subset_respects_set_eq") [hole; hole; hole; hole; hole; p1; p2; p3] (* maybe add a new lemma? *) let subset_set_eq_compat p1 p2 p3 = gApp (gInject "subset_respects_set_eq") [p1; p2; p3] let incl_bigcupl p = gApp (gInject "incl_bigcupl") [p] let incl_bigcup_compat p1 p2 = gApp (gInject "incl_bigcup_compat") [p1; p2] let imset_isSome s = gApp ~explicit:true (gInject "imset_isSome") [hole; s] let isSomeSet a = gFun ["x"] (fun [x] -> gApp (gInject "is_true") [gApp ~explicit:true (gInject "isSome") [a; gVar x]] ) [@ocaml.warning "-8"] let incl_subset l1 l2 p = gApp ~explicit:true (gInject "incl_subset") [hole; l1; l2; p] let setU_set_subset_compat p1 p2 = gApp (gInject "setU_set_subset_compat") [p1; p2] let setI_subset_compat p1 p2 = gApp ~explicit:true (gInject "setI_subset_compat") [hole; hole; hole; hole; hole; p1; p2] let nil_subset p = gApp (gInject "nil_subset") [p] let cons_subset (hd : coq_expr) (tl : coq_expr) (p : coq_expr) (phd : coq_expr) (ptl : coq_expr) = gApp ~explicit:true (gInject "cons_subset") [hole; hd; tl; p; phd; ptl] let setI_set_incl hsub1 hsub2 = gApp ~explicit:true (gInject "setI_set_incl") [hole; hole; hole; hole; hsub1; hsub2] let setI_set_eq_r p = gApp ~explicit:true (gInject "setI_set_eq_r") [hole; hole; hole; hole; p] let setU_subset_r s2 p = gApp ~explicit:true (gInject "setU_subset_r") [hole; hole; s2; hole; p] let setU_subset_l s2 p = gApp ~explicit:true (gInject "setU_subset_l") [hole; hole; s2; hole; p] let imset_set0_incl f x h = gApp ~explicit:true (gInject "imset_set0_incl") [hole; hole; f; x; h] let imset_singl_incl x f y h = gApp ~explicit:true (gInject "imset_singl_incl") [hole; hole; x; f; y; h] let imset_union_incl s1 s2 f x hin = gApp ~explicit:true (gInject "imset_union_incl") [hole; hole; s1; s2; f; x; hin] let imset_incl h = gApp (gInject "imset_incl") [h] let rewrite_set_r seq p = gApp ~explicit:true (gInject "rewrite_set_r") [hole; hole; hole; hole; p; seq] let rewrite_set_l seq p = gApp ~explicit:true (gInject "rewrite_set_l") [hole; hole; hole; hole; p; seq] let imset_bigcup_incl_l f a g x h = gApp ~explicit:true (gInject "imset_bigcup_incl_l") [hole; hole; hole; f; a; g; x; h] let set_eq_set_incl_r heq = gApp ~explicit:true (gInject "set_eq_set_incl_r") [hole; hole; hole; heq] let set_eq_set_incl_l heq = gApp ~explicit:true (gInject "set_eq_set_incl_l") [hole; hole; hole; heq] let in_imset f s x hin = gApp ~explicit:true (gInject "in_imset") [hole; hole; f; s; x; hin] let lift_union_compat h1 h2 = gApp ~explicit:true (gInject "union_lift_subset_compat") [hole; hole; hole; hole; hole; h1; h2] let lift_subset_pres_r h = gApp ~explicit:true (gInject "lift_subset_pres_r") [hole; hole; hole; hole; h] let lift_subset_pres_l h = gApp ~explicit:true (gInject "lift_subset_pres_l") [hole; hole; hole; hole; h] let bigcup_set0_subset f s = gApp ~explicit:true (gInject "bigcup_set0_subset") [hole; hole; f; s] let bigcup_set_U h1 h2 = gApp ~explicit:true (gInject "bigcup_set_U") [hole; hole; hole; hole; hole; hole; h1; h2] let bigcup_set_I_l h = gApp ~explicit:true (gInject "bigcup_set_I_l") [hole; hole; hole; hole; hole; hole; h] let set_incl_setI_l h = gApp ~explicit:true (gInject "set_incl_setI_l") [hole; hole; hole; hole; h] let set_incl_setI_r h = gApp ~explicit:true (gInject "set_incl_setI_r") [hole; hole; hole; hole; h] let set_incl_setU_l h1 h2 = gApp ~explicit:true (gInject "set_incl_setU_l") [hole; hole; hole; hole; h1; h2] let bigcup_cons_subset a b h1 h2 = gApp ~explicit:true (gInject "bigcup_cons_subset") [a; b; hole; hole; hole; hole; h1; h2] let bigcup_cons_subset_r a b h1 h2 = gApp ~explicit:true (gInject "bigcup_cons_subset_r") [a; b; hole; hole; hole; hole; hole; h1; h2] let bigcup_setI_cons_subset_r a b h1 h2 h3 = gApp ~explicit:true (gInject "bigcup_setI_cons_subset_r") [a; b; hole; hole; hole; hole; hole; hole; h1; h2; h3] let imset_bigcup_setI_cons_subset_r a b h1 h2 h3 = gApp ~explicit:true (gInject "imset_bigcup_setI_cons_subset_r") [a; b; hole; hole; hole; hole; hole; hole; h1; h2; h3] let bigcup_nil_subset = gApp ~explicit:true (gInject "bigcup_nil_subset") [hole; hole; hole; hole] let isSome_subset p = gApp ~explicit:true (gInject "isSome_subset") [hole; hole; hole; hole; hole; p] (* let bigcup_cons_setI_subset_compat a f h1 h2 = *) (* gApp *) (* ~explicit:true (gInject "bigcup_cons_setI_subset_compat") *) (* [a; hole; f; hole; hole; hole; hole; hole; h1; h2] *) let bigcup_cons_setI_subset_pres a f h = gApp ~explicit:true (gInject "bigcup_cons_setI_subset_pres") [a; hole; f; hole; hole; hole; hole; h] let bigcup_cons_setI_subset_compat_backtrack h1 h2 = gApp ~explicit:true (gInject "bigcup_cons_setI_subset_compat_backtrack") [hole; hole; hole; hole; hole; hole; hole; h1; h2] let bigcup_cons_setI_subset_compat_backtrack_weak h1 h2 = gApp ~explicit:true (gInject "bigcup_cons_setI_subset_compat_backtrack_weak") [hole; hole; hole; hole; hole; hole; h1; h2] let bigcup_cons_setI_subset_pres_backtrack h = gApp ~explicit:true (gInject "bigcup_cons_setI_subset_pres_backtrack") [hole; hole; hole; hole; hole; hole; h] let bigcup_cons_setI_subset_pres_backtrack_weak h = gApp ~explicit:true (gInject "bigcup_cons_setI_subset_pres_backtrack_weak") [hole; hole; hole; hole; hole; h] let bigcup_nil_setI f l s = gApp ~explicit:true (gInject "bigcup_nil_setI") [hole; hole; f; l; s] let isSome_set_eq h1 h2 = gApp ~explicit:true (gInject "isSome_set_eq") [hole; hole; hole; h1; h2] let set_eq_isSome_sound h = gApp ~explicit:true (gInject "set_eq_isSome_sound") [hole; hole; hole; h] let set_eq_isSome_complete h = gApp ~explicit:true (gInject "set_eq_isSome_complete") [hole; hole; hole; h] QuickChick-2.1.0/plugin/setLib.mli000066400000000000000000000162061476030541200167620ustar00rootroot00000000000000val set_singleton : GenericLib.coq_expr -> GenericLib.coq_expr val set_empty : GenericLib.coq_expr val set_full : GenericLib.coq_expr val set_bigcup : string -> GenericLib.coq_expr -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val set_suchThat : string -> GenericLib.coq_expr -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr val set_eq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val set_incl : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val set_union : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val set_int : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val imset : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val sub0set : GenericLib.coq_expr val imset_set0_subset : GenericLib.coq_expr val set_unions : GenericLib.coq_expr list -> GenericLib.coq_expr val set_eq_refl : GenericLib.coq_expr -> GenericLib.coq_expr val set_incl_refl : GenericLib.coq_expr val _incl_subset : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val incl_refl : GenericLib.coq_expr val incl_hd_same : GenericLib.coq_expr -> GenericLib.coq_expr val incl_tl : GenericLib.coq_expr -> GenericLib.coq_expr val setU_set_eq_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val setU_set0_r : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val set_eq_trans : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val set_incl_trans : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val setU_set0_l : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val setU_set0_neut_eq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val eq_bigcupl : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val cons_set_eq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val singl_set_eq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_setU_l : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_set1 : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val subset_respects_set_eq_l : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val subset_respects_set_eq_r : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val subset_respects_set_eq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val subset_set_eq_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val incl_bigcupl : GenericLib.coq_expr -> GenericLib.coq_expr val incl_bigcup_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val imset_isSome : GenericLib.coq_expr -> GenericLib.coq_expr val isSomeSet : GenericLib.coq_expr -> GenericLib.coq_expr val incl_subset : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val setU_set_subset_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val setI_subset_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val nil_subset : GenericLib.coq_expr -> GenericLib.coq_expr val cons_subset : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val setI_set_incl : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val setI_set_eq_r : GenericLib.coq_expr -> GenericLib.coq_expr val setU_subset_r : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val setU_subset_l : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val imset_set0_incl : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val imset_singl_incl : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val imset_union_incl : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val imset_incl : GenericLib.coq_expr -> GenericLib.coq_expr val rewrite_set_r : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val rewrite_set_l : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val imset_bigcup_incl_l : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val set_eq_set_incl_r : GenericLib.coq_expr -> GenericLib.coq_expr val set_eq_set_incl_l : GenericLib.coq_expr -> GenericLib.coq_expr val in_imset : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val lift_union_compat : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val lift_subset_pres_r : GenericLib.coq_expr -> GenericLib.coq_expr val lift_subset_pres_l : GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_set0_subset : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_set_U : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_set_I_l : GenericLib.coq_expr -> GenericLib.coq_expr val set_incl_setI_l : GenericLib.coq_expr -> GenericLib.coq_expr val set_incl_setI_r : GenericLib.coq_expr -> GenericLib.coq_expr val set_incl_setU_l : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_cons_subset : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_cons_subset_r : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_setI_cons_subset_r : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val imset_bigcup_setI_cons_subset_r : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_nil_subset : GenericLib.coq_expr val isSome_subset : GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_cons_setI_subset_pres : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_cons_setI_subset_compat_backtrack : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_cons_setI_subset_compat_backtrack_weak : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_cons_setI_subset_pres_backtrack : GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_cons_setI_subset_pres_backtrack_weak : GenericLib.coq_expr -> GenericLib.coq_expr val bigcup_nil_setI : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val isSome_set_eq : GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr val set_eq_isSome_sound : GenericLib.coq_expr -> GenericLib.coq_expr val set_eq_isSome_complete : GenericLib.coq_expr -> GenericLib.coq_expr QuickChick-2.1.0/plugin/simplDriver.ml000066400000000000000000000134101476030541200176610ustar00rootroot00000000000000(* open Libnames *) open Util open Constrexpr open GenericLib (* open SizeUtils *) open Sized (* open SizeMon open SizeSMon open SizeCorr *) open EnumSized open ArbitrarySized type derivable = Shrink | Show | GenSized | Sized | EnumSized (* | CanonicalSized | SizeMonotonic | SizedMonotonic | SizedCorrect *) let derivable_to_string = function | Shrink -> "Shrink" | Show -> "Show" | GenSized -> "GenSized" | EnumSized -> "EnumSized" | Sized -> "Sized" (* | CanonicalSized -> "CanonicalSized" | SizeMonotonic -> "SizeMonotonic" | SizedMonotonic -> "SizedMonotonic" | SizedCorrect -> "SizedCorrect" *) let mk_instance_name der tn = let prefix = derivable_to_string der in let strip_last s = List.hd (List.rev (String.split_on_char '.' s)) in var_to_string (fresh_name (prefix ^ strip_last tn)) let repeat_instance_name der tn = let prefix = derivable_to_string der in let strip_last s = List.hd (List.rev (String.split_on_char '.' s)) in (prefix ^ strip_last tn) (* Generic derivation function *) let derive (cn : derivable) (c : constr_expr) (name1 : string) (name2 : string) = let dt = match coerce_reference_to_dt_rep c with | Some dt -> dt | None -> failwith "Not supported type" in let coqTyCtr = List.map (fun (ty_ctr, _, _) -> gTyCtr ty_ctr) dt in let coqTyParams = List.map (fun (_, ty_params, _) -> List.map gTyParam ty_params) dt in let full_dt = List.map2 (fun coqTyCtr coqTyParams -> gApp ~explicit:true coqTyCtr coqTyParams) coqTyCtr coqTyParams in (* let ind_name = match c with | { CAst.v = CRef (r, _); _ } -> string_of_qualid r | _ -> failwith "Implement me for functions" in *) let class_name = derivable_to_string cn in (* let size_config = { _ty_ctr = ty_ctr ; _ctrs = ctrs ; _coqTyCtr = coqTyCtr ; _coqTyParams = coqTyParams ; _full_dt = full_dt ; _isCurrentTyCtr = sameTypeCtr ty_ctr } in *) let param_class_names = match cn with | Sized -> ["Sized"] | Shrink -> ["Shrink"] | Show -> ["Show"] | GenSized -> ["Gen"] | EnumSized -> ["Enum"] (* | CanonicalSized -> ["CanonicalSized"] | SizeMonotonic -> ["GenMonotonic"] | SizedMonotonic -> ["Gen"] | SizedCorrect -> ["GenMonotonicCorrect"; "CanonicalSized"]*) in let extra_arguments = match cn with | Show -> [] | Shrink -> [] | Sized -> [] | GenSized -> [] | EnumSized -> [] (* | CanonicalSized -> [] | SizeMonotonic -> [(gInject "s", gInject "nat")] | SizedMonotonic -> [] | SizedCorrect -> [] *) in (* Generate typeclass constraints. For each type parameter "A" we need `{_ : A} *) let instance_arguments : (arg list) list = List.map (fun coqTyParams -> let params = List.concat @@ List.map (fun tp -> (gArg ~assumName:tp ~assumImplicit:true ()) :: (List.map (fun name -> gArg ~assumType:(gApp (gInject name) [tp]) ~assumGeneralized:true ()) param_class_names) ) coqTyParams in let args = List.map (fun (name, typ) -> gArg ~assumName:name ~assumType:typ ()) extra_arguments in (* Add extra instance arguments *) params @ args) coqTyParams in (* The instance type *) let instance_type full_dt iargs = (* match cn with | SizeMonotonic -> let (_, size) = take_last iargs [] in gApp ~explicit:true (gInject class_name) [full_dt; gApp (gInject ("arbitrarySized")) [gVar size]] | SizedMonotonic -> gApp ~explicit:true (gInject class_name) [full_dt; gInject ("arbitrarySized")] | SizedCorrect -> gApp ~explicit:true (gInject class_name) [full_dt; hole; gInject ("arbitrarySized")] | _ -> *) gApp (gInject class_name) [full_dt] in (* Create the instance record. Only need to extend this for extra instances *) let (instance_record, functions_to_mutually_define) : (ty_ctr -> var list -> coq_expr) * (var * arg list * var * coq_expr * coq_expr) list = (* Copying code for Arbitrary, Sized from derive.ml *) match cn with | Show -> show_decl dt | Shrink -> shrink_decl dt | GenSized -> arbitrarySized_decl dt | EnumSized -> enumSized_decl dt | Sized -> sized_decl dt (* | CanonicalSized -> let ind_scheme = gInject ((ty_ctr_to_string ty_ctr) ^ "_ind") in sizeEqType ty_ctr ctrs ind_scheme iargs | SizeMonotonic -> let (iargs', size) = take_last iargs [] in sizeMon size_config (gVar size) iargs' (gInject name1) | SizedMonotonic -> sizeSMon size_config iargs | SizedCorrect -> let s_inst = gInject (repeat_instance_name Sized ind_name) in let c_inst = gInject (repeat_instance_name CanonicalSized ind_name) in (* TODO : use default names for gen and mon as well (?) *) genCorr size_config iargs (gInject name1) s_inst c_inst (gInject name2) *) in define_new_fixpoint @@ List.map (fun ((function_name, arguments, arg, return_type, body), instance_arguments) -> let arguments = instance_arguments @ arguments in (function_name, arguments, arg, return_type, body)) (List.combine functions_to_mutually_define instance_arguments); let rec iter3 f l1 l2 l3 = match (l1, l2, l3) with | x1 :: l1, x2 :: l2, x3 :: l3 -> f x1 x2 x3; iter3 f l1 l2 l3 | [], [], [] -> () | _ -> raise (Invalid_argument "iter3") in iter3 (fun instance_arguments (ty_ctr, _, _) full_dt -> let ind_name = ty_ctr_to_string ty_ctr in let instance_name = mk_instance_name cn ind_name in declare_class_instance instance_arguments instance_name (instance_type full_dt) (instance_record ty_ctr)) instance_arguments dt full_dt QuickChick-2.1.0/plugin/simplDriver.mli000066400000000000000000000004651476030541200200400ustar00rootroot00000000000000type derivable = Shrink | Show | GenSized | Sized | EnumSized val derivable_to_string : derivable -> string val mk_instance_name : derivable -> string -> string val repeat_instance_name : derivable -> string -> string val derive : derivable -> Constrexpr.constr_expr -> string -> string -> unit QuickChick-2.1.0/plugin/sizeUtils.ml000066400000000000000000000015561476030541200173640ustar00rootroot00000000000000open GenericLib open GenLib open CoqLib type size_inputs = { _ty_ctr : ty_ctr ; _ctrs : ctr_rep list ; _coqTyCtr : coq_expr ; _coqTyParams : coq_expr list ; _full_dt : coq_expr ; _isCurrentTyCtr : coq_type -> bool } let gen_list (arg : size_inputs) size arb_body (ctr, ty) = let rec aux i acc ty : coq_expr = match ty with | Arrow (ty1, ty2) -> bindGen (if arg._isCurrentTyCtr ty1 then gApp arb_body [size] else gInject "arbitrary") (Printf.sprintf "p%d" i) (fun pi -> aux (i+1) ((gVar pi) :: acc) ty2) | _ -> returnGen (gApp ~explicit:true (gCtr ctr) (arg._coqTyParams @ List.rev acc)) in aux 0 [] ty let rec fst_leq_proof ctrs = match ctrs with | [] -> forall_nil (gProd hole hole) | _c :: ctrs -> forall_cons (gProd hole hole) ltnOSn_pair (fst_leq_proof ctrs) QuickChick-2.1.0/plugin/sizeUtils.mli000066400000000000000000000007051476030541200175300ustar00rootroot00000000000000type size_inputs = { _ty_ctr : GenericLib.ty_ctr; _ctrs : GenericLib.ctr_rep list; _coqTyCtr : GenericLib.coq_expr; _coqTyParams : GenericLib.coq_expr list; _full_dt : GenericLib.coq_expr; _isCurrentTyCtr : GenericLib.coq_type -> bool; } val gen_list : size_inputs -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.constructor * GenericLib.coq_type -> GenericLib.coq_expr val fst_leq_proof : 'a list -> GenericLib.coq_expr QuickChick-2.1.0/plugin/sized.ml000066400000000000000000000310121476030541200164750ustar00rootroot00000000000000open Pp open Util open GenericLib open SetLib open CoqLib open Feedback let sizeM = gInject "QuickChick.Classes.size" let succ_zero x = false_ind hole (succ_neq_zero_app hole x) let base_ctrs ty_ctr ctrs = List.filter (fun (_, ty) -> isBaseBranch ty_ctr ty) ctrs (* Produces the record of the sized typeclass *) let sized_decl (types : (ty_ctr * ty_param list * ctr_rep list) list) : (ty_ctr -> var list -> coq_expr) * ((var * arg list * var * coq_expr * coq_expr) list) = let impl_function_names : (ty_ctr * var) list = List.map (fun (ty, _, _) -> let type_name = ty_ctr_to_string ty in let function_name = fresh_name ("size_impl_" ^ type_name) in (ty, function_name) ) types in let generate_size_function ((ty, ty_params, ctors) : (ty_ctr * ty_param list * ctr_rep list)) : var * arg list * var * coq_expr * coq_expr = let function_name = List.assoc ty impl_function_names in let coqTyParams = List.map gTyParam ty_params in let full_type = gApp ~explicit:true (gTyCtr ty) coqTyParams in let arg = fresh_name "x" in let arg_type = full_type in let return_type = gInject "Coq.Init.Datatypes.nat" in let is_current_ty_crt = function | TyCtr (ty_ctr', _) -> ty = ty_ctr' | _ -> false in (* Note: the size of an object do not take into consideration the size of other objetcts it might contain, besides objects of its own type. So actually we don't even need a fixpoint... but for now, we'll create one anyway for simplicity. *) let is_base_branch ty = fold_ty' (fun b ty' -> b && not (is_current_ty_crt ty')) true ty in let create_branch (ctr, ty) = ( ctr, generate_names_from_type "p" ty, if is_base_branch ty then fun _ -> gInt 0 else fun vs -> let opts = fold_ty_vars (fun _ v ty' -> if is_current_ty_crt ty' then [ gApp (gVar function_name) [gVar v] ] else [] ) (fun l1 l2 -> l1 @ l2) [] ty vs in gApp (gInject "S") [maximum opts] ) in let body = gMatch (gVar arg) (List.map create_branch ctors) in debug_coq_expr body; (function_name, [gArg ~assumName:(gVar arg) ~assumType:arg_type ()], arg, return_type, body) in let functions = List.map generate_size_function types in (* returns {| size := size_impl_... |} *) let instance_record ty_ctr _ivars : coq_expr = let impl_function_name = List.assoc ty_ctr impl_function_names in gRecord [("size", gVar impl_function_name)] in (instance_record, functions) let rec gen_args cty c_ctr n = match cty with | Arrow (ty1, ty2) -> if sameTypeCtr c_ctr ty1 then let x = Printf.sprintf "x%d" n in let ih = Printf.sprintf "IHx%d" n in let (args, ihargs) = gen_args ty2 c_ctr (n+1) in (x :: args, x :: ih :: ihargs) else let x = Printf.sprintf "x%d" n in let (args, ihargs) = gen_args ty2 c_ctr (n+1) in (x :: args, x :: ihargs) | _ -> ([], []) let rec dropIH cty ty_ctr l = match cty with | Arrow (ty1, ty2) -> (if sameTypeCtr ty_ctr ty1 then match l with | x :: _ihx :: l -> let (l1, l2) = dropIH ty2 ty_ctr l in (x :: l1, x :: l2) | _ -> failwith "Internal: Wrong number of arguments" else match l with | x :: l -> let (l1, l2) = dropIH ty2 ty_ctr l in (x :: l1, l2) | _ -> failwith "Internal: Wrong number of arguments") | _ -> ([], []) let zeroEqProof ty_ctr ctrs (ind_scheme : coq_expr) size zeroType zeroSized iargs = if List.is_empty ctrs then failwith "zeroEqProof call with no ctrs" else (); (* Common helpers, refactor? *) let coqTyCtr = gTyCtr ty_ctr in let coqTyParams = List.map gVar (list_drop_every 2 iargs) in let _full_dt = gApp ~explicit:true coqTyCtr coqTyParams in let base_ctrs = base_ctrs ty_ctr ctrs in let rec elim_set h ty n = match ty with | Arrow (_ty1, ty2) -> let w' = Printf.sprintf "x%d" n in let hw' = Printf.sprintf "Hx%d" n in let hc1 = Printf.sprintf "Hl%d" n in let hc2 = Printf.sprintf "Hr%d" n in gMatch (gVar h) [(injectCtr "ex_intro", [w'; hw'], fun [_w'; hw'] -> gMatch (gVar hw') [(injectCtr "conj", [hc1; hc2], fun [_hc1; hc2] -> elim_set hc2 ty2 (n+1) )] )] [@ocaml.warning "-8"] | _ -> discriminate (gVar h) in let rec elim_unions h ctrs = match ctrs with | [(_ctr, ty)] -> elim_set h ty 0 | (_ctr, ty) :: ctrs' -> gMatch (gVar h) [(injectCtr "or_introl", ["H1"], fun [h1] -> elim_set h1 ty 0); (injectCtr "or_intror", ["H1"], fun [h1] -> elim_unions h1 ctrs')] in let rec intro_set ty ctr_args ctr acc = match ty with | Arrow (_ty1, ty2) -> (match ctr_args with | arg :: ctr_args' -> gExIntro_impl arg (gConjIntro gI (intro_set ty2 ctr_args' ctr (arg :: acc))) | [] -> failwith "Internal: wrong number of arguments") | _ -> gEqRefl hole (* (gApp ~explicit:true (gCtr ctr) (coqTyParams @ List.rev acc)) *) in let rec intro_unions ctrs args curr_ctr = match ctrs with | [(ctr, ty)] -> if ctr = curr_ctr then intro_set ty args ctr [] else failwith "Internal: cannot find constructor" | (ctr, ty) :: ctrs' -> if ctr = curr_ctr then gOrIntroL (intro_set ty args ctr []) else gOrIntroR (intro_unions ctrs' args curr_ctr) in let create_case (ctr, ty) = let (_, iargs) = gen_args ty ty_ctr 0 in gFun iargs (fun iargs -> let (args, _) = dropIH ty ty_ctr iargs in let elem = gApp ~explicit:true (gCtr ctr) (coqTyParams @ (List.map gVar args)) in let lhs = gApp zeroSized [elem] in let rhs = gEq (gApp size [elem]) (gInt 0) in if isBaseBranch ty_ctr ty then gConjIntro (gFunTyped [("H1", lhs)] (fun [_h1] -> gEqRefl hole)) (gFunTyped [("H1", rhs)] (fun [_h1] -> intro_unions base_ctrs (List.map gVar args) ctr)) else gConjIntro (gFunTyped [("H1", lhs)] (fun [h1] -> elim_unions h1 base_ctrs)) (gFunTyped [("H1", rhs)] (fun [h1] -> succ_zero (gVar h1)))) in let proofs = List.map create_case ctrs in gApp ~explicit:true ind_scheme (coqTyParams @ (zeroType :: proofs)) let succEqProof ty_ctr ctrs (ind_scheme : coq_expr) succType succSized iargs = (* Common helpers, refactor? *) let coqTyCtr = gTyCtr ty_ctr in let coqTyParams = List.map gVar (list_drop_every 2 iargs) in let full_dt = gApp ~explicit:true coqTyCtr coqTyParams in let _base_ctrs = base_ctrs ty_ctr ctrs in let rec elim_set h leq ty n f ctr_flag size = match ty with | Arrow (ty1, ty2) -> let w' = Printf.sprintf "x%d" n in let hw' = Printf.sprintf "Hx%d" n in let hc1 = Printf.sprintf "Hl%d" n in let hc2 = Printf.sprintf "Hr%d" n in gMatch (gVar h) [(injectCtr "ex_intro", [w'; hw'], fun [_w'; hw'] -> gMatch (gVar hw') [(injectCtr "conj", [hc1; hc2], fun [hc1; hc2] -> let leq' = if sameTypeCtr ty_ctr ty1 then (gVar hc1) :: leq else leq in elim_set hc2 leq' ty2 (n+1) f ctr_flag size )] )] | _ -> if ctr_flag then let rec leq_proof = function | [h] -> h | h :: hs -> gApp (gInject "max_lub_ssr") [hole; hole; gSucc (gVar size); h; leq_proof hs] in gMatch (gVar h) [(injectCtr "erefl", [], fun [] -> leq_proof (List.rev leq))] else discriminate (gVar h) in let rec elim_unions h ctrs curr_ctr size = match ctrs with | [(ctr, ty)] -> elim_set h [] ty 0 (fun x -> x) (curr_ctr = ctr) size | (ctr, ty) :: ctrs' -> gMatch (gVar h) [(injectCtr "or_introl", ["H1"], fun [h1] -> elim_set h1 [] ty 0 (fun x -> x) (curr_ctr = ctr) size); (injectCtr "or_intror", ["H1"], fun [h1] -> elim_unions h1 ctrs' curr_ctr size)] in let rec intro_set leq ty ctr_args iargs ctr acc = match ty with | Arrow (ty1, ty2) -> (match ctr_args with | arg :: ctr_args' -> let (leq_l, leq_r, iargs') = if sameTypeCtr ty_ctr ty1 then (match iargs with | [_arg] -> (leq, leq, []) | _arg :: args -> (gApp (gInject "max_lub_l_ssr") [hole; hole; hole; leq], gApp (gInject "max_lub_r_ssr") [hole; hole; hole; leq], args)) else (gI, leq, iargs) in gExIntro_impl arg (gConjIntro leq_l (intro_set leq_r ty2 ctr_args' iargs' ctr (arg :: acc))) | [] -> failwith "Internal: wrong number of arguments") | _ -> gEqRefl (gApp ~explicit:true (gCtr ctr) (coqTyParams @ List.rev acc)) in let rec intro_unions h ctrs args ihargs curr_ctr = match ctrs with | [(ctr, ty)] -> if ctr = curr_ctr then intro_set (gVar h) ty args ihargs ctr [] else failwith "Internal: cannot find constructor" | (ctr, ty) :: ctrs' -> if ctr = curr_ctr then gOrIntroL (intro_set (gVar h) ty args ihargs ctr []) else gOrIntroR (intro_unions h ctrs' args ihargs curr_ctr) in let create_case size (ctr, ty) = let (_, iargs) = gen_args ty ty_ctr 0 in gFun iargs (fun iargs -> let (args, ihargs) = dropIH ty ty_ctr iargs in let elem = gApp ~explicit:true (gCtr ctr) (coqTyParams @ (List.map gVar args)) in let leq_size size = set_suchThat "x" full_dt (fun x -> gle (gApp sizeM [gVar x]) size) in let lhs = gApp (gApp succSized [(leq_size (gVar size))]) [elem] in let rhs = gApp (leq_size (gSucc (gVar size))) [elem] in if isBaseBranch ty_ctr ty then gConjIntro (gFunTyped [("H1", lhs)] (fun [_h1] -> gApp (gInject "leq0n") [hole])) (gFunTyped [("H1", rhs)] (fun [h1] -> intro_unions h1 ctrs (List.map gVar args) ihargs ctr)) else gConjIntro (gFunTyped [("H1", lhs)] (fun [h1] -> elim_unions h1 ctrs ctr size)) (gFunTyped [("H1", rhs)] (fun [h1] -> intro_unions h1 ctrs (List.map gVar args) ihargs ctr))) in let proofs size = List.map (create_case size) ctrs in gFun ["size"] (fun [size] -> gApp ~explicit:true ind_scheme (coqTyParams @ ((succType size) :: (proofs size)))) let sizeEqType ty_ctr ctrs ind_scheme iargs = (* Common helpers, refactor? *) let coqTyCtr = gTyCtr ty_ctr in let coqTyParams = List.map gVar (list_drop_every 2 iargs) in let full_dt = gApp ~explicit:true coqTyCtr coqTyParams in let bases = base_ctrs ty_ctr ctrs in (* Second reverse fold necessary *) let create_branch set tps (ctr,ty) = let rec aux i acc ty : coq_expr = match ty with | Arrow (ty1, ty2) -> let fi = Printf.sprintf "f%d" i in set_bigcup fi (if sameTypeCtr ty_ctr ty1 then set else gFun [fi] (fun _ -> gInject "True")) (fun f -> aux (i+1) (f::acc) ty2) | _ -> set_singleton (gApp ~explicit:true (gCtr ctr) (tps @ (List.map gVar (List.rev acc)))) in aux 0 [] ty in let lhs set ctrs = set_unions (List.map (create_branch set coqTyParams) ctrs) in let rhs size = set_suchThat "x" full_dt (fun x -> gEq (gApp sizeM [gVar x]) size) in let zeroSized = lhs hole bases in let succSized = gFunWithArgs [gArg ~assumName:(gInject "set") ()] (fun [set] -> lhs (gVar set) ctrs) in let zeroType = gFun ["f"] (fun [f] -> gIff (gApp zeroSized [gVar f]) (gApp (rhs (gInt 0)) [gVar f])) in let set_leq size = set_suchThat "x" full_dt (fun x -> gle (gApp sizeM [gVar x]) size) in let succType size = gFun ["f"] (fun [f] -> gIff (gApp (gApp succSized [set_leq (gVar size)]) [gVar f]) (gApp (set_leq (gSucc (gVar size))) [gVar f])) in let zeroSized_spec = zeroEqProof ty_ctr ctrs ind_scheme sizeM zeroType zeroSized iargs in let succSized_spec = succEqProof ty_ctr ctrs ind_scheme succType succSized iargs in msg_debug (str "zeroSized"); debug_coq_expr zeroSized; msg_debug (str "succSized"); debug_coq_expr succSized; msg_debug (str "zeroSized_spec"); debug_coq_expr zeroSized_spec; debug_coq_expr succSized_spec; gRecord [("zeroSized", zeroSized); ("succSized", succSized); ("zeroSized_spec", zeroSized_spec); ("succSized_spec", succSized_spec)] QuickChick-2.1.0/plugin/sized.mli000066400000000000000000000024261476030541200166550ustar00rootroot00000000000000val sizeM : GenericLib.coq_expr val succ_zero : GenericLib.coq_expr -> GenericLib.coq_expr val base_ctrs : GenericLib.ty_ctr -> ('a * GenericLib.coq_type) list -> ('a * GenericLib.coq_type) list val sized_decl : (GenericLib.ty_ctr * GenericLib.ty_param list * GenericLib.ctr_rep list) list -> (GenericLib.ty_ctr -> GenericLib.var list -> GenericLib.coq_expr) * ((GenericLib.var * GenericLib.arg list * GenericLib.var * GenericLib.coq_expr * GenericLib.coq_expr) list) val gen_args : GenericLib.coq_type -> GenericLib.ty_ctr -> int -> string list * string list val dropIH : GenericLib.coq_type -> GenericLib.ty_ctr -> 'a list -> 'a list * 'a list val zeroEqProof : GenericLib.ty_ctr -> (GenericLib.constructor * GenericLib.coq_type) list -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.var list -> GenericLib.coq_expr val succEqProof : GenericLib.ty_ctr -> (GenericLib.constructor * GenericLib.coq_type) list -> GenericLib.coq_expr -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr -> GenericLib.var list -> GenericLib.coq_expr val sizeEqType : GenericLib.ty_ctr -> (GenericLib.constructor * GenericLib.coq_type) list -> GenericLib.coq_expr -> GenericLib.var list -> GenericLib.coq_expr QuickChick-2.1.0/plugin/tactic_quickchick.mlg.cppo000066400000000000000000000241601476030541200221410ustar00rootroot00000000000000{ (* THIS FILE IS PREPROCESSED USING cppo MAKE SURE TO EDIT THE .cppo SOURCE OF THIS FILE RATHER THAN THE GENERATED RESULT *) open Ltac_plugin open Error open Pp open Stdarg } DECLARE PLUGIN "coq-quickchick.plugin" { let merge_sound = let rec get_hyps (s : Evd.evar_map) (c : EConstr.constr) = if EConstr.isProd s c then let (x,t1,t2) = EConstr.destProd s c in (x,t1) :: get_hyps s t2 else [] in Proofview.Goal.enter begin fun gl -> let c = Proofview.Goal.concl gl in let s = Proofview.Goal.sigma gl in let to_intro = get_hyps s c in let rec calc_ids acc opts = match opts with | [] -> begin match acc with | to_ind::rest -> (to_ind, List.rev acc) | _ -> failwith "No product/merge_sound" end | (nb,_) :: nbs -> begin match Context.binder_name nb with | Names.Name id -> calc_ids (id :: acc) nbs | Names.Anonymous -> calc_ids (Names.Id.of_string "H" :: acc) nbs end in match calc_ids [] to_intro with | (_to_induct, opts) -> Tactics.intros_using_then opts (fun ids -> Tacticals.tclTHENLIST [ Tacticals.onLastHyp Tactics.simplest_elim ; Tactics.intros ]) end;; let remember_induct h = Proofview.Goal.enter begin fun gl -> let s = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let cn = EConstr.mkVar h in Tacticals.tclTYPEOFTHEN cn (fun evm ct -> msg_debug (str "Here: " ++ Printer.pr_constr_env env s (EConstr.to_constr s ct) ++ fnl()); let to_remember = if EConstr.isApp s ct then begin let (ctr, cs) = EConstr.destApp s ct in let to_remember = ref [] in Array.iter (fun cx -> if EConstr.isApp s cx then to_remember := cx :: !to_remember else if EConstr.isConstruct s cx then to_remember := cx :: !to_remember else msg_debug (str "All good" ++ fnl ())) cs; !to_remember end else failwith "Not App" in let eqpat = CAst.make @@ Namegen.IntroAnonymous in let cl = { Locus.onhyps = None ; Locus.concl_occs = Locus.AllOccurrences } in let rec do_remembers (pats : EConstr.constr list) = match pats with | [] -> #if COQ_VERSION >= (8, 19, 0) Induction.induction false None cn None None #else Tactics.induction false None cn None None #endif | p :: ps -> Tacticals.tclTHEN #if COQ_VERSION >= (8, 18, 0) (Tactics.letin_pat_tac false (Some (true, eqpat)) (Names.Name.Anonymous) (Some s, p) cl) #else (Tactics.letin_pat_tac false (Some (true, eqpat)) (Names.Name.Anonymous) (s, p) cl) #endif (do_remembers ps) in msg_debug (int (List.length to_remember) ++ fnl ()); do_remembers to_remember ) end let quickchick_goal = Proofview.Goal.enter begin fun gl -> (* Convert goal to a constr_expr *) let c = Proofview.Goal.concl gl in let e = Proofview.Goal.env gl in let evd = Evd.from_env e in (* (* Make an evar with the goal as the type *) let evd, evar = Evarutil.new_pure_evar (Environ.named_context_val e) evd c in (* Externalize it *) #if COQ_VERSION >= (8, 17, 0) let ct = Constrextern.extern_constr e evd (EConstr.mkEvar (evar, SList.empty)) in #else let ct = Constrextern.extern_constr e evd (EConstr.mkEvar (evar, [])) in #endif *) match GenericLib.parse_dependent_type (EConstr.to_constr evd c) with | Some dt -> begin msg_debug (str (GenericLib.dep_type_to_string dt) ++ fnl ()); let open GenericLib in let decide prop = decOptToBool (g_decOpt prop (gInt 1000)) in let rec mkProperty = function | DProd ((var, _),body) -> g_forAll g_arbitrary (gFun [var_to_string var] (fun [_] -> mkProperty body )) | DArrow (x,y) -> GenericLib.debug_coq_expr (gType' [] x); gIf (decide (gType' [] x)) (mkProperty y) (g_checker gTT) | p -> g_checker (decide (gType' [] p)) in (* | DArrow (DTyCtr (tyctr, args), y) -> gIf (decide ) | DTyParam typaram -> gTyParam typaram | DTyCtr (tyctr, args) -> gApp (gTyCtr tyctr) (List.map mkProperty args) | DCtr (ctr, args) -> gApp (gCtr ctr) (List.map mkProperty args) | DTyVar var -> gVar var | DApp (f, args) -> gApp (mkProperty f) (List.map mkProperty args) | DNot p -> *) (*Use decOpt, for every arrow, assume instacne exists and match on it *) GenericLib.debug_coq_expr (mkProperty dt); (*run the generator called checker using QuickCheck.*) (*failwith "OUch!";*) let to_run = GenericLib.interp_open_coq_expr e evd (g_show (g_quickCheck (mkProperty dt))) in (*failwith "Oucher!";*) #if COQ_VERSION >= (8, 20, 0) (* FRAGILE probably won't be allowed in the future? *) let opaque_access = Library.indirect_accessor[@@warning "-3"] in QuickChick.define_and_run ~opaque_access to_run e evd; #else QuickChick.define_and_run to_run e evd; #endif Tacticals.tclIDTAC end | None -> failwith "Failed to Parse type" end (*Create dependency graph, anything that lacks a dependency, print becuase we need it to *) (* (* Make an evar with the goal as the type *) let evd, evar = Evarutil.new_pure_evar (Environ.named_context_val e) evd c in Printf.printf "So far so good\n"; flush stdout; (* Externalize it *) #if COQ_VERSION >= (8, 17, 0) let ct = Constrextern.extern_constr e evd (EConstr.mkEvar (evar, SList.empty)) in #else let ct = Constrextern.extern_constr e evd (EConstr.mkEvar (evar, [])) in #endif (* Construct : show (quickCheck (_ : ct)) *) let qct = CAst.make @@ Constrexpr.CApp (QuickChick.quickCheck, [ct, None]) in let sqct = CAst.make @@ Constrexpr.CApp (QuickChick.show, [(qct,None)]) in Printf.printf "So far so good2\n"; flush stdout; (* From here on I've tried a couple of things. Calling run_test directly with qct. Fails. Internalize here before calling define and run, fails. It always seems to fail in the 'interp' phase, with an unknown existential variable error. So I'm probably doing something stupid with the evar maps *) let evd, to_run = Constrintern.interp_open_constr e evd sqct in Printf.printf "So far so good 2.5\n"; flush stdout; QuickChick.define_and_run to_run e evd; Printf.printf "So far so good3\n"; flush stdout; (* TODO: This whole block doesn't look very monadic... *) Tacticals.tclIDTAC end (* (* Admit a constant with that type *) let tmpid = QuickChick.fresh_name "temporary_constant" in let _interp_st = Vernacentries.interp (CAst.make @@ Vernacexpr.VernacExpr ([], (* TODO: NoDischarge or DoDischarge? *) Vernacexpr.VernacAssumption ((NoDischarge, Decl_kinds.Conjectural), NoInline, [ (false, ( [CAst.make tmpid, None] , ct ) ) ] ))) in let s = QuickChick.runTest @@ CAst.make @@ Constrexpr.CApp (QuickChick.quickCheck, [CAst.make @@ CRef (Libnames.qualid_of_ident tmpid,None), None]) in (* I need to create an existential of type Checkable ct, and then call QuickChick.quickChick on that in the ast, before running QuickChick.runTest on the constr_expr. *) (* HACK (there *has* to be a better way): (\x : Checkable ct -> x) _ *) let base = Names.Id.of_string "x" in let is_visible_name id = try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true with Not_found -> false in (** Safe fresh name generation. *) let xid = Namegen.next_ident_away_from base is_visible_name in let binder_list = [CLocalAssum ([CAst.make @@ Names.Name xid], Default Explicit, ct)] in let f_body = CAst.make @@ CRef (CAst.make @@ Libnames.Ident xid,None) in let f = mkCLambdaN binder_list f_body in let hack_value = mkAppC (f , [ CAst.make @@ CEVarHole (None, Misctypes.IntroAnonymous, None) ] ) in *) (* (* Refactor - needs to see internals... *) let base = Names.id_of_string "x" in let is_visible_name id = try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true with Not_found -> false in (** Safe fresh name generation. *) let xid = Namegen.next_ident_away_from base is_visible_name in let f_body = mkAppC (QuickChick.show, [mkAppC (QuickChick.quickCheck, [mkAppC (QuickChick.mk_ref "checker", [ CRef (Ident ((Loc.dummy_loc, xid)),None) ])])]) in let f = mkCLambdaN Loc.dummy_loc bind_list f_body in let env = Global.env () in let evd = Evd.from_env env in let (cf,evd) = Constrintern.interp_constr env evd f in let actual_term = Constr.mkApp (cf, Array.of_list [c]) in *) (* let concl = Proofview.Goal.concl gl in let sigma = Tacmach.project gl in let hyps = named_context_val (Proofview.Goal.env gl) in let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in let () = if check && mem_named_context_val id hyps then errorlabstrm "Tactics.introduction" (str "Variable " ++ pr_id id ++ str " is already declared.") in match kind_of_term (whd_evar sigma concl) with | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b | _ -> raise (RefinerError IntroNeedsProduct) end *) *) } TACTIC EXTEND quickchick | ["quickchick"] -> { quickchick_goal } END TACTIC EXTEND merge_sound_core | ["merge_sound_core"] -> { merge_sound } END TACTIC EXTEND remember_induct | ["remember_induct" ident(h)] -> { remember_induct h } END QuickChick-2.1.0/plugin/tactic_quickchick.mli000066400000000000000000000000001476030541200211660ustar00rootroot00000000000000QuickChick-2.1.0/plugin/unifyQC.ml.cppo000066400000000000000000002360061476030541200177070ustar00rootroot00000000000000open Pp open Util open GenericLib open Error (* TODO : move to utils or smth *) type name_provider = { next_name : unit -> string } let mk_name_provider s = let cnt = ref 0 in { next_name = fun () -> let res = Printf.sprintf "%s_%d_" s !cnt in incr cnt; res } (* Ranges are undefined, unknowns or constructors applied to ranges *) module Unknown = struct type t = var let to_string = var_to_string let from_string x = fresh_name x let from_var x = x let from_id x = var_of_id x let undefined = var_of_id (Names.Id.of_string_soft "I@reallywantundefinedherebutwedonthavelaziness") end module UnknownOrd = struct type t = Unknown.t let compare x y = compare (Unknown.to_string x) (Unknown.to_string y) end type unknown = Unknown.t type range = Ctr of constructor * range list | Unknown of unknown | Undef of dep_type | FixedInput | Parameter of ty_param | RangeHole let is_parameter r = match r with | Parameter _ -> true | _ -> false let rec range_to_string = function | Ctr (c, rs) -> constructor_to_string c ^ " " ^ str_lst_to_string " " (List.map range_to_string rs) | Unknown u -> Unknown.to_string u | Undef dt -> Printf.sprintf "Undef (%s)" (dep_type_to_string dt) | FixedInput -> "FixedInput" | RangeHole -> "_" | Parameter p -> ty_param_to_string p let ranges_to_string rs = String.concat " " (List.map range_to_string rs) let rec matcher_pat_to_range m = match m with | MatchCtr (c,ms) -> Ctr (c, List.map matcher_pat_to_range ms) | MatchU u -> Unknown u | MatchParameter p -> Parameter p module UM = Map.Make(UnknownOrd) (* module US = Set.Make(UnknownOrd) *) (* Maps unknowns to range *) type umap = range UM.t let umfind k m = try UM.find k m with Not_found -> CErrors.user_err (str (Printf.sprintf "Can't find: %s" (Unknown.to_string k)) ++ fnl()) let lookup (k : unknown) (m : umap) = try Some (UM.find k m) with Not_found -> None (* For equality handling: require ordered (String, String) *) module OrdTSS = struct type t = unknown * unknown let compare x y = compare x y end module EqSet = Set.Make(OrdTSS) let eq_set_add u1 u2 eqs = let (u1', u2') = if u1 < u2 then (u1, u2) else (u2, u1) in EqSet.add (u1', u2') eqs module OrdTyp = struct type t = dep_type let compare = compare end module ArbSet = Set.Make(OrdTyp) type unknown_provider = { next_unknown : unit -> Unknown.t } let unk_provider = let np = mk_name_provider "unkn" in { next_unknown = fun () -> Unknown.from_string (np.next_name ()) } (* Match a constructor/ranges list to a fixed input *) (* Range list is toplevel, so it's mostly unifications. If any of the unknowns in rs is "FixedInput", then we need to create a fresh unknown, bind it to the other unknown and raise an equality check *) let rec raiseMatch (k : umap) (c : constructor) (rs : range list) (eqs: EqSet.t) : (umap * matcher_pat * EqSet.t) option = (foldM (fun (k, l, eqs) r -> match r with | Ctr (c', rs') -> raiseMatch k c' rs' eqs >>= fun (k', m, eqs') -> Some (k', m::l, eqs') | Unknown u -> let rec go u = lookup u k >>= fun r' -> begin match r' with | Undef _ -> (* The unknown should now be fixed *) Some (UM.add u FixedInput k, (MatchU u)::l, eqs) | FixedInput -> (* The unknown is already fixed, raise an eq check *) let u' = unk_provider.next_unknown () in Some (UM.add u' (Unknown u) k, (MatchU u')::l, eq_set_add u' u eqs) | Ctr (c', rs') -> raiseMatch k c' rs' eqs >>= fun (k', m, eqs') -> Some (k', m :: l, eqs') | Unknown u' -> go u' | RangeHole -> failwith "Internal: RangeHoles should not appear past entry" | Parameter _p -> failwith "QC Internal: Does this occur (Parameter in match)?" end in go u | Parameter p -> Some (k, MatchParameter p :: l, eqs) | _ -> failwith "Toplevel ranges should be Unknowns or constructors" ) (Some (k, [], eqs)) rs) >>= fun (k', l, eqs') -> Some (k', MatchCtr (c, List.rev l), eqs') (* Invariants: -- Everything has a binding, even if just Undef -- r1, r2 are never FixedInput, Undef (handled inline) -- TopLevel ranges can be unknowns or constructors applied to toplevel ranges -- Constructor bindings in umaps are also toplevel. -- Only unknowns can be bound to Undef/FixedInput *) let rec unify (k : umap) (r1 : range) (r2 : range) (eqs : EqSet.t) : (umap * range * EqSet.t * (unknown * matcher_pat) list) option = msg_debug (str (Printf.sprintf "Calling unify with %s %s" (range_to_string r1) (range_to_string r2)) ++ fnl ()); match r1, r2 with | Unknown u1, Unknown u2 -> if u1 = u2 then Some (k, Unknown u1, eqs, []) else lookup u1 k >>= fun r1 -> lookup u2 k >>= fun r2 -> msg_debug (str (Printf.sprintf "Unifying two unknowns with ranges: %s %s" (range_to_string r1) (range_to_string r2)) ++ fnl ()); begin match r1, r2 with (* "Delay" cases - unknowns call unify again *) (* TODO: rething return value *) | Unknown u1', _ -> unify k (Unknown u1') (Unknown u2) eqs >>= fun (k', _r', eqs', ms') -> Some (k', Unknown u1, eqs', ms') | _, Unknown u2' -> unify k (Unknown u1) (Unknown u2') eqs >>= fun (k', _r', eqs', ms') -> Some (k', Unknown u2, eqs', ms') (* "Hard" case: both are fixed. Need to raise an equality check on the inputs *) | FixedInput, FixedInput -> let (u1', u2') = if u1 < u2 then (u1, u2) else (u2, u1) in (* Need to insert an equality between u1 and u2 *) let eqs' = EqSet.add (u1, u2) eqs in (* Unify them in k *) Some (UM.add u1' (Unknown u2') k, Unknown u1', eqs', []) (* Easy cases: When at least one is undefined, it binds to the other *) (* Can probably replace fixed input with _ *) | Undef _ , Undef _ -> let (u1', u2') = if u1 < u2 then (u1, u2) else (u2, u1) in Some (UM.add u1' (Unknown u2') k, Unknown u1', eqs, []) | _, Undef _ -> Some (UM.add u2 (Unknown u1) k, Unknown u2, eqs, []) | Undef _, _ -> Some (UM.add u1 (Unknown u2) k, Unknown u1, eqs, []) (* Constructor bindings *) | Ctr (c1, rs1), Ctr (c2, rs2) -> msg_debug (str (Printf.sprintf "Constructors: %s - %s\n" (String.concat " " (List.map range_to_string rs1)) (String.concat " " (List.map range_to_string rs2))) ++ fnl ()); if c1 = c2 then foldM (fun b a -> let (r1, r2) = a in let (k, l, eqs, ms) = b in unify k r1 r2 eqs >>= fun res -> let (k', r', eqs', ms') = res in Some (k', r'::l, eqs', ms @ ms') ) (Some (k, [], eqs, [])) (List.combine rs1 rs2) >>= fun (k', rs', eqs', ms) -> Some (k', Ctr (c1, List.rev rs'), eqs', ms) else None (* Last hard cases: Constructors vs fixed *) | FixedInput, Ctr (c, rs) -> (* Raises a match and potential equalities *) raiseMatch k c rs eqs >>= fun (k', m, eqs') -> Some (UM.add u1 (Unknown u2) k', Unknown u1, eqs', [(u1, m)]) | Ctr (c, rs), FixedInput -> (* Raises a match and potential equalities *) raiseMatch k c rs eqs >>= fun (k', m, eqs') -> Some (UM.add u2 (Unknown u1) k', Unknown u2, eqs', [(u2, m)]) | Parameter p, Parameter q -> if p = q then Some (k, Parameter p, eqs, []) else None | _ -> failwith "QC Internal: RangeHole/Parameter in unify" end | Ctr (c1, rs1), Ctr (c2, rs2) -> msg_debug (str (Printf.sprintf "Constructors2: %s - %s\n" (String.concat " " (List.map range_to_string rs1)) (String.concat " " (List.map range_to_string rs2))) ++ fnl ()); if c1 = c2 then foldM (fun b a -> let (r1, r2) = a in let (k, l, eqs, ms) = b in unify k r1 r2 eqs >>= fun res -> let (k', r', eqs', ms') = res in Some (k', r'::l, eqs', ms @ ms') ) (Some (k, [], eqs, [])) (List.combine rs1 rs2) >>= fun (k', rs', eqs', ms) -> Some (k', Ctr (c1, List.rev rs'), eqs', ms) else None | Unknown u, Ctr (c, rs) | Ctr (c, rs), Unknown u -> lookup u k >>= fun r -> begin match r with | FixedInput -> (* Raises a match and potential equalities *) raiseMatch k c rs eqs >>= fun (k', m, eqs') -> Some (UM.add u (Ctr (c,rs)) k', Unknown u, eqs', [(u, m)]) | Undef _ -> Some (UM.add u (Ctr (c,rs)) k, Unknown u, eqs, []) | Ctr (c', rs') -> msg_debug (str (Printf.sprintf "Constructors3: %s \n" (String.concat " " (List.map range_to_string rs'))) ++ fnl ()); if c = c' then foldM (fun b a -> let (r1, r2) = a in let (k, l, eqs, ms) = b in unify k r1 r2 eqs >>= fun res -> let (k', r', eqs', ms') = res in Some (k', r'::l, eqs', ms @ ms') ) (Some (k, [], eqs, [])) (List.combine rs rs') >>= fun (k', _rs', eqs', ms) -> Some (k', Unknown u, eqs', ms) else None | Unknown u' -> unify k (Ctr (c,rs)) (Unknown u') eqs >>= fun (k', _r', eqs', m') -> Some (k', Unknown u, eqs', m') | _ -> failwith "QC Internal: Range Hole in toplevel?" end | Parameter p, Parameter q -> if p = q then Some (k, Parameter p, eqs, []) else None | _, _ -> failwith "QC Internal: TopLevel ranges should be Unknowns or Constructors" let rec fixRange u r k = match r with | FixedInput -> k | Undef _ -> UM.add u FixedInput k | Unknown u' -> begin try fixRange u' (UM.find u' k) k with Not_found -> UM.add u' FixedInput k end | Ctr (_, rs) -> List.fold_left (fun k r -> fixRange Unknown.undefined r k) k rs | Parameter _p -> k | RangeHole -> failwith "QC Internal: RangeHole in fixrange" let fixVariable x k = try fixRange x (UM.find x k) k with Not_found -> UM.add x FixedInput k (* Since this can fail - return an option *) let rec convert_to_range dt = match dt with | DTyVar x -> Some (Unknown x) | DCtr (c,dts) -> option_map (fun dts' -> Ctr (c, dts')) (sequenceM convert_to_range dts) | DTyCtr (c, dts) -> option_map (fun dts' -> Ctr (ty_ctr_to_ctr c, dts')) (sequenceM convert_to_range dts) | DTyParam param -> Some (Parameter param) | DHole -> Some RangeHole | _ -> None let rec is_fixed_range k = function | Undef _ -> false | FixedInput -> true | Unknown u' -> is_fixed_range k (umfind u' k) | Ctr (_, rs) -> List.for_all (is_fixed_range k) rs | RangeHole -> true (*TODO *) | Parameter _ -> true (* TODO *) let is_fixed k dt = option_map (is_fixed_range k) (convert_to_range dt) (* convert a range to a coq expression *) let rec range_to_coq_expr k r = match r with | Ctr (c, rs) -> gApp ~explicit:true (gCtr c) (List.map (range_to_coq_expr k) rs) | Unknown u -> begin match umfind u k with | FixedInput -> gVar u | Undef _ -> (msg_debug (str "It's stupid that this is called" ++ fnl ()); gVar u) | Unknown u' -> range_to_coq_expr k (Unknown u') | Ctr (c, rs) -> gApp (gCtr c) (List.map (range_to_coq_expr k) rs) | Parameter p -> gTyParam p | RangeHole -> hole end | RangeHole -> hole | Parameter p -> gTyParam p | _ -> failwith "QC Internal: TopLevel ranges should be Unknowns or Constructors" let rec dt_to_coq_expr k dt = match dt with | DTyVar u -> begin try begin match umfind u k with | FixedInput -> gVar u | Undef _ -> (msg_debug (str "It's stupid that this is called" ++ fnl ()); gVar u) | Unknown u' -> range_to_coq_expr k (Unknown u') | Ctr (c, rs) -> gApp (gCtr c) (List.map (range_to_coq_expr k) rs) | Parameter p -> gTyParam p | RangeHole -> hole end with _ -> gVar u end | DCtr (c,dts) -> gApp ~explicit:true (gCtr c) (List.map (dt_to_coq_expr k) dts) | DTyCtr (c, dts) -> gApp ~explicit:true (gCtr (ty_ctr_to_ctr c)) (List.map (dt_to_coq_expr k) dts) | DApp (dt, dts) -> gApp ~explicit:true (dt_to_coq_expr k dt) (List.map (dt_to_coq_expr k) dts) | DHole -> hole | _ -> failwith "QC Internal: dt_to_coq_expr" let rec is_dep_type = function | DArrow (dt1, dt2) -> is_dep_type dt1 || is_dep_type dt2 | DProd ((_, dt1), dt2) -> is_dep_type dt1 || is_dep_type dt2 | DTyParam _ -> false | DTyVar _ -> true | DCtr _ -> true | DTyCtr (_, dts) -> List.exists is_dep_type dts | DApp (dt, dts) -> List.exists is_dep_type (dt::dts) | DNot dt -> is_dep_type dt | DHole -> false type check = (coq_expr -> coq_expr) * int module CMap = Map.Make(OrdDepType) type cmap = (check list) CMap.t let lookup_checks k m = try Some (CMap.find k m) with Not_found -> None (* TODO: When handling parameters, this might need to add additional arguments *) (** Takes an equality map and two coq expressions [cleft] and [cright]. [cleft] is returned if all of the equalities hold, otherwise [cright] is returned. *) let handle_equalities init_size eqs (check_expr : coq_expr -> 'a -> 'a -> 'a -> 'a) (cleft : 'a) (cright : 'a) (cfuel : 'a) = EqSet.fold (fun (u1,u2) c -> let checker = gApp ~explicit:true (gInject "decOpt") [ gApp (gInject "Logic.eq") [gVar u1; gVar u2] ; hole ; init_size] in check_expr checker c cright cfuel ) eqs cleft type mode = Recursive of (Unknown.t * dep_type) list * (Unknown.t * dep_type) list * range list | NonRecursive of (Unknown.t * dep_type) list (* List of all unknowns that are still undefined *) type range_mode = | ModeFixed | ModeUndefUnknown of (Unknown.t * dep_type) | ModePartlyDef of ((Unknown.t * Unknown.t) list * (Unknown.t * dep_type) list * matcher_pat) | ModeParameter let range_mode_to_string = function | ModeFixed -> "Fixed" | ModeParameter -> "Param" | ModeUndefUnknown (u,_) -> Printf.sprintf "Unknown %s" (Unknown.to_string u) | ModePartlyDef (eqs, unks, pat) -> Printf.sprintf "Partial (eqs = %s, unks = %s, pat = %s)" (String.concat " " (List.map (fun (u1, u2) -> Printf.sprintf "%s = %s" (Unknown.to_string u1) (Unknown.to_string u2)) eqs)) (String.concat " " (List.map (fun (u,t) -> Unknown.to_string u) unks)) (matcher_pat_to_string pat) type compatible = Compatible | Incompatible | PartCompatible | InstCompatible exception Incompatible_mode let mode_analysis init_ctr curr_ctr (init_ranges : range list) (init_map : range UM.t) (curr_ranges : range list) (curr_map : range UM.t) = msg_debug (str (Printf.sprintf "Look here!! init_ctr = %s, curr_ctr = %s" (ty_ctr_to_string init_ctr) (ty_ctr_to_string curr_ctr)) ++ fnl ()); ignore (find_typeclass_bindings "EnumSizedSuchThat" curr_ctr); let unknowns_for_mode = ref [] in let remaining_unknowns = ref [] in let all_unknowns = ref [] in let actual_inputs = ref [] in (* Filter out parameters ranges -- hack! *) let init_ranges = List.filter (fun r -> not (is_parameter r)) init_ranges in let curr_ranges = List.filter (fun r -> not (is_parameter r)) curr_ranges in (* Compare ranges takes two ranges (the initial range r1 and the current range r2) as well as their parents, and returns: - true, if we can convert the current range to the same mode as the original range by instantiating a list of unknowns - false, if we can not convert (i.e. some things are more instantiated than they should be) *) let rec compare_ranges isTop p1 r1 p2 r2 = match r1, r2 with | Unknown u1, _ -> compare_ranges isTop u1 (UM.find u1 init_map) p2 r2 | _, Unknown u2 -> compare_ranges isTop p1 r1 u2 (UM.find u2 curr_map) | FixedInput, FixedInput -> if isTop then actual_inputs := Unknown p2 :: !actual_inputs; true | FixedInput, Undef dt -> if isTop then actual_inputs := Unknown p2 :: !actual_inputs; unknowns_for_mode := (p2, dt) :: !unknowns_for_mode; all_unknowns := (p2, dt) :: !all_unknowns; true | FixedInput, Ctr (c, rs) -> if isTop then actual_inputs := (Ctr (c,rs)) :: !actual_inputs; (* iterate through all the rs against fixed inputs *) List.for_all (fun b -> b) (List.map (compare_ranges false Unknown.undefined FixedInput Unknown.undefined) rs) | Undef _, FixedInput -> (* todo: something is wrong here *) false | Undef _, Undef dt -> (* Add the second range's parent to the list of unknowns that are free, but do not need to be instantiated for the mode to work *) remaining_unknowns := (p2,dt) :: !remaining_unknowns; all_unknowns := (p2, dt) :: !all_unknowns; true | Undef _, Ctr (_c, rs) -> List.iter (fun r' -> ignore (compare_ranges false p1 r1 Unknown.undefined r')) rs; false | _, _ -> qcfail (Printf.sprintf "Implement constructors for initial ranges: %s vs %s" (range_to_string r1) (range_to_string r2)) in if not (init_ctr = curr_ctr) then let rec find_all_unknowns p r = match r with | Unknown u -> find_all_unknowns u (UM.find u curr_map) | FixedInput -> () | Undef dt -> all_unknowns := (p, dt) :: !all_unknowns | Ctr (_c, rs) -> List.iter (find_all_unknowns Unknown.undefined) rs | RangeHole -> () | Parameter _ -> () in (List.iter (find_all_unknowns Unknown.undefined) curr_ranges; msg_debug (str "Mismatched constructors in mode analysis" ++ fnl ()); NonRecursive !all_unknowns) else if List.for_all (fun b -> b) (List.map2 (fun r1 r2 -> compare_ranges true Unknown.undefined r1 Unknown.undefined r2) init_ranges curr_ranges) then Recursive (List.rev !unknowns_for_mode, List.rev !remaining_unknowns, List.rev !actual_inputs) else NonRecursive !all_unknowns let isTyParam = function | DTyParam _ -> true | _ -> false let quickchick_cat = #if COQ_VERSION >= (8, 18, 0) CWarnings.create_category ~name:"quickchick" () #else "quickchick" #endif let warn_uninstantiated_variables = CWarnings.create ~name:"quickchick-uninstantiated-variables" ~category:quickchick_cat ~default:CWarnings.Enabled (fun allUnknowns -> str "After proccessing all constraints, there are still uninstantiated variables: " ++ prlist_with_sep (fun _ -> strbrk " , ") str (List.map var_to_string allUnknowns) ++ str ". Proceeding with caution..." ++ fnl ()) let handle_branch (* (type a) (type b) (* I've started to love ocaml again because of this *) *) (prod_class_names : string list) (_dep_type : dep_type) (init_size : coq_expr) (fail_exp : coq_expr) (not_enough_fuel_exp : coq_expr) (ret_exp : coq_expr -> coq_expr) (instantiate_existential_method : coq_expr) (instantiate_existential_methodST : int -> coq_expr (* pred *) -> coq_expr) (ex_bind : bool (* opt *) -> coq_expr -> string -> (var -> coq_expr) -> coq_expr) (rec_method : int -> unknown list option -> coq_expr list -> coq_expr) (rec_bind : bool (* opt *) -> coq_expr -> string -> (var -> coq_expr) -> coq_expr) (stMaybe : bool (* opt *) -> coq_expr -> string -> ((coq_expr -> coq_expr) * int) list -> coq_expr) (check_expr : int -> coq_expr -> coq_expr -> coq_expr -> coq_expr -> coq_expr) (match_inp : var -> matcher_pat -> coq_expr -> coq_expr -> coq_expr) (let_in_expr : string -> coq_expr -> (var -> coq_expr) -> coq_expr) (let_tuple_in_expr : var -> var list -> coq_expr -> coq_expr) (gen_ctr : ty_ctr) (init_umap : range UM.t) (init_tmap : dep_type UM.t) (input_ranges : range list) (result : Unknown.t) (c : dep_ctr) : (coq_expr * bool) = (* ************************ *) (* Step 0 : Initializations *) (* ************************ *) let (ctr, typ) = c in (* Local reference : is this constructor recursive or not? *) let is_base = ref true in (* Local references to handle map updates. Keep init_umap intact for mode analysis. *) let umap = ref init_umap in let tmap = ref init_tmap in (* Check map - registers necessary checks for variable instantiation *) let cmap = ref CMap.empty in (* Add all universally quantified unknowns in the u/t environments. *) let rec register_unknowns = function | DArrow (_dt1, dt2) -> register_unknowns dt2 | DProd ((x, dt1), dt2) -> umap := UM.add x (Undef dt1) !umap; tmap := UM.add x dt1 !tmap; register_unknowns dt2 | _ -> () in register_unknowns typ; msg_debug (str "Debug branch" ++ fnl ()); msg_debug (str ("Calculating ranges: " ^ dep_type_to_string (dep_result_type typ)) ++ fnl ()); (* !! Possibility of failure: The conclusion of each constructor must not contain function calls. Possible solution: Automatically transform such constructors to include an additional equality with a fresh unknown? *) let result_ranges = match dep_result_type typ with | DTyCtr (_, dts) as res -> begin match sequenceM convert_to_range (List.filter (fun dt -> not (isTyParam dt)) dts) with | Some ranges -> ranges | None -> qcfail (Printf.sprintf "Arguments to result of constructor %s can only be variables or constructors applied to variables: %s" (constructor_to_string ctr) (dep_type_to_string res)) end | res -> qcfail (Printf.sprintf "Result type of constructor %s is not a type constructor applied to arguments: %s" (constructor_to_string ctr) (dep_type_to_string res)) in (* Debugging init map *) msg_debug (str ("Handling branch: " ^ dep_type_to_string typ) ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; dep_fold_ty (fun _ dt1 -> msg_debug (str (Printf.sprintf "%s : %b\n" (dep_type_to_string dt1) (is_dep_type dt1)) ++ fnl())) (fun _ _ dt1 -> msg_debug (str (Printf.sprintf "%s : %b\n" (dep_type_to_string dt1) (is_dep_type dt1)) ++ fnl())) (fun _ -> ()) (fun _ -> ()) (fun _ -> ()) (fun _ -> ()) typ; (* End debugging *) (* ********************************************* *) (* Step 1: Unify result ranges with input ranges *) (* ********************************************* *) (* Set of equality checks necessary *) let eq_set = ref EqSet.empty in (* List of necessary pattern matches *) let matches = ref [] in (* Function to handle a single argument *) let unify_single_pair r_in r_res = match unify !umap r_in r_res !eq_set with | Some (umap', _range, eq_set', extra_matches) -> (* Unification succeeded; update info *) umap := umap'; eq_set := eq_set'; matches := extra_matches @ !matches | None -> (* Unification failed. *) qcfail "Matching result type error" (* TODO: Better error message here? *) in List.iter2 unify_single_pair input_ranges result_ranges; msg_debug (str "Unification complete" ++ fnl ()); (* ********************************************************* *) (* Interlude: Helper functions to instantiate a single range *) (* ********************************************************* *) (* Note: These functions should theoretically live outside of this block, but they rely on the parameterized arguments. Move to the front? *) (* Note - Existential handling: *) (* There is a mismatch between the monads in generation and checking. In generation, the main bind is G, the bind opt is G . option. In checking, the main function is of type option bool. For instantiating something (enumerable?) we need a list-monad bind. Which is to be used whenever we do instantiations. My solution would be to either: (a) lift the entire option monad (in the let fix declaration) to a list monad and convert back to an option at the end (b) decouple the instantiation bind from the call bind. Not sure what works better - to be discussed. *) (* Opt = list, not opt = opt *) (* When instantiating a single unknown, see if it must satisfy any additional predicates. *) (* Old comment: Process check map. XXX generator specific *) let process_checks bind x opt g (cont : var -> coq_expr) : coq_expr = msg_debug (str ("Processing checks for variable: " ^ (Unknown.to_string x)) ++ fnl ()); match lookup_checks (DTyVar x) !cmap with | Some checks -> (* Remove checks from cmap *) msg_debug (str "Actual checks needed" ++ fnl ()); cmap := CMap.remove (DTyVar x) !cmap; umap := fixVariable x !umap; bind true (stMaybe opt g (var_to_string x) checks) (var_to_string x) (fun x -> cont x) | None -> umap := fixVariable x !umap; bind opt g (var_to_string x) (fun x -> cont x) in (* Two mutually recursive functions follow for instantiating ranges. *) (* Function to instantiate a single range; uses the input check-map for additional checks. Takes a continuation that receives the (instantiated) range to produce a result. *) let rec instantiate_range_cont (parent : unknown) r (cont : range -> coq_expr) = msg_debug (str ("Calling instantiate_range_cont with : " ^ range_to_string r) ++ fnl ()); match r with | Ctr (c,rs) -> (* We need to recursively instantiate all the ranges rs, using the function below *) instantiate_toplevel_ranges_cont rs [] (fun rs' -> cont (Ctr (c, rs'))) | Undef _dt -> (* For undefined, we need to instantiate the parent by processing its checks. *) process_checks ex_bind parent false instantiate_existential_method (fun x -> cont (Unknown x)) | Unknown u -> (* Unknowns just propagate one step further *) instantiate_range_cont u (umfind u !umap) cont | FixedInput -> (* Just call the continuation on the parent. *) cont (Unknown parent) | Parameter p -> cont (Parameter p) | RangeHole -> cont RangeHole (* Function that operates on multiple top-level ranges at once, mapping the above over a list *) and instantiate_toplevel_ranges_cont (rs : range list) (acc : range list) (cont : range list -> coq_expr) : coq_expr = match rs with | r ::rs' -> (* For each range r, we need to recursively call instantiate_range with the current umap and cmap, and no defined parent. *) instantiate_range_cont Unknown.undefined r (* The continuation receives an updated umap', cmap' and a new range res, representing the (potentially instantiated) range. We then add res to an accumulator list and continue the traversal. *) (fun res -> instantiate_toplevel_ranges_cont rs' (res::acc) cont) | [] -> (* When we are done traversing the rs, we reverse the accumulator and call the continuation *) cont (List.rev acc) in (* Another helper function that ensures no function calls are left in the representation. Traverses the representation of each datatype and whenever it encounters a function call, it evaluates it after potentially instantiating its arguments, binds the result to a fresh unknown, and creates a new dep_type. Assumes: The input datatypes are range-convertible apart from any function calls. *) (* For your sanity, ask someone to explain this function before tweaking anything. *) let rec instantiate_function_calls_cont dts (acc : dep_type list) (cont : dep_type list -> coq_expr) : coq_expr = match dts with | [] -> cont (List.rev acc) | dt::dts' -> begin match dt with | DCtr (c, inner_dts) -> (* Call the instantiate function to first instantiate the inner datatypes *) instantiate_function_calls_cont inner_dts [] (fun inner_dts' -> (* Call the instantiate function as its continuation after repacking DCtr *) instantiate_function_calls_cont dts' (DCtr (c, inner_dts') :: acc) cont) | DTyVar x -> (* Just continue along instantiating the rest of the function calls *) instantiate_function_calls_cont dts' (DTyVar x :: acc) cont | DApp (DTyVar f, argdts) -> (* Again, instantiate the inner dts' function calls if necessary first *) instantiate_function_calls_cont argdts [] (fun argdts' -> (* Convert the datatypes to ranges *) let ranges = match sequenceM convert_to_range argdts' with (* TODO Message *) | None -> qcfail "Could not convert datatypes to ranges in function call" | Some ranges -> ranges in (* Then actually instantiate the ranges *) instantiate_toplevel_ranges_cont ranges [] (fun ranges' -> (* Create a fresh unknown u *) let u = unk_provider.next_unknown () in (* Convert the ranges to coq_exprs *) let coq_expr_args = List.map (range_to_coq_expr !umap) ranges' in (* Bind the result of the application f args to u *) let_in_expr (Unknown.to_string u) (gApp ~explicit:true (gVar f) coq_expr_args) (fun uvar -> umap := UM.add uvar FixedInput !umap; (* Given the variable representation of u, proceed to instantiate the rest of the dts' *) instantiate_function_calls_cont dts' (DTyVar uvar :: acc) cont))) | DTyCtr (_c,_dts) -> instantiate_function_calls_cont dts' (dt :: acc) cont | DTyParam p -> (* Just continue along instantiating the rest of the function calls *) instantiate_function_calls_cont dts' (DTyParam p :: acc) cont | DHole -> (* Just continue along instantiating the rest of the function calls *) instantiate_function_calls_cont dts' (DHole :: acc) cont | _ -> failwith ("Not a type! " ^ (dep_type_to_string dt)) end in (* *********************************************************** *) (* Actual computations - multiple mutually recursive functions *) (* *********************************************************** *) (* Main Function - handle_TyCtr : Handles a single constraint of the form (C e1 e2 ...) Inputs: - ctr_index : The index of the handled constraint. For example, if the constructor we are currently processing is : forall x y, A e -> C e1 e2 -> D e3 e4 -> P e5 e6 and we are handling (C e1 e2), then m = 2). - is_pos : A boolean flag that signifies if we are processing (C e1 e2 ..) or ~ (C e1 e2 ...) - c : The constraint type constructor C - dts : The arguments to the type constructor (e1 e2 ...) - dt' : The remainder constraints that are left to be processed. Notes: *) let rec handle_TyCtr (ctr_index : int) (is_pos : bool) (c : ty_ctr) (dts : dep_type list) (dt' : dep_type) = (* First instantiate the function calls in the dep_type list *) instantiate_function_calls_cont dts [] (fun dts' -> (* Convert the modified dep_types to ranges *) let ranges = match sequenceM convert_to_range dts' with | Some ranges -> ranges | None -> qcfail "Internal: After instantiating function calls, datatypes should be convertible to ranges." in (* Rewrite: Actually look at available instances. *) (* Inv: r has to be a toplevel range. *) let mode_analyze r umap = if is_parameter r then ModeParameter else if is_fixed_range umap r then ModeFixed else let handle_partial r umap = let eqs = ref [] in let unks = ref [] in let rec convert_to_pat parent r = match r with | Parameter x -> MatchParameter x | Ctr (ctr, rs) -> MatchCtr (ctr, List.map (convert_to_pat Unknown.undefined) rs) | Unknown u -> convert_to_pat u (UM.find u umap) | FixedInput -> (* introduce fresh unknown, match that, yield equality *) let u = make_up_name () in eqs := (u, parent) :: !eqs; MatchU u | Undef dt -> (* register as unknown to be generated from pattern *) if List.exists (fun ut -> (fst ut) = parent) !unks then begin (* Already fixed from another pattern. Test equality *) let u = make_up_name () in (* Add it in the map temporarily - will be fixed soon. *) eqs := (u, parent) :: !eqs; MatchU u end else begin unks := (parent, dt) :: !unks; MatchU parent end in ModePartlyDef (!eqs, !unks, convert_to_pat Unknown.undefined r) in (* At this point, it can only be an unknown or a constructor. *) match r with | Unknown u -> let rec unknown_chain u = match UM.find u umap with | Undef dt -> ModeUndefUnknown (u,dt) (* TODO which u? *) | Unknown u' -> unknown_chain u' | _ -> handle_partial r umap in unknown_chain u | Ctr _ -> handle_partial r umap | _ -> failwith "Not U/C MA" in (* r: range b: boolean false = input, true = output. m: Mode *) let compatible b m = match m, b with | ModeFixed, false -> Compatible | ModeUndefUnknown _, false -> InstCompatible | ModePartlyDef (eqs, unks, pat), false -> InstCompatible | ModeFixed, true -> Incompatible | ModeUndefUnknown _ , true -> Compatible | ModePartlyDef _, true -> PartCompatible in let mode_score bs ms filter_bs = let rec walk_scores ms bs = match ms, bs with | ModeParameter::ms', _::bs' when filter_bs-> walk_scores ms' bs' | ModeParameter::ms', bs when not filter_bs-> walk_scores ms' bs | m::ms', b::bs' -> compatible b m :: walk_scores ms' bs' | _, _ -> [] in let cs = walk_scores ms bs in (* let cs = List.map2 compatible bs ms in *) ((List.filter (fun c -> c == Compatible) cs), (List.filter (fun c -> c == InstCompatible) cs), (List.filter (fun c -> c == Incompatible) cs), (List.filter (fun c -> c == PartCompatible) cs)) in (* LOGIC: - Filter out incompatible - Prioritize production + Prioritize Modes that don't have PartCompatible + Default to PartCompatible with the shallowest pattern (TODO) - Fallback to checker - If none exist, fail with a more useful error message + Alternative: Call a let-bound generator to show the instance to the user *) (* Quick-and-dirty sorting based on logic above. Most of the time there will only be one producer, and the effect will be filtering for (in)compatibility. *) msg_debug (str (Printf.sprintf "Look here v2!! %s %s" (ty_ctr_to_string gen_ctr) (ty_ctr_to_string c)) ++ fnl ()); let producer_classes = List.concat (List.map (fun n -> find_typeclass_bindings n c) prod_class_names) in let checker_classes = List.concat (List.map (fun n -> find_typeclass_bindings n c) ["DecOpt"; "Dec"]) in let curr_modes = List.map (fun r -> mode_analyze r !umap) ranges in msg_debug (str (Printf.sprintf "Current Ranges: %s" (ranges_to_string ranges)) ++ fnl ()); msg_debug (str (Printf.sprintf "Current Modes: %s\n" (String.concat " " (List.map range_mode_to_string curr_modes))) ++ fnl ()); msg_debug (str "Producer classes: " ++ fnl ()); List.iter (fun bs -> msg_debug (str (String.concat " " (List.map (fun b -> Printf.sprintf "%b" b) bs)) ++ fnl ())) producer_classes; msg_debug (str "Checker classes: " ++ fnl ()); List.iter (fun bs -> msg_debug (str (String.concat " " (List.map (fun b -> Printf.sprintf "%b" b) bs)) ++ fnl ())) checker_classes; let ranked_producers = List.sort (fun ((c1,i1,_,p1),_) ((c2,i2,_,p2),_) -> compare (List.length p1, List.length i1) (List.length p2, List.length i2)) (List.filter (fun ((_,_,inc,_),_) -> List.length inc == 0) (List.map (fun bs -> (mode_score bs curr_modes true, bs)) producer_classes)) in msg_debug (str (Printf.sprintf "Look here v2!! %s %s" (ty_ctr_to_string gen_ctr) (ty_ctr_to_string c)) ++ fnl ()); List.iter (fun ((c,i,inc,p), bs) -> msg_debug (str (Printf.sprintf "%d-%d-%d-%d" (List.length c) (List.length i) (List.length inc) (List.length p)) ++ fnl ()); msg_debug (str (String.concat " " (List.map (Printf.sprintf "%b") bs)) ++ fnl ()); ) ranked_producers; (* Invariant: filter out params in recursive mode *) let compute_for_mode (ms : range_mode list) (bs : bool list) (is_rec : bool) = msg_debug (str "Computing for Mode: " ++ str (String.concat " " (List.map range_mode_to_string ms)) ++ str (String.concat " " (List.map (Printf.sprintf "%b") bs)) ++ fnl ()); let uts = ref UM.empty in let need_filtering = ref None in let unknown_gen = ref [] in let add_to_map u dt = try if UM.find u !uts = dt then () else failwith "Trying to add unknown in two different types?" with Not_found -> uts := UM.add u dt !uts in let process_mb_pair i m b = match m, b with | ModeFixed, false -> () | ModeUndefUnknown (u,dt), false -> add_to_map u dt | ModePartlyDef (_, unks, _), false -> List.iter (fun (u,dt) -> add_to_map u dt) unks | ModeFixed, true -> raise Incompatible_mode | ModeUndefUnknown (u,dt), true -> unknown_gen := (u, dt, i) :: !unknown_gen | ModePartlyDef (eqs,unks,pat), true -> need_filtering := Some (eqs, unks, pat, i) | _, _ -> () in let rec walk_mbs i ms bs = match ms, bs with | ModeParameter::ms',_ when is_rec -> walk_mbs i ms' bs | ModeParameter::ms',false::bs' when not is_rec -> walk_mbs i ms' bs' | m::ms', b::bs' -> process_mb_pair i m b; walk_mbs (i+1) ms' bs' | _, _ -> () in walk_mbs 0 ms bs; (!uts, !need_filtering, !unknown_gen) in if not (gen_ctr = c) then begin msg_debug (str "Non-recursive constructor" ++ fnl ()); begin match ranked_producers with | (_,bs) :: _ when is_pos -> msg_debug (str ("Found Producer! " ^ String.concat "," (List.map (Printf.sprintf "%b") bs)) ++ fnl ()); (* Begin producer stuff. *) (* Step 1: Figure out which unknowns need to be instantiated for mode to work out *) (* Invariant: These are not Incompatible *) let (uts, need_filtering, unknown_gen) = compute_for_mode curr_modes bs false in let unknowns_for_mode = UM.bindings uts in msg_debug (str "Unknowns for mode: " ++ str (String.concat " " (List.map (fun (u,_) -> Unknown.to_string u) unknowns_for_mode)) ++ fnl ()); (* Instantiate any unknowns that need to be for the mode to work. *) instantiate_toplevel_ranges_cont (List.map (fun (x,_t) -> Unknown x) unknowns_for_mode) [] (fun _ranges -> (* TODO: Need filtering. *) let (unknown_to_generate_for, letbinds) = match need_filtering, unknown_gen with | None, [(u, dt, i)] -> (u, []) | Some (eqs, unks, pat, i), [] -> (unk_provider.next_unknown (), []) | None, udtis -> (unk_provider.next_unknown (), List.rev (List.map (fun (u,_,_) -> u) udtis)) | _, _ -> failwith "Simultaneous Some/None/1" in let ranges_for_pred = let rs = List.map (range_to_coq_expr !umap) ranges in match need_filtering with | Some (_,_,_,i) -> List.mapi (fun j x -> if i = j then gVar unknown_to_generate_for else x) rs | _ -> rs in let pred_result = gApp ~explicit:true (gTyCtr c) ranges_for_pred in let pred = (* predicate we are generating for *) match letbinds with | [] -> gFun [var_to_string unknown_to_generate_for] (fun _ -> pred_result) | _ -> (* TODO: Type Params: What happens to gType below? *) let unknown_type = dtTupleType (List.map (fun (_,dt,_) -> dt) unknown_gen) in gFunTyped [(var_to_string unknown_to_generate_for, gType [] unknown_type)] (fun _ -> gLetTupleIn (unknown_to_generate_for) letbinds pred_result) in (* Need to add the unknown in the map. The type as it will be fixed soon. *) let unknown_range = match letbinds with | [] -> Undef DHole | _ -> listToPairAux (fun (acc, x) -> Ctr (injectCtr "Coq.Init.Datatypes.pair", [acc; x])) (List.map (fun u -> Unknown u) letbinds) in umap := UM.add unknown_to_generate_for unknown_range !umap; process_checks ex_bind unknown_to_generate_for true (instantiate_existential_methodST ctr_index pred) (fun _x' -> let cont () = recurse_type (ctr_index + 1) dt' in let rec construct_eqs = function | [] -> cont () | (u1,u2)::eqs' -> msg_debug (str (Printf.sprintf "Handling eq: %s = %s" (Unknown.to_string u1) (Unknown.to_string u2)) ++ fnl ()); msg_debug (str "Before fixing..." ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; (* umap := fixVariable u1 !umap; *) msg_debug (str "After fixing..." ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; let checker = gApp ~explicit:true (gInject "decOpt") [ gApp (gInject "Logic.eq") [gVar u1; gVar u2] ; hole ; init_size] in check_expr ctr_index checker (construct_eqs eqs') fail_exp not_enough_fuel_exp in let finalizer () = match need_filtering with | None -> cont () | Some (eqs, unks, pat, i) -> msg_debug (str (Printf.sprintf "0/Before matching %s with %s..." (Unknown.to_string unknown_to_generate_for) (matcher_pat_to_string pat)) ++ fnl ()); msg_debug (str (Printf.sprintf "About to fix: %s" (String.concat " " (List.map (fun (x,_) -> Unknown.to_string x) unks))) ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; List.iter (fun (u,_) -> umap := fixVariable u !umap) unks; List.iter (fun (u,_) -> umap := fixVariable u !umap) eqs; umap := UM.add unknown_to_generate_for (matcher_pat_to_range pat) !umap; msg_debug (str "After matching..." ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; match_inp unknown_to_generate_for pat (construct_eqs eqs) fail_exp in match letbinds with | [] -> finalizer () | _ -> begin List.iter (fun u -> umap := fixVariable u !umap) letbinds; gLetTupleIn (unknown_to_generate_for) letbinds (finalizer ()) end ) ) | _ -> begin match checker_classes with | bs :: _ -> msg_debug (str ("Found Checker ! " ^ String.concat "," (List.map (Printf.sprintf "%b") bs)) ++ fnl ()); (* Begin checker stuff. *) (* Then just make the checker call. *) let (uts, need_filtering, unknown_gen) = compute_for_mode curr_modes bs false in let unknowns_for_mode = UM.bindings uts in (* Instantiate any unknowns that need to be for the mode to work. *) instantiate_toplevel_ranges_cont (List.map (fun (x,_t) -> Unknown x) unknowns_for_mode) [] (fun _ranges -> (* Generate a fresh boolean unknown *) (* let unknown_to_generate_for = unk_provider.next_unknown () in umap := UM.add unknown_to_generate_for (Undef (DCtr (injectCtr "Coq.Init.Datatypes.bool", []))) !umap; *) let inputs_for_pred = List.map (range_to_coq_expr !umap) ranges (* (List.filter (fun r -> not (is_parameter r)) ranges) *) in let pred = gApp ~explicit:true (gTyCtr c) inputs_for_pred in let body_cont = recurse_type (ctr_index + 1) dt' in let body_fail = fail_exp in (* Construct the checker for the current type constructor *) let checker = gApp ~explicit:true (gInject "decOpt") (* P : Prop := c dts*) [ pred (* Instance *) ; hole (* Size. TODO: what do we do about this size? *) ; init_size ] in if is_pos then check_expr ctr_index checker body_cont body_fail not_enough_fuel_exp else check_expr ctr_index checker body_fail body_cont not_enough_fuel_exp ) | _ -> failwith ("No Checkers or Producers for relation: " ^ (ty_ctr_to_string c)) end end end else begin msg_debug (str (Printf.sprintf "Recursive:\nInput ranges: %s\nMode Ranges: %s\n" (ranges_to_string input_ranges) (ranges_to_string ranges)) ++ fnl ()); let rec_ms = List.map (fun r -> mode_analyze r init_umap) input_ranges in msg_debug (str (Printf.sprintf "Current Modes: %s\nRec Modes: %s\n" (String.concat " " (List.map range_mode_to_string curr_modes)) (String.concat " " (List.map range_mode_to_string rec_ms))) ++ fnl ()); let mode_to_b = function | ModeFixed -> false | ModeUndefUnknown _ -> true | _ -> failwith "Partial toplevel input?" in let rec_bs = List.map mode_to_b rec_ms in let can_use_recursive = msg_debug (str "Trying compute..." ++ fnl ()); try begin ignore (compute_for_mode curr_modes rec_bs true); msg_debug (str "Reaching here somehow?" ++ fnl ()); true end with Incompatible_mode -> false in msg_debug (str (Printf.sprintf "Is it? %b" can_use_recursive) ++ fnl ()); (* If the recursive case is a producer... *) if List.exists (fun b -> b) rec_bs && can_use_recursive then begin msg_debug (str "Entering recursive producer handler" ++ fnl ()); is_base := false; (* Then just make the recursive call. *) let (uts, need_filtering, unknown_gen) = compute_for_mode curr_modes rec_bs true in let unknowns_for_mode = UM.bindings uts in (* Instantiate any unknowns that need to be for the mode to work. *) instantiate_toplevel_ranges_cont (List.map (fun (x,_t) -> Unknown x) unknowns_for_mode) [] (fun _ranges -> let (unknown_to_generate_for, letbinds) = match need_filtering, unknown_gen with | None, [(u, dt, i)] -> (u, []) | Some (eqs, unks, pat, i), [] -> (unk_provider.next_unknown (), []) | None, udtis -> (unk_provider.next_unknown (), List.rev (List.map (fun (u,_,_) -> u) udtis)) | _, _ -> failwith "Simultaneous Some/None/2" in (* Need to add the unknown in the map. The type as it will be fixed soon. *) let unknown_range = match letbinds with | [] -> Undef DHole | _ -> listToPairAux (fun (acc, x) -> Ctr (injectCtr "Coq.Init.Datatypes.pair", [acc; x])) (List.map (fun u -> Unknown u) letbinds) in umap := UM.add unknown_to_generate_for unknown_range !umap; msg_debug (str (Printf.sprintf "Unknown to generate for: %s\n" (Unknown.to_string (unknown_to_generate_for))) ++ fnl ()); let inputs_for_rec_method = let rs = List.map (range_to_coq_expr !umap) (List.filter (fun r -> not (is_parameter r)) ranges) in List.map fst (List.filter (fun (r,b) -> not b) (List.combine rs rec_bs)) in (* TODO: refactor, letbinds not used by recmethod *) process_checks rec_bind unknown_to_generate_for true (rec_method ctr_index (Some letbinds) inputs_for_rec_method) (fun _shouldletthis -> let cont (_ : unit) = recurse_type (ctr_index + 1) dt' in let rec construct_eqs = function | [] -> cont () | (u1,u2)::eqs' -> (* umap := fixVariable u1 !umap; *) let checker = gApp ~explicit:true (gInject "decOpt") [ gApp (gInject "Logic.eq") [gVar u1; gVar u2] ; hole ; init_size] in check_expr ctr_index checker (construct_eqs eqs') fail_exp not_enough_fuel_exp in let finalizer (_ : unit) = match need_filtering with | None -> cont () | Some (eqs, unks, pat, i) -> msg_debug (str (Printf.sprintf "1/Before matching %s with %s..." (Unknown.to_string unknown_to_generate_for) (matcher_pat_to_string pat)) ++ fnl ()); msg_debug (str (Printf.sprintf "About to fix: %s" (String.concat " " (List.map (fun (x,_) -> Unknown.to_string x) unks))) ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; List.iter (fun (u,_) -> umap := fixVariable u !umap) eqs; List.iter (fun (u,_) -> umap := fixVariable u !umap) unks; umap := UM.add unknown_to_generate_for (matcher_pat_to_range pat) !umap; msg_debug (str "After matching..." ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; match_inp unknown_to_generate_for pat (construct_eqs eqs) fail_exp in match letbinds with | [] -> finalizer () | _ -> begin List.iter (fun u -> umap := fixVariable u !umap) letbinds; gLetTupleIn (unknown_to_generate_for) letbinds (finalizer ()) end ) ) end else if List.exists (fun b -> b) rec_bs && not can_use_recursive then begin msg_debug (str "Can't use recursive producer - checker must exist." ++ fnl ()); begin match checker_classes with | bs :: _ -> msg_debug (str ("Found Checker ! " ^ String.concat "," (List.map (Printf.sprintf "%b") bs)) ++ fnl ()); (* Begin checker stuff. *) (* Then just make the checker call. *) let (uts, need_filtering, unknown_gen) = compute_for_mode curr_modes bs false in let unknowns_for_mode = UM.bindings uts in (* Instantiate any unknowns that need to be for the mode to work. *) instantiate_toplevel_ranges_cont (List.map (fun (x,_t) -> Unknown x) unknowns_for_mode) [] (fun _ranges -> (* Generate a fresh boolean unknown *) (* let unknown_to_generate_for = unk_provider.next_unknown () in umap : = UM.add unknown_to_generate_for (Undef (DCtr (injectCtr "Coq.Init.Datatypes.bool", []))) !umap; *) let inputs_for_pred = List.map (range_to_coq_expr !umap) ranges (* (List.filter (fun r -> not (is_parameter r)) ranges) *) in let pred = gApp ~explicit:true (gTyCtr c) inputs_for_pred in let body_cont = recurse_type (ctr_index + 1) dt' in let body_fail = fail_exp in (* Construct the checker for the current type constructor *) let checker = gApp ~explicit:true (gInject "decOpt") (* P : Prop := c dts*) [ pred (* Instance *) ; hole (* Size. TODO: what do we do about this size? *) ; init_size ] in if is_pos then check_expr ctr_index checker body_cont body_fail not_enough_fuel_exp else check_expr ctr_index checker body_fail body_cont not_enough_fuel_exp ) | _ -> failwith "TODO: ERR MSG. No Classes found." end end else begin (* The recursive case is not a producer - check if there is an enumerator that works better! *) msg_debug (str "Entering non-recursive handler" ++ fnl ()); match ranked_producers with | (_,bs) :: _ -> msg_debug (str ("Found producer instead of recursive checker! " ^ String.concat "," (List.map (Printf.sprintf "%b") bs)) ++ fnl ()); (* Begin producer stuff. *) (* Step 1: Figure out which unknowns need to be instantiated for mode to work out *) (* Invariant: These are not Incompatible *) let (uts, need_filtering, unknown_gen) = compute_for_mode curr_modes bs false in let unknowns_for_mode = UM.bindings uts in (* Instantiate any unknowns that need to be for the mode to work. *) instantiate_toplevel_ranges_cont (List.map (fun (x,_t) -> Unknown x) unknowns_for_mode) [] (fun _ranges -> (* TODO: Need filtering. *) let unknown_to_generate_for = match need_filtering, unknown_gen with | None, [(u, dt, i)] -> u | Some (eqs, unks, pat, i), [] -> unk_provider.next_unknown () | _, _ -> failwith "Simultaneous Some/None/3" in let ranges_for_pred = let rs = List.map (range_to_coq_expr !umap) ranges in (* (List.filter (fun r -> not (is_parameter r)) ranges) in*) match need_filtering with | Some (_,_,_,i) -> List.mapi (fun j x -> if i = j then gVar unknown_to_generate_for else x) rs | _ -> rs in let pred_result = gApp ~explicit:true (gTyCtr c) ranges_for_pred in let pred = (* predicate we are generating for *) gFun [var_to_string unknown_to_generate_for] (fun _ -> pred_result) in (* Need to add the unknown in the map. The type as it will be fixed soon. *) umap := UM.add unknown_to_generate_for (Undef DHole) !umap; (* TODO: Filtering. *) process_checks ex_bind unknown_to_generate_for true (instantiate_existential_methodST ctr_index pred) (fun _x' -> let cont () = recurse_type (ctr_index + 1) dt' in let rec construct_eqs = function | [] -> cont () | (u1,u2)::eqs' -> (* umap := fixVariable u1 !umap;*) let checker = gApp ~explicit:true (gInject "decOpt") [ gApp (gInject "Logic.eq") [gVar u1; gVar u2] ; hole ; init_size] in check_expr ctr_index checker (construct_eqs eqs') fail_exp not_enough_fuel_exp in match need_filtering with | None -> cont () | Some (eqs, unks, pat, i) -> msg_debug (str (Printf.sprintf "2/Before matching %s with %s..." (Unknown.to_string unknown_to_generate_for) (matcher_pat_to_string pat)) ++ fnl ()); msg_debug (str (Printf.sprintf "About to fix: %s" (String.concat " " (List.map (fun (x,_) -> Unknown.to_string x) unks))) ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; List.iter (fun (u,_) -> umap := fixVariable u !umap) unks; List.iter (fun (u,_) -> umap := fixVariable u !umap) eqs; umap := UM.add unknown_to_generate_for (matcher_pat_to_range pat) !umap; msg_debug (str "After matching..." ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; match_inp unknown_to_generate_for pat (construct_eqs eqs) fail_exp ) ) | _ -> (* There is no good producer, just instantiate everything and make a recursive call. *) msg_debug (str "Entering recursive checker call" ++ fnl ()); is_base := false; (* Then just make the recursive call. *) let (uts, need_filtering, unknown_gen) = compute_for_mode curr_modes rec_bs true in let unknowns_for_mode = UM.bindings uts in (* Instantiate any unknowns that need to be for the mode to work. *) instantiate_toplevel_ranges_cont (List.map (fun (x,_t) -> Unknown x) unknowns_for_mode) [] (fun _ranges -> (* Generate a fresh boolean unknown *) let unknown_to_generate_for = unk_provider.next_unknown () in umap := UM.add unknown_to_generate_for (Undef (DCtr (injectCtr "Coq.Init.Datatypes.bool", []))) !umap; let inputs_for_rec_method = List.map (range_to_coq_expr !umap) (List.filter (fun r -> not (is_parameter r)) ranges) in let letbinds = None in process_checks rec_bind unknown_to_generate_for true (rec_method ctr_index letbinds inputs_for_rec_method) (fun _shouldletthis -> recurse_type (ctr_index+1) dt') ) end end ) (* (* TODO: positive/negative context *) (* Then do mode analysis on the new dts *) match mode_analysis gen_ctr c input_ranges init_umap ranges !umap with | Recursive (unknowns_for_mode, remaining_unknowns, actual_inputs) -> msg_debug (str "Mode analysis: Recursive." ++ fnl ()); let ums = String.concat " " (List.map (fun (u,t) -> Unknown.to_string u ^ " : " ^ dep_type_to_string t) unknowns_for_mode) in let rus = String.concat " " (List.map (fun (u,t) -> Unknown.to_string u ^ " : " ^ dep_type_to_string t) remaining_unknowns) in let ais = String.concat " " (List.map range_to_string actual_inputs) in msg_debug (str (ums ^ " - " ^ rus ^ " - " ^ ais) ++ fnl ()); (* Mark recursiveness of branch *) is_base := false; (* Instantiate all the unknowns needed for the mode to work out *) instantiate_toplevel_ranges_cont (List.map (fun (x,_t) -> Unknown x) unknowns_for_mode) [] (fun _ranges -> (* We will instantiate an unknown. First create a fresh one *) let fresh_unknown = match remaining_unknowns with | [(x,_)] -> x | _ -> unk_provider.next_unknown () in let unknown_type = match remaining_unknowns with | [] -> DCtr (injectCtr "Coq.Init.Datatypes.bool", []) | _ -> dtTupleType (List.map snd remaining_unknowns) in let unknown_range = match remaining_unknowns with | [] -> Undef unknown_type | [(_x,_)] -> Undef unknown_type | _ -> listToPairAux (fun (acc, x) -> Ctr (injectCtr "Coq.Init.Datatypes.pair", [acc; x])) (List.map (fun (x,_) -> Unknown x) remaining_unknowns) in umap := UM.add fresh_unknown unknown_range !umap; let letbinds = match remaining_unknowns with | [] -> None | [_] -> None | _ -> Some (List.map fst remaining_unknowns) in let args = List.map (range_to_coq_expr !umap) actual_inputs in (* TODO: Gather all checks, and add them to the check map *) process_checks rec_bind fresh_unknown true (rec_method ctr_index letbinds args) (fun _shouldletthis -> (* If letbinds exist, need to actually bind them *) match letbinds with | Some binds -> msg_debug (str "In let binds in process checks" ++ fnl ()); let_tuple_in_expr fresh_unknown binds (recurse_type (ctr_index+1) dt') | None -> recurse_type (ctr_index+1) dt' ) ) | NonRecursive [] -> msg_debug (str "Mode analysis: NonRecursive/Checker." ++ fnl ()); (* Checker *) let body_cont = recurse_type (ctr_index + 1) dt' in let body_fail = fail_exp in (* Construct the checker for the current type constructor *) let checker args = gApp ~explicit:true (gInject "decOpt") (* P : Prop := c dts*) [ gApp ~explicit:true (gTyCtr c) args (* Instance *) ; hole (* Size. TODO: what do we do about this size? *) ; init_size ] in (* Calculate arguments *) let args = msg_debug (str ("Calculating arguments with: " ^ (String.concat " " (List.map dep_type_to_string dts))) ++ fnl ()); List.map (dt_to_coq_expr !umap) dts (* match sequenceM (dt_to_coq_expr !umap) dts with | Some rs -> rs | None -> qcfail "Uninstantiated function calls after instantiation?"*) in if is_pos then check_expr ctr_index (checker args) body_cont body_fail not_enough_fuel_exp else check_expr ctr_index (checker args) body_fail body_cont not_enough_fuel_exp | NonRecursive all_unknowns -> msg_debug (str "Mode analysis: NonRecursive/Unknowns." ++ fnl ()); let ais = String.concat " " (List.map var_to_string (List.map fst all_unknowns)) in msg_debug (str ais ++ fnl ()); (* Call to arbitrarySizedST *) (* @arbitrarySizeST {A} (P : A -> Prop) {Instance} (size : nat) -> G (option A) *) (* We will instantiate an unknown. First create a fresh one *) let fresh_unknown = match all_unknowns with | [(x,_)] -> x | _ -> unk_provider.next_unknown () in let unknown_type = dtTupleType (List.map snd all_unknowns) in let unknown_range = match all_unknowns with | [] -> failwith "IMPOSSIBLE" | [(_x,_)] -> Undef unknown_type | _ -> listToPairAux (fun (acc, x) -> Ctr (injectCtr "Coq.Init.Datatypes.pair", [acc; x])) (List.map (fun (x,_) -> Unknown x) all_unknowns) in umap := UM.add fresh_unknown unknown_range !umap; let letbinds = match all_unknowns with | [] -> None | [_] -> None | _ -> Some (List.map fst all_unknowns) in (* LEO: LOOK AT THIS *) let _args = List.map (range_to_coq_expr !umap) ranges in let pred_result = gApp ~explicit:true (gTyCtr c) (List.map (range_to_coq_expr !umap) ranges) in let pred = (* predicate we are generating for *) gFun [var_to_string fresh_unknown] (fun _ -> match letbinds with | Some binds -> gLetTupleIn fresh_unknown binds pred_result | None -> pred_result ) in process_checks ex_bind fresh_unknown true (instantiate_existential_methodST ctr_index pred) (fun _x' -> recurse_type (ctr_index + 1) dt') ) *) (* let finalizer k cmap numbered_dts = match List.filter (fun (i, dt) -> not (is_fixed k dt)) numbered_dts with | [] -> (* Every argument to the constructor is fixed - perform a check *) (* Check if we are handling the current constructor. If yes, mark the need for decidability of current constructor *) (* need_dec is a ref in scope *) if c = gen_ctr then (need_dec := true; b := false) else (); (* Continuation handling dt2 : recurse one dt2 / None based on positivity *) let body_cont = recurse_type (m + 1) k cmap dt2 in let body_fail = fail_exp in if pos then check_expr m (checker (List.map (fun dt -> dt_to_coq_expr k dt) dts)) body_cont body_fail else check_expr m (checker (List.map (fun dt -> dt_to_coq_expr k dt) dts)) body_fail body_cont | [(i, DTyVar x)] -> begin (* Single variable to be generated for *) msg_debug (str (Printf.sprintf "%d %d %s %s %b \n" i n (ty_ctr_to_string c) (ty_ctr_to_string gen_ctr) pos) ++ fnl ()); if i = n && c = gen_ctr && pos then begin (* Recursive call *) b := false; let args = List.map snd (List.filter (fun (i, _) -> not (i = n)) (List.mapi (fun i dt -> (i+1, dt_to_coq_expr k dt)) dts)) in process_checks k cmap x (* Generate using recursive function *) true (rec_method ctr_index args) (fun k' cmap' x -> recurse_type (ctr_index + 1) k' cmap' dt2) end else if pos then begin (* Generate using "arbitrarySizeST" and annotations for type *) if c = gen_ctr then b := false; (* @arbitrarySizeST {A} (P : A -> Prop) {Instance} (size : nat) -> G (option A) *) let pred = (* predicate we are generating for *) gFun [var_to_string x] (fun [x] -> gApp ~explicit:true (gTyCtr c) (List.map (fun (j, dt) -> (* Replace the i-th variable with x - we're creating fun x => c dt_1 dt_2 ... x dt_{i+1} ... *) if i = j then gVar x else dt_to_coq_expr k dt ) numbered_dts)) in process_checks k cmap x true (class_methodST m pred) (fun k' cmap' x' -> recurse_type (m + 1) k' cmap' dt2) end else (* Negation. Since we expect the *positive* versions to be sparse, we can use suchThatMaybe for negative *) (* TODO: something about size for backtracking? *) let new_check = fun x -> checker (List.map (fun (j,dt) -> if i = j then x else dt_to_coq_expr k dt) numbered_dts) in let cmap' = match lookup_checks (DTyVar x) cmap with | Some checks -> CMap.add (DTyVar x) ((new_check, m) :: checks) cmap | _ -> CMap.add (DTyVar x) [(new_check, m)] cmap in recurse_type (m + 1) k cmap' dt2 end | [(i, dt) ] -> failwith ("Internal error: not a variable to be generated for" ^ (dep_type_to_string dt)) (* Multiple arguments to be generated for. Generalized arbitrarySizeST? *) | filtered -> if pos then begin (* For now, check if n is in the filtered list *) if c = gen_ctr then begin match List.filter (fun (i,dt) -> i = n) filtered with | [(_, DTyVar x)] -> begin b := false; (* Every other variable generated using "arbitrary" *) let rec build_arbs k cmap acc = function | [] -> (* base case - recursive call *) if pos then let generator = rec_method m (List.rev acc) in process_checks k cmap x true generator (fun k' cmap' x' -> recurse_type (m + 1) k' cmap' dt2) else failwith "Negation / build_arbs" | (i,dt)::rest -> if i = n then build_arbs k cmap acc rest (* Recursive argument - handle at the end *) else if is_fixed k dt then (* Fixed argument - do nothing *) build_arbs k cmap (dt_to_coq_expr k dt :: acc) rest else (* Call arbitrary and bind it to a new name *) let rdt = convert_to_range dt in instantiate_range_cont k cmap Unknown.undefined (fun k cmap c -> (* Continuation: call build_arbs on the rest *) build_arbs k cmap (c :: acc) rest ) rdt in build_arbs k cmap [] numbered_dts end | _ -> failwith "non-recursive call with multiple arguments" end else (* TODO: factor out *) let rec build_arbs k cmap acc = function (* TODO: Hacky: should try and find out which one is a variable *) | [(i,DTyVar x)] -> (* base case - recursive call *) if pos then begin (* @arbitrarySizeST {A} (P : A -> Prop) {Instance} (size : nat) -> G (option A) *) let pred = (* predicate we are generating for *) gFun [var_to_string x] (fun [x] -> gApp ~explicit:true (gTyCtr c) (List.map (fun (j, dt) -> (* Replace the i-th variable with x - we're creating fun x => c dt_1 dt_2 ... x dt_{i+1} ... *) if i = j then gVar x else dt_to_coq_expr k dt ) numbered_dts)) in process_checks k cmap x true (class_methodST m pred) (fun k' cmap' x' -> recurse_type (m + 1) k' cmap' dt2) end else failwith "Negation / build_arbs" | (i,dt)::rest -> if is_fixed k dt then (* Fixed argument - do nothing *) build_arbs k cmap (dt_to_coq_expr k dt :: acc) rest else (* Call arbitrary and bind it to a new name *) let rdt = convert_to_range dt in instantiate_range_cont k cmap Unknown.undefined (fun k cmap c -> (* Continuation: call build_arbs on the rest *) build_arbs k cmap (c :: acc) rest ) rdt in build_arbs k cmap [] numbered_dts (* TODO: Special handling for equality? *) (* | _ -> failwith (Printf.sprintf "Mode failure: %s\n" (String.concat " " (List.map (fun (i,d) -> Printf.sprintf "(%d, %s)" i (dep_type_to_string d)) filtered))) *) end else failwith "TODO: Negation with many things to be generated" in let rec instantiate_function_calls_cont k cmap dts acc = match dts with | [] -> finalizer k cmap (List.rev acc) | (i,dt)::dts -> begin match dt with | DApp (DTyVar f, argdts) -> (* TODO: Nested recursive calls *) let rec traverse_dts k cmap acc_args = function | [] -> let u = unk_provider.next_unknown () in let_in_expr (Unknown.to_string u) (gApp (gVar f) (List.rev acc_args)) (fun x -> instantiate_function_calls_cont (UM.add x FixedInput k) cmap dts ((i,DTyVar x)::acc) ) | arg::argdts' -> (* traverse_dts k cmap (arg :: acc_args) argdts' *) (* WARNING: ARG HERE COULD ALSO BE A FUNCTION *) instantiate_range_cont k cmap Unknown.undefined (fun k' c' e' -> traverse_dts k' c' (e' :: acc_args) argdts' ) (convert_to_range arg) in traverse_dts k cmap [] argdts | _ -> instantiate_function_calls_cont k cmap dts ((i,dt)::acc) end in instantiate_function_calls_cont k cmap numbered_dts [] *) (* and handle_app m (pos : bool) (f : dep_type) (xs : dep_type list) (k : umap) (cmap : cmap) (dt2 : dep_type) = (* Construct the checker for the current application *) let checker args = gApp ~explicit:true (gInject "dec") (* P : Prop := c dts*) [ gApp ~explicit:true (gType [] f) args (* Instance *) ; hole ] in UM.iter (fun x r -> msg_debug (str ("Bound: " ^ var_to_string x ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) k; let numbered_dts = List.mapi (fun i dt -> (i+1, dt)) xs in (* +1 because of nth being 1-indexed *) match List.filter (fun (i, dt) -> not (is_fixed k dt)) numbered_dts with | [] -> failwith "Check/app" | [x] -> failwith "Gen/1" | filtered -> if pos then begin let rec build_arbs k cmap acc = function (* TODO: Hacky: should try and find out which one is a variable *) | [(i,DTyVar x)] -> (* base case - recursive call *) if pos then begin (* @arbitrarySizeST {A} (P : A -> Prop) {Instance} (size : nat) -> G (option A) *) let pred = (* predicate we are generating for *) gFun [var_to_string x] (fun [x] -> gApp ~explicit:true (gType [] f) (List.map (fun (j, dt) -> (* Replace the i-th variable with x - we're creating fun x => c dt_1 dt_2 ... x dt_{i+1} ... *) if i = j then gVar x else dt_to_coq_expr k dt ) numbered_dts)) in process_checks k cmap x true (class_methodST m pred) (fun k' cmap' x' -> recurse_type (m + 1) k' cmap' dt2) end else failwith "Negation / build_arbs / application " | (i,dt)::rest -> if is_fixed k dt then (* Fixed argument - do nothing *) build_arbs k cmap (dt_to_coq_expr k dt :: acc) rest else (* Call arbitrary and bind it to a new name *) let rdt = convert_to_range dt in instantiate_range_cont k cmap Unknown.undefined (fun k cmap c -> (* Continuation: call build_arbs on the rest *) build_arbs k cmap (c :: acc) rest ) rdt in build_arbs k cmap [] numbered_dts end else failwith "Negation / application" *) (* Dispatcher for constraints *) and handle_dt (n : int) pos dt1 dt2 : coq_expr = match dt1 with | DTyCtr (c,dts) -> handle_TyCtr n pos c dts dt2 | DNot dt -> handle_dt n (not pos) dt dt2 (* | DApp (dt, dts) -> handle_app n pos dt dts umap cmap dt2 *) | _ -> failwith "Constraints should be type constructors/negations" (* Iterate through constraints *) and recurse_type (n : int) dt : coq_expr = msg_debug (str ("Recursing on type: " ^ dep_type_to_string dt) ++ fnl ()); match dt with | DProd (_, dt) -> (* Only introduces variables, doesn't constrain them *) recurse_type n dt | DArrow (dt1, dt2) -> msg_debug (str ("Darrowing: " ^ ((dep_type_to_string dt1))) ++ fnl ()); handle_dt n true dt1 dt2 | DTyCtr _ -> (* result *) (* Instantiate result *) msg_debug (str ("Instantiating result: " ^ (Unknown.to_string result)) ++ fnl ()); UM.iter (fun x r -> msg_debug (str ("Bound: " ^ (var_to_string x) ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) !umap; instantiate_range_cont Unknown.undefined (Unknown result) (fun res_range -> msg_debug (str ("Continuation of inst range in result") ++ fnl ()); (* Search if there is anything that is not fixed that requires instantiation *) let allUnknowns = List.map fst (UM.bindings !umap) in match List.filter (fun u -> match is_fixed !umap (DTyVar u) with | Some b -> not b | _ -> qcfail "Internal - filter") allUnknowns with | [] -> msg_debug (str "Final ret_exp call" ++ fnl ()); ret_exp (range_to_coq_expr !umap res_range) | us -> begin warn_uninstantiated_variables allUnknowns; instantiate_toplevel_ranges_cont (List.map (fun u -> Unknown u) us) [] (fun _unused_ranges -> ret_exp (range_to_coq_expr !umap res_range) ) end ) | _ -> failwith "Wrong type" in let branch_gen = msg_debug (str "Creating branch gen" ++ fnl ()); let rec walk_matches = function | [] -> msg_debug (str "Match output complete" ++ fnl ()); handle_equalities init_size !eq_set (check_expr (-1)) (recurse_type 0 typ) (fail_exp) not_enough_fuel_exp | (u,m)::ms -> begin msg_debug (str (Printf.sprintf "Processing Match: %s @ %s" (Unknown.to_string u) (matcher_pat_to_string m)) ++ fnl ()); match_inp u m (walk_matches ms) fail_exp end in (* matches are the matches returned by unification with the result type *) walk_matches !matches in (* Debugging resulting match *) (* UM.iter (fun x r -> msg_debug (str ("Bound: " ^ var_to_string x ^ " to Range: " ^ (range_to_string r)) ++ fnl ())) map; *) (* EqSet.iter (fun (u,u') -> msg_debug (str (Printf.sprintf "Eq: %s = %s\n" (Unknown.to_string u) (Unknown.to_string u')) ++ fnl())) eqs; *) (* List.iter (fun (u,m) -> msg_debug (str ((Unknown.to_string u) ^ (matcher_pat_to_string m)) ++ fnl ())) matches; *) msg_debug (str "Generated..." ++ fnl ()); (* debug_coq_expr branch_gen; *) (* End debugging *) (branch_gen ,!is_base) QuickChick-2.1.0/plugin/unifyQC.mli.cppo000066400000000000000000000104221476030541200200500ustar00rootroot00000000000000type name_provider = { next_name : unit -> string; } val mk_name_provider : string -> name_provider module Unknown : sig type t = GenericLib.var val to_string : GenericLib.var -> string val from_string : string -> GenericLib.var val from_var : 'a -> 'a val from_id : Names.Id.t -> GenericLib.var val undefined : GenericLib.var end module UnknownOrd : sig type t = Unknown.t val compare : GenericLib.var -> GenericLib.var -> int end type unknown = Unknown.t type range = Ctr of GenericLib.constructor * range list | Unknown of unknown | Undef of GenericLib.dep_type | FixedInput | Parameter of GenericLib.ty_param | RangeHole val is_parameter : range -> bool val range_to_string : range -> string module UM : CMap.ExtS with type key = Unknown.t and module Set := Set.Make(UnknownOrd) type umap = range UM.t val umfind : UM.key -> 'a UM.t -> 'a val lookup : unknown -> umap -> range option module OrdTSS : sig type t = unknown * unknown val compare : 'a -> 'a -> int end #if COQ_VERSION >= (8, 21, 0) module EqSet : CSet.ExtS with type elt = OrdTSS.t #else module EqSet : Set.S with type elt = OrdTSS.t #endif val eq_set_add : unknown -> unknown -> EqSet.t -> EqSet.t module OrdTyp : sig type t = GenericLib.dep_type val compare : 'a -> 'a -> int end #if COQ_VERSION >= (8, 21, 0) module ArbSet : CSet.ExtS with type elt = OrdTyp.t #else module ArbSet : Set.S with type elt = OrdTyp.t #endif type unknown_provider = { next_unknown : unit -> Unknown.t; } val unk_provider : unknown_provider val raiseMatch : umap -> GenericLib.constructor -> range list -> EqSet.t -> (umap * GenericLib.matcher_pat * EqSet.t) option val unify : umap -> range -> range -> EqSet.t -> (umap * range * EqSet.t * (unknown * GenericLib.matcher_pat) list) option val fixRange : UM.key -> range -> range UM.t -> range UM.t val fixVariable : UM.key -> range UM.t -> range UM.t val convert_to_range : GenericLib.dep_type -> range option val is_fixed : range UM.t -> GenericLib.dep_type -> bool option val range_to_coq_expr : range UM.t -> range -> GenericLib.coq_expr val dt_to_coq_expr : range UM.t -> GenericLib.dep_type -> GenericLib.coq_expr val is_dep_type : GenericLib.dep_type -> bool type check = (GenericLib.coq_expr -> GenericLib.coq_expr) * int module CMap : CMap.ExtS with type key = GenericLib.OrdDepType.t and module Set := Set.Make(GenericLib.OrdDepType) type cmap = check list CMap.t val lookup_checks : CMap.key -> 'a CMap.t -> 'a option val handle_equalities : GenericLib.coq_expr -> EqSet.t -> (GenericLib.coq_expr -> 'a -> 'a -> 'a -> 'a) -> 'a -> 'a -> 'a -> 'a type mode = Recursive of (Unknown.t * GenericLib.dep_type) list * (Unknown.t * GenericLib.dep_type) list * range list | NonRecursive of (Unknown.t * GenericLib.dep_type) list val mode_analysis : GenericLib.ty_ctr -> GenericLib.ty_ctr -> range list -> range UM.t -> range list -> range UM.t -> mode val isTyParam : GenericLib.dep_type -> bool val warn_uninstantiated_variables : ?loc:Loc.t -> GenericLib.var list -> unit val handle_branch : string list -> GenericLib.dep_type -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> (GenericLib.coq_expr -> GenericLib.coq_expr) -> GenericLib.coq_expr -> (int -> GenericLib.coq_expr -> GenericLib.coq_expr) -> (bool -> GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr) -> (int -> unknown list option -> GenericLib.coq_expr list -> GenericLib.coq_expr) -> (bool -> GenericLib.coq_expr -> string -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr) -> (bool -> GenericLib.coq_expr -> string -> ((GenericLib.coq_expr -> GenericLib.coq_expr) * int) list -> GenericLib.coq_expr) -> (int -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr) -> (GenericLib.var -> GenericLib.matcher_pat -> GenericLib.coq_expr -> GenericLib.coq_expr -> GenericLib.coq_expr) -> (string -> GenericLib.coq_expr -> (GenericLib.var -> GenericLib.coq_expr) -> GenericLib.coq_expr) -> (GenericLib.var -> GenericLib.var list -> GenericLib.coq_expr -> GenericLib.coq_expr) -> GenericLib.ty_ctr -> range UM.t -> GenericLib.dep_type UM.t -> range list -> Unknown.t -> GenericLib.dep_ctr -> GenericLib.coq_expr * bool QuickChick-2.1.0/plugin/weightmap.mlg.cppo000066400000000000000000000066511476030541200204660ustar00rootroot00000000000000DECLARE PLUGIN "coq-quickchick.plugin" { (* THIS FILE IS PREPROCESSED USING cppo MAKE SURE TO EDIT THE .cppo SOURCE OF THIS FILE RATHER THAN THE GENERATED RESULT *) open GenericLib open Stdarg open Error open Pp open Constrexpr open Libnames module CtrMap = Map.Make(Ord_ctr) type weight_ast = | WNum of int | WSize let weight_ast_to_string = function | WNum n -> string_of_int n | WSize -> "size" let weight_env : weight_ast CtrMap.t ref = Summary.ref ~name:"QC_weight_environ" CtrMap.empty let weight_env_to_string () = let all = CtrMap.fold (fun ctr w acc -> (Printf.sprintf "%s : %s\n" (constructor_to_string ctr) (weight_ast_to_string w))::acc) !weight_env [] in String.concat "" all let register_weights (l : (constructor * weight_ast) list) = List.iter (fun (c,w) -> weight_env := CtrMap.add c w !weight_env) l let convert_constr_to_weight c = match c.CAst.v with | CPrim (Number (NumTok.SPlus, i)) -> (match NumTok.Unsigned.to_nat i with | Some n -> WNum (int_of_string n) | None -> failwith "QC: Numeric weights should be positive integers." ) | CRef (r, _) -> if string_of_qualid r = "size" then WSize else failwith "QC: Expected number or 'size'." | _ -> failwith "QC: match failure." let convert_constr_to_cw_pair c : (constructor * weight_ast) = match c.CAst.v with | CNotation (_, _, ([a],[[b]],_,_)) -> let ctr = match a with | { CAst.v = CRef (r, _); _ } -> injectCtr (string_of_qualid r) | _ -> failwith "First argument should be a constructor name" in let w = convert_constr_to_weight b in (ctr,w) | _ -> failwith "Not a pair?" #if COQ_VERSION >= (8, 16, 0) let register_weights_object = Libobject.declare_object (Libobject.superglobal_object_nodischarge "QC_register_weights" ~cache:(fun ws -> register_weights ws) ~subst:None (* XXX should this be substitutive? why are we using qualid instead of Names.constructor? *)) let add_weights w = Lib.add_leaf (register_weights_object w) #else let register_weights_object = Libobject.declare_object {(Libobject.default_object ("QC_register_weights")) with Libobject.cache_function = (fun (_,ws) -> register_weights ws); Libobject.load_function = (fun _ (_,ws) -> register_weights ws)} let add_weights w = Lib.add_anonymous_leaf (register_weights_object w) #endif let lookup_weight b ctr size_var = try match CtrMap.find ctr !weight_env with | WNum n -> gInt n | WSize -> gSucc (gVar (size_var)) with Not_found -> if b then gInt 1 else gSucc (gVar (size_var)) } VERNAC COMMAND EXTEND QuickChickWeights CLASSIFIED AS SIDEFF | ["QuickChickWeights" constr(c)] -> { let weight_assocs = match c.CAst.v with | CNotation (_, _, ([a],[b],_,_)) -> let c = convert_constr_to_cw_pair a in let cs = List.map convert_constr_to_cw_pair b in c :: cs | _ -> failwith "QC: Expected list of constructor -> weights" in msg_debug (str "Current weights: " ++ fnl ()); msg_debug (str (weight_env_to_string ()) ++ fnl ()); add_weights weight_assocs } END (* let s1' = Names.string_of_id s1 in let s2' = Names.string_of_id s2 in Lib.add_anonymous_leaf (set_debug_flag s1' (s1',s2')) ] *) QuickChick-2.1.0/plugin/weightmap.mli000066400000000000000000000012201476030541200175130ustar00rootroot00000000000000module CtrMap : Map.S with type key = GenericLib.Ord_ctr.t type weight_ast = WNum of int | WSize val weight_ast_to_string : weight_ast -> string val weight_env : weight_ast CtrMap.t ref val weight_env_to_string : unit -> string val register_weights : (GenericLib.constructor * weight_ast) list -> unit val convert_constr_to_weight : Constrexpr.constr_expr_r CAst.t -> weight_ast val convert_constr_to_cw_pair : Constrexpr.constr_expr_r CAst.t -> GenericLib.constructor * weight_ast val register_weights_object : (GenericLib.constructor * weight_ast) list -> Libobject.obj val lookup_weight : bool -> CtrMap.key -> GenericLib.var -> GenericLib.coq_expr QuickChick-2.1.0/quickChickTool/000077500000000000000000000000001476030541200164465ustar00rootroot00000000000000QuickChick-2.1.0/quickChickTool/_tags000066400000000000000000000000411476030541200174610ustar00rootroot00000000000000true: rectypes, thread, traverse QuickChick-2.1.0/quickChickTool/dune000066400000000000000000000003511476030541200173230ustar00rootroot00000000000000(executable (package coq-quickchick) (name quickChickTool) (flags :standard -rectypes -warn-error -3 -w -32) (public_name quickChick) (libraries unix str)) (ocamllex quickChickToolLexer) (menhir (modules quickChickToolParser)) QuickChick-2.1.0/quickChickTool/quickChickTool.ml000066400000000000000000000754571476030541200217360ustar00rootroot00000000000000open QuickChickToolLexer open QuickChickToolParser open QuickChickToolTypes (* Utilities *) (* Apply a function for every file in a directory *) let for_all_files d f = let files = Sys.readdir d in Array.iter (fun file -> f (d ^ "/" ^ file)) files (* Rewrite a file line by line *) let sed_file file f = let src = open_in file in let tmpfile = file ^ ".tmp" in let tmp = open_out tmpfile in let rec go () = match input_line src with | line -> output_string tmp (f line); output_char tmp '\n'; go () | exception End_of_file -> close_in src; close_out tmp; Sys.rename tmpfile file in go () (* [String.ends_with] only available since 4.13.0 *) let ends_with ~suffix s = let n = String.length s in let nsuff = String.length suffix in nsuff <= n && String.sub s (n - nsuff) nsuff = suffix (* ----------------------------------------------------------------- *) (* Command-line *) let compile_command = ref "make" let top = ref "" (* Leo: or "Top"? *) let ocamlbuild_args = ref "" let sec_name = ref None let verbose = ref false let ansi = ref false let fail_fast = ref false let excluded = ref [] let nobase = ref false let analysis = ref false type mutant_id = Num of int | Tag of string let only_mutant = ref None let include_file = ref None let maxSuccess = ref None let current_filetype = ref "" let speclist = [ ("-s", Arg.String (fun name -> sec_name := Some name), "Which section's properties to test") ; ("-v", Arg.Unit (fun _ -> verbose := true), "Verbose mode") ; ("-failfast", Arg.Unit (fun _ -> fail_fast := true), "Stop as soon as a problem is detected") ; ("-color", Arg.Unit (fun _ -> ansi := true), "Use colors on an ANSI-compatible terminal") ; ("-cmd", Arg.String (fun name -> compile_command := name), "Compile command for entire directory") ; ("-top", Arg.String (fun name -> top := name), "Name of top-level logical module") ; ("-ocamlbuild", Arg.String (fun name -> ocamlbuild_args := name), "Arguments given to ocamlbuild") ; ("-nobase", Arg.Unit (fun _ -> nobase := true), "Do not test base mutant") ; ("-m", Arg.Int (fun n -> only_mutant := Some (Num n)), "Only test mutant number n") ; ("-N", Arg.Int (fun n -> maxSuccess := Some n), "Max number of successes") ; ("-tag", Arg.String (fun s -> only_mutant := Some (Tag s)), "Only test mutant number with a specific tag") ; ("-analysis", Arg.Unit (fun _ -> analysis := true), "Change output string to JSON format data") ; ("-include", Arg.String (fun incl -> include_file := Some incl), "File containing list of files to be included.") ; ("-exclude", Arg.Rest (fun excl -> excluded := excl :: !excluded), "(Deprecated) Files to be excluded. Must be the last argument") ] let usage_msg = "quickChick options\nMutation testing for current directory" ;; Arg.parse speclist (fun anon -> Printf.fprintf stderr "Warning: Anonymous argument %s\n" anon) usage_msg (* ----------------------------------------------------------------- *) (* Infrastructure *) let debug fmt = if !verbose then Printf.fprintf stdout (fmt ^^ "%!") else Printf.ifprintf stdout fmt let tmp_dir = "../_qc_" ^ Filename.basename (Unix.getcwd ()) ^ ".tmp" let ensure_dir_exists d = Sys.command ("mkdir -p " ^ d) let ensure_tmpdir_exists () = ignore (ensure_dir_exists tmp_dir) type highlight_style = Header | Failure | Success let highlight style s = if !ansi then begin begin match style with | Header -> print_string "\027[31m"; (* red *) print_string "\027[43m"; (* on yellow *) | Failure -> print_string "\027[37m"; (* white *) print_string "\027[41m"; (* on red *) | Success -> print_string "\027[30m"; (* black *) print_string "\027[42m"; (* on green *) end; print_string "\027[1m"; (* bold *) print_string s; print_string "\027[m" end else begin print_string s; end; print_newline (); flush_all () let rec add_heads accs lists = match lists with | [] -> List.map List.rev accs | ((h::_)::rest) -> add_heads (List.map (fun acc -> h :: acc) accs) rest | _ -> failwith "Doesn't have a head" let rec combinations (acc : 'a list) (lists : 'a list list) : 'a list list = match lists with | [] -> [List.rev acc] | [x] :: t -> combinations (x::acc) t | (x::xs) :: t -> combinations (x::acc) t @ add_heads (List.map (fun x' -> x' :: acc) xs) t | _ -> failwith "Empty inner list" let rec non_mutants (info : mutant_info) acc muts : (mutant_info * string list) = match muts with | [] -> (info, List.rev acc) | m :: muts' -> non_mutants info (Printf.sprintf "%s%s%s" m.mut_begin m.mut_body m.mut_end :: acc) muts' let begin_comment () = if !current_filetype = ".c" || !current_filetype = ".h" || !current_filetype = ".sol" then "/*" else "(*" let end_comment () = if !current_filetype = ".c" || !current_filetype = ".h" || !current_filetype = ".sol" then "*/" else "*)" (* acc is a list of a mutant-free prefix until this point *) let rec all_mutants' (acc : string list) (muts : mutant list) : (mutant_info * string list) list = match muts with | [] -> [(default_info, List.rev acc)] | {mut_info = info; mut_begin = start; mut_body = code; mut_end = endc} :: rest -> (* Don't keep current mutant, mutate the rest *) all_mutants' (Printf.sprintf "%s%s%s" start code endc :: acc) rest (* Insert current mutant. Mutate nothing else. *) @ [non_mutants info (Printf.sprintf "%s %s %s %s %s" start (end_comment ()) code (begin_comment ()) endc :: acc) rest] let all_mutants muts : (mutant_info * string) list = List.map (fun (opt, ss) -> (opt, String.concat "" ss)) (all_mutants' [] muts) let rec cartesian (lists : 'a list list) : 'a list list = match lists with | [ x ] -> List.map (fun y -> [y]) x | h::t -> List.concat (List.map (fun l -> (List.map (fun x -> x :: l) h)) (cartesian t)) | [] -> [] (* DEAD CODE let test_out handle_section input = let rec go sec = if handle_section sec.sec_name then let rec walk_nodes nodes = match nodes with | [] -> [] | (Text s) :: rest -> s :: (walk_nodes rest) | (Mutants ms) :: rest -> (Printf.sprintf "%s%s%s" ms.ms_begin ms.ms_base (String.concat "" (List.map output_mutant ms.ms_mutants))) :: walk_nodes rest | (QuickChick qc) :: rest -> (Printf.sprintf "%s*) QuickChick %s (*%s" qc.qc_begin qc.qc_body qc.qc_end) :: walk_nodes rest in Printf.sprintf "%s%s%s%s%s" (if sec.sec_name = "" || sec.sec_name.[0] = '_' then "" else sec.sec_begin) (if sec.sec_name = "" || sec.sec_name.[0] = '_' then "" else sec.sec_name) (* __default... -> don't print it *) (if sec.sec_name = "" || sec.sec_name.[0] = '_' then "" else sec.sec_end) (output_extends sec.sec_extends) (String.concat "" (walk_nodes sec.sec_nodes)) else output_section sec in String.concat "" (List.map go input) *) let quickCheckFunction () = match !maxSuccess with | None -> if !analysis then "quickCheckWith (updAnalysis stdArgs true)" else "quickCheck" | Some n -> if !analysis then "quickCheckWith (updAnalysis (updMaxSuccess stdArgs " ^ string_of_int n ^ ") true)" else "quickCheckWith (updMaxSuccess stdArgs " ^ string_of_int n ^ ")" (* Combine mutants with base. Receives a base mutant, plus a list of (optionally tagged) mutants. Produces all mutants, including base. *) let combine_mutants (bms : ('a * (mutant_info * 'a) list) list) : (mutant_info * 'a list) list = let rec combine_aux bms = match bms with | [] -> [(default_info, [])] | (b,ms)::bms' -> (* Construct a non-mutant version of the rest of the possibilities *) let non_mutant_rest = List.map fst bms' in (* Option 1: Mutate something now. *) let mutated_now = List.map (fun (info, m) -> (info, m :: non_mutant_rest)) ms in (* Option 2: Keep base. Mutate later. *) let mutated_later = List.map (fun (info, ms') -> (info, b :: ms')) (combine_aux bms') in mutated_now @ mutated_later in List.rev (combine_aux bms) let from_cons (l : 'a list) : 'a * 'a list = match l with [] -> failwith "Not expecting empty list!" | h::t -> (h,t) let from_Some (o : 'a option) : 'a = match o with None -> failwith "Not expecting None!" | Some x -> x let mutate_outs handle_section input = let things_to_check = ref [] in let go (sec : section) = if handle_section sec.sec_name then begin debug "Handling section: %s\n" sec.sec_name; let handle_node (n : node) = match n with | Text s -> (s, []) | Mutants ms -> (* To handle a mutant section, extract base + all mutants *) let (non_mutated, mutants) = match all_mutants ms.ms_mutants with | (_info,non_mutated) :: mutants -> (non_mutated, List.rev mutants) | [] -> failwith "Internal quickChickTool error: no base mutant" in (Printf.sprintf "%s%s%s" ms.ms_begin ms.ms_base non_mutated, List.map (fun (info, s) -> (info, Printf.sprintf "%s %s %s %s %s" ms.ms_begin (begin_comment ()) ms.ms_base (end_comment ()) s)) mutants) | QuickChick qc -> (* Test sections only affect the base *) things_to_check := qc.qc_body :: !things_to_check; (Printf.sprintf "%s QuickChick %s %s" qc.qc_begin qc.qc_body qc.qc_end, []) (* Add all tests *) in match List.map (fun (info, ss) -> (info, String.concat "" ss)) (combine_mutants (List.map handle_node sec.sec_nodes)) with | (_info, base) :: mutants -> (base, mutants) | [] -> failwith "Internal quickChickTool error: no base mutant after combining" end else (String.concat "" (List.map output_node sec.sec_nodes), []) in let result = List.map (fun (info, ss) -> (info, String.concat "" ss)) (combine_mutants (List.map go input)) in (result, !things_to_check) module SS = Set.Make(String) type 'a file_structure = File of string * 'a | Dir of string * 'a file_structure list let gather_all_vs_from_dir fs = let all_vs = ref [] in let rec loop fs = match fs with | File (s, _) -> if (Filename.check_suffix s ".v") && not (List.exists (fun x -> Filename.basename x = Filename.basename s) !excluded) then all_vs := (Filename.chop_suffix s ".v") :: !all_vs | Dir (s, fss) -> if not (List.exists (fun x -> Filename.basename x = Filename.basename s) !excluded) then List.iter loop fss else () in loop fs; !all_vs let split_words s = let i = ref 0 in let words = ref [] in let testchar j c = if String.contains " \r\t\n" c then ( (if !i < j then words := String.sub s !i (j - !i) :: !words); i := j + 1 ) in s |> String.iteri testchar; testchar (String.length s) '\n'; List.rev !words (* Find all .v files listed by file fpath. Assumes filenames have no * whitespace, and recognizes single-line comments prefixed with '#'. *) let vs_from_file fpath = let f = open_in fpath in let files = ref [] in try while true do (* Read the whole file f *) let line = input_line f in let line = match String.index line '#' with | exception Not_found -> line | i -> String.sub line 0 i in line |> split_words |> List.iter (fun w -> if Filename.check_suffix w ".v" then files := w :: !files) done; assert false with | End_of_file -> !files let gather_all_vs_from_file f fs = let included = vs_from_file f in let all_vs = ref [] in let rec loop fss = match fss with | File (s, _) -> if Filename.check_suffix s ".v" && List.exists (fun x -> Filename.basename x = Filename.basename s) included then all_vs := (Filename.chop_suffix s ".v") :: !all_vs | Dir (_, fsss) -> List.iter loop fsss in loop fs; !all_vs let gather_all_vs fs = match !include_file with | None -> gather_all_vs_from_dir fs | Some f -> gather_all_vs_from_file f fs let is_prefix pre s = String.length s >= String.length pre && String.sub s 0 (String.length pre) = pre type test_result = { mutable passed: int; mutable failed: int; mutable inconclusive: int } let test_results = {passed=0; failed=0; inconclusive=0} let reset_test_results () = test_results.passed <- 0; test_results.failed <- 0; test_results.inconclusive <- 0 type expected_results = ExpectOnlySuccesses | ExpectSomeFailure let something_failed = ref false let confirm_results e = let failed s = highlight Failure (Printf.sprintf "Unexpected result: %s" s); if !fail_fast then exit 1 else something_failed := true in if test_results.inconclusive > 0 then failed "Inconclusive test" else match e with | ExpectOnlySuccesses -> if test_results.failed > 0 then failed "Test failed in base" | ExpectSomeFailure -> if test_results.failed = 0 then failed "No tests failed for this mutant" let temporary_file = "QuickChickTop.v" let run_and_show_output_on_failure command msg = let chan = Unix.open_process_in command in let res = ref ([] : string list) in let rec process_otl_aux () = let e = input_line chan in res := e::!res; process_otl_aux() in try process_otl_aux () with End_of_file -> let stat = Unix.close_process_in chan in let result = match stat with Unix.WEXITED 0 -> List.rev !res | Unix.WEXITED i -> List.rev (Printf.sprintf "Exited with status %d" i :: !res) | Unix.WSIGNALED i -> List.rev (Printf.sprintf "Killed (%d)" i :: !res) | Unix.WSTOPPED i -> List.rev (Printf.sprintf "Stopped (%d)" i :: !res) in if stat <> (Unix.WEXITED 0) || !verbose then List.iter (fun s -> (print_string s; print_newline())) result; if stat = Unix.WEXITED 0 then () else failwith msg let tmp_int_re = Str.regexp "type int =[ ]*int" let string_of_process_status = function | Unix.WEXITED i -> Printf.sprintf "EXIT %d" i | Unix.WSIGNALED i -> Printf.sprintf "SIGNALED %d" i | Unix.WSTOPPED i -> Printf.sprintf "STOPPED %d" i let system args = match Unix.system args with | Unix.WEXITED 0 -> () | e -> highlight Failure (Printf.sprintf "Command failed: %s" (string_of_process_status e)); exit 1 let compile_and_run where e : unit = let here = Sys.getcwd() in Sys.chdir where; system !compile_command; for_all_files (Sys.getcwd ()) (fun file -> if ends_with ~suffix:".ml" file || ends_with ~suffix:".mli" file then sed_file file (fun line -> if Str.string_match tmp_int_re line 0 then "type tmptmptmp = int;; type int = tmptmptmp" else line)); let ocamlbuild_cmd = Printf.sprintf "ocamlbuild -use-ocamlfind -pkg zarith -cflag -rectypes %s %s.native" !ocamlbuild_args (Filename.chop_suffix temporary_file ".v") in run_and_show_output_on_failure ocamlbuild_cmd "Ocamlbuild failure"; reset_test_results(); let run_command = Printf.sprintf "./%s.native" (Filename.chop_suffix temporary_file ".v") in let chan = Unix.open_process_in run_command in let found_result = ref false in let rec process_otl_aux () = (* BCP: If we ever have long-running tests that do things like printing a . every once in a while, we'll need to change this so that they don't get buffered for too long: *) let e = input_line chan in let s_e = if !analysis then ("!![" ^ e ^ "]") else e in print_string s_e; print_newline(); begin if is_prefix "+++ Passed" e then (test_results.passed <- test_results.passed+1; found_result := true) else if is_prefix "+++ Failed (as expected)" e then (test_results.passed <- test_results.passed+1; found_result := true) else if is_prefix "*** Failed" e then (test_results.failed <- test_results.failed+1; found_result := true) end; process_otl_aux() in try process_otl_aux () with End_of_file -> if not !analysis then if not !found_result then begin highlight Failure "Test neither 'Passed' nor 'Failed'"; test_results.inconclusive <- test_results.inconclusive + 1 end; let stat = Unix.close_process_in chan in begin match stat with | Unix.WEXITED 0 -> () | Unix.WEXITED i -> highlight Failure (Printf.sprintf "Exited with status %d" i); test_results.inconclusive <- test_results.inconclusive + 1 | Unix.WSIGNALED i -> highlight Failure (Printf.sprintf "Killed (%d)" i); test_results.inconclusive <- test_results.inconclusive + 1 | Unix.WSTOPPED i -> highlight Failure (Printf.sprintf "Stopped (%d)" i); test_results.inconclusive <- test_results.inconclusive + 1 end; Sys.chdir here; confirm_results e let remove_vo v = if Filename.check_suffix v ".v" then let vo = Filename.chop_suffix v ".v" ^ ".vo" in if Sys.file_exists vo then begin debug "Removing %s\n" vo; ignore (Sys.command ("rm " ^ vo)) end let write_file out_file out_data = debug "Writing to file: %s\n" out_file; let out_channel = open_out out_file in output_string out_channel out_data; close_out out_channel; remove_vo out_file; out_file let write_tmp_file out_data = let vf = Filename.temp_file "QuickChick" ".v" in write_file vf out_data let coqc_single_cmd vf = Printf.sprintf "coqc -w none -Q . Top %s" vf let load_file f = let ic = open_in f in let n = in_channel_length ic in let s = Bytes.create n in really_input ic s 0 n; close_in ic; Bytes.to_string s let rec catMaybes = function | [] -> [] | Some x :: t -> x :: catMaybes t | None :: t -> catMaybes t (* ----------------------------------------------------------------- *) (* Parsing *) let is_dir f = (* This is just in case the file has disappeared between the time we listed the outer directory and the time we need to test whether one of its members is a subdirectory. Surprisingly, this can happen pretty often with emacs temp files... *) try Sys.is_directory f with Sys_error _ -> false let option_map f o = match o with | Some x -> Some (f x) | None -> None let rec parse_file_or_dir file_name = try debug "[parse_file_or_dir %s]\n" file_name; if is_dir file_name then begin if is_prefix tmp_dir (Filename.basename file_name) || (List.exists (fun x -> x = Filename.basename file_name) !excluded) then None else begin let ls = Sys.readdir file_name in if !verbose then begin Printf.printf "Directory contains: \n"; Array.iter (fun s -> Printf.printf " %s\n" s) ls end; let parsed = List.map (fun s -> parse_file_or_dir (file_name ^ "/" ^ s)) (Array.to_list ls) in Some (Dir (file_name, catMaybes parsed)) end end else if Filename.basename file_name = "Makefile" || Filename.basename file_name = "_CoqProject" then let s = load_file file_name in Some (File (file_name, [{ sec_begin = "(*" ; sec_name = "__default__" ^ file_name ; sec_end = "*)" ; sec_extends = None ; sec_nodes = [Text s] } ])) else let handle = (Filename.check_suffix file_name ".v" || Filename.check_suffix file_name ".ml"|| Filename.check_suffix file_name ".c" || Filename.check_suffix file_name ".py"|| Filename.check_suffix file_name ".sol" || Filename.basename file_name="_tags" || Filename.check_suffix file_name ".h") && not (List.exists (fun x -> x = Filename.basename file_name) !excluded) in if handle then begin debug "In file: %s\n" file_name; let lexbuf = Lexing.from_channel (open_in file_name) in lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = file_name }; let result = try program lexer lexbuf with exn -> (Printf.printf "Parse error when reading file: %s\n" file_name; raise exn) in let collapse l = let rec loop acc acc_text l = match l with | Text s :: l' -> loop acc (s :: acc_text) l' | n :: l' -> let text_acc_node = Text (String.concat "" (List.rev acc_text)) in loop (n :: text_acc_node :: acc) [] l' | [] -> let text_acc_node = Text (String.concat "" (List.rev acc_text)) in text_acc_node :: acc in List.rev (loop [] [] l) in let result = List.map (fun sec -> {sec with sec_nodes = collapse sec.sec_nodes}) result in let fix_extends extends = split_words (String.concat "" extends) in let result = List.map (fun sec -> {sec with sec_extends = option_map (fun e -> {e with ext_extends = fix_extends e.ext_extends}) sec.sec_extends} ) result in let fixed_default = match result with | sec :: ss -> { sec_begin = "(*" ; sec_name = "__default__" ^ file_name ; sec_end = "*)" ; sec_extends = sec.sec_extends ; sec_nodes = sec.sec_nodes } :: ss | _ -> failwith "Empty section list?" in Some (File (file_name, fixed_default)) end else None with Sys_error e -> failwith ("Sys_error " ^ e) (* ----------------------------------------------------------------- *) (* Main function *) let rec section_length_of_fs fs = match fs with | File (_, ss) -> List.length ss | Dir (_, fss) -> List.fold_left (+) 0 (List.map section_length_of_fs fss) (* TODO: "trim" is a confusing name for this function! *) let trim s = match split_words s with | [] -> "" | h :: _ -> h (* Create a table of sections *) let sec_find sec_graph s = debug "sec_find: %s\n" (trim s); try Hashtbl.find sec_graph (trim s) with Not_found -> begin let keys = Hashtbl.fold (fun k _v s -> k ^ " " ^ s) sec_graph "" in failwith (Printf.sprintf "QuickChick: Didn't find section called %s (available sections: %s)\n" s keys) end let build_sec_graph fs = let sec_graph = Hashtbl.create (section_length_of_fs fs) in let rec populate_hashtbl_sections (sections : section list) = match sections with | [] -> () | sec :: rest -> let extends = match sec.sec_extends with | Some ext -> ext.ext_extends | None -> [] in Hashtbl.add sec_graph (trim sec.sec_name) extends; populate_hashtbl_sections rest in let rec populate_hashtbl (fs : section list file_structure) = (* Populate based on an entire file structure *) begin match fs with | File (_, ss) -> populate_hashtbl_sections ss | Dir (_, fss) -> List.iter populate_hashtbl fss end in populate_hashtbl fs; sec_graph (* Decide whether to handle a section (mutate/uncomment quickChicks) *) let rec handle_section' sec_graph current_section starting_section = let current_section = trim current_section in let starting_section = trim starting_section in if !verbose then (Printf.printf "handle_section': current_section: %s\n" current_section; Printf.printf " starting_section: %s\n" starting_section; flush_all ()); current_section = starting_section || List.exists (fun starting_section' -> handle_section' sec_graph current_section starting_section') (sec_find sec_graph starting_section) let handle_section sec_graph sn' = if !verbose then (Printf.printf "Asking for section %s\n" sn'; flush_all ()); let sn' = trim sn' in match !sec_name with | Some sn -> handle_section' sec_graph sn' sn | None -> true (* LEO: This has duplication with the mutant generation above *) let calc_dir_mutants sec_graph (fs : section list file_structure) = let all_things_to_check = ref [] in let rec loop (fs : section list file_structure) = match fs with | File (s, ss) -> (* Printf.printf "Calc mutants for file: %s\n" s; flush_all (); *) begin current_filetype := Filename.extension s; match mutate_outs (handle_section sec_graph) ss with | (_info, base) :: muts, things_to_check -> (* Printf.printf "Number of mutants: %d\n" (List.length muts); *) all_things_to_check := (List.map (fun x -> (s,x)) things_to_check) @ !all_things_to_check; (* debug "Number of tests: %d\n%s\n" (List.length things_to_check) (String.concat "\n" things_to_check); *) (File (s, base), List.map (fun (info, m) -> (info, File (s, m))) muts) | _ -> failwith "no base mutant" end | Dir (s, fss) -> begin (* Printf.printf "Calc mutants for dir: %s\n" s; flush_all (); *) let bmfs = List.map loop fss in let rec all_mutant_fs (bmfs : ('a * (mutant_info * 'a) list) list) = match bmfs with | [] -> [(default_info, [])] | (b,mfs)::bmfs' -> let non_mutant_rest = List.map fst bmfs' in let mutated_now = List.map (fun (info, mf) -> (info, mf :: non_mutant_rest)) mfs in let mutated_later = List.map (fun (info, mfs') -> (info, b :: mfs')) (all_mutant_fs bmfs') in mutated_now @ mutated_later in begin match List.rev (all_mutant_fs bmfs) with | (_, base) :: muts -> (Dir (s, base), List.map (fun (info, m) -> (info, Dir (s, m))) muts) | [] -> failwith "no base dir mutant" end end in let result = loop fs in (result, !all_things_to_check) let string_of_tag ms = match ms with | None -> "" | Some t -> t (* more efficient version *) let starts_with ~prefix b = let len = String.length prefix in len > String.length b |> function | true -> false | false -> let rec f j = if j >= len then true else prefix.[j] = b.[j] && f (j+1) in f 0 (* BCP: This function is too big! And there's too much duplication. *) let main = (* List.iter (fun x -> print_endline x) !excluded;*) if !excluded <> [] then output_string stderr "Warning: -exclude option is deprecated\n"; (* Parsing.set_trace true; *) let fs = from_Some (parse_file_or_dir ".") in (* Fill the hashtable *) let sec_graph = build_sec_graph fs in (* Hashtbl.iter (fun a b -> Printf.printf "%s -> %s\n" a (String.concat ", " b)) sec_graph; flush_all (); *) match fs with | File (_, _) -> failwith ". can never be a file. Right?" | Dir (s, fss) -> begin let ((base, dir_mutants), all_things_to_check) = calc_dir_mutants sec_graph fs in (* List.iter (fun (s1,s2) -> Printf.printf "To test: %s - %s\n" s1 s2) all_things_to_check;*) let rec output_mut_dir tmp_dir fs = match fs with | File (s, out_data) -> let out_data = if Filename.basename s = "_CoqProject" then out_data ^ "\n" ^ temporary_file ^ "\n" else out_data in let out_file = tmp_dir ^ "/" ^ s in if not (Sys.file_exists out_file) || load_file out_file <> out_data then ignore (write_file out_file out_data) | Dir (s, fss) -> begin let dir_name = tmp_dir ^ "/" ^ s in if (ensure_dir_exists dir_name) <> 0 then failwith ("Could not create directory: " ^ dir_name) else List.iter (output_mut_dir tmp_dir) fss end in let all_vs = gather_all_vs (Dir (s, fss)) in let extractions = List.map (fun s -> Filename.basename s) all_vs in let mk_import s = let splits = List.tl (String.split_on_char '/' s) in String.concat "." splits in let imports = List.map (fun s -> (if !top = "" then "" else !top ^ ".") ^ (mk_import s)) all_vs in let (test_names, tests) = let number_of_tests = List.length all_things_to_check in let make_test i (f, s) : string * string = let s = let s = trim s in String.sub s 0 (String.length s - 1) in let testname = (* Leo: better qualification *) trim (Filename.basename (Filename.chop_suffix f ".v")) ^ "." ^ s in let structured_structured_output = ( Printf.sprintf "Definition test%d := print_extracted_coq_string (\"{\"\"name\"\": \"\"%s\"\", \" ++ show (withTime(fun tt => %s %s)) ++ \"}" i testname (quickCheckFunction ()) testname ^ (if i == number_of_tests - 1 then "" else ", ") ^ "\")%string.\n" ) in let readable_output = ( Printf.sprintf "Definition test%d := print_extracted_coq_string (\"Checking %s...\" ++ newline ++ show (%s %s))%%string.\n" i testname (quickCheckFunction ()) testname ) in (Printf.sprintf "test%d" i, if !analysis then structured_structured_output else readable_output) in List.split (List.mapi make_test all_things_to_check) in let tmp_file_data = "Require Import String.\n"^ "From QuickChick Require Import QuickChick.\n\n"^ (if imports <> [] then "Require " ^ (String.concat " " imports) ^ ".\n\n" else "")^ (String.concat "\n" tests) ^ "\n" ^ (if (extractions @ test_names <> []) then "Separate Extraction " ^ (String.concat " " extractions) ^ " " ^ (String.concat " " test_names) ^ ".\n" else "") in ensure_tmpdir_exists(); ignore (write_file (tmp_dir ^ "/" ^ temporary_file) tmp_file_data); let dir = tmp_dir ^ "/" ^ s in (* Base mutant *) if not (!nobase) && !only_mutant = None then begin highlight Header "Testing base..."; (* Entire file structure is copied *) output_mut_dir tmp_dir base; compile_and_run dir ExpectOnlySuccesses; end; (* For each mutant structure *) List.iteri (fun i (info, m) -> begin if !only_mutant = Some (Num i) || !only_mutant = None || (match info.tag, !only_mutant with | Some fulltag, Some (Tag tag) -> starts_with ~prefix:(String.trim tag) (String.trim fulltag) | _ -> false) then begin Printf.printf "\n"; let t = match info.tag with None -> "" | Some s -> ": " ^ String.trim s in (* TODO: The line number info should also include the file name! *) highlight Header (Printf.sprintf "Testing mutant %d (%s: line %d)%s" i info.file_name info.line_number t); ensure_tmpdir_exists(); (* Entire file structure is copied *) output_mut_dir tmp_dir m; reset_test_results(); compile_and_run dir ExpectSomeFailure end end) (List.rev dir_mutants) end; if not !analysis then begin if !something_failed then begin highlight Failure "At least one of the tests above produced an unexpected result."; exit 1 end; highlight Success "All tests produced the expected results" end QuickChick-2.1.0/quickChickTool/quickChickToolLexer.mll000066400000000000000000000050371476030541200230750ustar00rootroot00000000000000{ open QuickChickToolParser (* Function to increase line count in lexbuf *) let line_incs s lexbuf = (* Printf.printf "Read: %s\n" s; *) let splits = String.split_on_char '\n' s in let pos = lexbuf.Lexing.lex_curr_p in (* Printf.printf "Was in line %d, position %d\n" pos.pos_lnum (pos.pos_cnum - pos.pos_bol); *) lexbuf.Lexing.lex_curr_p <- { pos with Lexing.pos_lnum = pos.Lexing.pos_lnum + (List.length splits - 1); Lexing.pos_bol = if List.length splits > 1 then pos.Lexing.pos_cnum - (String.length (List.hd (List.rev splits))) else pos.Lexing.pos_bol } let python_comment_bit = ref false } let white = [' ' '\t' '\r' '\n'] let nonwhite = [^ ' ' '\t' '\r' '\n'] (* Main Parsing match *) rule lexer = parse (* OCaml-style comments... *) | (white* "(*!" white* "Section" as s) { line_incs s lexbuf; T_StartSection s } | (white* "(*!" white* "extends" as s) { line_incs s lexbuf; T_Extends s } | (white* "(*!" white* "QuickChick" as s) { line_incs s lexbuf; T_StartQuickChick s } | (white* "(*!" white* "QuickCheck" as s) { line_incs s lexbuf; T_StartQuickCheck s } | (white* "(*!!" as s) { line_incs s lexbuf; T_StartMutTag s } | (white* "(*!" white* "*)" as s) { line_incs s lexbuf; T_StartMutants s } | (white* "(*!" as s) { line_incs s lexbuf; T_StartMutant s } | (white* "(*" as s) { line_incs s lexbuf; T_StartComment s } | (white* "*)" as s) { line_incs s lexbuf; T_EndComment s } (* C-style comments... *) | (white* "/*!" white* "Section" as s) { line_incs s lexbuf; T_StartSection s } | (white* "/*!" white* "extends" as s) { line_incs s lexbuf; T_Extends s } | (white* "/*!" white* "QuickChick" as s) { line_incs s lexbuf; T_StartQuickChick s } | (white* "/*!" white* "QuickCheck" as s) { line_incs s lexbuf; T_StartQuickCheck s } | (white* "/*!!" as s) { line_incs s lexbuf; T_StartMutTag s } | (white* "/*!" white* "*/" as s) { line_incs s lexbuf; T_StartMutants s } | (white* "/*!" as s) { line_incs s lexbuf; T_StartMutant s } | (white* "/*" as s) { line_incs s lexbuf; T_StartComment s } | (white* "*/" as s) { line_incs s lexbuf; T_EndComment s } (* Other *) | (white* as s) (nonwhite as c) { line_incs (s^(String.make 1 c)) lexbuf; T_Char (s^(String.make 1 c)) } | (white* as s) eof { line_incs s lexbuf; T_Eof s } QuickChick-2.1.0/quickChickTool/quickChickToolParser.mly000066400000000000000000000116051476030541200232650ustar00rootroot00000000000000%{ open Lexing open QuickChickToolTypes (* type node = (* Base chunk of text *) | Text of string (* Sections: identifier + a bunch of nodes + extend? *) | Section of string * node list * string option (* Commented out QuickChick call *) | QuickChick of string (* Mutant: list of +/- idents, base, list of mutants *) | Mutant of (bool * string) list * string * string list *) (* Uncomment for more debugging... *) %} %token T_Char %token T_Extends %token T_StartSection %token T_StartQuickChick %token T_StartQuickCheck %token T_StartMutTag %token T_StartMutant %token T_StartMutants %token T_StartComment %token T_EndComment %token T_Eof %start program %type program %type section %type sections %type section_contents %type section_content %type mutants %type mutant %type code %type extends %% program: default_section T_Eof { [$1] } | default_section sections T_Eof { $1 :: $2 } | error { let pos = Parsing.symbol_start_pos () in failwith (Printf.sprintf "Error in line %d, position %d" pos.pos_lnum (pos.pos_cnum - pos.pos_bol)) } default_section: section_contents { { sec_begin = "" ; sec_name = "" ; sec_end = "" ; sec_extends = None ; sec_nodes = $1 } } section_contents: { [] } | section_content section_contents { $1 :: $2 } section_content: T_Char { Text $1 } | T_StartQuickChick code T_EndComment { QuickChick { qc_begin = $1; qc_body = String.concat "" $2; qc_end = $3 } } | T_StartQuickCheck code T_EndComment { QuickChick { qc_begin = $1; qc_body = String.concat "" $2; qc_end = $3 } } | T_StartMutants mutants { Mutants { ms_begin = $1; ms_base = ""; ms_mutants = $2 } } | T_StartMutants code mutants { Mutants { ms_begin = $1; ms_base = String.concat "" $2; ms_mutants = $3 } } | T_StartComment section_contents T_EndComment { Text (Printf.sprintf "%s%s%s" $1 (String.concat "" (List.map output_node $2)) $3) } code: T_Char { [$1] } | T_Char code { $1 :: $2 } /* | error { let pos = Parsing.symbol_start_pos () in failwith (Printf.sprintf "Error in line %d, position %d" pos.pos_lnum (pos.pos_cnum - pos.pos_bol)) } */ mutants: mutant_tag { [$1] } | mutant_tag mutants { $1 :: $2 } mutant_tag: T_StartMutTag code T_EndComment mutant { let m = $4 in {m with mut_info = {m.mut_info with tag = Some (String.concat "" $2)}} } | mutant { $1 } mutant: T_StartMutant code T_EndComment { let pos = Parsing.symbol_start_pos () in { mut_info = { file_name = pos.pos_fname ; line_number = pos.pos_lnum ; tag = None } ; mut_begin = $1 ; mut_body = String.concat "" $2 ; mut_end = $3 } } | T_StartMutants { let pos = Parsing.symbol_start_pos () in { mut_info = { file_name = pos.pos_fname ; line_number = pos.pos_lnum ; tag = None } ; mut_begin = "(*" ; mut_body = "" ; mut_end = "*)" } } sections: section { [$1] } | section sections { $1 :: $2 } section: T_StartSection code T_EndComment extends section_contents { { sec_begin = $1 ; sec_name = String.concat "" $2 ; sec_end = $3 ; sec_extends = $4 ; sec_nodes = $5 } } extends: { None } | T_Extends code T_EndComment { Some { ext_begin = $1 ; ext_extends = $2 ; ext_end = $3 } } QuickChick-2.1.0/quickChickTool/quickChickToolTypes.ml000066400000000000000000000034111476030541200227400ustar00rootroot00000000000000type mutant_info = { file_name : string ; line_number : int ; tag : string option } let default_info = { file_name = "" ; line_number = -1 ; tag = None } type mutant = { mut_info : mutant_info ; mut_begin : string ; mut_body : string ; mut_end : string } type node = (* Base chunk of text *) | Text of string (* Commented out QuickChick call *) | QuickChick of { qc_begin : string ; qc_body : string ; qc_end : string } (* Mutant: start of mutant, base, list of mutants *) | Mutants of { ms_begin : string ; ms_base : string ; ms_mutants : mutant list } type extend = { ext_begin : string ; ext_extends : string list ; ext_end : string } type section = (* Sections: Start comment, section name, end comment, extends, contents *) { sec_begin : string ; sec_name : string ; sec_end : string ; sec_extends : extend option ; sec_nodes : node list } let output_mutant (m : mutant) : string = m.mut_begin ^ m.mut_body ^ m.mut_end let output_node (n : node) : string = match n with | Text s -> s | QuickChick qc -> (qc.qc_begin ^ qc.qc_body ^ qc.qc_end) | Mutants ms -> Printf.sprintf "%s%s%s" ms.ms_begin ms.ms_base (String.concat "" (List.map output_mutant ms.ms_mutants)) let output_extends (me : extend option) : string = match me with | Some ext -> ext.ext_begin ^ String.concat "" ext.ext_extends ^ ext.ext_end | None -> "" let output_section (sec : section) : string = let qual s = if sec.sec_name = "" || sec.sec_name.[0] = '_' then "" else s in Printf.sprintf "%s%s%s%s%s" (qual sec.sec_begin) (qual sec.sec_name) (qual sec.sec_end) (output_extends sec.sec_extends) (String.concat "" (List.map output_node sec.sec_nodes)) QuickChick-2.1.0/scripts/000077500000000000000000000000001476030541200152215ustar00rootroot00000000000000QuickChick-2.1.0/scripts/dune000066400000000000000000000000741476030541200161000ustar00rootroot00000000000000(rule (target mycppo) (action (run sh %{dep:mk-mycppo}))) QuickChick-2.1.0/scripts/mk-mycppo000066400000000000000000000003301476030541200170540ustar00rootroot00000000000000# sh mk-mycppo generates the script mycppo # Usage: sh mycppo input.v.cppo output.v COQVER=$(coqc -print-version) COQVER=${COQVER%% *} printf "cppo -V OCAML:$(ocamlc -version) -V COQ:$COQVER -n \$1 -o \$2" > mycppo QuickChick-2.1.0/scripts/quickchick000077500000000000000000000011641476030541200172670ustar00rootroot00000000000000#!/bin/sh set -e # Test mutated QuickChick test executable ($1) # quickchick-expectfailure must be findable in PATH QC_OUT_DIR=qc-out mkdir -p $QC_OUT_DIR/ QC_ALL_MUTANTS_FILE=$QC_OUT_DIR/qc-mutants # Dynamic mutant discovery # TODO: allow mutants to be found via other means QC_MUTANT=DISCOVERY ./"$1" # Test each mutant xargs -n 1 -I {} quickchick-expectfailure ./"$1" {} < $QC_ALL_MUTANTS_FILE if [ "$2" != "" ] then N_MUTANTS=$(wc -l $QC_ALL_MUTANTS_FILE|egrep -o "[0-9]+") if [ -z "$N_MUTANTS" ] || [ $2 -ne $N_MUTANTS ] then echo "Unexpected number of mutants: $N_MUTANTS (expected $2)" exit 1 fi fi QuickChick-2.1.0/scripts/quickchick-expectfailure000077500000000000000000000006251476030541200221260ustar00rootroot00000000000000#!/bin/sh # Run a QuickChick test executable ($1) with a given mutant ($2) and ensure at # least one test fails. set -e QC_OUT_DIR=qc-out mkdir -p $QC_OUT_DIR/ LOG_FILE=$QC_OUT_DIR/testlog-${1##*/}-${2##*/} echo "Mutant $2: Testing..." QC_MUTANT=$2 $1 > $LOG_FILE grep -q '^\*\*\* Failed' $LOG_FILE \ || (echo "Mutant $2: Tests passed, but failure was expected."; exit 1) echo "Mutant $2: Killed!" QuickChick-2.1.0/sf-experiment/000077500000000000000000000000001476030541200163205ustar00rootroot00000000000000QuickChick-2.1.0/sf-experiment/.depend000066400000000000000000000035361476030541200175670ustar00rootroot00000000000000Preface.vo Preface.glob Preface.v.beautified: Preface.v Preface.vio: Preface.v Basics.vo Basics.glob Basics.v.beautified: Basics.v Basics.vio: Basics.v Induction.vo Induction.glob Induction.v.beautified: Induction.v Basics.vo Induction.vio: Induction.v Basics.vio Lists.vo Lists.glob Lists.v.beautified: Lists.v Induction.vo Lists.vio: Lists.v Induction.vio Poly.vo Poly.glob Poly.v.beautified: Poly.v Lists.vo Poly.vio: Poly.v Lists.vio Tactics.vo Tactics.glob Tactics.v.beautified: Tactics.v Poly.vo Tactics.vio: Tactics.v Poly.vio Logic.vo Logic.glob Logic.v.beautified: Logic.v Tactics.vo Logic.vio: Logic.v Tactics.vio IndProp.vo IndProp.glob IndProp.v.beautified: IndProp.v Logic.vo IndProp.vio: IndProp.v Logic.vio Maps.vo Maps.glob Maps.v.beautified: Maps.v Maps.vio: Maps.v ProofObjects.vo ProofObjects.glob ProofObjects.v.beautified: ProofObjects.v IndProp.vo ProofObjects.vio: ProofObjects.v IndProp.vio IndPrinciples.vo IndPrinciples.glob IndPrinciples.v.beautified: IndPrinciples.v ProofObjects.vo IndPrinciples.vio: IndPrinciples.v ProofObjects.vio Rel.vo Rel.glob Rel.v.beautified: Rel.v IndProp.vo Rel.vio: Rel.v IndProp.vio Imp.vo Imp.glob Imp.v.beautified: Imp.v Maps.vo Imp.vio: Imp.v Maps.vio ImpParser.vo ImpParser.glob ImpParser.v.beautified: ImpParser.v Maps.vo Imp.vo ImpParser.vio: ImpParser.v Maps.vio Imp.vio ImpCEvalFun.vo ImpCEvalFun.glob ImpCEvalFun.v.beautified: ImpCEvalFun.v Imp.vo Maps.vo ImpCEvalFun.vio: ImpCEvalFun.v Imp.vio Maps.vio Extraction.vo Extraction.glob Extraction.v.beautified: Extraction.v ImpCEvalFun.vo Imp.vo ImpParser.vo Extraction.vio: Extraction.v ImpCEvalFun.vio Imp.vio ImpParser.vio Auto.vo Auto.glob Auto.v.beautified: Auto.v Maps.vo Imp.vo Auto.vio: Auto.v Maps.vio Imp.vio Postscript.vo Postscript.glob Postscript.v.beautified: Postscript.v Postscript.vio: Postscript.v Bib.vo Bib.glob Bib.v.beautified: Bib.v Bib.vio: Bib.v QuickChick-2.1.0/sf-experiment/Auto.v000066400000000000000000000520631476030541200174250ustar00rootroot00000000000000(** * Auto: More Automation *) Set Warnings "-notation-overridden,-parsing". Require Import Coq.omega.Omega. Require Import Maps. Require Import Imp. (** Up to now, we've used the more manual part of Coq's tactic facilities. In this chapter, we'll learn more about some of Coq's powerful automation features: proof search via the [auto] tactic, automated forward reasoning via the [Ltac] hypothesis matching machinery, and deferred instantiation of existential variables using [eapply] and [eauto]. Using these features together with Ltac's scripting facilities will enable us to make our proofs startlingly short! Used properly, they can also make proofs more maintainable and robust to changes in underlying definitions. A deeper treatment of [auto] and [eauto] can be found in the [UseAuto] chapter. There's another major category of automation we haven't discussed much yet, namely built-in decision procedures for specific kinds of problems: [omega] is one example, but there are others. This topic will be deferred for a while longer. Our motivating example will be this proof, repeated with just a few small changes from the [Imp] chapter. We will simplify this proof in several stages. *) Ltac inv H := inversion H; subst; clear H. Theorem ceval_deterministic: forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 E1 E2; generalize dependent st2; induction E1; intros st2 E2; inv E2. - (* E_Skip *) reflexivity. - (* E_Ass *) reflexivity. - (* E_Seq *) assert (st' = st'0) as EQ1. { (* Proof of assertion *) apply IHE1_1; assumption. } subst st'0. apply IHE1_2. assumption. (* E_IfTrue *) - (* b evaluates to true *) apply IHE1. assumption. - (* b evaluates to false (contradiction) *) rewrite H in H5. inversion H5. (* E_IfFalse *) - (* b evaluates to true (contradiction) *) rewrite H in H5. inversion H5. - (* b evaluates to false *) apply IHE1. assumption. (* E_WhileFalse *) - (* b evaluates to false *) reflexivity. - (* b evaluates to true (contradiction) *) rewrite H in H2. inversion H2. (* E_WhileTrue *) - (* b evaluates to false (contradiction) *) rewrite H in H4. inversion H4. - (* b evaluates to true *) assert (st' = st'0) as EQ1. { (* Proof of assertion *) apply IHE1_1; assumption. } subst st'0. apply IHE1_2. assumption. Qed. (* ################################################################# *) (** * The [auto] Tactic *) (** Thus far, our proof scripts mostly apply relevant hypotheses or lemmas by name, and one at a time. *) Example auto_example_1 : forall (P Q R: Prop), (P -> Q) -> (Q -> R) -> P -> R. Proof. intros P Q R H1 H2 H3. apply H2. apply H1. assumption. Qed. (** The [auto] tactic frees us from this drudgery by _searching_ for a sequence of applications that will prove the goal *) Example auto_example_1' : forall (P Q R: Prop), (P -> Q) -> (Q -> R) -> P -> R. Proof. intros P Q R H1 H2 H3. auto. Qed. (** The [auto] tactic solves goals that are solvable by any combination of - [intros] and - [apply] (of hypotheses from the local context, by default). *) (** Using [auto] is always "safe" in the sense that it will never fail and will never change the proof state: either it completely solves the current goal, or it does nothing. *) (** Here is a more interesting example showing [auto]'s power: *) Example auto_example_2 : forall P Q R S T U : Prop, (P -> Q) -> (P -> R) -> (T -> R) -> (S -> T -> U) -> ((P->Q) -> (P->S)) -> T -> P -> U. Proof. auto. Qed. (** Proof search could, in principle, take an arbitrarily long time, so there are limits to how far [auto] will search by default. *) Example auto_example_3 : forall (P Q R S T U: Prop), (P -> Q) -> (Q -> R) -> (R -> S) -> (S -> T) -> (T -> U) -> P -> U. Proof. (* When it cannot solve the goal, [auto] does nothing *) auto. (* Optional argument says how deep to search (default is 5) *) auto 6. Qed. (** When searching for potential proofs of the current goal, [auto] considers the hypotheses in the current context together with a _hint database_ of other lemmas and constructors. Some common lemmas about equality and logical operators are installed in this hint database by default. *) Example auto_example_4 : forall P Q R : Prop, Q -> (Q -> R) -> P \/ (Q /\ R). Proof. auto. Qed. (** We can extend the hint database just for the purposes of one application of [auto] by writing [auto using ...]. *) Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m. Proof. intros. omega. Qed. Example auto_example_6 : forall n m p : nat, (n <= p -> (n <= m /\ m <= n)) -> n <= p -> n = m. Proof. intros. auto. (* does nothing: auto doesn't destruct hypotheses! *) auto using le_antisym. Qed. (** Of course, in any given development there will probably be some specific constructors and lemmas that are used very often in proofs. We can add these to the global hint database by writing Hint Resolve T. at the top level, where [T] is a top-level theorem or a constructor of an inductively defined proposition (i.e., anything whose type is an implication). As a shorthand, we can write Hint Constructors c. to tell Coq to do a [Hint Resolve] for _all_ of the constructors from the inductive definition of [c]. It is also sometimes necessary to add Hint Unfold d. where [d] is a defined symbol, so that [auto] knows to expand uses of [d], thus enabling further possibilities for applying lemmas that it knows about. *) Hint Resolve le_antisym. Example auto_example_6' : forall n m p : nat, (n<= p -> (n <= m /\ m <= n)) -> n <= p -> n = m. Proof. intros. auto. (* picks up hint from database *) Qed. Definition is_fortytwo x := x = 42. Example auto_example_7: forall x, (x <= 42 /\ 42 <= x) -> is_fortytwo x. Proof. auto. (* does nothing *) Abort. Hint Unfold is_fortytwo. Example auto_example_7' : forall x, (x <= 42 /\ 42 <= x) -> is_fortytwo x. Proof. auto. Qed. (** Now let's take a first pass over [ceval_deterministic] to simplify the proof script. *) Theorem ceval_deterministic': forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 E1 E2. generalize dependent st2; induction E1; intros st2 E2; inv E2; auto. - (* E_Seq *) assert (st' = st'0) as EQ1 by auto. subst st'0. auto. - (* E_IfTrue *) + (* b evaluates to false (contradiction) *) rewrite H in H5. inversion H5. - (* E_IfFalse *) + (* b evaluates to true (contradiction) *) rewrite H in H5. inversion H5. - (* E_WhileFalse *) + (* b evaluates to true (contradiction) *) rewrite H in H2. inversion H2. (* E_WhileTrue *) - (* b evaluates to false (contradiction) *) rewrite H in H4. inversion H4. - (* b evaluates to true *) assert (st' = st'0) as EQ1 by auto. subst st'0. auto. Qed. (** When we are using a particular tactic many times in a proof, we can use a variant of the [Proof] command to make that tactic into a default within the proof. Saying [Proof with t] (where [t] is an arbitrary tactic) allows us to use [t1...] as a shorthand for [t1;t] within the proof. As an illustration, here is an alternate version of the previous proof, using [Proof with auto]. *) Theorem ceval_deterministic'_alt: forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof with auto. intros c st st1 st2 E1 E2; generalize dependent st2; induction E1; intros st2 E2; inv E2... - (* E_Seq *) assert (st' = st'0) as EQ1... subst st'0... - (* E_IfTrue *) + (* b evaluates to false (contradiction) *) rewrite H in H5. inversion H5. - (* E_IfFalse *) + (* b evaluates to true (contradiction) *) rewrite H in H5. inversion H5. - (* E_WhileFalse *) + (* b evaluates to true (contradiction) *) rewrite H in H2. inversion H2. (* E_WhileTrue *) - (* b evaluates to false (contradiction) *) rewrite H in H4. inversion H4. - (* b evaluates to true *) assert (st' = st'0) as EQ1... subst st'0... Qed. (* ################################################################# *) (** * Searching For Hypotheses *) (** The proof has become simpler, but there is still an annoying amount of repetition. Let's start by tackling the contradiction cases. Each of them occurs in a situation where we have both H1: beval st b = false and H2: beval st b = true as hypotheses. The contradiction is evident, but demonstrating it is a little complicated: we have to locate the two hypotheses [H1] and [H2] and do a [rewrite] following by an [inversion]. We'd like to automate this process. (In fact, Coq has a built-in tactic [congruence] that will do the job in this case. But we'll ignore the existence of this tactic for now, in order to demonstrate how to build forward search tactics by hand.) As a first step, we can abstract out the piece of script in question by writing a little function in Coq's tactic programming language, Ltac. *) Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2. Theorem ceval_deterministic'': forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 E1 E2. generalize dependent st2; induction E1; intros st2 E2; inv E2; auto. - (* E_Seq *) assert (st' = st'0) as EQ1 by auto. subst st'0. auto. - (* E_IfTrue *) + (* b evaluates to false (contradiction) *) rwinv H H5. - (* E_IfFalse *) + (* b evaluates to true (contradiction) *) rwinv H H5. - (* E_WhileFalse *) + (* b evaluates to true (contradiction) *) rwinv H H2. (* E_WhileTrue *) - (* b evaluates to false (contradiction) *) rwinv H H4. - (* b evaluates to true *) assert (st' = st'0) as EQ1 by auto. subst st'0. auto. Qed. (** That was is a bit better, but not much. We really want Coq to discover the relevant hypotheses for us. We can do this by using the [match goal] facility of Ltac. *) Ltac find_rwinv := match goal with H1: ?E = true, H2: ?E = false |- _ => rwinv H1 H2 end. (** The [match goal] tactic looks for two distinct hypotheses that have the form of equalities, with the same arbitrary expression [E] on the left and with conflicting boolean values on the right. If such hypotheses are found, it binds [H1] and [H2] to their names and applies the [rwinv] tactic to [H1] and [H2]. Adding this tactic to the ones that we invoke in each case of the induction handles all of the contradictory cases. *) Theorem ceval_deterministic''': forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 E1 E2. generalize dependent st2; induction E1; intros st2 E2; inv E2; try find_rwinv; auto. - (* E_Seq *) assert (st' = st'0) as EQ1 by auto. subst st'0. auto. - (* E_WhileTrue *) + (* b evaluates to true *) assert (st' = st'0) as EQ1 by auto. subst st'0. auto. Qed. (** Let's see about the remaining cases. Each of them involves applying a conditional hypothesis to extract an equality. Currently we have phrased these as assertions, so that we have to predict what the resulting equality will be (although we can then use [auto] to prove it). An alternative is to pick the relevant hypotheses to use and then rewrite with them, as follows: *) Theorem ceval_deterministic'''': forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 E1 E2. generalize dependent st2; induction E1; intros st2 E2; inv E2; try find_rwinv; auto. - (* E_Seq *) rewrite (IHE1_1 st'0 H1) in *. auto. - (* E_WhileTrue *) + (* b evaluates to true *) rewrite (IHE1_1 st'0 H3) in *. auto. Qed. (** Now we can automate the task of finding the relevant hypotheses to rewrite with. *) Ltac find_eqn := match goal with H1: forall x, ?P x -> ?L = ?R, H2: ?P ?X |- _ => rewrite (H1 X H2) in * end. (** The pattern [forall x, ?P x -> ?L = ?R] matches any hypothesis of the form "for all [x], _some property of [x]_ implies _some equality_." The property of [x] is bound to the pattern variable [P], and the left- and right-hand sides of the equality are bound to [L] and [R]. The name of this hypothesis is bound to [H1]. Then the pattern [?P ?X] matches any hypothesis that provides evidence that [P] holds for some concrete [X]. If both patterns succeed, we apply the [rewrite] tactic (instantiating the quantified [x] with [X] and providing [H2] as the required evidence for [P X]) in all hypotheses and the goal. One problem remains: in general, there may be several pairs of hypotheses that have the right general form, and it seems tricky to pick out the ones we actually need. A key trick is to realize that we can _try them all_! Here's how this works: - each execution of [match goal] will keep trying to find a valid pair of hypotheses until the tactic on the RHS of the match succeeds; if there are no such pairs, it fails; - [rewrite] will fail given a trivial equation of the form [X = X]; - we can wrap the whole thing in a [repeat], which will keep doing useful rewrites until only trivial ones are left. *) Theorem ceval_deterministic''''': forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 E1 E2. generalize dependent st2; induction E1; intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto. Qed. (** The big payoff in this approach is that our proof script should be robust in the face of modest changes to our language. For example, we can add a [REPEAT] command to the language. *) Module Repeat. Inductive com : Type := | CSkip : com | CAsgn : id -> aexp -> com | CSeq : com -> com -> com | CIf : bexp -> com -> com -> com | CWhile : bexp -> com -> com | CRepeat : com -> bexp -> com. (** [REPEAT] behaves like [WHILE], except that the loop guard is checked _after_ each execution of the body, with the loop repeating as long as the guard stays _false_. Because of this, the body will always execute at least once. *) Notation "'SKIP'" := CSkip. Notation "c1 ; c2" := (CSeq c1 c2) (at level 80, right associativity). Notation "X '::=' a" := (CAsgn X a) (at level 60). Notation "'WHILE' b 'DO' c 'END'" := (CWhile b c) (at level 80, right associativity). Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" := (CIf e1 e2 e3) (at level 80, right associativity). Notation "'REPEAT' e1 'UNTIL' b2 'END'" := (CRepeat e1 b2) (at level 80, right associativity). Inductive ceval : state -> com -> state -> Prop := | E_Skip : forall st, ceval st SKIP st | E_Ass : forall st a1 n X, aeval st a1 = n -> ceval st (X ::= a1) (t_update st X n) | E_Seq : forall c1 c2 st st' st'', ceval st c1 st' -> ceval st' c2 st'' -> ceval st (c1 ; c2) st'' | E_IfTrue : forall st st' b1 c1 c2, beval st b1 = true -> ceval st c1 st' -> ceval st (IFB b1 THEN c1 ELSE c2 FI) st' | E_IfFalse : forall st st' b1 c1 c2, beval st b1 = false -> ceval st c2 st' -> ceval st (IFB b1 THEN c1 ELSE c2 FI) st' | E_WhileFalse : forall b1 st c1, beval st b1 = false -> ceval st (WHILE b1 DO c1 END) st | E_WhileTrue : forall st st' st'' b1 c1, beval st b1 = true -> ceval st c1 st' -> ceval st' (WHILE b1 DO c1 END) st'' -> ceval st (WHILE b1 DO c1 END) st'' | E_RepeatEnd : forall st st' b1 c1, ceval st c1 st' -> beval st' b1 = true -> ceval st (CRepeat c1 b1) st' | E_RepeatLoop : forall st st' st'' b1 c1, ceval st c1 st' -> beval st' b1 = false -> ceval st' (CRepeat c1 b1) st'' -> ceval st (CRepeat c1 b1) st''. Notation "c1 '/' st '\\' st'" := (ceval st c1 st') (at level 40, st at level 39). (** Our first attempt at the proof is disappointing: the [E_RepeatEnd] and [E_RepeatLoop] cases are not handled by our previous automation. *) Theorem ceval_deterministic: forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 E1 E2. generalize dependent st2; induction E1; intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto. - (* E_RepeatEnd *) + (* b evaluates to false (contradiction) *) find_rwinv. (* oops: why didn't [find_rwinv] solve this for us already? answer: we did things in the wrong order. *) - (* E_RepeatLoop *) + (* b evaluates to true (contradiction) *) find_rwinv. Qed. (** To fix this, we just have to swap the invocations of [find_eqn] and [find_rwinv]. *) Theorem ceval_deterministic': forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 E1 E2. generalize dependent st2; induction E1; intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto. Qed. End Repeat. (** These examples just give a flavor of what "hyper-automation" can achieve in Coq. The details of [match goal] are a bit tricky, and debugging scripts using it is, frankly, not very pleasant. But it is well worth adding at least simple uses to your proofs, both to avoid tedium and to "future proof" them. *) (* ----------------------------------------------------------------- *) (** *** [eapply] and [eauto] *) (** To close the chapter, we'll introduce one more convenient feature of Coq: its ability to delay instantiation of quantifiers. To motivate this feature, recall this example from the [Imp] chapter: *) Example ceval_example1: (X ::= ANum 2;; IFB BLe (AId X) (ANum 1) THEN Y ::= ANum 3 ELSE Z ::= ANum 4 FI) / empty_state \\ (t_update (t_update empty_state X 2) Z 4). Proof. (* We supply the intermediate state [st']... *) apply E_Seq with (t_update empty_state X 2). - apply E_Ass. reflexivity. - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity. Qed. (** In the first step of the proof, we had to explicitly provide a longish expression to help Coq instantiate a "hidden" argument to the [E_Seq] constructor. This was needed because the definition of [E_Seq]... E_Seq : forall c1 c2 st st' st'', c1 / st \\ st' -> c2 / st' \\ st'' -> (c1 ;; c2) / st \\ st'' is quantified over a variable, [st'], that does not appear in its conclusion, so unifying its conclusion with the goal state doesn't help Coq find a suitable value for this variable. If we leave out the [with], this step fails ("Error: Unable to find an instance for the variable [st']"). What's silly about this error is that the appropriate value for [st'] will actually become obvious in the very next step, where we apply [E_Ass]. If Coq could just wait until we get to this step, there would be no need to give the value explicitly. This is exactly what the [eapply] tactic gives us: *) Example ceval'_example1: (X ::= ANum 2;; IFB BLe (AId X) (ANum 1) THEN Y ::= ANum 3 ELSE Z ::= ANum 4 FI) / empty_state \\ (t_update (t_update empty_state X 2) Z 4). Proof. eapply E_Seq. (* 1 *) - apply E_Ass. (* 2 *) reflexivity. (* 3 *) - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity. Qed. (** The tactic [eapply H] tactic behaves just like [apply H] except that, after it finishes unifying the goal state with the conclusion of [H], it does not bother to check whether all the variables that were introduced in the process have been given concrete values during unification. If you step through the proof above, you'll see that the goal state at position [1] mentions the _existential variable_ [?st'] in both of the generated subgoals. The next step (which gets us to position [2]) replaces [?st'] with a concrete value. This new value contains a new existential variable [?n], which is instantiated in its turn by the following [reflexivity] step, position [3]. When we start working on the second subgoal (position [4]), we observe that the occurrence of [?st'] in this subgoal has been replaced by the value that it was given during the first subgoal. *) (** Several of the tactics that we've seen so far, including [exists], [constructor], and [auto], have [e...] variants. For example, here's a proof using [eauto]: *) Hint Constructors ceval. Hint Transparent state. Hint Transparent total_map. Definition st12 := t_update (t_update empty_state X 1) Y 2. Definition st21 := t_update (t_update empty_state X 2) Y 1. Example auto_example_8 : exists s', (IFB (BLe (AId X) (AId Y)) THEN (Z ::= AMinus (AId Y) (AId X)) ELSE (Y ::= APlus (AId X) (AId Z)) FI) / st21 \\ s'. Proof. eauto. Qed. (** The [eauto] tactic works just like [auto], except that it uses [eapply] instead of [apply]. *) (** $Date: 2017-05-24 10:56:51 -0400 (Wed, 24 May 2017) $ *) QuickChick-2.1.0/sf-experiment/Basics.v000066400000000000000000000110461476030541200177150ustar00rootroot00000000000000(** * Basics: Functional Programming in Coq *) From QuickChick Require Import QuickChick. Import QcNotation. Open Scope qc_scope. Import GenLow GenHigh. Require Import List ZArith. Import ListNotations. (* Require Import mathcomp.ssreflect.ssreflect. From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype. *) Inductive day : Type := | monday : day | tuesday : day | wednesday : day | thursday : day | friday : day | saturday : day | sunday : day. Definition next_weekday (d:day) : day := match d with | monday => tuesday | tuesday => wednesday | wednesday => thursday | thursday => friday | friday => monday | saturday => monday | sunday => monday end. Definition test_next_weekday := (next_weekday (next_weekday saturday)) = tuesday. (* BCP: Needs an equality test. QuickCheck test_next_weekday. *) (* BCP: QC needs the native one. (Unless we make this Checkable somehow.) Inductive bool : Type := | true : bool | false : bool. *) Definition negb (b:bool) : bool := match b with | true => false | false => true end. Definition andb (b1:bool) (b2:bool) : bool := match b1 with | true => b2 | false => false end. Definition orb (b1:bool) (b2:bool) : bool := match b1 with | true => true | false => b2 end. Definition nandb (b1:bool) (b2:bool) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *) := false. Definition test_nandb1 := (nandb true false). (*! QuickChick test_nandb1. *) Definition minustwo (n : nat) : nat := match n with | O => O | S O => O | S (S n') => n' end. Fixpoint evenb (n:nat) : bool := match n with | O => true | S O => false | S (S n') => evenb n' end. Definition oddb (n:nat) : bool := negb (evenb n). Definition test_oddb1 := oddb 1. (*! QuickChick test_oddb1. *) Module NatPlayground2. Fixpoint plus (n : nat) (m : nat) : nat := match n with | O => m | S n' => S (plus n' m) end. Fixpoint mult (n m : nat) : nat := match n with | O => O | S n' => plus m (mult n' m) end. Definition test_mult1 := (mult 3 3) =? 9. (*! QuickChick test_mult1. *) Fixpoint minus (n m:nat) : nat := match n, m with | O , _ => O | S _ , O => n | S n', S m' => minus n' m' end. End NatPlayground2. Fixpoint exp (base power : nat) : nat := match power with | O => S O | S p => mult base (exp base p) end. Fixpoint factorial (n:nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *) := 0. Definition test_factorial1 := (factorial 3) =? 6. (*! QuickChick test_factorial1. *) Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope. Notation "x - y" := (minus x y) (at level 50, left associativity) : nat_scope. Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope. Check ((0 + 1) + 1). Fixpoint beq_nat (n m : nat) : bool := match n with | O => match m with | O => true | S m' => false end | S n' => match m with | O => false | S m' => beq_nat n' m' end end. Fixpoint leb (n m : nat) : bool := match n with | O => true | S n' => match m with | O => false | S m' => leb n' m' end end. Notation "'FORALLX' x : T , c" := (forAllShrink (@arbitrary T _) shrink (fun x => c)) (at level 200, x ident, T at level 200, c at level 200, right associativity (* , format "'[' 'exists' '/ ' x .. y , '/ ' p ']'" *) ) : type_scope. Definition plus_O_n := FORALL n:nat, 0 + n =? n. (*! QuickChick plus_O_n. *) (* BCP: This should be automatable, we guessed... *) Instance bool_eq (x y : bool) : Dec (x = y). constructor. unfold ssrbool.decidable. repeat (decide equality). Defined. (* BCP: Should be able to use Dec everywhere now :-) *) Definition negb_involutive (b: bool) := (negb (negb b) = b)?. Check negb_involutive. QuickChick negb_involutive. Definition negb_involutive2 (b: bool) := Bool.eqb (negb (negb b)) b. (*! QuickChick negb_involutive2. *) Definition andb_commutative := fun b c => Bool.eqb (andb b c) (andb c b). (*! QuickCheck andb_commutative. *) (* BCP: Don't know what to do with this one! Theorem identity_fn_applied_twice : forall (f : bool -> bool), (forall (x : bool), f x = x) -> forall (b : bool), f (f b) = b. *) Definition andb_eq_orb := fun (b c : bool) => (Bool.eqb (andb b c) (orb b c)) ==> (Bool.eqb b c). (*! QuickCheck andb_eq_orb. *) QuickChick-2.1.0/sf-experiment/Bib.v000066400000000000000000000023601476030541200172040ustar00rootroot00000000000000(** * Bib: Bibliography *) (* ################################################################# *) (** * Resources cited in this volume *) (** [Bertot 2004] Interactive Theorem Proving and Program Development: Coq'Art: The Calculus of Inductive Constructions, by Yves Bertot and Pierre Casteran. Springer-Verlag, 2004. http://tinyurl.com/z3o7nqu [Chlipala 2013] Certified Programming with Dependent Types, by Adam Chlipala. MIT Press. 2013. http://tinyurl.com/zqdnyg2 [Lipovaca 2011] Learn You a Haskell for Great Good! A Beginner's Guide, by Miran Lipovaca, No Starch Press, April 2011. http://learnyouahaskell.com [O'Sullivan 2008] Bryan O'Sullivan, John Goerzen, and Don Stewart: Real world Haskell - code you can believe in. O'Reilly 2008. http://book.realworldhaskell.org [Pugh 1991] Pugh, William. "The Omega test: a fast and practical integer programming algorithm for dependence analysis." Proceedings of the 1991 ACM/IEEE conference on Supercomputing. ACM, 1991. http://dl.acm.org/citation.cfm?id=125848 [Wadler 2015] Philip Wadler. "Propositions as types." Communications of the ACM 58, no. 12 (2015): 75-84. http://dl.acm.org/citation.cfm?id=2699407 *) (* $Date: 2017-05-23 13:45:44 -0400 (Tue, 23 May 2017) $ *) QuickChick-2.1.0/sf-experiment/Extraction.v000066400000000000000000000121021476030541200206230ustar00rootroot00000000000000(** * Extraction: Extracting ML from Coq *) (* DROP *) (* ################################################################# *) (** * Basic Extraction *) (** In its simplest form, extracting an efficient program from one written in Coq is completely straightforward. First we say what language we want to extract into. Options are OCaml (the most mature), Haskell (mostly works), and Scheme (a bit out of date). *) Extraction Language Ocaml. (** Now we load up the Coq environment with some definitions, either directly or by importing them from other modules. *) Require Import Coq.Arith.Arith. Require Import Coq.Arith.EqNat. Require Import ImpCEvalFun. (** Finally, we tell Coq the name of a definition to extract and the name of a file to put the extracted code into. *) Extraction "imp1.ml" ceval_step. (** When Coq processes this command, it generates a file [imp1.ml] containing an extracted version of [ceval_step], together with everything that it recursively depends on. Compile the present [.v] file and have a look at [imp1.ml] now. *) (* ################################################################# *) (** * Controlling Extraction of Specific Types *) (** We can tell Coq to extract certain [Inductive] definitions to specific OCaml types. For each one, we must say - how the Coq type itself should be represented in OCaml, and - how each constructor should be translated. *) Extract Inductive bool => "bool" [ "true" "false" ]. (** Also, for non-enumeration types (where the constructors take arguments), we give an OCaml expression that can be used as a "recursor" over elements of the type. (Think Church numerals.) *) Extract Inductive nat => "int" [ "0" "(fun x -> x + 1)" ] "(fun zero succ n -> if n=0 then zero () else succ (n-1))". (** We can also extract defined constants to specific OCaml terms or operators. *) Extract Constant plus => "( + )". Extract Constant mult => "( * )". Extract Constant beq_nat => "( = )". (** Important: It is entirely _your responsibility_ to make sure that the translations you're proving make sense. For example, it might be tempting to include this one Extract Constant minus => "( - )". but doing so could lead to serious confusion! (Why?) *) Extraction "imp2.ml" ceval_step. (** Have a look at the file [imp2.ml]. Notice how the fundamental definitions have changed from [imp1.ml]. *) (* ################################################################# *) (** * A Complete Example *) (** To use our extracted evaluator to run Imp programs, all we need to add is a tiny driver program that calls the evaluator and prints out the result. For simplicity, we'll print results by dumping out the first four memory locations in the final state. Also, to make it easier to type in examples, let's extract a parser from the [ImpParser] Coq module. To do this, we need a few magic declarations to set up the right correspondence between Coq strings and lists of OCaml characters. *) Require Import Ascii String. Extract Inductive ascii => char [ "(* If this appears, you're using Ascii internals. Please don't *) (fun (b0,b1,b2,b3,b4,b5,b6,b7) -> let f b i = if b then 1 lsl i else 0 in Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))" ] "(* If this appears, you're using Ascii internals. Please don't *) (fun f c -> let n = Char.code c in let h i = (n land (1 lsl i)) <> 0 in f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))". Extract Constant zero => "'\000'". Extract Constant one => "'\001'". Extract Constant shift => "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". Extract Inlined Constant ascii_dec => "(=)". (** We also need one more variant of booleans. *) Extract Inductive sumbool => "bool" ["true" "false"]. (** The extraction is the same as always. *) Require Import Imp. Require Import ImpParser. Extraction "imp.ml" empty_state ceval_step parse. (** Now let's run our generated Imp evaluator. First, have a look at [impdriver.ml]. (This was written by hand, not extracted.) Next, compile the driver together with the extracted code and execute it, as follows. ocamlc -w -20 -w -26 -o impdriver imp.mli imp.ml impdriver.ml ./impdriver (The [-w] flags to [ocamlc] are just there to suppress a few spurious warnings.) *) (* ################################################################# *) (** * Discussion *) (** Since we've proved that the [ceval_step] function behaves the same as the [ceval] relation in an appropriate sense, the extracted program can be viewed as a _certified_ Imp interpreter. Of course, the parser we're using is not certified, since we didn't prove anything about it! *) (* ################################################################# *) (** * Going Further *) (** Further details about extraction can be found in the Extract chapter in _Verified Functional Algorithms_ (_Software Foundations_ volume 3). *) (* /DROP *) (** $Date: 2017-05-22 11:43:34 -0400 (Mon, 22 May 2017) $ *) QuickChick-2.1.0/sf-experiment/Imp.v000066400000000000000000001717641476030541200172540ustar00rootroot00000000000000(** * Imp: Simple Imperative Programs *) (** In this chapter, we'll take a more serious look at how to use Coq to study interesting things outside of itself. Our case study is a _simple imperative programming language_ called Imp, embodying a tiny core fragment of conventional mainstream languages such as C and Java. Here is a familiar mathematical function written in Imp. Z ::= X;; Y ::= 1;; WHILE not (Z = 0) DO Y ::= Y * Z;; Z ::= Z - 1 END *) (** This chapter looks at how to define the _syntax_ and _semantics_ of Imp; further chapters in _Programming Language Foundations_ (_Software Foundations_, volume 2) develop a theory of _program equivalence_ and introduce _Hoare Logic_, a widely used logic for reasoning about imperative programs. *) (* IMPORTS *) Set Warnings "-notation-overridden,-parsing". Require Import Coq.Bool.Bool. Require Import Coq.Arith.Arith. Require Import Coq.Arith.EqNat. Require Import Coq.omega.Omega. Require Import Coq.Lists.List. Require Import Coq.omega.Omega. Import ListNotations. Require Import Maps. (* /IMPORTS *) (* ################################################################# *) (** * Arithmetic and Boolean Expressions *) (** We'll present Imp in three parts: first a core language of _arithmetic and boolean expressions_, then an extension of these expressions with _variables_, and finally a language of _commands_ including assignment, conditions, sequencing, and loops. *) (* ================================================================= *) (** ** Syntax *) Module AExp. (** These two definitions specify the _abstract syntax_ of arithmetic and boolean expressions. *) Inductive aexp : Type := | ANum : nat -> aexp | APlus : aexp -> aexp -> aexp | AMinus : aexp -> aexp -> aexp | AMult : aexp -> aexp -> aexp. Inductive bexp : Type := | BTrue : bexp | BFalse : bexp | BEq : aexp -> aexp -> bexp | BLe : aexp -> aexp -> bexp | BNot : bexp -> bexp | BAnd : bexp -> bexp -> bexp. (** In this chapter, we'll elide the translation from the concrete syntax that a programmer would actually write to these abstract syntax trees -- the process that, for example, would translate the string ["1+2*3"] to the AST APlus (ANum 1) (AMult (ANum 2) (ANum 3)). The optional chapter [ImpParser] develops a simple implementation of a lexical analyzer and parser that can perform this translation. You do _not_ need to understand that chapter to understand this one, but if you haven't taken a course where these techniques are covered (e.g., a compilers course) you may want to skim it. *) (** For comparison, here's a conventional BNF (Backus-Naur Form) grammar defining the same abstract syntax: a ::= nat | a + a | a - a | a * a b ::= true | false | a = a | a <= a | not b | b and b *) (** Compared to the Coq version above... - The BNF is more informal -- for example, it gives some suggestions about the surface syntax of expressions (like the fact that the addition operation is written [+] and is an infix symbol) while leaving other aspects of lexical analysis and parsing (like the relative precedence of [+], [-], and [*], the use of parens to explicitly group subexpressions, etc.) unspecified. Some additional information (and human intelligence) would be required to turn this description into a formal definition, for example when implementing a compiler. The Coq version consistently omits all this information and concentrates on the abstract syntax only. - On the other hand, the BNF version is lighter and easier to read. Its informality makes it flexible, a big advantage in situations like discussions at the blackboard, where conveying general ideas is more important than getting every detail nailed down precisely. Indeed, there are dozens of BNF-like notations and people switch freely among them, usually without bothering to say which form of BNF they're using because there is no need to: a rough-and-ready informal understanding is all that's important. It's good to be comfortable with both sorts of notations: informal ones for communicating between humans and formal ones for carrying out implementations and proofs. *) (* ================================================================= *) (** ** Evaluation *) (** _Evaluating_ an arithmetic expression produces a number. *) Fixpoint aeval (a : aexp) : nat := match a with | ANum n => n | APlus a1 a2 => (aeval a1) + (aeval a2) | AMinus a1 a2 => (aeval a1) - (aeval a2) | AMult a1 a2 => (aeval a1) * (aeval a2) end. Example test_aeval1: aeval (APlus (ANum 2) (ANum 2)) = 4. Proof. reflexivity. Qed. (** Similarly, evaluating a boolean expression yields a boolean. *) Fixpoint beval (b : bexp) : bool := match b with | BTrue => true | BFalse => false | BEq a1 a2 => beq_nat (aeval a1) (aeval a2) | BLe a1 a2 => leb (aeval a1) (aeval a2) | BNot b1 => negb (beval b1) | BAnd b1 b2 => andb (beval b1) (beval b2) end. (* ================================================================= *) (** ** Optimization *) (** We haven't defined very much yet, but we can already get some mileage out of the definitions. Suppose we define a function that takes an arithmetic expression and slightly simplifies it, changing every occurrence of [0+e] (i.e., [(APlus (ANum 0) e]) into just [e]. *) Fixpoint optimize_0plus (a:aexp) : aexp := match a with | ANum n => ANum n | APlus (ANum 0) e2 => optimize_0plus e2 | APlus e1 e2 => APlus (optimize_0plus e1) (optimize_0plus e2) | AMinus e1 e2 => AMinus (optimize_0plus e1) (optimize_0plus e2) | AMult e1 e2 => AMult (optimize_0plus e1) (optimize_0plus e2) end. (** To make sure our optimization is doing the right thing we can test it on some examples and see if the output looks OK. *) Example test_optimize_0plus: optimize_0plus (APlus (ANum 2) (APlus (ANum 0) (APlus (ANum 0) (ANum 1)))) = APlus (ANum 2) (ANum 1). Proof. reflexivity. Qed. (** But if we want to be sure the optimization is correct -- i.e., that evaluating an optimized expression gives the same result as the original -- we should prove it. *) Theorem optimize_0plus_sound: forall a, aeval (optimize_0plus a) = aeval a. Proof. intros a. induction a. - (* ANum *) reflexivity. - (* APlus *) destruct a1. + (* a1 = ANum n *) destruct n. * (* n = 0 *) simpl. apply IHa2. * (* n <> 0 *) simpl. rewrite IHa2. reflexivity. + (* a1 = APlus a1_1 a1_2 *) simpl. simpl in IHa1. rewrite IHa1. rewrite IHa2. reflexivity. + (* a1 = AMinus a1_1 a1_2 *) simpl. simpl in IHa1. rewrite IHa1. rewrite IHa2. reflexivity. + (* a1 = AMult a1_1 a1_2 *) simpl. simpl in IHa1. rewrite IHa1. rewrite IHa2. reflexivity. - (* AMinus *) simpl. rewrite IHa1. rewrite IHa2. reflexivity. - (* AMult *) simpl. rewrite IHa1. rewrite IHa2. reflexivity. Qed. (* ################################################################# *) (** * Coq Automation *) (** The amount of repetition in this last proof is a little annoying. And if either the language of arithmetic expressions or the optimization being proved sound were significantly more complex, it would start to be a real problem. So far, we've been doing all our proofs using just a small handful of Coq's tactics and completely ignoring its powerful facilities for constructing parts of proofs automatically. This section introduces some of these facilities, and we will see more over the next several chapters. Getting used to them will take some energy -- Coq's automation is a power tool -- but it will allow us to scale up our efforts to more complex definitions and more interesting properties without becoming overwhelmed by boring, repetitive, low-level details. *) (* ================================================================= *) (** ** Tacticals *) (** _Tacticals_ is Coq's term for tactics that take other tactics as arguments -- "higher-order tactics," if you will. *) (* ----------------------------------------------------------------- *) (** *** The [try] Tactical *) (** If [T] is a tactic, then [try T] is a tactic that is just like [T] except that, if [T] fails, [try T] _successfully_ does nothing at all (instead of failing). *) Theorem silly1 : forall ae, aeval ae = aeval ae. Proof. try reflexivity. (* this just does [reflexivity] *) Qed. Theorem silly2 : forall (P : Prop), P -> P. Proof. intros P HP. try reflexivity. (* just [reflexivity] would have failed *) apply HP. (* we can still finish the proof in some other way *) Qed. (** There is no real reason to use [try] in completely manual proofs like these, but it is very useful for doing automated proofs in conjunction with the [;] tactical, which we show next. *) (* ----------------------------------------------------------------- *) (** *** The [;] Tactical (Simple Form) *) (** In its most common form, the [;] tactical takes two tactics as arguments. The compound tactic [T;T'] first performs [T] and then performs [T'] on _each subgoal_ generated by [T]. *) (** For example, consider the following trivial lemma: *) Lemma foo : forall n, leb 0 n = true. Proof. intros. destruct n. (* Leaves two subgoals, which are discharged identically... *) - (* n=0 *) simpl. reflexivity. - (* n=Sn' *) simpl. reflexivity. Qed. (** We can simplify this proof using the [;] tactical: *) Lemma foo' : forall n, leb 0 n = true. Proof. intros. (* [destruct] the current goal *) destruct n; (* then [simpl] each resulting subgoal *) simpl; (* and do [reflexivity] on each resulting subgoal *) reflexivity. Qed. (** Using [try] and [;] together, we can get rid of the repetition in the proof that was bothering us a little while ago. *) Theorem optimize_0plus_sound': forall a, aeval (optimize_0plus a) = aeval a. Proof. intros a. induction a; (* Most cases follow directly by the IH... *) try (simpl; rewrite IHa1; rewrite IHa2; reflexivity). (* ... but the remaining cases -- ANum and APlus -- are different: *) - (* ANum *) reflexivity. - (* APlus *) destruct a1; (* Again, most cases follow directly by the IH: *) try (simpl; simpl in IHa1; rewrite IHa1; rewrite IHa2; reflexivity). (* The interesting case, on which the [try...] does nothing, is when [e1 = ANum n]. In this case, we have to destruct [n] (to see whether the optimization applies) and rewrite with the induction hypothesis. *) + (* a1 = ANum n *) destruct n; simpl; rewrite IHa2; reflexivity. Qed. (** Coq experts often use this "[...; try... ]" idiom after a tactic like [induction] to take care of many similar cases all at once. Naturally, this practice has an analog in informal proofs. For example, here is an informal proof of the optimization theorem that matches the structure of the formal one: _Theorem_: For all arithmetic expressions [a], aeval (optimize_0plus a) = aeval a. _Proof_: By induction on [a]. Most cases follow directly from the IH. The remaining cases are as follows: - Suppose [a = ANum n] for some [n]. We must show aeval (optimize_0plus (ANum n)) = aeval (ANum n). This is immediate from the definition of [optimize_0plus]. - Suppose [a = APlus a1 a2] for some [a1] and [a2]. We must show aeval (optimize_0plus (APlus a1 a2)) = aeval (APlus a1 a2). Consider the possible forms of [a1]. For most of them, [optimize_0plus] simply calls itself recursively for the subexpressions and rebuilds a new expression of the same form as [a1]; in these cases, the result follows directly from the IH. The interesting case is when [a1 = ANum n] for some [n]. If [n = ANum 0], then optimize_0plus (APlus a1 a2) = optimize_0plus a2 and the IH for [a2] is exactly what we need. On the other hand, if [n = S n'] for some [n'], then again [optimize_0plus] simply calls itself recursively, and the result follows from the IH. [] *) (** However, this proof can still be improved: the first case (for [a = ANum n]) is very trivial -- even more trivial than the cases that we said simply followed from the IH -- yet we have chosen to write it out in full. It would be better and clearer to drop it and just say, at the top, "Most cases are either immediate or direct from the IH. The only interesting case is the one for [APlus]..." We can make the same improvement in our formal proof too. Here's how it looks: *) Theorem optimize_0plus_sound'': forall a, aeval (optimize_0plus a) = aeval a. Proof. intros a. induction a; (* Most cases follow directly by the IH *) try (simpl; rewrite IHa1; rewrite IHa2; reflexivity); (* ... or are immediate by definition *) try reflexivity. (* The interesting case is when a = APlus a1 a2. *) - (* APlus *) destruct a1; try (simpl; simpl in IHa1; rewrite IHa1; rewrite IHa2; reflexivity). + (* a1 = ANum n *) destruct n; simpl; rewrite IHa2; reflexivity. Qed. (* ----------------------------------------------------------------- *) (** *** The [;] Tactical (General Form) *) (** The [;] tactical also has a more general form than the simple [T;T'] we've seen above. If [T], [T1], ..., [Tn] are tactics, then T; [T1 | T2 | ... | Tn] is a tactic that first performs [T] and then performs [T1] on the first subgoal generated by [T], performs [T2] on the second subgoal, etc. So [T;T'] is just special notation for the case when all of the [Ti]'s are the same tactic; i.e., [T;T'] is shorthand for: T; [T' | T' | ... | T'] *) (* ----------------------------------------------------------------- *) (** *** The [repeat] Tactical *) (** The [repeat] tactical takes another tactic and keeps applying this tactic until it fails. Here is an example showing that [10] is in a long list using repeat. *) Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10]. Proof. repeat (try (left; reflexivity); right). Qed. (** The tactic [repeat T] never fails: if the tactic [T] doesn't apply to the original goal, then repeat still succeeds without changing the original goal (i.e., it repeats zero times). *) Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10]. Proof. repeat (left; reflexivity). repeat (right; try (left; reflexivity)). Qed. (** The tactic [repeat T] also does not have any upper bound on the number of times it applies [T]. If [T] is a tactic that always succeeds, then repeat [T] will loop forever (e.g., [repeat simpl] loops forever, since [simpl] always succeeds). While evaluation in Coq's term language, Gallina, is guaranteed to terminate, tactic evaluation is not! This does not affect Coq's logical consistency, however, since the job of [repeat] and other tactics is to guide Coq in constructing proofs; if the construction process diverges, this simply means that we have failed to construct a proof, not that we have constructed a wrong one. *) (** **** Exercise: 3 stars (optimize_0plus_b) *) (** Since the [optimize_0plus] transformation doesn't change the value of [aexp]s, we should be able to apply it to all the [aexp]s that appear in a [bexp] without changing the [bexp]'s value. Write a function which performs that transformation on [bexp]s, and prove it is sound. Use the tacticals we've just seen to make the proof as elegant as possible. *) Fixpoint optimize_0plus_b (b : bexp) : bexp (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Theorem optimize_0plus_b_sound : forall b, beval (optimize_0plus_b b) = beval b. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 4 stars, optional (optimizer) *) (** _Design exercise_: The optimization implemented by our [optimize_0plus] function is only one of many possible optimizations on arithmetic and boolean expressions. Write a more sophisticated optimizer and prove it correct. (You will probably find it easiest to start small -- add just a single, simple optimization and prove it correct -- and build up to something more interesting incrementially.) (* FILL IN HERE *) *) (** [] *) (* ================================================================= *) (** ** Defining New Tactic Notations *) (** Coq also provides several ways of "programming" tactic scripts. - The [Tactic Notation] idiom illustrated below gives a handy way to define "shorthand tactics" that bundle several tactics into a single command. - For more sophisticated programming, Coq offers a built-in programming language called [Ltac] with primitives that can examine and modify the proof state. The details are a bit too complicated to get into here (and it is generally agreed that [Ltac] is not the most beautiful part of Coq's design!), but they can be found in the reference manual and other books on Coq, and there are many examples of [Ltac] definitions in the Coq standard library that you can use as examples. - There is also an OCaml API, which can be used to build tactics that access Coq's internal structures at a lower level, but this is seldom worth the trouble for ordinary Coq users. The [Tactic Notation] mechanism is the easiest to come to grips with, and it offers plenty of power for many purposes. Here's an example. *) Tactic Notation "simpl_and_try" tactic(c) := simpl; try c. (** This defines a new tactical called [simpl_and_try] that takes one tactic [c] as an argument and is defined to be equivalent to the tactic [simpl; try c]. Now writing "[simpl_and_try reflexivity.]" in a proof will be the same as writing "[simpl; try reflexivity.]" *) (* ================================================================= *) (** ** The [omega] Tactic *) (** The [omega] tactic implements a decision procedure for a subset of first-order logic called _Presburger arithmetic_. It is based on the Omega algorithm invented in 1991 by William Pugh [Pugh 1991]. If the goal is a universally quantified formula made out of - numeric constants, addition ([+] and [S]), subtraction ([-] and [pred]), and multiplication by constants (this is what makes it Presburger arithmetic), - equality ([=] and [<>]) and inequality ([<=]), and - the logical connectives [/\], [\/], [~], and [->], then invoking [omega] will either solve the goal or tell you that it is actually false. *) Example silly_presburger_example : forall m n o p, m + n <= n + o /\ o + 3 = p + 3 -> m <= p. Proof. intros. omega. Qed. (** (Note the [Require Import Coq.omega.Omega.] at the top of the file.) *) (* ================================================================= *) (** ** A Few More Handy Tactics *) (** Finally, here are some miscellaneous tactics that you may find convenient. - [clear H]: Delete hypothesis [H] from the context. - [subst x]: Find an assumption [x = e] or [e = x] in the context, replace [x] with [e] throughout the context and current goal, and clear the assumption. - [subst]: Substitute away _all_ assumptions of the form [x = e] or [e = x]. - [rename... into...]: Change the name of a hypothesis in the proof context. For example, if the context includes a variable named [x], then [rename x into y] will change all occurrences of [x] to [y]. - [assumption]: Try to find a hypothesis [H] in the context that exactly matches the goal; if one is found, behave like [apply H]. - [contradiction]: Try to find a hypothesis [H] in the current context that is logically equivalent to [False]. If one is found, solve the goal. - [constructor]: Try to find a constructor [c] (from some [Inductive] definition in the current environment) that can be applied to solve the current goal. If one is found, behave like [apply c]. We'll see examples below. *) (* ################################################################# *) (** * Evaluation as a Relation *) (** We have presented [aeval] and [beval] as functions defined by [Fixpoint]s. Another way to think about evaluation -- one that we will see is often more flexible -- is as a _relation_ between expressions and their values. This leads naturally to [Inductive] definitions like the following one for arithmetic expressions... *) Module aevalR_first_try. Inductive aevalR : aexp -> nat -> Prop := | E_ANum : forall (n: nat), aevalR (ANum n) n | E_APlus : forall (e1 e2: aexp) (n1 n2: nat), aevalR e1 n1 -> aevalR e2 n2 -> aevalR (APlus e1 e2) (n1 + n2) | E_AMinus: forall (e1 e2: aexp) (n1 n2: nat), aevalR e1 n1 -> aevalR e2 n2 -> aevalR (AMinus e1 e2) (n1 - n2) | E_AMult : forall (e1 e2: aexp) (n1 n2: nat), aevalR e1 n1 -> aevalR e2 n2 -> aevalR (AMult e1 e2) (n1 * n2). (** It will be convenient to have an infix notation for [aevalR]. We'll write [e \\ n] to mean that arithmetic expression [e] evaluates to value [n]. (This notation is one place where the limitation to ASCII symbols becomes a little bothersome. The standard notation for the evaluation relation is a double down-arrow. We'll typeset it like this in the HTML version of the notes and use a double slash as the closest approximation in [.v] files.) *) Notation "e '\\' n" := (aevalR e n) (at level 50, left associativity) : type_scope. End aevalR_first_try. (** In fact, Coq provides a way to use this notation in the definition of [aevalR] itself. This reduces confusion by avoiding situations where we're working on a proof involving statements in the form [e \\ n] but we have to refer back to a definition written using the form [aevalR e n]. We do this by first "reserving" the notation, then giving the definition together with a declaration of what the notation means. *) Reserved Notation "e '\\' n" (at level 50, left associativity). Inductive aevalR : aexp -> nat -> Prop := | E_ANum : forall (n:nat), (ANum n) \\ n | E_APlus : forall (e1 e2: aexp) (n1 n2 : nat), (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2) | E_AMinus : forall (e1 e2: aexp) (n1 n2 : nat), (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2) | E_AMult : forall (e1 e2: aexp) (n1 n2 : nat), (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2) where "e '\\' n" := (aevalR e n) : type_scope. (* ================================================================= *) (** ** Inference Rule Notation *) (** In informal discussions, it is convenient to write the rules for [aevalR] and similar relations in the more readable graphical form of _inference rules_, where the premises above the line justify the conclusion below the line (we have already seen them in the [IndProp] chapter). *) (** For example, the constructor [E_APlus]... | E_APlus : forall (e1 e2: aexp) (n1 n2: nat), aevalR e1 n1 -> aevalR e2 n2 -> aevalR (APlus e1 e2) (n1 + n2) ...would be written like this as an inference rule: e1 \\ n1 e2 \\ n2 -------------------- (E_APlus) APlus e1 e2 \\ n1+n2 *) (** Formally, there is nothing deep about inference rules: they are just implications. You can read the rule name on the right as the name of the constructor and read each of the linebreaks between the premises above the line (as well as the line itself) as [->]. All the variables mentioned in the rule ([e1], [n1], etc.) are implicitly bound by universal quantifiers at the beginning. (Such variables are often called _metavariables_ to distinguish them from the variables of the language we are defining. At the moment, our arithmetic expressions don't include variables, but we'll soon be adding them.) The whole collection of rules is understood as being wrapped in an [Inductive] declaration. In informal prose, this is either elided or else indicated by saying something like "Let [aevalR] be the smallest relation closed under the following rules...". *) (** For example, [\\] is the smallest relation closed under these rules: ----------- (E_ANum) ANum n \\ n e1 \\ n1 e2 \\ n2 -------------------- (E_APlus) APlus e1 e2 \\ n1+n2 e1 \\ n1 e2 \\ n2 --------------------- (E_AMinus) AMinus e1 e2 \\ n1-n2 e1 \\ n1 e2 \\ n2 -------------------- (E_AMult) AMult e1 e2 \\ n1*n2 *) (* ================================================================= *) (** ** Equivalence of the Definitions *) (** It is straightforward to prove that the relational and functional definitions of evaluation agree: *) Theorem aeval_iff_aevalR : forall a n, (a \\ n) <-> aeval a = n. Proof. split. - (* -> *) intros H. induction H; simpl. + (* E_ANum *) reflexivity. + (* E_APlus *) rewrite IHaevalR1. rewrite IHaevalR2. reflexivity. + (* E_AMinus *) rewrite IHaevalR1. rewrite IHaevalR2. reflexivity. + (* E_AMult *) rewrite IHaevalR1. rewrite IHaevalR2. reflexivity. - (* <- *) generalize dependent n. induction a; simpl; intros; subst. + (* ANum *) apply E_ANum. + (* APlus *) apply E_APlus. apply IHa1. reflexivity. apply IHa2. reflexivity. + (* AMinus *) apply E_AMinus. apply IHa1. reflexivity. apply IHa2. reflexivity. + (* AMult *) apply E_AMult. apply IHa1. reflexivity. apply IHa2. reflexivity. Qed. (** We can make the proof quite a bit shorter by making more use of tacticals. *) Theorem aeval_iff_aevalR' : forall a n, (a \\ n) <-> aeval a = n. Proof. (* WORKED IN CLASS *) split. - (* -> *) intros H; induction H; subst; reflexivity. - (* <- *) generalize dependent n. induction a; simpl; intros; subst; constructor; try apply IHa1; try apply IHa2; reflexivity. Qed. (** **** Exercise: 3 stars (bevalR) *) (** Write a relation [bevalR] in the same style as [aevalR], and prove that it is equivalent to [beval].*) Inductive bevalR: bexp -> bool -> Prop := (* FILL IN HERE *) . Lemma beval_iff_bevalR : forall b bv, bevalR b bv <-> beval b = bv. Proof. (* FILL IN HERE *) Admitted. (** [] *) End AExp. (* ================================================================= *) (** ** Computational vs. Relational Definitions *) (** For the definitions of evaluation for arithmetic and boolean expressions, the choice of whether to use functional or relational definitions is mainly a matter of taste: either way works. However, there are circumstances where relational definitions of evaluation work much better than functional ones. *) Module aevalR_division. (** For example, suppose that we wanted to extend the arithmetic operations by considering also a division operation:*) Inductive aexp : Type := | ANum : nat -> aexp | APlus : aexp -> aexp -> aexp | AMinus : aexp -> aexp -> aexp | AMult : aexp -> aexp -> aexp | ADiv : aexp -> aexp -> aexp. (* <--- new *) (** Extending the definition of [aeval] to handle this new operation would not be straightforward (what should we return as the result of [ADiv (ANum 5) (ANum 0)]?). But extending [aevalR] is straightforward. *) Reserved Notation "e '\\' n" (at level 50, left associativity). Inductive aevalR : aexp -> nat -> Prop := | E_ANum : forall (n:nat), (ANum n) \\ n | E_APlus : forall (a1 a2: aexp) (n1 n2 : nat), (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2) | E_AMinus : forall (a1 a2: aexp) (n1 n2 : nat), (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2) | E_AMult : forall (a1 a2: aexp) (n1 n2 : nat), (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2) | E_ADiv : forall (a1 a2: aexp) (n1 n2 n3: nat), (a1 \\ n1) -> (a2 \\ n2) -> (n2 > 0) -> (mult n2 n3 = n1) -> (ADiv a1 a2) \\ n3 where "a '\\' n" := (aevalR a n) : type_scope. End aevalR_division. Module aevalR_extended. (** Suppose, instead, that we want to extend the arithmetic operations by a nondeterministic number generator [any] that, when evaluated, may yield any number. (Note that this is not the same as making a _probabilistic_ choice among all possible numbers -- we're not specifying any particular distribution of results, but just saying what results are _possible_.) *) Reserved Notation "e '\\' n" (at level 50, left associativity). Inductive aexp : Type := | AAny : aexp (* <--- NEW *) | ANum : nat -> aexp | APlus : aexp -> aexp -> aexp | AMinus : aexp -> aexp -> aexp | AMult : aexp -> aexp -> aexp. (** Again, extending [aeval] would be tricky, since now evaluation is _not_ a deterministic function from expressions to numbers, but extending [aevalR] is no problem: *) Inductive aevalR : aexp -> nat -> Prop := | E_Any : forall (n:nat), AAny \\ n (* <--- new *) | E_ANum : forall (n:nat), (ANum n) \\ n | E_APlus : forall (a1 a2: aexp) (n1 n2 : nat), (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2) | E_AMinus : forall (a1 a2: aexp) (n1 n2 : nat), (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2) | E_AMult : forall (a1 a2: aexp) (n1 n2 : nat), (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2) where "a '\\' n" := (aevalR a n) : type_scope. End aevalR_extended. (** At this point you maybe wondering: which style should I use by default? The examples above show that relational definitions are fundamentally more powerful than functional ones. For situations like these, where the thing being defined is not easy to express as a function, or indeed where it is _not_ a function, there is no choice. But what about when both styles are workable? One point in favor of relational definitions is that some people feel they are more elegant and easier to understand. Another is that Coq automatically generates nice inversion and induction principles from [Inductive] definitions. On the other hand, functional definitions can often be more convenient: - Functions are by definition deterministic and defined on all arguments; for a relation we have to show these properties explicitly if we need them. - With functions we can also take advantage of Coq's computation mechanism to simplify expressions during proofs. Furthermore, functions can be directly "extracted" to executable code in OCaml or Haskell. Ultimately, the choice often comes down to either the specifics of a particular situation or simply a question of taste. Indeed, in large Coq developments it is common to see a definition given in _both_ functional and relational styles, plus a lemma stating that the two coincide, allowing further proofs to switch from one point of view to the other at will.*) (* ################################################################# *) (** * Expressions With Variables *) (** Let's turn our attention back to defining Imp. The next thing we need to do is to enrich our arithmetic and boolean expressions with variables. To keep things simple, we'll assume that all variables are global and that they only hold numbers. *) (* ================================================================= *) (** ** States *) (** Since we'll want to look variables up to find out their current values, we'll reuse the type [id] from the [Maps] chapter for the type of variables in Imp. A _machine state_ (or just _state_) represents the current values of _all_ variables at some point in the execution of a program. *) (** For simplicity, we assume that the state is defined for _all_ variables, even though any given program is only going to mention a finite number of them. The state captures all of the information stored in memory. For Imp programs, because each variable stores a natural number, we can represent the state as a mapping from identifiers to [nat]. For more complex programming languages, the state might have more structure. *) Definition state := total_map nat. Definition empty_state : state := t_empty 0. (* ================================================================= *) (** ** Syntax *) (** We can add variables to the arithmetic expressions we had before by simply adding one more constructor: *) Inductive aexp : Type := | ANum : nat -> aexp | AId : id -> aexp (* <----- NEW *) | APlus : aexp -> aexp -> aexp | AMinus : aexp -> aexp -> aexp | AMult : aexp -> aexp -> aexp. (** Defining a few variable names as notational shorthands will make examples easier to read: *) Definition W : id := Id "W". Definition X : id := Id "X". Definition Y : id := Id "Y". Definition Z : id := Id "Z". (** (This convention for naming program variables ([X], [Y], [Z]) clashes a bit with our earlier use of uppercase letters for types. Since we're not using polymorphism heavily in the chapters devoped to Imp, this overloading should not cause confusion.) *) (** The definition of [bexp]s is unchanged (except for using the new [aexp]s): *) Inductive bexp : Type := | BTrue : bexp | BFalse : bexp | BEq : aexp -> aexp -> bexp | BLe : aexp -> aexp -> bexp | BNot : bexp -> bexp | BAnd : bexp -> bexp -> bexp. (* ================================================================= *) (** ** Evaluation *) (** The arith and boolean evaluators are extended to handle variables in the obvious way, taking a state as an extra argument: *) Fixpoint aeval (st : state) (a : aexp) : nat := match a with | ANum n => n | AId x => st x (* <----- NEW *) | APlus a1 a2 => (aeval st a1) + (aeval st a2) | AMinus a1 a2 => (aeval st a1) - (aeval st a2) | AMult a1 a2 => (aeval st a1) * (aeval st a2) end. Fixpoint beval (st : state) (b : bexp) : bool := match b with | BTrue => true | BFalse => false | BEq a1 a2 => beq_nat (aeval st a1) (aeval st a2) | BLe a1 a2 => leb (aeval st a1) (aeval st a2) | BNot b1 => negb (beval st b1) | BAnd b1 b2 => andb (beval st b1) (beval st b2) end. Example aexp1 : aeval (t_update empty_state X 5) (APlus (ANum 3) (AMult (AId X) (ANum 2))) = 13. Proof. reflexivity. Qed. Example bexp1 : beval (t_update empty_state X 5) (BAnd BTrue (BNot (BLe (AId X) (ANum 4)))) = true. Proof. reflexivity. Qed. (* ################################################################# *) (** * Commands *) (** Now we are ready define the syntax and behavior of Imp _commands_ (sometimes called _statements_). *) (* ================================================================= *) (** ** Syntax *) (** Informally, commands [c] are described by the following BNF grammar. (We choose this slightly awkward concrete syntax for the sake of being able to define Imp syntax using Coq's Notation mechanism. In particular, we use [IFB] to avoid conflicting with the [if] notation from the standard library.) c ::= SKIP | x ::= a | c ;; c | IFB b THEN c ELSE c FI | WHILE b DO c END *) (** For example, here's factorial in Imp: Z ::= X;; Y ::= 1;; WHILE not (Z = 0) DO Y ::= Y * Z;; Z ::= Z - 1 END When this command terminates, the variable [Y] will contain the factorial of the initial value of [X]. *) (** Here is the formal definition of the abstract syntax of commands: *) Inductive com : Type := | CSkip : com | CAss : id -> aexp -> com | CSeq : com -> com -> com | CIf : bexp -> com -> com -> com | CWhile : bexp -> com -> com. (** As usual, we can use a few [Notation] declarations to make things more readable. To avoid conflicts with Coq's built-in notations, we keep this light -- in particular, we don't introduce any notations for [aexps] and [bexps] to avoid confusion with the numeric and boolean operators we've already defined. *) Notation "'SKIP'" := CSkip. Notation "x '::=' a" := (CAss x a) (at level 60). Notation "c1 ;; c2" := (CSeq c1 c2) (at level 80, right associativity). Notation "'WHILE' b 'DO' c 'END'" := (CWhile b c) (at level 80, right associativity). Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" := (CIf c1 c2 c3) (at level 80, right associativity). (** For example, here is the factorial function again, written as a formal definition to Coq: *) Definition fact_in_coq : com := Z ::= AId X;; Y ::= ANum 1;; WHILE BNot (BEq (AId Z) (ANum 0)) DO Y ::= AMult (AId Y) (AId Z);; Z ::= AMinus (AId Z) (ANum 1) END. (* ================================================================= *) (** ** More Examples *) (** Assignment: *) Definition plus2 : com := X ::= (APlus (AId X) (ANum 2)). Definition XtimesYinZ : com := Z ::= (AMult (AId X) (AId Y)). Definition subtract_slowly_body : com := Z ::= AMinus (AId Z) (ANum 1) ;; X ::= AMinus (AId X) (ANum 1). (* ----------------------------------------------------------------- *) (** *** Loops *) Definition subtract_slowly : com := WHILE BNot (BEq (AId X) (ANum 0)) DO subtract_slowly_body END. Definition subtract_3_from_5_slowly : com := X ::= ANum 3 ;; Z ::= ANum 5 ;; subtract_slowly. (* ----------------------------------------------------------------- *) (** *** An infinite loop: *) Definition loop : com := WHILE BTrue DO SKIP END. (* ################################################################# *) (** * Evaluating Commands *) (** Next we need to define what it means to evaluate an Imp command. The fact that [WHILE] loops don't necessarily terminate makes defining an evaluation function tricky... *) (* ================================================================= *) (** ** Evaluation as a Function (Failed Attempt) *) (** Here's an attempt at defining an evaluation function for commands, omitting the [WHILE] case. *) Fixpoint ceval_fun_no_while (st : state) (c : com) : state := match c with | SKIP => st | x ::= a1 => t_update st x (aeval st a1) | c1 ;; c2 => let st' := ceval_fun_no_while st c1 in ceval_fun_no_while st' c2 | IFB b THEN c1 ELSE c2 FI => if (beval st b) then ceval_fun_no_while st c1 else ceval_fun_no_while st c2 | WHILE b DO c END => st (* bogus *) end. (** In a traditional functional programming language like OCaml or Haskell we could add the [WHILE] case as follows: Fixpoint ceval_fun (st : state) (c : com) : state := match c with ... | WHILE b DO c END => if (beval st b) then ceval_fun st (c; WHILE b DO c END) else st end. Coq doesn't accept such a definition ("Error: Cannot guess decreasing argument of fix") because the function we want to define is not guaranteed to terminate. Indeed, it _doesn't_ always terminate: for example, the full version of the [ceval_fun] function applied to the [loop] program above would never terminate. Since Coq is not just a functional programming language but also a consistent logic, any potentially non-terminating function needs to be rejected. Here is an (invalid!) program showing what would go wrong if Coq allowed non-terminating recursive functions: Fixpoint loop_false (n : nat) : False := loop_false n. That is, propositions like [False] would become provable ([loop_false 0] would be a proof of [False]), which would be a disaster for Coq's logical consistency. Thus, because it doesn't terminate on all inputs, of [ceval_fun] cannot be written in Coq -- at least not without additional tricks and workarounds (see chapter [ImpCEvalFun] if you're curious about what those might be). *) (* ================================================================= *) (** ** Evaluation as a Relation *) (** Here's a better way: define [ceval] as a _relation_ rather than a _function_ -- i.e., define it in [Prop] instead of [Type], as we did for [aevalR] above. *) (** This is an important change. Besides freeing us from awkward workarounds, it gives us a lot more flexibility in the definition. For example, if we add nondeterministic features like [any] to the language, we want the definition of evaluation to be nondeterministic -- i.e., not only will it not be total, it will not even be a function! *) (** We'll use the notation [c / st \\ st'] for the [ceval] relation: [c / st \\ st'] means that executing program [c] in a starting state [st] results in an ending state [st']. This can be pronounced "[c] takes state [st] to [st']". *) (* ----------------------------------------------------------------- *) (** *** Operational Semantics *) (** Here is an informal definition of evaluation, presented as inference rules for readability: ---------------- (E_Skip) SKIP / st \\ st aeval st a1 = n -------------------------------- (E_Ass) x := a1 / st \\ (t_update st x n) c1 / st \\ st' c2 / st' \\ st'' ------------------- (E_Seq) c1;;c2 / st \\ st'' beval st b1 = true c1 / st \\ st' ------------------------------------- (E_IfTrue) IF b1 THEN c1 ELSE c2 FI / st \\ st' beval st b1 = false c2 / st \\ st' ------------------------------------- (E_IfFalse) IF b1 THEN c1 ELSE c2 FI / st \\ st' beval st b = false ------------------------------ (E_WhileFalse) WHILE b DO c END / st \\ st beval st b = true c / st \\ st' WHILE b DO c END / st' \\ st'' --------------------------------- (E_WhileTrue) WHILE b DO c END / st \\ st'' *) (** Here is the formal definition. Make sure you understand how it corresponds to the inference rules. *) Reserved Notation "c1 '/' st '\\' st'" (at level 40, st at level 39). Inductive ceval : com -> state -> state -> Prop := | E_Skip : forall st, SKIP / st \\ st | E_Ass : forall st a1 n x, aeval st a1 = n -> (x ::= a1) / st \\ (t_update st x n) | E_Seq : forall c1 c2 st st' st'', c1 / st \\ st' -> c2 / st' \\ st'' -> (c1 ;; c2) / st \\ st'' | E_IfTrue : forall st st' b c1 c2, beval st b = true -> c1 / st \\ st' -> (IFB b THEN c1 ELSE c2 FI) / st \\ st' | E_IfFalse : forall st st' b c1 c2, beval st b = false -> c2 / st \\ st' -> (IFB b THEN c1 ELSE c2 FI) / st \\ st' | E_WhileFalse : forall b st c, beval st b = false -> (WHILE b DO c END) / st \\ st | E_WhileTrue : forall st st' st'' b c, beval st b = true -> c / st \\ st' -> (WHILE b DO c END) / st' \\ st'' -> (WHILE b DO c END) / st \\ st'' where "c1 '/' st '\\' st'" := (ceval c1 st st'). (** The cost of defining evaluation as a relation instead of a function is that we now need to construct _proofs_ that some program evaluates to some result state, rather than just letting Coq's computation mechanism do it for us. *) Example ceval_example1: (X ::= ANum 2;; IFB BLe (AId X) (ANum 1) THEN Y ::= ANum 3 ELSE Z ::= ANum 4 FI) / empty_state \\ (t_update (t_update empty_state X 2) Z 4). Proof. (* We must supply the intermediate state *) apply E_Seq with (t_update empty_state X 2). - (* assignment command *) apply E_Ass. reflexivity. - (* if command *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity. Qed. (** **** Exercise: 2 stars (ceval_example2) *) Example ceval_example2: (X ::= ANum 0;; Y ::= ANum 1;; Z ::= ANum 2) / empty_state \\ (t_update (t_update (t_update empty_state X 0) Y 1) Z 2). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, advanced (pup_to_n) *) (** Write an Imp program that sums the numbers from [1] to [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y]. Prove that this program executes as intended for [X] = [2] (this is trickier than you might expect). *) Definition pup_to_n : com (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Theorem pup_to_2_ceval : pup_to_n / (t_update empty_state X 2) \\ t_update (t_update (t_update (t_update (t_update (t_update empty_state X 2) Y 0) Y 2) X 1) Y 3) X 0. Proof. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** Determinism of Evaluation *) (** Changing from a computational to a relational definition of evaluation is a good move because it frees us from the artificial requirement that evaluation should be a total function. But it also raises a question: Is the second definition of evaluation really a partial function? Or is it possible that, beginning from the same state [st], we could evaluate some command [c] in different ways to reach two different output states [st'] and [st'']? In fact, this cannot happen: [ceval] _is_ a partial function: *) Theorem ceval_deterministic: forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 E1 E2. generalize dependent st2. induction E1; intros st2 E2; inversion E2; subst. - (* E_Skip *) reflexivity. - (* E_Ass *) reflexivity. - (* E_Seq *) assert (st' = st'0) as EQ1. { (* Proof of assertion *) apply IHE1_1; assumption. } subst st'0. apply IHE1_2. assumption. - (* E_IfTrue, b1 evaluates to true *) apply IHE1. assumption. - (* E_IfTrue, b1 evaluates to false (contradiction) *) rewrite H in H5. inversion H5. - (* E_IfFalse, b1 evaluates to true (contradiction) *) rewrite H in H5. inversion H5. - (* E_IfFalse, b1 evaluates to false *) apply IHE1. assumption. - (* E_WhileFalse, b1 evaluates to false *) reflexivity. - (* E_WhileFalse, b1 evaluates to true (contradiction) *) rewrite H in H2. inversion H2. - (* E_WhileTrue, b1 evaluates to false (contradiction) *) rewrite H in H4. inversion H4. - (* E_WhileTrue, b1 evaluates to true *) assert (st' = st'0) as EQ1. { (* Proof of assertion *) apply IHE1_1; assumption. } subst st'0. apply IHE1_2. assumption. Qed. (* ################################################################# *) (** * Reasoning About Imp Programs *) (** We'll get deeper into systematic techniques for reasoning about Imp programs in the following chapters, but we can do quite a bit just working with the bare definitions. This section explores some examples. *) Theorem plus2_spec : forall st n st', st X = n -> plus2 / st \\ st' -> st' X = n + 2. Proof. intros st n st' HX Heval. (** Inverting [Heval] essentially forces Coq to expand one step of the [ceval] computation -- in this case revealing that [st'] must be [st] extended with the new value of [X], since [plus2] is an assignment *) inversion Heval. subst. clear Heval. simpl. apply t_update_eq. Qed. (** **** Exercise: 3 stars, recommendedM (XtimesYinZ_spec) *) (** State and prove a specification of [XtimesYinZ]. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 3 stars, recommended (loop_never_stops) *) Theorem loop_never_stops : forall st st', ~(loop / st \\ st'). Proof. intros st st' contra. unfold loop in contra. remember (WHILE BTrue DO SKIP END) as loopdef eqn:Heqloopdef. (** Proceed by induction on the assumed derivation showing that [loopdef] terminates. Most of the cases are immediately contradictory (and so can be solved in one step with [inversion]). *) (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (no_whilesR) *) (** Consider the following function: *) Fixpoint no_whiles (c : com) : bool := match c with | SKIP => true | _ ::= _ => true | c1 ;; c2 => andb (no_whiles c1) (no_whiles c2) | IFB _ THEN ct ELSE cf FI => andb (no_whiles ct) (no_whiles cf) | WHILE _ DO _ END => false end. (** This predicate yields [true] just on programs that have no while loops. Using [Inductive], write a property [no_whilesR] such that [no_whilesR c] is provable exactly when [c] is a program with no while loops. Then prove its equivalence with [no_whiles]. *) Inductive no_whilesR: com -> Prop := (* FILL IN HERE *) . Theorem no_whiles_eqv: forall c, no_whiles c = true <-> no_whilesR c. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 4 starsM (no_whiles_terminating) *) (** Imp programs that don't involve while loops always terminate. State and prove a theorem [no_whiles_terminating] that says this. *) (** Use either [no_whiles] or [no_whilesR], as you prefer. *) (* FILL IN HERE *) (** [] *) (* ################################################################# *) (** * Additional Exercises *) (** **** Exercise: 3 stars (stack_compiler) *) (** HP Calculators, programming languages like Forth and Postscript and abstract machines like the Java Virtual Machine all evaluate arithmetic expressions using a stack. For instance, the expression (2*3)+(3*(4-2)) would be entered as 2 3 * 3 4 2 - * + and evaluated like this (where we show the program being evaluated on the right and the contents of the stack on the left): [ ] | 2 3 * 3 4 2 - * + [2] | 3 * 3 4 2 - * + [3, 2] | * 3 4 2 - * + [6] | 3 4 2 - * + [3, 6] | 4 2 - * + [4, 3, 6] | 2 - * + [2, 4, 3, 6] | - * + [2, 3, 6] | * + [6, 6] | + [12] | The task of this exercise is to write a small compiler that translates [aexp]s into stack machine instructions. The instruction set for our stack language will consist of the following instructions: - [SPush n]: Push the number [n] on the stack. - [SLoad x]: Load the identifier [x] from the store and push it on the stack - [SPlus]: Pop the two top numbers from the stack, add them, and push the result onto the stack. - [SMinus]: Similar, but subtract. - [SMult]: Similar, but multiply. *) Inductive sinstr : Type := | SPush : nat -> sinstr | SLoad : id -> sinstr | SPlus : sinstr | SMinus : sinstr | SMult : sinstr. (** Write a function to evaluate programs in the stack language. It should take as input a state, a stack represented as a list of numbers (top stack item is the head of the list), and a program represented as a list of instructions, and it should return the stack after executing the program. Test your function on the examples below. Note that the specification leaves unspecified what to do when encountering an [SPlus], [SMinus], or [SMult] instruction if the stack contains less than two elements. In a sense, it is immaterial what we do, since our compiler will never emit such a malformed program. *) Fixpoint s_execute (st : state) (stack : list nat) (prog : list sinstr) : list nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example s_execute1 : s_execute empty_state [] [SPush 5; SPush 3; SPush 1; SMinus] = [2; 5]. (* FILL IN HERE *) Admitted. Example s_execute2 : s_execute (t_update empty_state X 3) [3;4] [SPush 4; SLoad X; SMult; SPlus] = [15; 4]. (* FILL IN HERE *) Admitted. (** Next, write a function that compiles an [aexp] into a stack machine program. The effect of running the program should be the same as pushing the value of the expression on the stack. *) Fixpoint s_compile (e : aexp) : list sinstr (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** After you've defined [s_compile], prove the following to test that it works. *) Example s_compile1 : s_compile (AMinus (AId X) (AMult (ANum 2) (AId Y))) = [SLoad X; SPush 2; SLoad Y; SMult; SMinus]. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 4 stars, advanced (stack_compiler_correct) *) (** Now we'll prove the correctness of the compiler implemented in the previous exercise. Remember that the specification left unspecified what to do when encountering an [SPlus], [SMinus], or [SMult] instruction if the stack contains less than two elements. (In order to make your correctness proof easier you might find it helpful to go back and change your implementation!) Prove the following theorem. You will need to start by stating a more general lemma to get a usable induction hypothesis; the main theorem will then be a simple corollary of this lemma. *) Theorem s_compile_correct : forall (st : state) (e : aexp), s_execute st [] (s_compile e) = [ aeval st e ]. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, optional (short_circuit) *) (** Most modern programming languages use a "short-circuit" evaluation rule for boolean [and]: to evaluate [BAnd b1 b2], first evaluate [b1]. If it evaluates to [false], then the entire [BAnd] expression evaluates to [false] immediately, without evaluating [b2]. Otherwise, [b2] is evaluated to determine the result of the [BAnd] expression. Write an alternate version of [beval] that performs short-circuit evaluation of [BAnd] in this manner, and prove that it is equivalent to [beval]. *) (* FILL IN HERE *) (** [] *) Module BreakImp. (** **** Exercise: 4 stars, advanced (break_imp) *) (** Imperative languages like C and Java often include a [break] or similar statement for interrupting the execution of loops. In this exercise we consider how to add [break] to Imp. First, we need to enrich the language of commands with an additional case. *) Inductive com : Type := | CSkip : com | CBreak : com (* <-- new *) | CAss : id -> aexp -> com | CSeq : com -> com -> com | CIf : bexp -> com -> com -> com | CWhile : bexp -> com -> com. Notation "'SKIP'" := CSkip. Notation "'BREAK'" := CBreak. Notation "x '::=' a" := (CAss x a) (at level 60). Notation "c1 ;; c2" := (CSeq c1 c2) (at level 80, right associativity). Notation "'WHILE' b 'DO' c 'END'" := (CWhile b c) (at level 80, right associativity). Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" := (CIf c1 c2 c3) (at level 80, right associativity). (** Next, we need to define the behavior of [BREAK]. Informally, whenever [BREAK] is executed in a sequence of commands, it stops the execution of that sequence and signals that the innermost enclosing loop should terminate. (If there aren't any enclosing loops, then the whole program simply terminates.) The final state should be the same as the one in which the [BREAK] statement was executed. One important point is what to do when there are multiple loops enclosing a given [BREAK]. In those cases, [BREAK] should only terminate the _innermost_ loop. Thus, after executing the following... X ::= 0;; Y ::= 1;; WHILE 0 <> Y DO WHILE TRUE DO BREAK END;; X ::= 1;; Y ::= Y - 1 END ... the value of [X] should be [1], and not [0]. One way of expressing this behavior is to add another parameter to the evaluation relation that specifies whether evaluation of a command executes a [BREAK] statement: *) Inductive result : Type := | SContinue : result | SBreak : result. Reserved Notation "c1 '/' st '\\' s '/' st'" (at level 40, st, s at level 39). (** Intuitively, [c / st \\ s / st'] means that, if [c] is started in state [st], then it terminates in state [st'] and either signals that the innermost surrounding loop (or the whole program) should exit immediately ([s = SBreak]) or that execution should continue normally ([s = SContinue]). The definition of the "[c / st \\ s / st']" relation is very similar to the one we gave above for the regular evaluation relation ([c / st \\ st']) -- we just need to handle the termination signals appropriately: - If the command is [SKIP], then the state doesn't change and execution of any enclosing loop can continue normally. - If the command is [BREAK], the state stays unchanged but we signal a [SBreak]. - If the command is an assignment, then we update the binding for that variable in the state accordingly and signal that execution can continue normally. - If the command is of the form [IFB b THEN c1 ELSE c2 FI], then the state is updated as in the original semantics of Imp, except that we also propagate the signal from the execution of whichever branch was taken. - If the command is a sequence [c1 ;; c2], we first execute [c1]. If this yields a [SBreak], we skip the execution of [c2] and propagate the [SBreak] signal to the surrounding context; the resulting state is the same as the one obtained by executing [c1] alone. Otherwise, we execute [c2] on the state obtained after executing [c1], and propagate the signal generated there. - Finally, for a loop of the form [WHILE b DO c END], the semantics is almost the same as before. The only difference is that, when [b] evaluates to true, we execute [c] and check the signal that it raises. If that signal is [SContinue], then the execution proceeds as in the original semantics. Otherwise, we stop the execution of the loop, and the resulting state is the same as the one resulting from the execution of the current iteration. In either case, since [BREAK] only terminates the innermost loop, [WHILE] signals [SContinue]. *) (** Based on the above description, complete the definition of the [ceval] relation. *) Inductive ceval : com -> state -> result -> state -> Prop := | E_Skip : forall st, CSkip / st \\ SContinue / st (* FILL IN HERE *) where "c1 '/' st '\\' s '/' st'" := (ceval c1 st s st'). (** Now prove the following properties of your definition of [ceval]: *) Theorem break_ignore : forall c st st' s, (BREAK;; c) / st \\ s / st' -> st = st'. Proof. (* FILL IN HERE *) Admitted. Theorem while_continue : forall b c st st' s, (WHILE b DO c END) / st \\ s / st' -> s = SContinue. Proof. (* FILL IN HERE *) Admitted. Theorem while_stops_on_break : forall b c st st', beval st b = true -> c / st \\ SBreak / st' -> (WHILE b DO c END) / st \\ SContinue / st'. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, advanced, optional (while_break_true) *) Theorem while_break_true : forall b c st st', (WHILE b DO c END) / st \\ SContinue / st' -> beval st' b = true -> exists st'', c / st'' \\ SBreak / st'. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 4 stars, advanced, optional (ceval_deterministic) *) Theorem ceval_deterministic: forall (c:com) st st1 st2 s1 s2, c / st \\ s1 / st1 -> c / st \\ s2 / st2 -> st1 = st2 /\ s1 = s2. Proof. (* FILL IN HERE *) Admitted. (** [] *) End BreakImp. (** **** Exercise: 4 stars, optional (add_for_loop) *) (** Add C-style [for] loops to the language of commands, update the [ceval] definition to define the semantics of [for] loops, and add cases for [for] loops as needed so that all the proofs in this file are accepted by Coq. A [for] loop should be parameterized by (a) a statement executed initially, (b) a test that is run on each iteration of the loop to determine whether the loop should continue, (c) a statement executed at the end of each loop iteration, and (d) a statement that makes up the body of the loop. (You don't need to worry about making up a concrete Notation for [for] loops, but feel free to play with this too if you like.) *) (* FILL IN HERE *) (** [] *) (* $Date: 2017-05-24 10:56:51 -0400 (Wed, 24 May 2017) $ *) QuickChick-2.1.0/sf-experiment/ImpCEvalFun.v000066400000000000000000000305141476030541200206230ustar00rootroot00000000000000(** * ImpCEvalFun: Evaluation Function for Imp *) (** We saw in the [Imp] chapter how a naive approach to defining a function representing evaluation for Imp runs into difficulties. There, we adopted the solution of changing from a functional to a relational definition of evaluation. In this optional chapter, we consider strategies for getting the functional approach to work. *) (* ################################################################# *) (** * A Broken Evaluator *) (* IMPORTS *) Require Import Coq.omega.Omega. Require Import Coq.Arith.Arith. Require Import Imp. Require Import Maps. (* /IMPORTS *) (** Here was our first try at an evaluation function for commands, omitting [WHILE]. *) Fixpoint ceval_step1 (st : state) (c : com) : state := match c with | SKIP => st | l ::= a1 => t_update st l (aeval st a1) | c1 ;; c2 => let st' := ceval_step1 st c1 in ceval_step1 st' c2 | IFB b THEN c1 ELSE c2 FI => if (beval st b) then ceval_step1 st c1 else ceval_step1 st c2 | WHILE b1 DO c1 END => st (* bogus *) end. (** As we remarked in chapter [Imp], in a traditional functional programming language like ML or Haskell we could write the WHILE case as follows: | WHILE b1 DO c1 END => if (beval st b1) then ceval_step1 st (c1;; WHILE b1 DO c1 END) else st Coq doesn't accept such a definition ([Error: Cannot guess decreasing argument of fix]) because the function we want to define is not guaranteed to terminate. Indeed, the changed [ceval_step1] function applied to the [loop] program from [Imp.v] would never terminate. Since Coq is not just a functional programming language, but also a consistent logic, any potentially non-terminating function needs to be rejected. Here is an invalid(!) Coq program showing what would go wrong if Coq allowed non-terminating recursive functions: Fixpoint loop_false (n : nat) : False := loop_false n. That is, propositions like [False] would become provable (e.g., [loop_false 0] would be a proof of [False]), which would be a disaster for Coq's logical consistency. Thus, because it doesn't terminate on all inputs, the full version of [ceval_step1] cannot be written in Coq -- at least not without one additional trick... *) (* ################################################################# *) (** * A Step-Indexed Evaluator *) (** The trick we need is to pass an _additional_ parameter to the evaluation function that tells it how long to run. Informally, we start the evaluator with a certain amount of "gas" in its tank, and we allow it to run until either it terminates in the usual way _or_ it runs out of gas, at which point we simply stop evaluating and say that the final result is the empty memory. (We could also say that the result is the current state at the point where the evaluator runs out fo gas -- it doesn't really matter because the result is going to be wrong in either case!) *) Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state := match i with | O => empty_state | S i' => match c with | SKIP => st | l ::= a1 => t_update st l (aeval st a1) | c1 ;; c2 => let st' := ceval_step2 st c1 i' in ceval_step2 st' c2 i' | IFB b THEN c1 ELSE c2 FI => if (beval st b) then ceval_step2 st c1 i' else ceval_step2 st c2 i' | WHILE b1 DO c1 END => if (beval st b1) then let st' := ceval_step2 st c1 i' in ceval_step2 st' c i' else st end end. (** _Note_: It is tempting to think that the index [i] here is counting the "number of steps of evaluation." But if you look closely you'll see that this is not the case: for example, in the rule for sequencing, the same [i] is passed to both recursive calls. Understanding the exact way that [i] is treated will be important in the proof of [ceval__ceval_step], which is given as an exercise below. One thing that is not so nice about this evaluator is that we can't tell, from its result, whether it stopped because the program terminated normally or because it ran out of gas. Our next version returns an [option state] instead of just a [state], so that we can distinguish between normal and abnormal termination. *) Fixpoint ceval_step3 (st : state) (c : com) (i : nat) : option state := match i with | O => None | S i' => match c with | SKIP => Some st | l ::= a1 => Some (t_update st l (aeval st a1)) | c1 ;; c2 => match (ceval_step3 st c1 i') with | Some st' => ceval_step3 st' c2 i' | None => None end | IFB b THEN c1 ELSE c2 FI => if (beval st b) then ceval_step3 st c1 i' else ceval_step3 st c2 i' | WHILE b1 DO c1 END => if (beval st b1) then match (ceval_step3 st c1 i') with | Some st' => ceval_step3 st' c i' | None => None end else Some st end end. (** We can improve the readability of this version by introducing a bit of auxiliary notation to hide the plumbing involved in repeatedly matching against optional states. *) Notation "'LETOPT' x <== e1 'IN' e2" := (match e1 with | Some x => e2 | None => None end) (right associativity, at level 60). Fixpoint ceval_step (st : state) (c : com) (i : nat) : option state := match i with | O => None | S i' => match c with | SKIP => Some st | l ::= a1 => Some (t_update st l (aeval st a1)) | c1 ;; c2 => LETOPT st' <== ceval_step st c1 i' IN ceval_step st' c2 i' | IFB b THEN c1 ELSE c2 FI => if (beval st b) then ceval_step st c1 i' else ceval_step st c2 i' | WHILE b1 DO c1 END => if (beval st b1) then LETOPT st' <== ceval_step st c1 i' IN ceval_step st' c i' else Some st end end. Definition test_ceval (st:state) (c:com) := match ceval_step st c 500 with | None => None | Some st => Some (st X, st Y, st Z) end. (* Compute (test_ceval empty_state (X ::= ANum 2;; IFB BLe (AId X) (ANum 1) THEN Y ::= ANum 3 ELSE Z ::= ANum 4 FI)). ====> Some (2, 0, 4) *) (** **** Exercise: 2 stars, recommended (pup_to_n) *) (** Write an Imp program that sums the numbers from [1] to [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y]. Make sure your solution satisfies the test that follows. *) Definition pup_to_n : com (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (* Example pup_to_n_1 : test_ceval (t_update empty_state X 5) pup_to_n = Some (0, 15, 0). Proof. reflexivity. Qed. *) (** [] *) (** **** Exercise: 2 stars, optional (peven) *) (** Write a [While] program that sets [Z] to [0] if [X] is even and sets [Z] to [1] otherwise. Use [ceval_test] to test your program. *) (* FILL IN HERE *) (** [] *) (* ################################################################# *) (** * Relational vs. Step-Indexed Evaluation *) (** As for arithmetic and boolean expressions, we'd hope that the two alternative definitions of evaluation would actually amount to the same thing in the end. This section shows that this is the case. *) Theorem ceval_step__ceval: forall c st st', (exists i, ceval_step st c i = Some st') -> c / st \\ st'. Proof. intros c st st' H. inversion H as [i E]. clear H. generalize dependent st'. generalize dependent st. generalize dependent c. induction i as [| i' ]. - (* i = 0 -- contradictory *) intros c st st' H. inversion H. - (* i = S i' *) intros c st st' H. destruct c; simpl in H; inversion H; subst; clear H. + (* SKIP *) apply E_Skip. + (* ::= *) apply E_Ass. reflexivity. + (* ;; *) destruct (ceval_step st c1 i') eqn:Heqr1. * (* Evaluation of r1 terminates normally *) apply E_Seq with s. apply IHi'. rewrite Heqr1. reflexivity. apply IHi'. simpl in H1. assumption. * (* Otherwise -- contradiction *) inversion H1. + (* IFB *) destruct (beval st b) eqn:Heqr. * (* r = true *) apply E_IfTrue. rewrite Heqr. reflexivity. apply IHi'. assumption. * (* r = false *) apply E_IfFalse. rewrite Heqr. reflexivity. apply IHi'. assumption. + (* WHILE *) destruct (beval st b) eqn :Heqr. * (* r = true *) destruct (ceval_step st c i') eqn:Heqr1. { (* r1 = Some s *) apply E_WhileTrue with s. rewrite Heqr. reflexivity. apply IHi'. rewrite Heqr1. reflexivity. apply IHi'. simpl in H1. assumption. } { (* r1 = None *) inversion H1. } * (* r = false *) inversion H1. apply E_WhileFalse. rewrite <- Heqr. subst. reflexivity. Qed. (** **** Exercise: 4 stars (ceval_step__ceval_inf) *) (** Write an informal proof of [ceval_step__ceval], following the usual template. (The template for case analysis on an inductively defined value should look the same as for induction, except that there is no induction hypothesis.) Make your proof communicate the main ideas to a human reader; do not simply transcribe the steps of the formal proof. (* FILL IN HERE *) [] *) Theorem ceval_step_more: forall i1 i2 st st' c, i1 <= i2 -> ceval_step st c i1 = Some st' -> ceval_step st c i2 = Some st'. Proof. induction i1 as [|i1']; intros i2 st st' c Hle Hceval. - (* i1 = 0 *) simpl in Hceval. inversion Hceval. - (* i1 = S i1' *) destruct i2 as [|i2']. inversion Hle. assert (Hle': i1' <= i2') by omega. destruct c. + (* SKIP *) simpl in Hceval. inversion Hceval. reflexivity. + (* ::= *) simpl in Hceval. inversion Hceval. reflexivity. + (* ;; *) simpl in Hceval. simpl. destruct (ceval_step st c1 i1') eqn:Heqst1'o. * (* st1'o = Some *) apply (IHi1' i2') in Heqst1'o; try assumption. rewrite Heqst1'o. simpl. simpl in Hceval. apply (IHi1' i2') in Hceval; try assumption. * (* st1'o = None *) inversion Hceval. + (* IFB *) simpl in Hceval. simpl. destruct (beval st b); apply (IHi1' i2') in Hceval; assumption. + (* WHILE *) simpl in Hceval. simpl. destruct (beval st b); try assumption. destruct (ceval_step st c i1') eqn: Heqst1'o. * (* st1'o = Some *) apply (IHi1' i2') in Heqst1'o; try assumption. rewrite -> Heqst1'o. simpl. simpl in Hceval. apply (IHi1' i2') in Hceval; try assumption. * (* i1'o = None *) simpl in Hceval. inversion Hceval. Qed. (** **** Exercise: 3 stars, recommended (ceval__ceval_step) *) (** Finish the following proof. You'll need [ceval_step_more] in a few places, as well as some basic facts about [<=] and [plus]. *) Theorem ceval__ceval_step: forall c st st', c / st \\ st' -> exists i, ceval_step st c i = Some st'. Proof. intros c st st' Hce. induction Hce. (* FILL IN HERE *) Admitted. (** [] *) Theorem ceval_and_ceval_step_coincide: forall c st st', c / st \\ st' <-> exists i, ceval_step st c i = Some st'. Proof. intros c st st'. split. apply ceval__ceval_step. apply ceval_step__ceval. Qed. (* ################################################################# *) (** * Determinism of Evaluation Again *) (** Using the fact that the relational and step-indexed definition of evaluation are the same, we can give a slicker proof that the evaluation _relation_ is deterministic. *) Theorem ceval_deterministic' : forall c st st1 st2, c / st \\ st1 -> c / st \\ st2 -> st1 = st2. Proof. intros c st st1 st2 He1 He2. apply ceval__ceval_step in He1. apply ceval__ceval_step in He2. inversion He1 as [i1 E1]. inversion He2 as [i2 E2]. apply ceval_step_more with (i2 := i1 + i2) in E1. apply ceval_step_more with (i2 := i1 + i2) in E2. rewrite E1 in E2. inversion E2. reflexivity. omega. omega. Qed. (** $Date: 2017-05-24 10:56:51 -0400 (Wed, 24 May 2017) $ *) QuickChick-2.1.0/sf-experiment/ImpParser.v000066400000000000000000000331711476030541200204160ustar00rootroot00000000000000(** * ImpParser: Lexing and Parsing in Coq *) (** The development of the Imp language in [Imp.v] completely ignores issues of concrete syntax -- how an ascii string that a programmer might write gets translated into abstract syntax trees defined by the datatypes [aexp], [bexp], and [com]. In this chapter, we illustrate how the rest of the story can be filled in by building a simple lexical analyzer and parser using Coq's functional programming facilities. It is not important to understand all the details here (and accordingly, the explanations are fairly terse and there are no exercises). The main point is simply to demonstrate that it can be done. You are invited to look through the code -- most of it is not very complicated, though the parser relies on some "monadic" programming idioms that may require a little work to make out -- but most readers will probably want to just skim down to the Examples section at the very end to get the punchline. *) (* DROP *) (* ################################################################# *) (** * Internals *) Set Warnings "-notation-overridden,-parsing,-deprecated-implicit-arguments". Require Import Coq.Strings.String. Require Import Coq.Strings.Ascii. Require Import Coq.Arith.Arith. Require Import Coq.Arith.EqNat. Require Import Coq.Lists.List. Import ListNotations. Require Import Maps. Require Import Imp. (* ================================================================= *) (** ** Lexical Analysis *) Definition isWhite (c : ascii) : bool := let n := nat_of_ascii c in orb (orb (beq_nat n 32) (* space *) (beq_nat n 9)) (* tab *) (orb (beq_nat n 10) (* linefeed *) (beq_nat n 13)). (* Carriage return. *) Notation "x '<=?' y" := (leb x y) (at level 70, no associativity) : nat_scope. Definition isLowerAlpha (c : ascii) : bool := let n := nat_of_ascii c in andb (97 <=? n) (n <=? 122). Definition isAlpha (c : ascii) : bool := let n := nat_of_ascii c in orb (andb (65 <=? n) (n <=? 90)) (andb (97 <=? n) (n <=? 122)). Definition isDigit (c : ascii) : bool := let n := nat_of_ascii c in andb (48 <=? n) (n <=? 57). Inductive chartype := white | alpha | digit | other. Definition classifyChar (c : ascii) : chartype := if isWhite c then white else if isAlpha c then alpha else if isDigit c then digit else other. Fixpoint list_of_string (s : string) : list ascii := match s with | EmptyString => [] | String c s => c :: (list_of_string s) end. Fixpoint string_of_list (xs : list ascii) : string := fold_right String EmptyString xs. Definition token := string. Fixpoint tokenize_helper (cls : chartype) (acc xs : list ascii) : list (list ascii) := let tk := match acc with [] => [] | _::_ => [rev acc] end in match xs with | [] => tk | (x::xs') => match cls, classifyChar x, x with | _, _, "(" => tk ++ ["("]::(tokenize_helper other [] xs') | _, _, ")" => tk ++ [")"]::(tokenize_helper other [] xs') | _, white, _ => tk ++ (tokenize_helper white [] xs') | alpha,alpha,x => tokenize_helper alpha (x::acc) xs' | digit,digit,x => tokenize_helper digit (x::acc) xs' | other,other,x => tokenize_helper other (x::acc) xs' | _,tp,x => tk ++ (tokenize_helper tp [x] xs') end end %char. Definition tokenize (s : string) : list string := map string_of_list (tokenize_helper white [] (list_of_string s)). Example tokenize_ex1 : tokenize "abc12==3 223*(3+(a+c))" %string = ["abc"; "12"; "=="; "3"; "223"; "*"; "("; "3"; "+"; "("; "a"; "+"; "c"; ")"; ")"]%string. Proof. reflexivity. Qed. (* ================================================================= *) (** ** Parsing *) (* ----------------------------------------------------------------- *) (** *** Options With Errors *) (** An [option] type with error messages: *) Inductive optionE (X:Type) : Type := | SomeE : X -> optionE X | NoneE : string -> optionE X. Implicit Arguments SomeE [[X]]. Implicit Arguments NoneE [[X]]. (** Some syntactic sugar to make writing nested match-expressions on optionE more convenient. *) Notation "'DO' ( x , y ) <== e1 ; e2" := (match e1 with | SomeE (x,y) => e2 | NoneE err => NoneE err end) (right associativity, at level 60). Notation "'DO' ( x , y ) <-- e1 ; e2 'OR' e3" := (match e1 with | SomeE (x,y) => e2 | NoneE err => e3 end) (right associativity, at level 60, e2 at next level). (* ----------------------------------------------------------------- *) (** *** Generic Combinators for Building Parsers *) Open Scope string_scope. Definition parser (T : Type) := list token -> optionE (T * list token). Fixpoint many_helper {T} (p : parser T) acc steps xs := match steps, p xs with | 0, _ => NoneE "Too many recursive calls" | _, NoneE _ => SomeE ((rev acc), xs) | S steps', SomeE (t, xs') => many_helper p (t::acc) steps' xs' end. (** A (step-indexed) parser that expects zero or more [p]s: *) Fixpoint many {T} (p : parser T) (steps : nat) : parser (list T) := many_helper p [] steps. (** A parser that expects a given token, followed by [p]: *) Definition firstExpect {T} (t : token) (p : parser T) : parser T := fun xs => match xs with | x::xs' => if string_dec x t then p xs' else NoneE ("expected '" ++ t ++ "'.") | [] => NoneE ("expected '" ++ t ++ "'.") end. (** A parser that expects a particular token: *) Definition expect (t : token) : parser unit := firstExpect t (fun xs => SomeE(tt, xs)). (* ----------------------------------------------------------------- *) (** *** A Recursive-Descent Parser for Imp *) (** Identifiers: *) Definition parseIdentifier (xs : list token) : optionE (id * list token) := match xs with | [] => NoneE "Expected identifier" | x::xs' => if forallb isLowerAlpha (list_of_string x) then SomeE (Id x, xs') else NoneE ("Illegal identifier:'" ++ x ++ "'") end. (** Numbers: *) Definition parseNumber (xs : list token) : optionE (nat * list token) := match xs with | [] => NoneE "Expected number" | x::xs' => if forallb isDigit (list_of_string x) then SomeE (fold_left (fun n d => 10 * n + (nat_of_ascii d - nat_of_ascii "0"%char)) (list_of_string x) 0, xs') else NoneE "Expected number" end. (** Parse arithmetic expressions *) Fixpoint parsePrimaryExp (steps:nat) (xs : list token) : optionE (aexp * list token) := match steps with | 0 => NoneE "Too many recursive calls" | S steps' => DO (i, rest) <-- parseIdentifier xs ; SomeE (AId i, rest) OR DO (n, rest) <-- parseNumber xs ; SomeE (ANum n, rest) OR (DO (e, rest) <== firstExpect "(" (parseSumExp steps') xs; DO (u, rest') <== expect ")" rest ; SomeE(e,rest')) end with parseProductExp (steps:nat) (xs : list token) := match steps with | 0 => NoneE "Too many recursive calls" | S steps' => DO (e, rest) <== parsePrimaryExp steps' xs ; DO (es, rest') <== many (firstExpect "*" (parsePrimaryExp steps')) steps' rest; SomeE (fold_left AMult es e, rest') end with parseSumExp (steps:nat) (xs : list token) := match steps with | 0 => NoneE "Too many recursive calls" | S steps' => DO (e, rest) <== parseProductExp steps' xs ; DO (es, rest') <== many (fun xs => DO (e,rest') <-- firstExpect "+" (parseProductExp steps') xs; SomeE ( (true, e), rest') OR DO (e,rest') <== firstExpect "-" (parseProductExp steps') xs; SomeE ( (false, e), rest')) steps' rest; SomeE (fold_left (fun e0 term => match term with (true, e) => APlus e0 e | (false, e) => AMinus e0 e end) es e, rest') end. Definition parseAExp := parseSumExp. (** Parsing boolean expressions: *) Fixpoint parseAtomicExp (steps:nat) (xs : list token) := match steps with | 0 => NoneE "Too many recursive calls" | S steps' => DO (u,rest) <-- expect "true" xs; SomeE (BTrue,rest) OR DO (u,rest) <-- expect "false" xs; SomeE (BFalse,rest) OR DO (e,rest) <-- firstExpect "not" (parseAtomicExp steps') xs; SomeE (BNot e, rest) OR DO (e,rest) <-- firstExpect "(" (parseConjunctionExp steps') xs; (DO (u,rest') <== expect ")" rest; SomeE (e, rest')) OR DO (e, rest) <== parseProductExp steps' xs; (DO (e', rest') <-- firstExpect "==" (parseAExp steps') rest; SomeE (BEq e e', rest') OR DO (e', rest') <-- firstExpect "<=" (parseAExp steps') rest; SomeE (BLe e e', rest') OR NoneE "Expected '==' or '<=' after arithmetic expression") end with parseConjunctionExp (steps:nat) (xs : list token) := match steps with | 0 => NoneE "Too many recursive calls" | S steps' => DO (e, rest) <== parseAtomicExp steps' xs ; DO (es, rest') <== many (firstExpect "&&" (parseAtomicExp steps')) steps' rest; SomeE (fold_left BAnd es e, rest') end. Definition parseBExp := parseConjunctionExp. Check parseConjunctionExp. Definition testParsing {X : Type} (p : nat -> list token -> optionE (X * list token)) (s : string) := let t := tokenize s in p 100 t. (* Eval compute in testParsing parseProductExp "x*y*(x*x)*x". Eval compute in testParsing parseConjunctionExp "not((x==x||x*x<=(x*x)*x)&&x==x". *) (** Parsing commands: *) Fixpoint parseSimpleCommand (steps:nat) (xs : list token) := match steps with | 0 => NoneE "Too many recursive calls" | S steps' => DO (u, rest) <-- expect "SKIP" xs; SomeE (SKIP, rest) OR DO (e,rest) <-- firstExpect "IF" (parseBExp steps') xs; DO (c,rest') <== firstExpect "THEN" (parseSequencedCommand steps') rest; DO (c',rest'') <== firstExpect "ELSE" (parseSequencedCommand steps') rest'; DO (u,rest''') <== expect "END" rest''; SomeE(IFB e THEN c ELSE c' FI, rest''') OR DO (e,rest) <-- firstExpect "WHILE" (parseBExp steps') xs; DO (c,rest') <== firstExpect "DO" (parseSequencedCommand steps') rest; DO (u,rest'') <== expect "END" rest'; SomeE(WHILE e DO c END, rest'') OR DO (i, rest) <== parseIdentifier xs; DO (e, rest') <== firstExpect ":=" (parseAExp steps') rest; SomeE(i ::= e, rest') end with parseSequencedCommand (steps:nat) (xs : list token) := match steps with | 0 => NoneE "Too many recursive calls" | S steps' => DO (c, rest) <== parseSimpleCommand steps' xs; DO (c', rest') <-- firstExpect ";" (parseSequencedCommand steps') rest; SomeE(c ;; c', rest') OR SomeE(c, rest) end. Definition bignumber := 1000. Definition parse (str : string) : optionE (com * list token) := let tokens := tokenize str in parseSequencedCommand bignumber tokens. (* ################################################################# *) (** * Examples *) (* Compute parse " IF x == y + 1 + 2 - y * 6 + 3 THEN x := x * 1;; y := 0 ELSE SKIP END ". ====> SomeE (IFB BEq (AId (Id 0)) (APlus (AMinus (APlus (APlus (AId (Id 1)) (ANum 1)) (ANum 2)) (AMult (AId (Id 1)) (ANum 6))) (ANum 3)) THEN Id 0 ::= AMult (AId (Id 0)) (ANum 1);; Id 1 ::= ANum 0 ELSE SKIP FI, []) *) (* Compute parse " SKIP;; z:=x*y*(x*x);; WHILE x==x DO IF z <= z*z && not x == 2 THEN x := z;; y := z ELSE SKIP END;; SKIP END;; x:=z ". ====> SomeE (SKIP;; Id 0 ::= AMult (AMult (AId (Id 1)) (AId (Id 2))) (AMult (AId (Id 1)) (AId (Id 1)));; WHILE BEq (AId (Id 1)) (AId (Id 1)) DO IFB BAnd (BLe (AId (Id 0)) (AMult (AId (Id 0)) (AId (Id 0)))) (BNot (BEq (AId (Id 1)) (ANum 2))) THEN Id 1 ::= AId (Id 0);; Id 2 ::= AId (Id 0) ELSE SKIP FI;; SKIP END;; Id 1 ::= AId (Id 0), []) *) (* Compute parse " SKIP;; z:=x*y*(x*x);; WHILE x==x DO IF z <= z*z && not x == 2 THEN x := z;; y := z ELSE SKIP END;; SKIP END;; x:=z ". =====> SomeE (SKIP;; Id 0 ::= AMult (AMult (AId (Id 1)) (AId (Id 2))) (AMult (AId (Id 1)) (AId (Id 1)));; WHILE BEq (AId (Id 1)) (AId (Id 1)) DO IFB BAnd (BLe (AId (Id 0)) (AMult (AId (Id 0)) (AId (Id 0)))) (BNot (BEq (AId (Id 1)) (ANum 2))) THEN Id 1 ::= AId (Id 0);; Id 2 ::= AId (Id 0) ELSE SKIP FI;; SKIP END;; Id 1 ::= AId (Id 0), []). *) (* /DROP *) (** $Date: 2017-04-26 17:33:43 -0400 (Wed, 26 Apr 2017) $ *) QuickChick-2.1.0/sf-experiment/IndPrinciples.v000066400000000000000000000631361476030541200212630ustar00rootroot00000000000000(** * IndPrinciples: Induction Principles *) (** With the Curry-Howard correspondence and its realization in Coq in mind, we can now take a deeper look at induction principles. *) Set Warnings "-notation-overridden,-parsing". Require Export ProofObjects. (* ################################################################# *) (** * Basics *) (** Every time we declare a new [Inductive] datatype, Coq automatically generates an _induction principle_ for this type. This induction principle is a theorem like any other: If [t] is defined inductively, the corresponding induction principle is called [t_ind]. Here is the one for natural numbers: *) Check nat_ind. (* ===> nat_ind : forall P : nat -> Prop, P 0 -> (forall n : nat, P n -> P (S n)) -> forall n : nat, P n *) (** The [induction] tactic is a straightforward wrapper that, at its core, simply performs [apply t_ind]. To see this more clearly, let's experiment with directly using [apply nat_ind], instead of the [induction] tactic, to carry out some proofs. Here, for example, is an alternate proof of a theorem that we saw in the [Basics] chapter. *) Theorem mult_0_r' : forall n:nat, n * 0 = 0. Proof. apply nat_ind. - (* n = O *) reflexivity. - (* n = S n' *) simpl. intros n' IHn'. rewrite -> IHn'. reflexivity. Qed. (** This proof is basically the same as the earlier one, but a few minor differences are worth noting. First, in the induction step of the proof (the ["S"] case), we have to do a little bookkeeping manually (the [intros]) that [induction] does automatically. Second, we do not introduce [n] into the context before applying [nat_ind] -- the conclusion of [nat_ind] is a quantified formula, and [apply] needs this conclusion to exactly match the shape of the goal state, including the quantifier. By contrast, the [induction] tactic works either with a variable in the context or a quantified variable in the goal. These conveniences make [induction] nicer to use in practice than applying induction principles like [nat_ind] directly. But it is important to realize that, modulo these bits of bookkeeping, applying [nat_ind] is what we are really doing. *) (** **** Exercise: 2 stars, optional (plus_one_r') *) (** Complete this proof without using the [induction] tactic. *) Theorem plus_one_r' : forall n:nat, n + 1 = S n. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** Coq generates induction principles for every datatype defined with [Inductive], including those that aren't recursive. Although of course we don't need induction to prove properties of non-recursive datatypes, the idea of an induction principle still makes sense for them: it gives a way to prove that a property holds for all values of the type. These generated principles follow a similar pattern. If we define a type [t] with constructors [c1] ... [cn], Coq generates a theorem with this shape: t_ind : forall P : t -> Prop, ... case for c1 ... -> ... case for c2 ... -> ... ... case for cn ... -> forall n : t, P n The specific shape of each case depends on the arguments to the corresponding constructor. Before trying to write down a general rule, let's look at some more examples. First, an example where the constructors take no arguments: *) Inductive yesno : Type := | yes : yesno | no : yesno. Check yesno_ind. (* ===> yesno_ind : forall P : yesno -> Prop, P yes -> P no -> forall y : yesno, P y *) (** **** Exercise: 1 star, optional (rgb) *) (** Write out the induction principle that Coq will generate for the following datatype. Write down your answer on paper or type it into a comment, and then compare it with what Coq prints. *) Inductive rgb : Type := | red : rgb | green : rgb | blue : rgb. Check rgb_ind. (** [] *) (** Here's another example, this time with one of the constructors taking some arguments. *) Inductive natlist : Type := | nnil : natlist | ncons : nat -> natlist -> natlist. Check natlist_ind. (* ===> (modulo a little variable renaming) natlist_ind : forall P : natlist -> Prop, P nnil -> (forall (n : nat) (l : natlist), P l -> P (ncons n l)) -> forall n : natlist, P n *) (** **** Exercise: 1 star, optional (natlist1) *) (** Suppose we had written the above definition a little differently: *) Inductive natlist1 : Type := | nnil1 : natlist1 | nsnoc1 : natlist1 -> nat -> natlist1. (** Now what will the induction principle look like? *) (** [] *) (** From these examples, we can extract this general rule: - The type declaration gives several constructors; each corresponds to one clause of the induction principle. - Each constructor [c] takes argument types [a1] ... [an]. - Each [ai] can be either [t] (the datatype we are defining) or some other type [s]. - The corresponding case of the induction principle says: - "For all values [x1]...[xn] of types [a1]...[an], if [P] holds for each of the inductive arguments (each [xi] of type [t]), then [P] holds for [c x1 ... xn]". *) (** **** Exercise: 1 star, optional (byntree_ind) *) (** Write out the induction principle that Coq will generate for the following datatype. (Again, write down your answer on paper or type it into a comment, and then compare it with what Coq prints.) *) Inductive byntree : Type := | bempty : byntree | bleaf : yesno -> byntree | nbranch : yesno -> byntree -> byntree -> byntree. (** [] *) (** **** Exercise: 1 star, optional (ex_set) *) (** Here is an induction principle for an inductively defined set. ExSet_ind : forall P : ExSet -> Prop, (forall b : bool, P (con1 b)) -> (forall (n : nat) (e : ExSet), P e -> P (con2 n e)) -> forall e : ExSet, P e Give an [Inductive] definition of [ExSet]: *) Inductive ExSet : Type := (* FILL IN HERE *) . (** [] *) (* ################################################################# *) (** * Polymorphism *) (** Next, what about polymorphic datatypes? The inductive definition of polymorphic lists Inductive list (X:Type) : Type := | nil : list X | cons : X -> list X -> list X. is very similar to that of [natlist]. The main difference is that, here, the whole definition is _parameterized_ on a set [X]: that is, we are defining a _family_ of inductive types [list X], one for each [X]. (Note that, wherever [list] appears in the body of the declaration, it is always applied to the parameter [X].) The induction principle is likewise parameterized on [X]: list_ind : forall (X : Type) (P : list X -> Prop), P [] -> (forall (x : X) (l : list X), P l -> P (x :: l)) -> forall l : list X, P l Note that the _whole_ induction principle is parameterized on [X]. That is, [list_ind] can be thought of as a polymorphic function that, when applied to a type [X], gives us back an induction principle specialized to the type [list X]. *) (** **** Exercise: 1 star, optional (tree) *) (** Write out the induction principle that Coq will generate for the following datatype. Compare your answer with what Coq prints. *) Inductive tree (X:Type) : Type := | leaf : X -> tree X | node : tree X -> tree X -> tree X. Check tree_ind. (** [] *) (** **** Exercise: 1 star, optional (mytype) *) (** Find an inductive definition that gives rise to the following induction principle: mytype_ind : forall (X : Type) (P : mytype X -> Prop), (forall x : X, P (constr1 X x)) -> (forall n : nat, P (constr2 X n)) -> (forall m : mytype X, P m -> forall n : nat, P (constr3 X m n)) -> forall m : mytype X, P m *) (** [] *) (** **** Exercise: 1 star, optional (foo) *) (** Find an inductive definition that gives rise to the following induction principle: foo_ind : forall (X Y : Type) (P : foo X Y -> Prop), (forall x : X, P (bar X Y x)) -> (forall y : Y, P (baz X Y y)) -> (forall f1 : nat -> foo X Y, (forall n : nat, P (f1 n)) -> P (quux X Y f1)) -> forall f2 : foo X Y, P f2 *) (** [] *) (** **** Exercise: 1 star, optional (foo') *) (** Consider the following inductive definition: *) Inductive foo' (X:Type) : Type := | C1 : list X -> foo' X -> foo' X | C2 : foo' X. (** What induction principle will Coq generate for [foo']? Fill in the blanks, then check your answer with Coq.) foo'_ind : forall (X : Type) (P : foo' X -> Prop), (forall (l : list X) (f : foo' X), _______________________ -> _______________________ ) -> ___________________________________________ -> forall f : foo' X, ________________________ *) (** [] *) (* ################################################################# *) (** * Induction Hypotheses *) (** Where does the phrase "induction hypothesis" fit into this story? The induction principle for numbers forall P : nat -> Prop, P 0 -> (forall n : nat, P n -> P (S n)) -> forall n : nat, P n is a generic statement that holds for all propositions [P] (or rather, strictly speaking, for all families of propositions [P] indexed by a number [n]). Each time we use this principle, we are choosing [P] to be a particular expression of type [nat->Prop]. We can make proofs by induction more explicit by giving this expression a name. For example, instead of stating the theorem [mult_0_r] as "[forall n, n * 0 = 0]," we can write it as "[forall n, P_m0r n]", where [P_m0r] is defined as... *) Definition P_m0r (n:nat) : Prop := n * 0 = 0. (** ... or equivalently: *) Definition P_m0r' : nat->Prop := fun n => n * 0 = 0. (** Now it is easier to see where [P_m0r] appears in the proof. *) Theorem mult_0_r'' : forall n:nat, P_m0r n. Proof. apply nat_ind. - (* n = O *) reflexivity. - (* n = S n' *) (* Note the proof state at this point! *) intros n IHn. unfold P_m0r in IHn. unfold P_m0r. simpl. apply IHn. Qed. (** This extra naming step isn't something that we do in normal proofs, but it is useful to do it explicitly for an example or two, because it allows us to see exactly what the induction hypothesis is. If we prove [forall n, P_m0r n] by induction on [n] (using either [induction] or [apply nat_ind]), we see that the first subgoal requires us to prove [P_m0r 0] ("[P] holds for zero"), while the second subgoal requires us to prove [forall n', P_m0r n' -> P_m0r (S n')] (that is "[P] holds of [S n'] if it holds of [n']" or, more elegantly, "[P] is preserved by [S]"). The _induction hypothesis_ is the premise of this latter implication -- the assumption that [P] holds of [n'], which we are allowed to use in proving that [P] holds for [S n']. *) (* ################################################################# *) (** * More on the [induction] Tactic *) (** The [induction] tactic actually does even more low-level bookkeeping for us than we discussed above. Recall the informal statement of the induction principle for natural numbers: - If [P n] is some proposition involving a natural number n, and we want to show that P holds for _all_ numbers n, we can reason like this: - show that [P O] holds - show that, if [P n'] holds, then so does [P (S n')] - conclude that [P n] holds for all n. So, when we begin a proof with [intros n] and then [induction n], we are first telling Coq to consider a _particular_ [n] (by introducing it into the context) and then telling it to prove something about _all_ numbers (by using induction). What Coq actually does in this situation, internally, is to "re-generalize" the variable we perform induction on. For example, in our original proof that [plus] is associative... *) Theorem plus_assoc' : forall n m p : nat, n + (m + p) = (n + m) + p. Proof. (* ...we first introduce all 3 variables into the context, which amounts to saying "Consider an arbitrary [n], [m], and [p]..." *) intros n m p. (* ...We now use the [induction] tactic to prove [P n] (that is, [n + (m + p) = (n + m) + p]) for _all_ [n], and hence also for the particular [n] that is in the context at the moment. *) induction n as [| n']. - (* n = O *) reflexivity. - (* n = S n' *) (* In the second subgoal generated by [induction] -- the "inductive step" -- we must prove that [P n'] implies [P (S n')] for all [n']. The [induction] tactic automatically introduces [n'] and [P n'] into the context for us, leaving just [P (S n')] as the goal. *) simpl. rewrite -> IHn'. reflexivity. Qed. (** It also works to apply [induction] to a variable that is quantified in the goal. *) Theorem plus_comm' : forall n m : nat, n + m = m + n. Proof. induction n as [| n']. - (* n = O *) intros m. rewrite <- plus_n_O. reflexivity. - (* n = S n' *) intros m. simpl. rewrite -> IHn'. rewrite <- plus_n_Sm. reflexivity. Qed. (** Note that [induction n] leaves [m] still bound in the goal -- i.e., what we are proving inductively is a statement beginning with [forall m]. If we do [induction] on a variable that is quantified in the goal _after_ some other quantifiers, the [induction] tactic will automatically introduce the variables bound by these quantifiers into the context. *) Theorem plus_comm'' : forall n m : nat, n + m = m + n. Proof. (* Let's do induction on [m] this time, instead of [n]... *) induction m as [| m']. - (* m = O *) simpl. rewrite <- plus_n_O. reflexivity. - (* m = S m' *) simpl. rewrite <- IHm'. rewrite <- plus_n_Sm. reflexivity. Qed. (** **** Exercise: 1 star, optional (plus_explicit_prop) *) (** Rewrite both [plus_assoc'] and [plus_comm'] and their proofs in the same style as [mult_0_r''] above -- that is, for each theorem, give an explicit [Definition] of the proposition being proved by induction, and state the theorem and proof in terms of this defined proposition. *) (* FILL IN HERE *) (** [] *) (* ################################################################# *) (** * Induction Principles in [Prop] *) (** Earlier, we looked in detail at the induction principles that Coq generates for inductively defined _sets_. The induction principles for inductively defined _propositions_ like [ev] are a tiny bit more complicated. As with all induction principles, we want to use the induction principle on [ev] to prove things by inductively considering the possible shapes that something in [ev] can have. Intuitively speaking, however, what we want to prove are not statements about _evidence_ but statements about _numbers_: accordingly, we want an induction principle that lets us prove properties of numbers by induction on evidence. For example, from what we've said so far, you might expect the inductive definition of [ev]... Inductive ev : nat -> Prop := | ev_0 : ev 0 | ev_SS : forall n : nat, ev n -> ev (S (S n)). ...to give rise to an induction principle that looks like this... ev_ind_max : forall P : (forall n : nat, ev n -> Prop), P O ev_0 -> (forall (m : nat) (E : ev m), P m E -> P (S (S m)) (ev_SS m E)) -> forall (n : nat) (E : ev n), P n E ... because: - Since [ev] is indexed by a number [n] (every [ev] object [E] is a piece of evidence that some particular number [n] is even), the proposition [P] is parameterized by both [n] and [E] -- that is, the induction principle can be used to prove assertions involving both an even number and the evidence that it is even. - Since there are two ways of giving evidence of evenness ([ev] has two constructors), applying the induction principle generates two subgoals: - We must prove that [P] holds for [O] and [ev_0]. - We must prove that, whenever [n] is an even number and [E] is an evidence of its evenness, if [P] holds of [n] and [E], then it also holds of [S (S n)] and [ev_SS n E]. - If these subgoals can be proved, then the induction principle tells us that [P] is true for _all_ even numbers [n] and evidence [E] of their evenness. This is more flexibility than we normally need or want: it is giving us a way to prove logical assertions where the assertion involves properties of some piece of _evidence_ of evenness, while all we really care about is proving properties of _numbers_ that are even -- we are interested in assertions about numbers, not about evidence. It would therefore be more convenient to have an induction principle for proving propositions [P] that are parameterized just by [n] and whose conclusion establishes [P] for all even numbers [n]: forall P : nat -> Prop, ... -> forall n : nat, even n -> P n For this reason, Coq actually generates the following simplified induction principle for [ev]: *) Check ev_ind. (* ===> ev_ind : forall P : nat -> Prop, P 0 -> (forall n : nat, ev n -> P n -> P (S (S n))) -> forall n : nat, ev n -> P n *) (** In particular, Coq has dropped the evidence term [E] as a parameter of the the proposition [P]. *) (** In English, [ev_ind] says: - Suppose, [P] is a property of natural numbers (that is, [P n] is a [Prop] for every [n]). To show that [P n] holds whenever [n] is even, it suffices to show: - [P] holds for [0], - for any [n], if [n] is even and [P] holds for [n], then [P] holds for [S (S n)]. *) (** As expected, we can apply [ev_ind] directly instead of using [induction]. For example, we can use it to show that [ev'] (the slightly awkward alternate definition of evenness that we saw in an exercise in the \chap{IndProp} chapter) is equivalent to the cleaner inductive definition [ev]: *) Theorem ev_ev' : forall n, ev n -> ev' n. Proof. apply ev_ind. - (* ev_0 *) apply ev'_0. - (* ev_SS *) intros m Hm IH. apply (ev'_sum 2 m). + apply ev'_2. + apply IH. Qed. (** The precise form of an [Inductive] definition can affect the induction principle Coq generates. For example, in chapter [IndProp], we defined [<=] as: *) (* Inductive le : nat -> nat -> Prop := | le_n : forall n, le n n | le_S : forall n m, (le n m) -> (le n (S m)). *) (** This definition can be streamlined a little by observing that the left-hand argument [n] is the same everywhere in the definition, so we can actually make it a "general parameter" to the whole definition, rather than an argument to each constructor. *) Inductive le (n:nat) : nat -> Prop := | le_n : le n n | le_S : forall m, (le n m) -> (le n (S m)). Notation "m <= n" := (le m n). (** The second one is better, even though it looks less symmetric. Why? Because it gives us a simpler induction principle. *) Check le_ind. (* ===> forall (n : nat) (P : nat -> Prop), P n -> (forall m : nat, n <= m -> P m -> P (S m)) -> forall n0 : nat, n <= n0 -> P n0 *) (* ################################################################# *) (** * Formal vs. Informal Proofs by Induction *) (** Question: What is the relation between a formal proof of a proposition [P] and an informal proof of the same proposition [P]? Answer: The latter should _teach_ the reader how to produce the former. Question: How much detail is needed?? Unfortunately, there is no single right answer; rather, there is a range of choices. At one end of the spectrum, we can essentially give the reader the whole formal proof (i.e., the "informal" proof will amount to just transcribing the formal one into words). This may give the reader the ability to reproduce the formal one for themselves, but it probably doesn't _teach_ them anything much. At the other end of the spectrum, we can say "The theorem is true and you can figure out why for yourself if you think about it hard enough." This is also not a good teaching strategy, because often writing the proof requires one or more significant insights into the thing we're proving, and most readers will give up before they rediscover all the same insights as we did. In the middle is the golden mean -- a proof that includes all of the essential insights (saving the reader the hard work that we went through to find the proof in the first place) plus high-level suggestions for the more routine parts to save the reader from spending too much time reconstructing these (e.g., what the IH says and what must be shown in each case of an inductive proof), but not so much detail that the main ideas are obscured. Since we've spent much of this chapter looking "under the hood" at formal proofs by induction, now is a good moment to talk a little about _informal_ proofs by induction. In the real world of mathematical communication, written proofs range from extremely longwinded and pedantic to extremely brief and telegraphic. Although the ideal is somewhere in between, while one is getting used to the style it is better to start out at the pedantic end. Also, during the learning phase, it is probably helpful to have a clear standard to compare against. With this in mind, we offer two templates -- one for proofs by induction over _data_ (i.e., where the thing we're doing induction on lives in [Type]) and one for proofs by induction over _evidence_ (i.e., where the inductively defined thing lives in [Prop]). *) (* ================================================================= *) (** ** Induction Over an Inductively Defined Set *) (** _Template_: - _Theorem_: _Proof_: By induction on [n]. - Suppose [n = c a1 ... ak], where <...and here we state the IH for each of the [a]'s that has type [S], if any>. We must show <...and here we restate [P(c a1 ... ak)]>. - [] _Example_: - _Theorem_: For all sets [X], lists [l : list X], and numbers [n], if [length l = n] then [index (S n) l = None]. _Proof_: By induction on [l]. - Suppose [l = []]. We must show, for all numbers [n], that, if [length [] = n], then [index (S n) [] = None]. This follows immediately from the definition of [index]. - Suppose [l = x :: l'] for some [x] and [l'], where [length l' = n'] implies [index (S n') l' = None], for any number [n']. We must show, for all [n], that, if [length (x::l') = n] then [index (S n) (x::l') = None]. Let [n] be a number with [length l = n]. Since length l = length (x::l') = S (length l'), it suffices to show that index (S (length l')) l' = None. But this follows directly from the induction hypothesis, picking [n'] to be [length l']. [] *) (* ================================================================= *) (** ** Induction Over an Inductively Defined Proposition *) (** Since inductively defined proof objects are often called "derivation trees," this form of proof is also known as _induction on derivations_. _Template_: - _Theorem_: P]," where [Q] is some inductively defined proposition (more generally, "For all [x] [y] [z], [Q x y z -> P x y z]")> _Proof_: By induction on a derivation of [Q]. - Suppose the final rule used to show [Q] is [c]. Then <...and here we state the types of all of the [a]'s together with any equalities that follow from the definition of the constructor and the IH for each of the [a]'s that has type [Q], if there are any>. We must show <...and here we restate [P]>. - [] _Example_ - _Theorem_: The [<=] relation is transitive -- i.e., for all numbers [n], [m], and [o], if [n <= m] and [m <= o], then [n <= o]. _Proof_: By induction on a derivation of [m <= o]. - Suppose the final rule used to show [m <= o] is [le_n]. Then [m = o] and we must show that [n <= m], which is immediate by hypothesis. - Suppose the final rule used to show [m <= o] is [le_S]. Then [o = S o'] for some [o'] with [m <= o']. We must show that [n <= S o']. By induction hypothesis, [n <= o']. But then, by [le_S], [n <= S o']. [] *) (** $Date: 2017-04-26 17:33:43 -0400 (Wed, 26 Apr 2017) $ *) QuickChick-2.1.0/sf-experiment/IndProp.v000066400000000000000000001572571476030541200201030ustar00rootroot00000000000000(** * IndProp: Inductively Defined Propositions *) Set Warnings "-notation-overridden,-parsing". Require Export Logic. Require Coq.omega.Omega. (* ################################################################# *) (** * Inductively Defined Propositions *) (** In the [Logic] chapter, we looked at several ways of writing propositions, including conjunction, disjunction, and quantifiers. In this chapter, we bring a new tool into the mix: _inductive definitions_. Recall that we have seen two ways of stating that a number [n] is even: We can say (1) [evenb n = true], or (2) [exists k, n = double k]. Yet another possibility is to say that [n] is even if we can establish its evenness from the following rules: - Rule [ev_0]: The number [0] is even. - Rule [ev_SS]: If [n] is even, then [S (S n)] is even. *) (** To illustrate how this definition of evenness works, let's imagine using it to show that [4] is even. By rule [ev_SS], it suffices to show that [2] is even. This, in turn, is again guaranteed by rule [ev_SS], as long as we can show that [0] is even. But this last fact follows directly from the [ev_0] rule. *) (** We will see many definitions like this one during the rest of the course. For purposes of informal discussions, it is helpful to have a lightweight notation that makes them easy to read and write. _Inference rules_ are one such notation: *) (** ------------ (ev_0) ev 0 ev n -------------- (ev_SS) ev (S (S n)) *) (** Each of the textual rules above is reformatted here as an inference rule; the intended reading is that, if the _premises_ above the line all hold, then the _conclusion_ below the line follows. For example, the rule [ev_SS] says that, if [n] satisfies [ev], then [S (S n)] also does. If a rule has no premises above the line, then its conclusion holds unconditionally. We can represent a proof using these rules by combining rule applications into a _proof tree_. Here's how we might transcribe the above proof that [4] is even: *) (** ------ (ev_0) ev 0 ------ (ev_SS) ev 2 ------ (ev_SS) ev 4 *) (** Why call this a "tree" (rather than a "stack", for example)? Because, in general, inference rules can have multiple premises. We will see examples of this below. *) (** Putting all of this together, we can translate the definition of evenness into a formal Coq definition using an [Inductive] declaration, where each constructor corresponds to an inference rule: *) Inductive ev : nat -> Prop := | ev_0 : ev 0 | ev_SS : forall n : nat, ev n -> ev (S (S n)). (** This definition is different in one crucial respect from previous uses of [Inductive]: its result is not a [Type], but rather a function from [nat] to [Prop] -- that is, a property of numbers. Note that we've already seen other inductive definitions that result in functions, such as [list], whose type is [Type -> Type]. What is new here is that, because the [nat] argument of [ev] appears _unnamed_, to the _right_ of the colon, it is allowed to take different values in the types of different constructors: [0] in the type of [ev_0] and [S (S n)] in the type of [ev_SS]. In contrast, the definition of [list] names the [X] parameter _globally_, to the _left_ of the colon, forcing the result of [nil] and [cons] to be the same ([list X]). Had we tried to bring [nat] to the left in defining [ev], we would have seen an error: *) Fail Inductive wrong_ev (n : nat) : Prop := | wrong_ev_0 : wrong_ev 0 | wrong_ev_SS : forall n, wrong_ev n -> wrong_ev (S (S n)). (* ===> Error: A parameter of an inductive type n is not allowed to be used as a bound variable in the type of its constructor. *) (** ("Parameter" here is Coq jargon for an argument on the left of the colon in an [Inductive] definition; "index" is used to refer to arguments on the right of the colon.) *) (** We can think of the definition of [ev] as defining a Coq property [ev : nat -> Prop], together with theorems [ev_0 : ev 0] and [ev_SS : forall n, ev n -> ev (S (S n))]. Such "constructor theorems" have the same status as proven theorems. In particular, we can use Coq's [apply] tactic with the rule names to prove [ev] for particular numbers... *) Theorem ev_4 : ev 4. Proof. apply ev_SS. apply ev_SS. apply ev_0. Qed. (** ... or we can use function application syntax: *) Theorem ev_4' : ev 4. Proof. apply (ev_SS 2 (ev_SS 0 ev_0)). Qed. (** We can also prove theorems that have hypotheses involving [ev]. *) Theorem ev_plus4 : forall n, ev n -> ev (4 + n). Proof. intros n. simpl. intros Hn. apply ev_SS. apply ev_SS. apply Hn. Qed. (** More generally, we can show that any number multiplied by 2 is even: *) (** **** Exercise: 1 star (ev_double) *) Theorem ev_double : forall n, ev (double n). Proof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Using Evidence in Proofs *) (** Besides _constructing_ evidence that numbers are even, we can also _reason about_ such evidence. Introducing [ev] with an [Inductive] declaration tells Coq not only that the constructors [ev_0] and [ev_SS] are valid ways to build evidence that some number is even, but also that these two constructors are the _only_ ways to build evidence that numbers are even (in the sense of [ev]). *) (** In other words, if someone gives us evidence [E] for the assertion [ev n], then we know that [E] must have one of two shapes: - [E] is [ev_0] (and [n] is [O]), or - [E] is [ev_SS n' E'] (and [n] is [S (S n')], where [E'] is evidence for [ev n']). *) (** This suggests that it should be possible to analyze a hypothesis of the form [ev n] much as we do inductively defined data structures; in particular, it should be possible to argue by _induction_ and _case analysis_ on such evidence. Let's look at a few examples to see what this means in practice. *) (* ================================================================= *) (** ** Inversion on Evidence *) (** Suppose we are proving some fact involving a number [n], and we are given [ev n] as a hypothesis. We already know how to perform case analysis on [n] using the [inversion] tactic, generating separate subgoals for the case where [n = O] and the case where [n = S n'] for some [n']. But for some proofs we may instead want to analyze the evidence that [ev n] _directly_. By the definition of [ev], there are two cases to consider: - If the evidence is of the form [ev_0], we know that [n = 0]. - Otherwise, the evidence must have the form [ev_SS n' E'], where [n = S (S n')] and [E'] is evidence for [ev n']. *) (** We can perform this kind of reasoning in Coq, again using the [inversion] tactic. Besides allowing us to reason about equalities involving constructors, [inversion] provides a case-analysis principle for inductively defined propositions. When used in this way, its syntax is similar to [destruct]: We pass it a list of identifiers separated by [|] characters to name the arguments to each of the possible constructors. *) Theorem ev_minus2 : forall n, ev n -> ev (pred (pred n)). Proof. intros n E. inversion E as [| n' E']. - (* E = ev_0 *) simpl. apply ev_0. - (* E = ev_SS n' E' *) simpl. apply E'. Qed. (** In words, here is how the inversion reasoning works in this proof: - If the evidence is of the form [ev_0], we know that [n = 0]. Therefore, it suffices to show that [ev (pred (pred 0))] holds. By the definition of [pred], this is equivalent to showing that [ev 0] holds, which directly follows from [ev_0]. - Otherwise, the evidence must have the form [ev_SS n' E'], where [n = S (S n')] and [E'] is evidence for [ev n']. We must then show that [ev (pred (pred (S (S n'))))] holds, which, after simplification, follows directly from [E']. *) (** This particular proof also works if we replace [inversion] by [destruct]: *) Theorem ev_minus2' : forall n, ev n -> ev (pred (pred n)). Proof. intros n E. destruct E as [| n' E']. - (* E = ev_0 *) simpl. apply ev_0. - (* E = ev_SS n' E' *) simpl. apply E'. Qed. (** The difference between the two forms is that [inversion] is more convenient when used on a hypothesis that consists of an inductive property applied to a complex expression (as opposed to a single variable). Here's is a concrete example. Suppose that we wanted to prove the following variation of [ev_minus2]: *) Theorem evSS_ev : forall n, ev (S (S n)) -> ev n. (** Intuitively, we know that evidence for the hypothesis cannot consist just of the [ev_0] constructor, since [O] and [S] are different constructors of the type [nat]; hence, [ev_SS] is the only case that applies. Unfortunately, [destruct] is not smart enough to realize this, and it still generates two subgoals. Even worse, in doing so, it keeps the final goal unchanged, failing to provide any useful information for completing the proof. *) Proof. intros n E. destruct E as [| n' E']. - (* E = ev_0. *) (* We must prove that [n] is even from no assumptions! *) Abort. (** What happened, exactly? Calling [destruct] has the effect of replacing all occurrences of the property argument by the values that correspond to each constructor. This is enough in the case of [ev_minus2'] because that argument, [n], is mentioned directly in the final goal. However, it doesn't help in the case of [evSS_ev] since the term that gets replaced ([S (S n)]) is not mentioned anywhere. *) (** The [inversion] tactic, on the other hand, can detect (1) that the first case does not apply, and (2) that the [n'] that appears on the [ev_SS] case must be the same as [n]. This allows us to complete the proof: *) Theorem evSS_ev : forall n, ev (S (S n)) -> ev n. Proof. intros n E. inversion E as [| n' E']. (* We are in the [E = ev_SS n' E'] case now. *) apply E'. Qed. (** By using [inversion], we can also apply the principle of explosion to "obviously contradictory" hypotheses involving inductive properties. For example: *) Theorem one_not_even : ~ ev 1. Proof. intros H. inversion H. Qed. (** **** Exercise: 1 star (inversion_practice) *) (** Prove the following results using [inversion]. *) Theorem SSSSev__even : forall n, ev (S (S (S (S n)))) -> ev n. Proof. (* FILL IN HERE *) Admitted. Theorem even5_nonsense : ev 5 -> 2 + 2 = 9. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** The way we've used [inversion] here may seem a bit mysterious at first. Until now, we've only used [inversion] on equality propositions, to utilize injectivity of constructors or to discriminate between different constructors. But we see here that [inversion] can also be applied to analyzing evidence for inductively defined propositions. Here's how [inversion] works in general. Suppose the name [I] refers to an assumption [P] in the current context, where [P] has been defined by an [Inductive] declaration. Then, for each of the constructors of [P], [inversion I] generates a subgoal in which [I] has been replaced by the exact, specific conditions under which this constructor could have been used to prove [P]. Some of these subgoals will be self-contradictory; [inversion] throws these away. The ones that are left represent the cases that must be proved to establish the original goal. For those, [inversion] adds all equations into the proof context that must hold of the arguments given to [P] (e.g., [S (S n') = n] in the proof of [evSS_ev]). *) (** The [ev_double] exercise above shows that our new notion of evenness is implied by the two earlier ones (since, by [even_bool_prop] in chapter [Logic], we already know that those are equivalent to each other). To show that all three coincide, we just need the following lemma: *) Lemma ev_even_firsttry : forall n, ev n -> exists k, n = double k. Proof. (* WORKED IN CLASS *) (** We could try to proceed by case analysis or induction on [n]. But since [ev] is mentioned in a premise, this strategy would probably lead to a dead end, as in the previous section. Thus, it seems better to first try inversion on the evidence for [ev]. Indeed, the first case can be solved trivially. *) intros n E. inversion E as [| n' E']. - (* E = ev_0 *) exists 0. reflexivity. - (* E = ev_SS n' E' *) simpl. (** Unfortunately, the second case is harder. We need to show [exists k, S (S n') = double k], but the only available assumption is [E'], which states that [ev n'] holds. Since this isn't directly useful, it seems that we are stuck and that performing case analysis on [E] was a waste of time. If we look more closely at our second goal, however, we can see that something interesting happened: By performing case analysis on [E], we were able to reduce the original result to an similar one that involves a _different_ piece of evidence for [ev]: [E']. More formally, we can finish our proof by showing that exists k', n' = double k', which is the same as the original statement, but with [n'] instead of [n]. Indeed, it is not difficult to convince Coq that this intermediate result suffices. *) assert (I : (exists k', n' = double k') -> (exists k, S (S n') = double k)). { intros [k' Hk']. rewrite Hk'. exists (S k'). reflexivity. } apply I. (* reduce the original goal to the new one *) Admitted. (* ================================================================= *) (** ** Induction on Evidence *) (** If this looks familiar, it is no coincidence: We've encountered similar problems in the [Induction] chapter, when trying to use case analysis to prove results that required induction. And once again the solution is... induction! The behavior of [induction] on evidence is the same as its behavior on data: It causes Coq to generate one subgoal for each constructor that could have used to build that evidence, while providing an induction hypotheses for each recursive occurrence of the property in question. *) (** Let's try our current lemma again: *) Lemma ev_even : forall n, ev n -> exists k, n = double k. Proof. intros n E. induction E as [|n' E' IH]. - (* E = ev_0 *) exists 0. reflexivity. - (* E = ev_SS n' E' with IH : exists k', n' = double k' *) destruct IH as [k' Hk']. rewrite Hk'. exists (S k'). reflexivity. Qed. (** Here, we can see that Coq produced an [IH] that corresponds to [E'], the single recursive occurrence of [ev] in its own definition. Since [E'] mentions [n'], the induction hypothesis talks about [n'], as opposed to [n] or some other number. *) (** The equivalence between the second and third definitions of evenness now follows. *) Theorem ev_even_iff : forall n, ev n <-> exists k, n = double k. Proof. intros n. split. - (* -> *) apply ev_even. - (* <- *) intros [k Hk]. rewrite Hk. apply ev_double. Qed. (** As we will see in later chapters, induction on evidence is a recurring technique across many areas, and in particular when formalizing the semantics of programming languages, where many properties of interest are defined inductively. *) (** The following exercises provide simple examples of this technique, to help you familiarize yourself with it. *) (** **** Exercise: 2 stars (ev_sum) *) Theorem ev_sum : forall n m, ev n -> ev m -> ev (n + m). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 4 stars, advanced, optional (ev_alternate) *) (** In general, there may be multiple ways of defining a property inductively. For example, here's a (slightly contrived) alternative definition for [ev]: *) Inductive ev' : nat -> Prop := | ev'_0 : ev' 0 | ev'_2 : ev' 2 | ev'_sum : forall n m, ev' n -> ev' m -> ev' (n + m). (** Prove that this definition is logically equivalent to the old one. (You may want to look at the previous theorem when you get to the induction step.) *) Theorem ev'_ev : forall n, ev' n <-> ev n. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, advanced, recommended (ev_ev__ev) *) (** Finding the appropriate thing to do induction on is a bit tricky here: *) Theorem ev_ev__ev : forall n m, ev (n+m) -> ev n -> ev m. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, optional (ev_plus_plus) *) (** This exercise just requires applying existing lemmas. No induction or even case analysis is needed, though some of the rewriting may be tedious. *) Theorem ev_plus_plus : forall n m p, ev (n+m) -> ev (n+p) -> ev (m+p). Proof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Inductive Relations *) (** A proposition parameterized by a number (such as [ev]) can be thought of as a _property_ -- i.e., it defines a subset of [nat], namely those numbers for which the proposition is provable. In the same way, a two-argument proposition can be thought of as a _relation_ -- i.e., it defines a set of pairs for which the proposition is provable. *) Module Playground. (** One useful example is the "less than or equal to" relation on numbers. *) (** The following definition should be fairly intuitive. It says that there are two ways to give evidence that one number is less than or equal to another: either observe that they are the same number, or give evidence that the first is less than or equal to the predecessor of the second. *) Inductive le : nat -> nat -> Prop := | le_n : forall n, le n n | le_S : forall n m, (le n m) -> (le n (S m)). Notation "m <= n" := (le m n). (** Proofs of facts about [<=] using the constructors [le_n] and [le_S] follow the same patterns as proofs about properties, like [ev] above. We can [apply] the constructors to prove [<=] goals (e.g., to show that [3<=3] or [3<=6]), and we can use tactics like [inversion] to extract information from [<=] hypotheses in the context (e.g., to prove that [(2 <= 1) -> 2+2=5].) *) (** Here are some sanity checks on the definition. (Notice that, although these are the same kind of simple "unit tests" as we gave for the testing functions we wrote in the first few lectures, we must construct their proofs explicitly -- [simpl] and [reflexivity] don't do the job, because the proofs aren't just a matter of simplifying computations.) *) Theorem test_le1 : 3 <= 3. Proof. (* WORKED IN CLASS *) apply le_n. Qed. Theorem test_le2 : 3 <= 6. Proof. (* WORKED IN CLASS *) apply le_S. apply le_S. apply le_S. apply le_n. Qed. Theorem test_le3 : (2 <= 1) -> 2 + 2 = 5. Proof. (* WORKED IN CLASS *) intros H. inversion H. inversion H2. Qed. (** The "strictly less than" relation [n < m] can now be defined in terms of [le]. *) End Playground. Definition lt (n m:nat) := le (S n) m. Notation "m < n" := (lt m n). (** Here are a few more simple relations on numbers: *) Inductive square_of : nat -> nat -> Prop := | sq : forall n:nat, square_of n (n * n). Inductive next_nat : nat -> nat -> Prop := | nn : forall n:nat, next_nat n (S n). Inductive next_even : nat -> nat -> Prop := | ne_1 : forall n, ev (S n) -> next_even n (S n) | ne_2 : forall n, ev (S (S n)) -> next_even n (S (S n)). (** **** Exercise: 2 stars, optional (total_relation) *) (** Define an inductive binary relation [total_relation] that holds between every pair of natural numbers. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 2 stars, optional (empty_relation) *) (** Define an inductive binary relation [empty_relation] (on numbers) that never holds. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 3 stars, optional (le_exercises) *) (** Here are a number of facts about the [<=] and [<] relations that we are going to need later in the course. The proofs make good practice exercises. *) Lemma le_trans : forall m n o, m <= n -> n <= o -> m <= o. Proof. (* FILL IN HERE *) Admitted. Theorem O_le_n : forall n, 0 <= n. Proof. (* FILL IN HERE *) Admitted. Theorem n_le_m__Sn_le_Sm : forall n m, n <= m -> S n <= S m. Proof. (* FILL IN HERE *) Admitted. Theorem Sn_le_Sm__n_le_m : forall n m, S n <= S m -> n <= m. Proof. (* FILL IN HERE *) Admitted. Theorem le_plus_l : forall a b, a <= a + b. Proof. (* FILL IN HERE *) Admitted. Theorem plus_lt : forall n1 n2 m, n1 + n2 < m -> n1 < m /\ n2 < m. Proof. unfold lt. (* FILL IN HERE *) Admitted. Theorem lt_S : forall n m, n < m -> n < S m. Proof. (* FILL IN HERE *) Admitted. Theorem leb_complete : forall n m, leb n m = true -> n <= m. Proof. (* FILL IN HERE *) Admitted. (** Hint: The next one may be easiest to prove by induction on [m]. *) Theorem leb_correct : forall n m, n <= m -> leb n m = true. Proof. (* FILL IN HERE *) Admitted. (** Hint: This theorem can easily be proved without using [induction]. *) Theorem leb_true_trans : forall n m o, leb n m = true -> leb m o = true -> leb n o = true. Proof. (* FILL IN HERE *) Admitted. (** **** Exercise: 2 stars, optional (leb_iff) *) Theorem leb_iff : forall n m, leb n m = true <-> n <= m. Proof. (* FILL IN HERE *) Admitted. (** [] *) Module R. (** **** Exercise: 3 stars, recommendedM (R_provability) *) (** We can define three-place relations, four-place relations, etc., in just the same way as binary relations. For example, consider the following three-place relation on numbers: *) Inductive R : nat -> nat -> nat -> Prop := | c1 : R 0 0 0 | c2 : forall m n o, R m n o -> R (S m) n (S o) | c3 : forall m n o, R m n o -> R m (S n) (S o) | c4 : forall m n o, R (S m) (S n) (S (S o)) -> R m n o | c5 : forall m n o, R m n o -> R n m o. (** - Which of the following propositions are provable? - [R 1 1 2] - [R 2 2 6] - If we dropped constructor [c5] from the definition of [R], would the set of provable propositions change? Briefly (1 sentence) explain your answer. - If we dropped constructor [c4] from the definition of [R], would the set of provable propositions change? Briefly (1 sentence) explain your answer. (* FILL IN HERE *) [] *) (** **** Exercise: 3 stars, optional (R_fact) *) (** The relation [R] above actually encodes a familiar function. Figure out which function; then state and prove this equivalence in Coq? *) Definition fR : nat -> nat -> nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Theorem R_equiv_fR : forall m n o, R m n o <-> fR m n = o. Proof. (* FILL IN HERE *) Admitted. (** [] *) End R. (** **** Exercise: 4 stars, advanced (subsequence) *) (** A list is a _subsequence_ of another list if all of the elements in the first list occur in the same order in the second list, possibly with some extra elements in between. For example, [1;2;3] is a subsequence of each of the lists [1;2;3] [1;1;1;2;2;3] [1;2;7;3] [5;6;1;9;9;2;7;3;8] but it is _not_ a subsequence of any of the lists [1;2] [1;3] [5;6;2;1;7;3;8]. - Define an inductive proposition [subseq] on [list nat] that captures what it means to be a subsequence. (Hint: You'll need three cases.) - Prove [subseq_refl] that subsequence is reflexive, that is, any list is a subsequence of itself. - Prove [subseq_app] that for any lists [l1], [l2], and [l3], if [l1] is a subsequence of [l2], then [l1] is also a subsequence of [l2 ++ l3]. - (Optional, harder) Prove [subseq_trans] that subsequence is transitive -- that is, if [l1] is a subsequence of [l2] and [l2] is a subsequence of [l3], then [l1] is a subsequence of [l3]. Hint: choose your induction carefully! *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 2 stars, optionalM (R_provability2) *) (** Suppose we give Coq the following definition: Inductive R : nat -> list nat -> Prop := | c1 : R 0 [] | c2 : forall n l, R n l -> R (S n) (n :: l) | c3 : forall n l, R (S n) l -> R n l. Which of the following propositions are provable? - [R 2 [1;0]] - [R 1 [1;2;1;0]] - [R 6 [3;2;1;0]] *) (** [] *) (* ################################################################# *) (** * Case Study: Regular Expressions *) (** The [ev] property provides a simple example for illustrating inductive definitions and the basic techniques for reasoning about them, but it is not terribly exciting -- after all, it is equivalent to the two non-inductive of evenness that we had already seen, and does not seem to offer any concrete benefit over them. To give a better sense of the power of inductive definitions, we now show how to use them to model a classic concept in computer science: _regular expressions_. *) (** Regular expressions are a simple language for describing strings, defined as follows: *) Inductive reg_exp (T : Type) : Type := | EmptySet : reg_exp T | EmptyStr : reg_exp T | Char : T -> reg_exp T | App : reg_exp T -> reg_exp T -> reg_exp T | Union : reg_exp T -> reg_exp T -> reg_exp T | Star : reg_exp T -> reg_exp T. Arguments EmptySet {T}. Arguments EmptyStr {T}. Arguments Char {T} _. Arguments App {T} _ _. Arguments Union {T} _ _. Arguments Star {T} _. (** Note that this definition is _polymorphic_: Regular expressions in [reg_exp T] describe strings with characters drawn from [T] -- that is, lists of elements of [T]. (We depart slightly from standard practice in that we do not require the type [T] to be finite. This results in a somewhat different theory of regular expressions, but the difference is not significant for our purposes.) *) (** We connect regular expressions and strings via the following rules, which define when a regular expression _matches_ some string: - The expression [EmptySet] does not match any string. - The expression [EmptyStr] matches the empty string [[]]. - The expression [Char x] matches the one-character string [[x]]. - If [re1] matches [s1], and [re2] matches [s2], then [App re1 re2] matches [s1 ++ s2]. - If at least one of [re1] and [re2] matches [s], then [Union re1 re2] matches [s]. - Finally, if we can write some string [s] as the concatenation of a sequence of strings [s = s_1 ++ ... ++ s_k], and the expression [re] matches each one of the strings [s_i], then [Star re] matches [s]. As a special case, the sequence of strings may be empty, so [Star re] always matches the empty string [[]] no matter what [re] is. We can easily translate this informal definition into an [Inductive] one as follows: *) Inductive exp_match {T} : list T -> reg_exp T -> Prop := | MEmpty : exp_match [] EmptyStr | MChar : forall x, exp_match [x] (Char x) | MApp : forall s1 re1 s2 re2, exp_match s1 re1 -> exp_match s2 re2 -> exp_match (s1 ++ s2) (App re1 re2) | MUnionL : forall s1 re1 re2, exp_match s1 re1 -> exp_match s1 (Union re1 re2) | MUnionR : forall re1 s2 re2, exp_match s2 re2 -> exp_match s2 (Union re1 re2) | MStar0 : forall re, exp_match [] (Star re) | MStarApp : forall s1 s2 re, exp_match s1 re -> exp_match s2 (Star re) -> exp_match (s1 ++ s2) (Star re). (** Again, for readability, we can also display this definition using inference-rule notation. At the same time, let's introduce a more readable infix notation. *) Notation "s =~ re" := (exp_match s re) (at level 80). (** ---------------- (MEmpty) [] =~ EmptyStr --------------- (MChar) [x] =~ Char x s1 =~ re1 s2 =~ re2 ------------------------- (MApp) s1 ++ s2 =~ App re1 re2 s1 =~ re1 --------------------- (MUnionL) s1 =~ Union re1 re2 s2 =~ re2 --------------------- (MUnionR) s2 =~ Union re1 re2 --------------- (MStar0) [] =~ Star re s1 =~ re s2 =~ Star re --------------------------- (MStarApp) s1 ++ s2 =~ Star re *) (** Notice that these rules are not _quite_ the same as the informal ones that we gave at the beginning of the section. First, we don't need to include a rule explicitly stating that no string matches [EmptySet]; we just don't happen to include any rule that would have the effect of some string matching [EmptySet]. (Indeed, the syntax of inductive definitions doesn't even _allow_ us to give such a "negative rule.") Second, the informal rules for [Union] and [Star] correspond to two constructors each: [MUnionL] / [MUnionR], and [MStar0] / [MStarApp]. The result is logically equivalent to the original rules but more convenient to use in Coq, since the recursive occurrences of [exp_match] are given as direct arguments to the constructors, making it easier to perform induction on evidence. (The [exp_match_ex1] and [exp_match_ex2] exercises below ask you to prove that the constructors given in the inductive declaration and the ones that would arise from a more literal transcription of the informal rules are indeed equivalent.) Let's illustrate these rules with a few examples. *) Example reg_exp_ex1 : [1] =~ Char 1. Proof. apply MChar. Qed. Example reg_exp_ex2 : [1; 2] =~ App (Char 1) (Char 2). Proof. apply (MApp [1] _ [2]). - apply MChar. - apply MChar. Qed. (** (Notice how the last example applies [MApp] to the strings [[1]] and [[2]] directly. Since the goal mentions [[1; 2]] instead of [[1] ++ [2]], Coq wouldn't be able to figure out how to split the string on its own.) Using [inversion], we can also show that certain strings do _not_ match a regular expression: *) Example reg_exp_ex3 : ~ ([1; 2] =~ Char 1). Proof. intros H. inversion H. Qed. (** We can define helper functions to help write down regular expressions. The [reg_exp_of_list] function constructs a regular expression that matches exactly the list that it receives as an argument: *) Fixpoint reg_exp_of_list {T} (l : list T) := match l with | [] => EmptyStr | x :: l' => App (Char x) (reg_exp_of_list l') end. Example reg_exp_ex4 : [1; 2; 3] =~ reg_exp_of_list [1; 2; 3]. Proof. simpl. apply (MApp [1]). { apply MChar. } apply (MApp [2]). { apply MChar. } apply (MApp [3]). { apply MChar. } apply MEmpty. Qed. (** We can also prove general facts about [exp_match]. For instance, the following lemma shows that every string [s] that matches [re] also matches [Star re]. *) Lemma MStar1 : forall T s (re : reg_exp T) , s =~ re -> s =~ Star re. Proof. intros T s re H. rewrite <- (app_nil_r _ s). apply (MStarApp s [] re). - apply H. - apply MStar0. Qed. (** (Note the use of [app_nil_r] to change the goal of the theorem to exactly the same shape expected by [MStarApp].) *) (** **** Exercise: 3 stars (exp_match_ex1) *) (** The following lemmas show that the informal matching rules given at the beginning of the chapter can be obtained from the formal inductive definition. *) Lemma empty_is_empty : forall T (s : list T), ~ (s =~ EmptySet). Proof. (* FILL IN HERE *) Admitted. Lemma MUnion' : forall T (s : list T) (re1 re2 : reg_exp T), s =~ re1 \/ s =~ re2 -> s =~ Union re1 re2. Proof. (* FILL IN HERE *) Admitted. (** The next lemma is stated in terms of the [fold] function from the [Poly] chapter: If [ss : list (list T)] represents a sequence of strings [s1, ..., sn], then [fold app ss []] is the result of concatenating them all together. *) Lemma MStar' : forall T (ss : list (list T)) (re : reg_exp T), (forall s, In s ss -> s =~ re) -> fold app ss [] =~ Star re. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 4 stars (reg_exp_of_list) *) (** Prove that [reg_exp_of_list] satisfies the following specification: *) Lemma reg_exp_of_list_spec : forall T (s1 s2 : list T), s1 =~ reg_exp_of_list s2 <-> s1 = s2. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** Since the definition of [exp_match] has a recursive structure, we might expect that proofs involving regular expressions will often require induction on evidence. For example, suppose that we wanted to prove the following intuitive result: If a regular expression [re] matches some string [s], then all elements of [s] must occur somewhere in [re]. To state this theorem, we first define a function [re_chars] that lists all characters that occur in a regular expression: *) Fixpoint re_chars {T} (re : reg_exp T) : list T := match re with | EmptySet => [] | EmptyStr => [] | Char x => [x] | App re1 re2 => re_chars re1 ++ re_chars re2 | Union re1 re2 => re_chars re1 ++ re_chars re2 | Star re => re_chars re end. (** We can then phrase our theorem as follows: *) Theorem in_re_match : forall T (s : list T) (re : reg_exp T) (x : T), s =~ re -> In x s -> In x (re_chars re). Proof. intros T s re x Hmatch Hin. induction Hmatch as [ |x' |s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2 |s1 re1 re2 Hmatch IH|re1 s2 re2 Hmatch IH |re|s1 s2 re Hmatch1 IH1 Hmatch2 IH2]. (* WORKED IN CLASS *) - (* MEmpty *) apply Hin. - (* MChar *) apply Hin. - simpl. rewrite in_app_iff in *. destruct Hin as [Hin | Hin]. + (* In x s1 *) left. apply (IH1 Hin). + (* In x s2 *) right. apply (IH2 Hin). - (* MUnionL *) simpl. rewrite in_app_iff. left. apply (IH Hin). - (* MUnionR *) simpl. rewrite in_app_iff. right. apply (IH Hin). - (* MStar0 *) destruct Hin. (** Something interesting happens in the [MStarApp] case. We obtain _two_ induction hypotheses: One that applies when [x] occurs in [s1] (which matches [re]), and a second one that applies when [x] occurs in [s2] (which matches [Star re]). This is a good illustration of why we need induction on evidence for [exp_match], as opposed to [re]: The latter would only provide an induction hypothesis for strings that match [re], which would not allow us to reason about the case [In x s2]. *) - (* MStarApp *) simpl. rewrite in_app_iff in Hin. destruct Hin as [Hin | Hin]. + (* In x s1 *) apply (IH1 Hin). + (* In x s2 *) apply (IH2 Hin). Qed. (** **** Exercise: 4 stars (re_not_empty) *) (** Write a recursive function [re_not_empty] that tests whether a regular expression matches some string. Prove that your function is correct. *) Fixpoint re_not_empty {T : Type} (re : reg_exp T) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Lemma re_not_empty_correct : forall T (re : reg_exp T), (exists s, s =~ re) <-> re_not_empty re = true. Proof. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** The [remember] Tactic *) (** One potentially confusing feature of the [induction] tactic is that it happily lets you try to set up an induction over a term that isn't sufficiently general. The effect of this is to lose information (much as [destruct] can do), and leave you unable to complete the proof. Here's an example: *) Lemma star_app: forall T (s1 s2 : list T) (re : reg_exp T), s1 =~ Star re -> s2 =~ Star re -> s1 ++ s2 =~ Star re. Proof. intros T s1 s2 re H1. (** Just doing an [inversion] on [H1] won't get us very far in the recursive cases. (Try it!). So we need induction. Here is a naive first attempt: *) induction H1 as [|x'|s1 re1 s2' re2 Hmatch1 IH1 Hmatch2 IH2 |s1 re1 re2 Hmatch IH|re1 s2' re2 Hmatch IH |re''|s1 s2' re'' Hmatch1 IH1 Hmatch2 IH2]. (** But now, although we get seven cases (as we would expect from the definition of [exp_match]), we have lost a very important bit of information from [H1]: the fact that [s1] matched something of the form [Star re]. This means that we have to give proofs for _all_ seven constructors of this definition, even though all but two of them ([MStar0] and [MStarApp]) are contradictory. We can still get the proof to go through for a few constructors, such as [MEmpty]... *) - (* MEmpty *) simpl. intros H. apply H. (** ... but most cases get stuck. For [MChar], for instance, we must show that s2 =~ Char x' -> x' :: s2 =~ Char x', which is clearly impossible. *) - (* MChar. Stuck... *) Abort. (** The problem is that [induction] over a Prop hypothesis only works properly with hypotheses that are completely general, i.e., ones in which all the arguments are variables, as opposed to more complex expressions, such as [Star re]. (In this respect, [induction] on evidence behaves more like [destruct] than like [inversion].) We can solve this problem by generalizing over the problematic expressions with an explicit equality: *) Lemma star_app: forall T (s1 s2 : list T) (re re' : reg_exp T), s1 =~ re' -> re' = Star re -> s2 =~ Star re -> s1 ++ s2 =~ Star re. (** We can now proceed by performing induction over evidence directly, because the argument to the first hypothesis is sufficiently general, which means that we can discharge most cases by inverting the [re' = Star re] equality in the context. This idiom is so common that Coq provides a tactic to automatically generate such equations for us, avoiding thus the need for changing the statements of our theorems. *) (** Invoking the tactic [remember e as x] causes Coq to (1) replace all occurrences of the expression [e] by the variable [x], and (2) add an equation [x = e] to the context. Here's how we can use it to show the above result: *) Abort. Lemma star_app: forall T (s1 s2 : list T) (re : reg_exp T), s1 =~ Star re -> s2 =~ Star re -> s1 ++ s2 =~ Star re. Proof. intros T s1 s2 re H1. remember (Star re) as re'. (** We now have [Heqre' : re' = Star re]. *) generalize dependent s2. induction H1 as [|x'|s1 re1 s2' re2 Hmatch1 IH1 Hmatch2 IH2 |s1 re1 re2 Hmatch IH|re1 s2' re2 Hmatch IH |re''|s1 s2' re'' Hmatch1 IH1 Hmatch2 IH2]. (** The [Heqre'] is contradictory in most cases, which allows us to conclude immediately. *) - (* MEmpty *) inversion Heqre'. - (* MChar *) inversion Heqre'. - (* MApp *) inversion Heqre'. - (* MUnionL *) inversion Heqre'. - (* MUnionR *) inversion Heqre'. (** The interesting cases are those that correspond to [Star]. Note that the induction hypothesis [IH2] on the [MStarApp] case mentions an additional premise [Star re'' = Star re'], which results from the equality generated by [remember]. *) - (* MStar0 *) inversion Heqre'. intros s H. apply H. - (* MStarApp *) inversion Heqre'. rewrite H0 in IH2, Hmatch1. intros s2 H1. rewrite <- app_assoc. apply MStarApp. + apply Hmatch1. + apply IH2. * reflexivity. * apply H1. Qed. (** **** Exercise: 4 stars (exp_match_ex2) *) (** The [MStar''] lemma below (combined with its converse, the [MStar'] exercise above), shows that our definition of [exp_match] for [Star] is equivalent to the informal one given previously. *) Lemma MStar'' : forall T (s : list T) (re : reg_exp T), s =~ Star re -> exists ss : list (list T), s = fold app ss [] /\ forall s', In s' ss -> s' =~ re. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 5 stars, advanced (pumping) *) (** One of the first really interesting theorems in the theory of regular expressions is the so-called _pumping lemma_, which states, informally, that any sufficiently long string [s] matching a regular expression [re] can be "pumped" by repeating some middle section of [s] an arbitrary number of times to produce a new string also matching [re]. To begin, we need to define "sufficiently long." Since we are working in a constructive logic, we actually need to be able to calculate, for each regular expression [re], the minimum length for strings [s] to guarantee "pumpability." *) Module Pumping. Fixpoint pumping_constant {T} (re : reg_exp T) : nat := match re with | EmptySet => 0 | EmptyStr => 1 | Char _ => 2 | App re1 re2 => pumping_constant re1 + pumping_constant re2 | Union re1 re2 => pumping_constant re1 + pumping_constant re2 | Star _ => 1 end. (** Next, it is useful to define an auxiliary function that repeats a string (appends it to itself) some number of times. *) Fixpoint napp {T} (n : nat) (l : list T) : list T := match n with | 0 => [] | S n' => l ++ napp n' l end. Lemma napp_plus: forall T (n m : nat) (l : list T), napp (n + m) l = napp n l ++ napp m l. Proof. intros T n m l. induction n as [|n IHn]. - reflexivity. - simpl. rewrite IHn, app_assoc. reflexivity. Qed. (** Now, the pumping lemma itself says that, if [s =~ re] and if the length of [s] is at least the pumping constant of [re], then [s] can be split into three substrings [s1 ++ s2 ++ s3] in such a way that [s2] can be repeated any number of times and the result, when combined with [s1] and [s3] will still match [re]. Since [s2] is also guaranteed not to be the empty string, this gives us a (constructive!) way to generate strings matching [re] that are as long as we like. *) Lemma pumping : forall T (re : reg_exp T) s, s =~ re -> pumping_constant re <= length s -> exists s1 s2 s3, s = s1 ++ s2 ++ s3 /\ s2 <> [] /\ forall m, s1 ++ napp m s2 ++ s3 =~ re. (** To streamline the proof (which you are to fill in), the [omega] tactic, which is enabled by the following [Require], is helpful in several places for automatically completing tedious low-level arguments involving equalities or inequalities over natural numbers. We'll return to [omega] in a later chapter, but feel free to experiment with it now if you like. The first case of the induction gives an example of how it is used. *) Import Coq.omega.Omega. Proof. intros T re s Hmatch. induction Hmatch as [ | x | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2 | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2 ]. - (* MEmpty *) simpl. omega. (* FILL IN HERE *) Admitted. End Pumping. (** [] *) (* ################################################################# *) (** * Case Study: Improving Reflection *) (** We've seen in the [Logic] chapter that we often need to relate boolean computations to statements in [Prop]. But performing this conversion in the way we did it there can result in tedious proof scripts. Consider the proof of the following theorem: *) Theorem filter_not_empty_In : forall n l, filter (beq_nat n) l <> [] -> In n l. Proof. intros n l. induction l as [|m l' IHl']. - (* l = [] *) simpl. intros H. apply H. reflexivity. - (* l = m :: l' *) simpl. destruct (beq_nat n m) eqn:H. + (* beq_nat n m = true *) intros _. rewrite beq_nat_true_iff in H. rewrite H. left. reflexivity. + (* beq_nat n m = false *) intros H'. right. apply IHl'. apply H'. Qed. (** In the first branch after [destruct], we explicitly apply the [beq_nat_true_iff] lemma to the equation generated by destructing [beq_nat n m], to convert the assumption [beq_nat n m = true] into the assumption [n = m]; then we had to [rewrite] using this assumption to complete the case. We can streamline this by defining an inductive proposition that yields a better case-analysis principle for [beq_nat n m]. Instead of generating an equation such as [beq_nat n m = true], which is generally not directly useful, this principle gives us right away the assumption we really need: [n = m]. We'll actually define something a bit more general, which can be used with arbitrary properties (and not just equalities): *) Module FirstTry. Inductive reflect : Prop -> bool -> Prop := | ReflectT : forall (P:Prop), P -> reflect P true | ReflectF : forall (P:Prop), ~ P -> reflect P false. (** Before explaining this, let's rearrange it a little: Since the types of both [ReflectT] and [ReflectF] begin with [forall (P:Prop)], we can make the definition a bit more readable and easier to work with by making [P] a parameter of the whole Inductive declaration. *) End FirstTry. Inductive reflect (P : Prop) : bool -> Prop := | ReflectT : P -> reflect P true | ReflectF : ~ P -> reflect P false. (** The [reflect] property takes two arguments: a proposition [P] and a boolean [b]. Intuitively, it states that the property [P] is _reflected_ in (i.e., equivalent to) the boolean [b]: [P] holds if and only if [b = true]. To see this, notice that, by definition, the only way we can produce evidence that [reflect P true] holds is by showing that [P] is true and using the [ReflectT] constructor. If we invert this statement, this means that it should be possible to extract evidence for [P] from a proof of [reflect P true]. Conversely, the only way to show [reflect P false] is by combining evidence for [~ P] with the [ReflectF] constructor. It is easy to formalize this intuition and show that the two statements are indeed equivalent: *) Theorem iff_reflect : forall P b, (P <-> b = true) -> reflect P b. Proof. (* WORKED IN CLASS *) intros P b H. destruct b. - apply ReflectT. rewrite H. reflexivity. - apply ReflectF. rewrite H. intros H'. inversion H'. Qed. (** **** Exercise: 2 stars, recommended (reflect_iff) *) Theorem reflect_iff : forall P b, reflect P b -> (P <-> b = true). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** The advantage of [reflect] over the normal "if and only if" connective is that, by destructing a hypothesis or lemma of the form [reflect P b], we can perform case analysis on [b] while at the same time generating appropriate hypothesis in the two branches ([P] in the first subgoal and [~ P] in the second). *) Lemma beq_natP : forall n m, reflect (n = m) (beq_nat n m). Proof. intros n m. apply iff_reflect. rewrite beq_nat_true_iff. reflexivity. Qed. (** The new proof of [filter_not_empty_In] now goes as follows. Notice how the calls to [destruct] and [apply] are combined into a single call to [destruct]. *) (** (To see this clearly, look at the two proofs of [filter_not_empty_In] with Coq and observe the differences in proof state at the beginning of the first case of the [destruct].) *) Theorem filter_not_empty_In' : forall n l, filter (beq_nat n) l <> [] -> In n l. Proof. intros n l. induction l as [|m l' IHl']. - (* l = [] *) simpl. intros H. apply H. reflexivity. - (* l = m :: l' *) simpl. destruct (beq_natP n m) as [H | H]. + (* n = m *) intros _. rewrite H. left. reflexivity. + (* n <> m *) intros H'. right. apply IHl'. apply H'. Qed. (** **** Exercise: 3 stars, recommended (beq_natP_practice) *) (** Use [beq_natP] as above to prove the following: *) Fixpoint count n l := match l with | [] => 0 | m :: l' => (if beq_nat n m then 1 else 0) + count n l' end. Theorem beq_natP_practice : forall n l, count n l = 0 -> ~(In n l). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** This technique gives us only a small gain in convenience for the proofs we've seen here, but using [reflect] consistently often leads to noticeably shorter and clearer scripts as proofs get larger. We'll see many more examples in later chapters. The use of the [reflect] property was popularized by _SSReflect_, a Coq library that has been used to formalize important results in mathematics, including as the 4-color theorem and the Feit-Thompson theorem. The name SSReflect stands for _small-scale reflection_, i.e., the pervasive use of reflection to simplify small proof steps with boolean computations. *) (* ################################################################# *) (** * Additional Exercises *) (** **** Exercise: 3 stars, recommended (nostutter) *) (** Formulating inductive definitions of properties is an important skill you'll need in this course. Try to solve this exercise without any help at all. We say that a list "stutters" if it repeats the same element consecutively. The property "[nostutter mylist]" means that [mylist] does not stutter. Formulate an inductive definition for [nostutter]. (This is different from the [NoDup] property in the exercise above; the sequence [1;4;1] repeats but does not stutter.) *) Inductive nostutter {X:Type} : list X -> Prop := (* FILL IN HERE *) . (** Make sure each of these tests succeeds, but feel free to change the suggested proof (in comments) if the given one doesn't work for you. Your definition might be different from ours and still be correct, in which case the examples might need a different proof. (You'll notice that the suggested proofs use a number of tactics we haven't talked about, to make them more robust to different possible ways of defining [nostutter]. You can probably just uncomment and use them as-is, but you can also prove each example with more basic tactics.) *) Example test_nostutter_1: nostutter [3;1;4;1;5;6]. (* FILL IN HERE *) Admitted. (* Proof. repeat constructor; apply beq_nat_false_iff; auto. Qed. *) Example test_nostutter_2: nostutter (@nil nat). (* FILL IN HERE *) Admitted. (* Proof. repeat constructor; apply beq_nat_false_iff; auto. Qed. *) Example test_nostutter_3: nostutter [5]. (* FILL IN HERE *) Admitted. (* Proof. repeat constructor; apply beq_nat_false; auto. Qed. *) Example test_nostutter_4: not (nostutter [3;1;1;4]). (* FILL IN HERE *) Admitted. (* Proof. intro. repeat match goal with h: nostutter _ |- _ => inversion h; clear h; subst end. contradiction H1; auto. Qed. *) (** [] *) (** **** Exercise: 4 stars, advanced (filter_challenge) *) (** Let's prove that our definition of [filter] from the [Poly] chapter matches an abstract specification. Here is the specification, written out informally in English: A list [l] is an "in-order merge" of [l1] and [l2] if it contains all the same elements as [l1] and [l2], in the same order as [l1] and [l2], but possibly interleaved. For example, [1;4;6;2;3] is an in-order merge of [1;6;2] and [4;3]. Now, suppose we have a set [X], a function [test: X->bool], and a list [l] of type [list X]. Suppose further that [l] is an in-order merge of two lists, [l1] and [l2], such that every item in [l1] satisfies [test] and no item in [l2] satisfies test. Then [filter test l = l1]. Translate this specification into a Coq theorem and prove it. (You'll need to begin by defining what it means for one list to be a merge of two others. Do this with an inductive relation, not a [Fixpoint].) *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 5 stars, advanced, optional (filter_challenge_2) *) (** A different way to characterize the behavior of [filter] goes like this: Among all subsequences of [l] with the property that [test] evaluates to [true] on all their members, [filter test l] is the longest. Formalize this claim and prove it. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 4 stars, optional (palindromes) *) (** A palindrome is a sequence that reads the same backwards as forwards. - Define an inductive proposition [pal] on [list X] that captures what it means to be a palindrome. (Hint: You'll need three cases. Your definition should be based on the structure of the list; just having a single constructor like c : forall l, l = rev l -> pal l may seem obvious, but will not work very well.) - Prove ([pal_app_rev]) that forall l, pal (l ++ rev l). - Prove ([pal_rev] that) forall l, pal l -> l = rev l. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 5 stars, optional (palindrome_converse) *) (** Again, the converse direction is significantly more difficult, due to the lack of evidence. Using your definition of [pal] from the previous exercise, prove that forall l, l = rev l -> pal l. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 4 stars, advanced, optional (NoDup) *) (** Recall the definition of the [In] property from the [Logic] chapter, which asserts that a value [x] appears at least once in a list [l]: *) (* Fixpoint In (A : Type) (x : A) (l : list A) : Prop := match l with | [] => False | x' :: l' => x' = x \/ In A x l' end *) (** Your first task is to use [In] to define a proposition [disjoint X l1 l2], which should be provable exactly when [l1] and [l2] are lists (with elements of type X) that have no elements in common. *) (* FILL IN HERE *) (** Next, use [In] to define an inductive proposition [NoDup X l], which should be provable exactly when [l] is a list (with elements of type [X]) where every member is different from every other. For example, [NoDup nat [1;2;3;4]] and [NoDup bool []] should be provable, while [NoDup nat [1;2;1]] and [NoDup bool [true;true]] should not be. *) (* FILL IN HERE *) (** Finally, state and prove one or more interesting theorems relating [disjoint], [NoDup] and [++] (list append). *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 4 stars, advanced, optional (pigeonhole principle) *) (** The _pigeonhole principle_ states a basic fact about counting: if we distribute more than [n] items into [n] pigeonholes, some pigeonhole must contain at least two items. As often happens, this apparently trivial fact about numbers requires non-trivial machinery to prove, but we now have enough... *) (** First prove an easy useful lemma. *) Lemma in_split : forall (X:Type) (x:X) (l:list X), In x l -> exists l1 l2, l = l1 ++ x :: l2. Proof. (* FILL IN HERE *) Admitted. (** Now define a property [repeats] such that [repeats X l] asserts that [l] contains at least one repeated element (of type [X]). *) Inductive repeats {X:Type} : list X -> Prop := (* FILL IN HERE *) . (** Now, here's a way to formalize the pigeonhole principle. Suppose list [l2] represents a list of pigeonhole labels, and list [l1] represents the labels assigned to a list of items. If there are more items than labels, at least two items must have the same label -- i.e., list [l1] must contain repeats. This proof is much easier if you use the [excluded_middle] hypothesis to show that [In] is decidable, i.e., [forall x l, (In x l) \/ ~ (In x l)]. However, it is also possible to make the proof go through _without_ assuming that [In] is decidable; if you manage to do this, you will not need the [excluded_middle] hypothesis. *) Theorem pigeonhole_principle: forall (X:Type) (l1 l2:list X), excluded_middle -> (forall x, In x l1 -> In x l2) -> length l2 < length l1 -> repeats l1. Proof. intros X l1. induction l1 as [|x l1' IHl1']. (* FILL IN HERE *) Admitted. (** [] *) (** $Date: 2017-04-26 17:33:43 -0400 (Wed, 26 Apr 2017) $ *) QuickChick-2.1.0/sf-experiment/Induction.v000066400000000000000000000006451476030541200204500ustar00rootroot00000000000000(** * Induction: Proof by Induction *) Require Export Basics. From QuickChick Require Import QuickChick. Import QcDefaultNotation. Open Scope qc_scope. Import GenLow GenHigh. Require Import List ZArith. Import ListNotations. (* Require Import mathcomp.ssreflect.ssreflect. From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype. *) Definition plus_n_O (n:nat) := n =? n + 0. (*! QuickChick plus_n_O. *) QuickChick-2.1.0/sf-experiment/Lists.v000066400000000000000000000173661476030541200176220ustar00rootroot00000000000000(** * Lists: Working with Structured Data *) From QuickChick Require Import QuickChick. Import QcDefaultNotation. Open Scope qc_scope. Import GenLow GenHigh. Require Import List ZArith. Import ListNotations. (* Require Import mathcomp.ssreflect.ssreflect. From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype. *) Require Export Induction. Module NatList. Inductive natprod : Type := | pair : nat -> nat -> natprod. Derive Arbitrary for natprod. Derive Show for natprod. Instance natprod_eq (x y : natprod) : Dec (x = y). constructor. unfold ssrbool.decidable. repeat (decide equality). Defined. Definition fst (p : natprod) : nat := match p with | pair x y => x end. Definition snd (p : natprod) : nat := match p with | pair x y => y end. Notation "( x , y )" := (pair x y). Definition swap_pair (p : natprod) : natprod := match p with | (x,y) => (y,x) end. (* BCP: boring! *) Definition equal_pair (p : natprod) (q : natprod) : bool := match p,q with | (p1,p2),(q1,q2) => andb (p1 =? q1) (p2 =? q2) end. Definition surjective_pairing (p : natprod) := equal_pair p (fst p, snd p). (*! QuickCheck surjective_pairing. *) Inductive natlist : Type := | nil : natlist | cons : nat -> natlist -> natlist. Derive Arbitrary for natlist. Derive Show for natlist. Instance natlist_eq (x y : natlist) : Dec (x = y). constructor. unfold ssrbool.decidable. repeat (decide equality). Defined. Notation "x :: l" := (cons x l) (at level 60, right associativity). Notation "[ ]" := nil. Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..). Fixpoint repeat (n count : nat) : natlist := match count with | O => nil | S count' => n :: (repeat n count') end. Fixpoint length (l:natlist) : nat := match l with | nil => O | h :: t => S (length t) end. Fixpoint app (l1 l2 : natlist) : natlist := match l1 with | nil => l2 | h :: t => h :: (app t l2) end. Notation "x ++ y" := (app x y) (right associativity, at level 60). Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5]. Proof. reflexivity. Qed. Example test_app2: nil ++ [4;5] = [4;5]. Proof. reflexivity. Qed. Example test_app3: [1;2;3] ++ nil = [1;2;3]. Proof. reflexivity. Qed. Definition hd (default:nat) (l:natlist) : nat := match l with | nil => default | h :: t => h end. Definition tl (l:natlist) : natlist := match l with | nil => nil | h :: t => t end. Definition test_hd1 := hd 0 [1;2;3] =? 1. (*! QuickChick test_hd1. *) Fixpoint equal_list l1 l2 := match l1,l2 with | [],[] => true | h1::t1,h2::t2 => andb (h1=?h2) (equal_list t1 t2) | _,_ => false end. Definition test_tl := equal_list (tl [1;2;3]) [2;3]. (*! QuickChick test_tl. *) Fixpoint alternate (l1 l2 : natlist) : natlist (* REPLACE THIS LINE WITH ":= _your_definition_ ." *) := []. Definition bag := natlist. Definition nil_app := fun l:natlist => equal_list ([] ++ l) l. (* QuickChick nil_app. *) Definition tl_length_pred := fun l:natlist => pred (length l) =? length (tl l). (* Ugh -- temporary hack *) Definition tl_length_prop := forAllShrink arbitrary shrink tl_length_pred. (*! QuickChick tl_length_prop. *) Definition app_assoc := fun l1 l2 l3 : natlist => (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3). Instance app_assoc_dec (l1 l2 l3 : natlist) : Dec (app_assoc l1 l2 l3). unfold app_assoc. apply natlist_eq. Defined. (* BCP: What do I need to write here? QuickChick app_assoc. *) Fixpoint rev (l:natlist) : natlist := match l with | nil => nil | h :: t => rev t ++ [h] end. Definition rev_length := fun l : natlist => length (rev l) =? length l. (*! QuickChick rev_length. *) Fixpoint beq_natlist (l1 l2 : natlist) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *) := false. (* BCP: Use this elsewhere *) Definition beq_natlist_refl := fun l:natlist => Bool.eqb true (beq_natlist l l). QuickChick (expectFailure beq_natlist). (* BCP: I wonder how best to do this...? *) Definition rev_injective := fun (l1 l2 : natlist) => (equal_list (rev l1) (rev l2)) ==> equal_list l1 l2. (* BCP: Probably needs some mutations to be interesting... *) (*! QuickChick beq_natlist. *) (* Let's try with the dependent stuff... *) Inductive eq_list : natlist -> natlist -> Prop := | eq_nil : eq_list [] [] | eq_cons : forall h l1 l2, eq_list l1 l2 -> eq_list (h::l1) (h::l2). Inductive snoc_of : natlist -> nat -> natlist -> Prop := | snoc_of_nil : forall x, snoc_of [] x [x] | snoc_of_cons : forall x h t t', snoc_of t x t' -> snoc_of (h::t) x (h::t'). Derive ArbitrarySizedSuchThat for (fun h => snoc_of t h t'). Derive ArbitrarySizedSuchThat for (fun t' => snoc_of t h t'). Inductive reverse_of : natlist -> natlist -> Prop := | reverse_of_nil : reverse_of [] [] | reverse_of_cons : forall h t t' t'', reverse_of t t' -> snoc_of t' h t'' -> reverse_of (h::t) t''. Derive ArbitrarySizedSuchThat for (fun l => reverse_of l l'). Derive ArbitrarySizedSuchThat for (fun l => reverse_of l' l). Inductive equal_reverses : (natlist * natlist)%type -> Prop := | eqrev : forall l1 l2 l, reverse_of l1 l -> reverse_of l2 l -> equal_reverses (Coq.Init.Datatypes.pair l1 l2). Derive ArbitrarySizedSuchThat for (fun l1l2 => equal_reverses l1l2). (* Need to actual write decidability if we want to use it Instance equal_reverses_dec l1l2 : Dec (equal_reverses l1l2). Proof. constructor; unfold ssrbool.decidable. destruct l1l2 as [l1 l2]. (* ... *) Admitted. *) Definition rev_injective_checker : Checker := forAll (genST (fun l1l2 => equal_reverses l1l2)) (fun l1l2 => match l1l2 with | Some (Coq.Init.Datatypes.pair l1 l2) => ((l1 = l2)?) | None => true end). QuickChick rev_injective_checker. Fixpoint nth_bad (l:natlist) (n:nat) : nat := match l with | nil => 42 (* arbitrary! *) | a :: l' => match beq_nat n O with | true => a | false => nth_bad l' (pred n) end end. Inductive natoption : Type := | Some : nat -> natoption | None : natoption. Derive Arbitrary for natoption. Derive Show for natoption. Instance natoption_eq (x y : natoption) : Dec (x = y). constructor. unfold ssrbool.decidable. repeat (decide equality). Defined. Fixpoint nth_error (l:natlist) (n:nat) : natoption := match l with | nil => None | a :: l' => match beq_nat n O with | true => Some a | false => nth_error l' (pred n) end end. (* BCP: Fix *) Definition test_nth_error1 := (nth_error [4;5;6;7] 0) = (Some 4)?. (*! QuickChick test_nth_error1. *) End NatList. Inductive id : Type := | Id : nat -> id. Derive Arbitrary for id. Derive Show for id. Instance id_eq (x y : id) : Dec (x = y). constructor. unfold ssrbool.decidable. repeat (decide equality). Defined. Definition beq_id (x1 x2 : id) := match x1, x2 with | Id n1, Id n2 => beq_nat n1 n2 end. (* BCP: Extraction inside modules is broken! *) (* Module PartialMap. *) Export NatList. Inductive partial_map : Type := | empty : partial_map | record : id -> nat -> partial_map -> partial_map. Derive Arbitrary for partial_map. Derive Show for partial_map. Instance partial_map_eq (x y : partial_map) : Dec (x = y). constructor. unfold ssrbool.decidable. repeat (decide equality). Defined. Definition update (d : partial_map) (x : id) (value : nat) : partial_map := record x value d. Fixpoint find (x : id) (d : partial_map) : natoption := match d with | empty => None | record y v d' => if beq_id x y then Some v else find x d' end. Definition update_eq := fun (d : partial_map) (x : id) (v: nat) => (find x (update d x v) = Some v)?. (*! QuickChick update_eq. *) QuickChick-2.1.0/sf-experiment/Logic.v000066400000000000000000001417211476030541200175520ustar00rootroot00000000000000(** * Logic: Logic in Coq *) Set Warnings "-notation-overridden,-parsing". Require Export Tactics. (** In previous chapters, we have seen many examples of factual claims (_propositions_) and ways of presenting evidence of their truth (_proofs_). In particular, we have worked extensively with _equality propositions_ of the form [e1 = e2], with implications ([P -> Q]), and with quantified propositions ([forall x, P]). In this chapter, we will see how Coq can be used to carry out other familiar forms of logical reasoning. Before diving into details, let's talk a bit about the status of mathematical statements in Coq. Recall that Coq is a _typed_ language, which means that every sensible expression in its world has an associated type. Logical claims are no exception: any statement we might try to prove in Coq has a type, namely [Prop], the type of _propositions_. We can see this with the [Check] command: *) Check 3 = 3. (* ===> Prop *) Check forall n m : nat, n + m = m + n. (* ===> Prop *) (** Note that _all_ syntactically well-formed propositions have type [Prop] in Coq, regardless of whether they are true or not. Simply _being_ a proposition is one thing; being _provable_ is something else! *) Check forall n : nat, n = 2. (* ===> Prop *) Check 3 = 4. (* ===> Prop *) (** Indeed, propositions don't just have types: they are _first-class objects_ that can be manipulated in the same ways as the other entities in Coq's world. So far, we've seen one primary place that propositions can appear: in [Theorem] (and [Lemma] and [Example]) declarations. *) Theorem plus_2_2_is_4 : 2 + 2 = 4. Proof. reflexivity. Qed. (** But propositions can be used in many other ways. For example, we can give a name to a proposition using a [Definition], just as we have given names to expressions of other sorts. *) Definition plus_fact : Prop := 2 + 2 = 4. Check plus_fact. (* ===> plus_fact : Prop *) (** We can later use this name in any situation where a proposition is expected -- for example, as the claim in a [Theorem] declaration. *) Theorem plus_fact_is_true : plus_fact. Proof. reflexivity. Qed. (** We can also write _parameterized_ propositions -- that is, functions that take arguments of some type and return a proposition. *) (** For instance, the following function takes a number and returns a proposition asserting that this number is equal to three: *) Definition is_three (n : nat) : Prop := n = 3. Check is_three. (* ===> nat -> Prop *) (** In Coq, functions that return propositions are said to define _properties_ of their arguments. For instance, here's a (polymorphic) property defining the familiar notion of an _injective function_. *) Definition injective {A B} (f : A -> B) := forall x y : A, f x = f y -> x = y. Lemma succ_inj : injective S. Proof. intros n m H. inversion H. reflexivity. Qed. (** The equality operator [=] is also a function that returns a [Prop]. The expression [n = m] is syntactic sugar for [eq n m], defined using Coq's [Notation] mechanism. Because [eq] can be used with elements of any type, it is also polymorphic: *) Check @eq. (* ===> forall A : Type, A -> A -> Prop *) (** (Notice that we wrote [@eq] instead of [eq]: The type argument [A] to [eq] is declared as implicit, so we need to turn off implicit arguments to see the full type of [eq].) *) (* ################################################################# *) (** * Logical Connectives *) (* ================================================================= *) (** ** Conjunction *) (** The _conjunction_ (or _logical and_) of propositions [A] and [B] is written [A /\ B], representing the claim that both [A] and [B] are true. *) Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4. (** To prove a conjunction, use the [split] tactic. It will generate two subgoals, one for each part of the statement: *) Proof. (* WORKED IN CLASS *) split. - (* 3 + 4 = 7 *) reflexivity. - (* 2 + 2 = 4 *) reflexivity. Qed. (** For any propositions [A] and [B], if we assume that [A] is true and we assume that [B] is true, we can conclude that [A /\ B] is also true. *) Lemma and_intro : forall A B : Prop, A -> B -> A /\ B. Proof. intros A B HA HB. split. - apply HA. - apply HB. Qed. (** Since applying a theorem with hypotheses to some goal has the effect of generating as many subgoals as there are hypotheses for that theorem, we can apply [and_intro] to achieve the same effect as [split]. *) Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4. Proof. apply and_intro. - (* 3 + 4 = 7 *) reflexivity. - (* 2 + 2 = 4 *) reflexivity. Qed. (** **** Exercise: 2 stars (and_exercise) *) Example and_exercise : forall n m : nat, n + m = 0 -> n = 0 /\ m = 0. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** So much for proving conjunctive statements. To go in the other direction -- i.e., to _use_ a conjunctive hypothesis to help prove something else -- we employ the [destruct] tactic. If the proof context contains a hypothesis [H] of the form [A /\ B], writing [destruct H as [HA HB]] will remove [H] from the context and add two new hypotheses: [HA], stating that [A] is true, and [HB], stating that [B] is true. *) Lemma and_example2 : forall n m : nat, n = 0 /\ m = 0 -> n + m = 0. Proof. (* WORKED IN CLASS *) intros n m H. destruct H as [Hn Hm]. rewrite Hn. rewrite Hm. reflexivity. Qed. (** As usual, we can also destruct [H] right when we introduce it, instead of introducing and then destructing it: *) Lemma and_example2' : forall n m : nat, n = 0 /\ m = 0 -> n + m = 0. Proof. intros n m [Hn Hm]. rewrite Hn. rewrite Hm. reflexivity. Qed. (** You may wonder why we bothered packing the two hypotheses [n = 0] and [m = 0] into a single conjunction, since we could have also stated the theorem with two separate premises: *) Lemma and_example2'' : forall n m : nat, n = 0 -> m = 0 -> n + m = 0. Proof. intros n m Hn Hm. rewrite Hn. rewrite Hm. reflexivity. Qed. (** For this theorem, both formulations are fine. But it's important to understand how to work with conjunctive hypotheses because conjunctions often arise from intermediate steps in proofs, especially in bigger developments. Here's a simple example: *) Lemma and_example3 : forall n m : nat, n + m = 0 -> n * m = 0. Proof. intros n m H. assert (H' : n = 0 /\ m = 0). { apply and_exercise. apply H. } destruct H' as [Hn Hm]. rewrite Hn. reflexivity. Qed. (** Another common situation with conjunctions is that we know [A /\ B] but in some context we need just [A] (or just [B]). The following lemmas are useful in such cases: *) Lemma proj1 : forall P Q : Prop, P /\ Q -> P. Proof. intros P Q [HP HQ]. apply HP. Qed. (** **** Exercise: 1 star, optional (proj2) *) Lemma proj2 : forall P Q : Prop, P /\ Q -> Q. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** Finally, we sometimes need to rearrange the order of conjunctions and/or the grouping of multi-way conjunctions. The following commutativity and associativity theorems are handy in such cases. *) Theorem and_commut : forall P Q : Prop, P /\ Q -> Q /\ P. Proof. (* WORKED IN CLASS *) intros P Q [HP HQ]. split. - (* left *) apply HQ. - (* right *) apply HP. Qed. (** **** Exercise: 2 stars (and_assoc) *) (** (In the following proof of associativity, notice how the _nested_ intro pattern breaks the hypothesis [H : P /\ (Q /\ R)] down into [HP : P], [HQ : Q], and [HR : R]. Finish the proof from there.) *) Theorem and_assoc : forall P Q R : Prop, P /\ (Q /\ R) -> (P /\ Q) /\ R. Proof. intros P Q R [HP [HQ HR]]. (* FILL IN HERE *) Admitted. (** [] *) (** By the way, the infix notation [/\] is actually just syntactic sugar for [and A B]. That is, [and] is a Coq operator that takes two propositions as arguments and yields a proposition. *) Check and. (* ===> and : Prop -> Prop -> Prop *) (* ================================================================= *) (** ** Disjunction *) (** Another important connective is the _disjunction_, or _logical or_ of two propositions: [A \/ B] is true when either [A] or [B] is. (Alternatively, we can write [or A B], where [or : Prop -> Prop -> Prop].) To use a disjunctive hypothesis in a proof, we proceed by case analysis, which, as for [nat] or other data types, can be done with [destruct] or [intros]. Here is an example: *) Lemma or_example : forall n m : nat, n = 0 \/ m = 0 -> n * m = 0. Proof. (* This pattern implicitly does case analysis on [n = 0 \/ m = 0] *) intros n m [Hn | Hm]. - (* Here, [n = 0] *) rewrite Hn. reflexivity. - (* Here, [m = 0] *) rewrite Hm. rewrite <- mult_n_O. reflexivity. Qed. (** Conversely, to show that a disjunction holds, we need to show that one of its sides does. This is done via two tactics, [left] and [right]. As their names imply, the first one requires proving the left side of the disjunction, while the second requires proving its right side. Here is a trivial use... *) Lemma or_intro : forall A B : Prop, A -> A \/ B. Proof. intros A B HA. left. apply HA. Qed. (** ... and a slightly more interesting example requiring both [left] and [right]: *) Lemma zero_or_succ : forall n : nat, n = 0 \/ n = S (pred n). Proof. intros [|n]. - left. reflexivity. - right. reflexivity. Qed. (** **** Exercise: 1 star (mult_eq_0) *) Lemma mult_eq_0 : forall n m, n * m = 0 -> n = 0 \/ m = 0. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (or_commut) *) Theorem or_commut : forall P Q : Prop, P \/ Q -> Q \/ P. Proof. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** Falsehood and Negation *) (** So far, we have mostly been concerned with proving that certain things are _true_ -- addition is commutative, appending lists is associative, etc. Of course, we may also be interested in _negative_ results, showing that certain propositions are _not_ true. In Coq, such negative statements are expressed with the negation operator [~]. To see how negation works, recall the discussion of the _principle of explosion_ from the [Tactics] chapter; it asserts that, if we assume a contradiction, then any other proposition can be derived. Following this intuition, we could define [~ P] ("not [P]") as [forall Q, P -> Q]. Coq actually makes a slightly different choice, defining [~ P] as [P -> False], where [False] is a _particular_ contradictory proposition defined in the standard library. *) Module MyNot. Definition not (P:Prop) := P -> False. Notation "~ x" := (not x) : type_scope. Check not. (* ===> Prop -> Prop *) End MyNot. (** Since [False] is a contradictory proposition, the principle of explosion also applies to it. If we get [False] into the proof context, we can [destruct] it to complete any goal: *) Theorem ex_falso_quodlibet : forall (P:Prop), False -> P. Proof. (* WORKED IN CLASS *) intros P contra. destruct contra. Qed. (** The Latin _ex falso quodlibet_ means, literally, "from falsehood follows whatever you like"; this is another common name for the principle of explosion. *) (** **** Exercise: 2 stars, optional (not_implies_our_not) *) (** Show that Coq's definition of negation implies the intuitive one mentioned above: *) Fact not_implies_our_not : forall (P:Prop), ~ P -> (forall (Q:Prop), P -> Q). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** This is how we use [not] to state that [0] and [1] are different elements of [nat]: *) Theorem zero_not_one : ~(0 = 1). Proof. intros contra. inversion contra. Qed. (** Such inequality statements are frequent enough to warrant a special notation, [x <> y]: *) Check (0 <> 1). (* ===> Prop *) Theorem zero_not_one' : 0 <> 1. Proof. intros H. inversion H. Qed. (** It takes a little practice to get used to working with negation in Coq. Even though you can see perfectly well why a statement involving negation is true, it can be a little tricky at first to get things into the right configuration so that Coq can understand it! Here are proofs of a few familiar facts to get you warmed up. *) Theorem not_False : ~ False. Proof. unfold not. intros H. destruct H. Qed. Theorem contradiction_implies_anything : forall P Q : Prop, (P /\ ~P) -> Q. Proof. (* WORKED IN CLASS *) intros P Q [HP HNA]. unfold not in HNA. apply HNA in HP. destruct HP. Qed. Theorem double_neg : forall P : Prop, P -> ~~P. Proof. (* WORKED IN CLASS *) intros P H. unfold not. intros G. apply G. apply H. Qed. (** **** Exercise: 2 stars, advanced, recommendedM (double_neg_inf) *) (** Write an informal proof of [double_neg]: _Theorem_: [P] implies [~~P], for any proposition [P]. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 2 stars, recommended (contrapositive) *) Theorem contrapositive : forall (P Q : Prop), (P -> Q) -> (~Q -> ~P). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (not_both_true_and_false) *) Theorem not_both_true_and_false : forall P : Prop, ~ (P /\ ~P). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star, advancedM (informal_not_PNP) *) (** Write an informal proof (in English) of the proposition [forall P : Prop, ~(P /\ ~P)]. *) (* FILL IN HERE *) (** [] *) (** Similarly, since inequality involves a negation, it requires a little practice to be able to work with it fluently. Here is one useful trick. If you are trying to prove a goal that is nonsensical (e.g., the goal state is [false = true]), apply [ex_falso_quodlibet] to change the goal to [False]. This makes it easier to use assumptions of the form [~P] that may be available in the context -- in particular, assumptions of the form [x<>y]. *) Theorem not_true_is_false : forall b : bool, b <> true -> b = false. Proof. intros [] H. - (* b = true *) unfold not in H. apply ex_falso_quodlibet. apply H. reflexivity. - (* b = false *) reflexivity. Qed. (** Since reasoning with [ex_falso_quodlibet] is quite common, Coq provides a built-in tactic, [exfalso], for applying it. *) Theorem not_true_is_false' : forall b : bool, b <> true -> b = false. Proof. intros [] H. - (* b = false *) unfold not in H. exfalso. (* <=== *) apply H. reflexivity. - (* b = true *) reflexivity. Qed. (* ================================================================= *) (** ** Truth *) (** Besides [False], Coq's standard library also defines [True], a proposition that is trivially true. To prove it, we use the predefined constant [I : True]: *) Lemma True_is_true : True. Proof. apply I. Qed. (** Unlike [False], which is used extensively, [True] is used quite rarely, since it is trivial (and therefore uninteresting) to prove as a goal, and it carries no useful information as a hypothesis. But it can be quite useful when defining complex [Prop]s using conditionals or as a parameter to higher-order [Prop]s. We will see examples of such uses of [True] later on. *) (* ================================================================= *) (** ** Logical Equivalence *) (** The handy "if and only if" connective, which asserts that two propositions have the same truth value, is just the conjunction of two implications. *) Module MyIff. Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P). Notation "P <-> Q" := (iff P Q) (at level 95, no associativity) : type_scope. End MyIff. Theorem iff_sym : forall P Q : Prop, (P <-> Q) -> (Q <-> P). Proof. (* WORKED IN CLASS *) intros P Q [HAB HBA]. split. - (* -> *) apply HBA. - (* <- *) apply HAB. Qed. Lemma not_true_iff_false : forall b, b <> true <-> b = false. Proof. (* WORKED IN CLASS *) intros b. split. - (* -> *) apply not_true_is_false. - (* <- *) intros H. rewrite H. intros H'. inversion H'. Qed. (** **** Exercise: 1 star, optional (iff_properties) *) (** Using the above proof that [<->] is symmetric ([iff_sym]) as a guide, prove that it is also reflexive and transitive. *) Theorem iff_refl : forall P : Prop, P <-> P. Proof. (* FILL IN HERE *) Admitted. Theorem iff_trans : forall P Q R : Prop, (P <-> Q) -> (Q <-> R) -> (P <-> R). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (or_distributes_over_and) *) Theorem or_distributes_over_and : forall P Q R : Prop, P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** Some of Coq's tactics treat [iff] statements specially, avoiding the need for some low-level proof-state manipulation. In particular, [rewrite] and [reflexivity] can be used with [iff] statements, not just equalities. To enable this behavior, we need to import a special Coq library that allows rewriting with other formulas besides equality: *) Require Import Coq.Setoids.Setoid. (** Here is a simple example demonstrating how these tactics work with [iff]. First, let's prove a couple of basic iff equivalences... *) Lemma mult_0 : forall n m, n * m = 0 <-> n = 0 \/ m = 0. Proof. split. - apply mult_eq_0. - apply or_example. Qed. Lemma or_assoc : forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R. Proof. intros P Q R. split. - intros [H | [H | H]]. + left. left. apply H. + left. right. apply H. + right. apply H. - intros [[H | H] | H]. + left. apply H. + right. left. apply H. + right. right. apply H. Qed. (** We can now use these facts with [rewrite] and [reflexivity] to give smooth proofs of statements involving equivalences. Here is a ternary version of the previous [mult_0] result: *) Lemma mult_0_3 : forall n m p, n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0. Proof. intros n m p. rewrite mult_0. rewrite mult_0. rewrite or_assoc. reflexivity. Qed. (** The [apply] tactic can also be used with [<->]. When given an equivalence as its argument, [apply] tries to guess which side of the equivalence to use. *) Lemma apply_iff_example : forall n m : nat, n * m = 0 -> n = 0 \/ m = 0. Proof. intros n m H. apply mult_0. apply H. Qed. (* ================================================================= *) (** ** Existential Quantification *) (** Another important logical connective is _existential quantification_. To say that there is some [x] of type [T] such that some property [P] holds of [x], we write [exists x : T, P]. As with [forall], the type annotation [: T] can be omitted if Coq is able to infer from the context what the type of [x] should be. *) (** To prove a statement of the form [exists x, P], we must show that [P] holds for some specific choice of value for [x], known as the _witness_ of the existential. This is done in two steps: First, we explicitly tell Coq which witness [t] we have in mind by invoking the tactic [exists t]. Then we prove that [P] holds after all occurrences of [x] are replaced by [t]. *) Lemma four_is_even : exists n : nat, 4 = n + n. Proof. exists 2. reflexivity. Qed. (** Conversely, if we have an existential hypothesis [exists x, P] in the context, we can destruct it to obtain a witness [x] and a hypothesis stating that [P] holds of [x]. *) Theorem exists_example_2 : forall n, (exists m, n = 4 + m) -> (exists o, n = 2 + o). Proof. (* WORKED IN CLASS *) intros n [m Hm]. (* note implicit [destruct] here *) exists (2 + m). apply Hm. Qed. (** **** Exercise: 1 star (dist_not_exists) *) (** Prove that "[P] holds for all [x]" implies "there is no [x] for which [P] does not hold." *) Theorem dist_not_exists : forall (X:Type) (P : X -> Prop), (forall x, P x) -> ~ (exists x, ~ P x). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars (dist_exists_or) *) (** Prove that existential quantification distributes over disjunction. *) Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop), (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x). Proof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Programming with Propositions *) (** The logical connectives that we have seen provide a rich vocabulary for defining complex propositions from simpler ones. To illustrate, let's look at how to express the claim that an element [x] occurs in a list [l]. Notice that this property has a simple recursive structure: *) (** - If [l] is the empty list, then [x] cannot occur on it, so the property "[x] appears in [l]" is simply false. - Otherwise, [l] has the form [x' :: l']. In this case, [x] occurs in [l] if either it is equal to [x'] or it occurs in [l']. We can translate this directly into a straightforward recursive function from taking an element and a list and returning a proposition: *) Fixpoint In {A : Type} (x : A) (l : list A) : Prop := match l with | [] => False | x' :: l' => x' = x \/ In x l' end. (** When [In] is applied to a concrete list, it expands into a concrete sequence of nested disjunctions. *) Example In_example_1 : In 4 [1; 2; 3; 4; 5]. Proof. (* WORKED IN CLASS *) simpl. right. right. right. left. reflexivity. Qed. Example In_example_2 : forall n, In n [2; 4] -> exists n', n = 2 * n'. Proof. (* WORKED IN CLASS *) simpl. intros n [H | [H | []]]. - exists 1. rewrite <- H. reflexivity. - exists 2. rewrite <- H. reflexivity. Qed. (** (Notice the use of the empty pattern to discharge the last case _en passant_.) *) (** We can also prove more generic, higher-level lemmas about [In]. Note, in the next, how [In] starts out applied to a variable and only gets expanded when we do case analysis on this variable: *) Lemma In_map : forall (A B : Type) (f : A -> B) (l : list A) (x : A), In x l -> In (f x) (map f l). Proof. intros A B f l x. induction l as [|x' l' IHl']. - (* l = nil, contradiction *) simpl. intros []. - (* l = x' :: l' *) simpl. intros [H | H]. + rewrite H. left. reflexivity. + right. apply IHl'. apply H. Qed. (** This way of defining propositions recursively, though convenient in some cases, also has some drawbacks. In particular, it is subject to Coq's usual restrictions regarding the definition of recursive functions, e.g., the requirement that they be "obviously terminating." In the next chapter, we will see how to define propositions _inductively_, a different technique with its own set of strengths and limitations. *) (** **** Exercise: 2 stars (In_map_iff) *) Lemma In_map_iff : forall (A B : Type) (f : A -> B) (l : list A) (y : B), In y (map f l) <-> exists x, f x = y /\ In x l. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars (in_app_iff) *) Lemma in_app_iff : forall A l l' (a:A), In a (l++l') <-> In a l \/ In a l'. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (All) *) (** Recall that functions returning propositions can be seen as _properties_ of their arguments. For instance, if [P] has type [nat -> Prop], then [P n] states that property [P] holds of [n]. Drawing inspiration from [In], write a recursive function [All] stating that some property [P] holds of all elements of a list [l]. To make sure your definition is correct, prove the [All_In] lemma below. (Of course, your definition should _not_ just restate the left-hand side of [All_In].) *) Fixpoint All {T : Type} (P : T -> Prop) (l : list T) : Prop (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Lemma All_In : forall T (P : T -> Prop) (l : list T), (forall x, In x l -> P x) <-> All P l. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (combine_odd_even) *) (** Complete the definition of the [combine_odd_even] function below. It takes as arguments two properties of numbers, [Podd] and [Peven], and it should return a property [P] such that [P n] is equivalent to [Podd n] when [n] is odd and equivalent to [Peven n] otherwise. *) Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** To test your definition, prove the following facts: *) Theorem combine_odd_even_intro : forall (Podd Peven : nat -> Prop) (n : nat), (oddb n = true -> Podd n) -> (oddb n = false -> Peven n) -> combine_odd_even Podd Peven n. Proof. (* FILL IN HERE *) Admitted. Theorem combine_odd_even_elim_odd : forall (Podd Peven : nat -> Prop) (n : nat), combine_odd_even Podd Peven n -> oddb n = true -> Podd n. Proof. (* FILL IN HERE *) Admitted. Theorem combine_odd_even_elim_even : forall (Podd Peven : nat -> Prop) (n : nat), combine_odd_even Podd Peven n -> oddb n = false -> Peven n. Proof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Applying Theorems to Arguments *) (** One feature of Coq that distinguishes it from many other proof assistants is that it treats _proofs_ as first-class objects. There is a great deal to be said about this, but it is not necessary to understand it in detail in order to use Coq. This section gives just a taste, while a deeper exploration can be found in the optional chapters [ProofObjects] and [IndPrinciples]. *) (** We have seen that we can use the [Check] command to ask Coq to print the type of an expression. We can also use [Check] to ask what theorem a particular identifier refers to. *) Check plus_comm. (* ===> forall n m : nat, n + m = m + n *) (** Coq prints the _statement_ of the [plus_comm] theorem in the same way that it prints the _type_ of any term that we ask it to [Check]. Why? The reason is that the identifier [plus_comm] actually refers to a _proof object_ -- a data structure that represents a logical derivation establishing of the truth of the statement [forall n m : nat, n + m = m + n]. The type of this object _is_ the statement of the theorem that it is a proof of. *) (** Intuitively, this makes sense because the statement of a theorem tells us what we can use that theorem for, just as the type of a computational object tells us what we can do with that object -- e.g., if we have a term of type [nat -> nat -> nat], we can give it two [nat]s as arguments and get a [nat] back. Similarly, if we have an object of type [n = m -> n + n = m + m] and we provide it an "argument" of type [n = m], we can derive [n + n = m + m]. *) (** Operationally, this analogy goes even further: by applying a theorem, as if it were a function, to hypotheses with matching types, we can specialize its result without having to resort to intermediate assertions. For example, suppose we wanted to prove the following result: *) Lemma plus_comm3 : forall n m p, n + (m + p) = (p + m) + n. (** It appears at first sight that we ought to be able to prove this by rewriting with [plus_comm] twice to make the two sides match. The problem, however, is that the second [rewrite] will undo the effect of the first. *) Proof. intros n m p. rewrite plus_comm. rewrite plus_comm. (* We are back where we started... *) Abort. (** One simple way of fixing this problem, using only tools that we already know, is to use [assert] to derive a specialized version of [plus_comm] that can be used to rewrite exactly where we want. *) Lemma plus_comm3_take2 : forall n m p, n + (m + p) = (p + m) + n. Proof. intros n m p. rewrite plus_comm. assert (H : m + p = p + m). { rewrite plus_comm. reflexivity. } rewrite H. reflexivity. Qed. (** A more elegant alternative is to apply [plus_comm] directly to the arguments we want to instantiate it with, in much the same way as we apply a polymorphic function to a type argument. *) Lemma plus_comm3_take3 : forall n m p, n + (m + p) = (p + m) + n. Proof. intros n m p. rewrite plus_comm. rewrite (plus_comm m). reflexivity. Qed. (** You can "use theorems as functions" in this way with almost all tactics that take a theorem name as an argument. Note also that theorem application uses the same inference mechanisms as function application; thus, it is possible, for example, to supply wildcards as arguments to be inferred, or to declare some hypotheses to a theorem as implicit by default. These features are illustrated in the proof below. *) Example lemma_application_ex : forall {n : nat} {ns : list nat}, In n (map (fun m => m * 0) ns) -> n = 0. Proof. intros n ns H. destruct (proj1 _ _ (In_map_iff _ _ _ _ _) H) as [m [Hm _]]. rewrite mult_0_r in Hm. rewrite <- Hm. reflexivity. Qed. (** We will see many more examples of the idioms from this section in later chapters. *) (* ################################################################# *) (** * Coq vs. Set Theory *) (** Coq's logical core, the _Calculus of Inductive Constructions_, differs in some important ways from other formal systems that are used by mathematicians for writing down precise and rigorous proofs. For example, in the most popular foundation for mainstream paper-and-pencil mathematics, Zermelo-Fraenkel Set Theory (ZFC), a mathematical object can potentially be a member of many different sets; a term in Coq's logic, on the other hand, is a member of at most one type. This difference often leads to slightly different ways of capturing informal mathematical concepts, but these are, by and large, quite natural and easy to work with. For example, instead of saying that a natural number [n] belongs to the set of even numbers, we would say in Coq that [ev n] holds, where [ev : nat -> Prop] is a property describing even numbers. However, there are some cases where translating standard mathematical reasoning into Coq can be either cumbersome or sometimes even impossible, unless we enrich the core logic with additional axioms. We conclude this chapter with a brief discussion of some of the most significant differences between the two worlds. *) (* ================================================================= *) (** ** Functional Extensionality *) (** The equality assertions that we have seen so far mostly have concerned elements of inductive types ([nat], [bool], etc.). But since Coq's equality operator is polymorphic, these are not the only possibilities -- in particular, we can write propositions claiming that two _functions_ are equal to each other: *) Example function_equality_ex1 : plus 3 = plus (pred 4). Proof. reflexivity. Qed. (** In common mathematical practice, two functions [f] and [g] are considered equal if they produce the same outputs: (forall x, f x = g x) -> f = g This is known as the principle of _functional extensionality_. Informally speaking, an "extensional property" is one that pertains to an object's observable behavior. Thus, functional extensionality simply means that a function's identity is completely determined by what we can observe from it -- i.e., in Coq terms, the results we obtain after applying it. Functional extensionality is not part of Coq's basic axioms. This means that some "reasonable" propositions are not provable. *) Example function_equality_ex2 : (fun x => plus x 1) = (fun x => plus 1 x). Proof. (* Stuck *) Abort. (** However, we can add functional extensionality to Coq's core logic using the [Axiom] command. *) Axiom functional_extensionality : forall {X Y: Type} {f g : X -> Y}, (forall (x:X), f x = g x) -> f = g. (** Using [Axiom] has the same effect as stating a theorem and skipping its proof using [Admitted], but it alerts the reader that this isn't just something we're going to come back and fill in later! We can now invoke functional extensionality in proofs: *) Example function_equality_ex2 : (fun x => plus x 1) = (fun x => plus 1 x). Proof. apply functional_extensionality. intros x. apply plus_comm. Qed. (** Naturally, we must be careful when adding new axioms into Coq's logic, as they may render it _inconsistent_ -- that is, they may make it possible to prove every proposition, including [False]! Unfortunately, there is no simple way of telling whether an axiom is safe to add: hard work is generally required to establish the consistency of any particular combination of axioms. However, it is known that adding functional extensionality, in particular, _is_ consistent. To check whether a particular proof relies on any additional axioms, use the [Print Assumptions] command. *) Print Assumptions function_equality_ex2. (* ===> Axioms: functional_extensionality : forall (X Y : Type) (f g : X -> Y), (forall x : X, f x = g x) -> f = g *) (** **** Exercise: 4 stars (tr_rev) *) (** One problem with the definition of the list-reversing function [rev] that we have is that it performs a call to [app] on each step; running [app] takes time asymptotically linear in the size of the list, which means that [rev] has quadratic running time. We can improve this with the following definition: *) Fixpoint rev_append {X} (l1 l2 : list X) : list X := match l1 with | [] => l2 | x :: l1' => rev_append l1' (x :: l2) end. Definition tr_rev {X} (l : list X) : list X := rev_append l []. (** This version is said to be _tail-recursive_, because the recursive call to the function is the last operation that needs to be performed (i.e., we don't have to execute [++] after the recursive call); a decent compiler will generate very efficient code in this case. Prove that the two definitions are indeed equivalent. *) Lemma tr_rev_correct : forall X, @tr_rev X = @rev X. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** Propositions and Booleans *) (** We've seen two different ways of encoding logical facts in Coq: with _booleans_ (of type [bool]), and with _propositions_ (of type [Prop]). For instance, to claim that a number [n] is even, we can say either - (1) that [evenb n] returns [true], or - (2) that there exists some [k] such that [n = double k]. Indeed, these two notions of evenness are equivalent, as can easily be shown with a couple of auxiliary lemmas. We often say that the boolean [evenb n] _reflects_ the proposition [exists k, n = double k]. *) Theorem evenb_double : forall k, evenb (double k) = true. Proof. intros k. induction k as [|k' IHk']. - reflexivity. - simpl. apply IHk'. Qed. (** **** Exercise: 3 stars (evenb_double_conv) *) Theorem evenb_double_conv : forall n, exists k, n = if evenb n then double k else S (double k). Proof. (* Hint: Use the [evenb_S] lemma from [Induction.v]. *) (* FILL IN HERE *) Admitted. (** [] *) Theorem even_bool_prop : forall n, evenb n = true <-> exists k, n = double k. Proof. intros n. split. - intros H. destruct (evenb_double_conv n) as [k Hk]. rewrite Hk. rewrite H. exists k. reflexivity. - intros [k Hk]. rewrite Hk. apply evenb_double. Qed. (** Similarly, to state that two numbers [n] and [m] are equal, we can say either (1) that [beq_nat n m] returns [true] or (2) that [n = m]. These two notions are equivalent. *) Theorem beq_nat_true_iff : forall n1 n2 : nat, beq_nat n1 n2 = true <-> n1 = n2. Proof. intros n1 n2. split. - apply beq_nat_true. - intros H. rewrite H. rewrite <- beq_nat_refl. reflexivity. Qed. (** However, while the boolean and propositional formulations of a claim are equivalent from a purely logical perspective, they need not be equivalent _operationally_. Equality provides an extreme example: knowing that [beq_nat n m = true] is generally of little direct help in the middle of a proof involving [n] and [m]; however, if we convert the statement to the equivalent form [n = m], we can rewrite with it. The case of even numbers is also interesting. Recall that, when proving the backwards direction of [even_bool_prop] (i.e., [evenb_double], going from the propositional to the boolean claim), we used a simple induction on [k]. On the other hand, the converse (the [evenb_double_conv] exercise) required a clever generalization, since we can't directly prove [(exists k, n = double k) -> evenb n = true]. For these examples, the propositional claims are more useful than their boolean counterparts, but this is not always the case. For instance, we cannot test whether a general proposition is true or not in a function definition; as a consequence, the following code fragment is rejected: *) Fail Definition is_even_prime n := if n = 2 then true else false. (** Coq complains that [n = 2] has type [Prop], while it expects an elements of [bool] (or some other inductive type with two elements). The reason for this error message has to do with the _computational_ nature of Coq's core language, which is designed so that every function that it can express is computable and total. One reason for this is to allow the extraction of executable programs from Coq developments. As a consequence, [Prop] in Coq does _not_ have a universal case analysis operation telling whether any given proposition is true or false, since such an operation would allow us to write non-computable functions. Although general non-computable properties cannot be phrased as boolean computations, it is worth noting that even many _computable_ properties are easier to express using [Prop] than [bool], since recursive function definitions are subject to significant restrictions in Coq. For instance, the next chapter shows how to define the property that a regular expression matches a given string using [Prop]. Doing the same with [bool] would amount to writing a regular expression matcher, which would be more complicated, harder to understand, and harder to reason about. Conversely, an important side benefit of stating facts using booleans is enabling some proof automation through computation with Coq terms, a technique known as _proof by reflection_. Consider the following statement: *) Example even_1000 : exists k, 1000 = double k. (** The most direct proof of this fact is to give the value of [k] explicitly. *) Proof. exists 500. reflexivity. Qed. (** On the other hand, the proof of the corresponding boolean statement is even simpler: *) Example even_1000' : evenb 1000 = true. Proof. reflexivity. Qed. (** What is interesting is that, since the two notions are equivalent, we can use the boolean formulation to prove the other one without mentioning the value 500 explicitly: *) Example even_1000'' : exists k, 1000 = double k. Proof. apply even_bool_prop. reflexivity. Qed. (** Although we haven't gained much in terms of proof size in this case, larger proofs can often be made considerably simpler by the use of reflection. As an extreme example, the Coq proof of the famous _4-color theorem_ uses reflection to reduce the analysis of hundreds of different cases to a boolean computation. We won't cover reflection in great detail, but it serves as a good example showing the complementary strengths of booleans and general propositions. *) (** **** Exercise: 2 stars (logical_connectives) *) (** The following lemmas relate the propositional connectives studied in this chapter to the corresponding boolean operations. *) Lemma andb_true_iff : forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true. Proof. (* FILL IN HERE *) Admitted. Lemma orb_true_iff : forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (beq_nat_false_iff) *) (** The following theorem is an alternate "negative" formulation of [beq_nat_true_iff] that is more convenient in certain situations (we'll see examples in later chapters). *) Theorem beq_nat_false_iff : forall x y : nat, beq_nat x y = false <-> x <> y. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (beq_list) *) (** Given a boolean operator [beq] for testing equality of elements of some type [A], we can define a function [beq_list beq] for testing equality of lists with elements in [A]. Complete the definition of the [beq_list] function below. To make sure that your definition is correct, prove the lemma [beq_list_true_iff]. *) Fixpoint beq_list {A : Type} (beq : A -> A -> bool) (l1 l2 : list A) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Lemma beq_list_true_iff : forall A (beq : A -> A -> bool), (forall a1 a2, beq a1 a2 = true <-> a1 = a2) -> forall l1 l2, beq_list beq l1 l2 = true <-> l1 = l2. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, recommended (All_forallb) *) (** Recall the function [forallb], from the exercise [forall_exists_challenge] in chapter [Tactics]: *) Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool := match l with | [] => true | x :: l' => andb (test x) (forallb test l') end. (** Prove the theorem below, which relates [forallb] to the [All] property of the above exercise. *) Theorem forallb_true_iff : forall X test (l : list X), forallb test l = true <-> All (fun x => test x = true) l. Proof. (* FILL IN HERE *) Admitted. (** Are there any important properties of the function [forallb] which are not captured by this specification? *) (* FILL IN HERE *) (** [] *) (* ================================================================= *) (** ** Classical vs. Constructive Logic *) (** We have seen that it is not possible to test whether or not a proposition [P] holds while defining a Coq function. You may be surprised to learn that a similar restriction applies to _proofs_! In other words, the following intuitive reasoning principle is not derivable in Coq: *) Definition excluded_middle := forall P : Prop, P \/ ~ P. (** To understand operationally why this is the case, recall that, to prove a statement of the form [P \/ Q], we use the [left] and [right] tactics, which effectively require knowing which side of the disjunction holds. But the universally quantified [P] in [excluded_middle] is an _arbitrary_ proposition, which we know nothing about. We don't have enough information to choose which of [left] or [right] to apply, just as Coq doesn't have enough information to mechanically decide whether [P] holds or not inside a function. *) (** However, if we happen to know that [P] is reflected in some boolean term [b], then knowing whether it holds or not is trivial: we just have to check the value of [b]. *) Theorem restricted_excluded_middle : forall P b, (P <-> b = true) -> P \/ ~ P. Proof. intros P [] H. - left. rewrite H. reflexivity. - right. rewrite H. intros contra. inversion contra. Qed. (** In particular, the excluded middle is valid for equations [n = m], between natural numbers [n] and [m]. *) Theorem restricted_excluded_middle_eq : forall (n m : nat), n = m \/ n <> m. Proof. intros n m. apply (restricted_excluded_middle (n = m) (beq_nat n m)). symmetry. apply beq_nat_true_iff. Qed. (** It may seem strange that the general excluded middle is not available by default in Coq; after all, any given claim must be either true or false. Nonetheless, there is an advantage in not assuming the excluded middle: statements in Coq can make stronger claims than the analogous statements in standard mathematics. Notably, if there is a Coq proof of [exists x, P x], it is possible to explicitly exhibit a value of [x] for which we can prove [P x] -- in other words, every proof of existence is necessarily _constructive_. *) (** Logics like Coq's, which do not assume the excluded middle, are referred to as _constructive logics_. More conventional logical systems such as ZFC, in which the excluded middle does hold for arbitrary propositions, are referred to as _classical_. *) (** The following example illustrates why assuming the excluded middle may lead to non-constructive proofs: _Claim_: There exist irrational numbers [a] and [b] such that [a ^ b] is rational. _Proof_: It is not difficult to show that [sqrt 2] is irrational. If [sqrt 2 ^ sqrt 2] is rational, it suffices to take [a = b = sqrt 2] and we are done. Otherwise, [sqrt 2 ^ sqrt 2] is irrational. In this case, we can take [a = sqrt 2 ^ sqrt 2] and [b = sqrt 2], since [a ^ b = sqrt 2 ^ (sqrt 2 * sqrt 2) = sqrt 2 ^ 2 = 2]. [] Do you see what happened here? We used the excluded middle to consider separately the cases where [sqrt 2 ^ sqrt 2] is rational and where it is not, without knowing which one actually holds! Because of that, we wind up knowing that such [a] and [b] exist but we cannot determine what their actual values are (at least, using this line of argument). As useful as constructive logic is, it does have its limitations: There are many statements that can easily be proven in classical logic but that have much more complicated constructive proofs, and there are some that are known to have no constructive proof at all! Fortunately, like functional extensionality, the excluded middle is known to be compatible with Coq's logic, allowing us to add it safely as an axiom. However, we will not need to do so in this book: the results that we cover can be developed entirely within constructive logic at negligible extra cost. It takes some practice to understand which proof techniques must be avoided in constructive reasoning, but arguments by contradiction, in particular, are infamous for leading to non-constructive proofs. Here's a typical example: suppose that we want to show that there exists [x] with some property [P], i.e., such that [P x]. We start by assuming that our conclusion is false; that is, [~ exists x, P x]. From this premise, it is not hard to derive [forall x, ~ P x]. If we manage to show that this intermediate fact results in a contradiction, we arrive at an existence proof without ever exhibiting a value of [x] for which [P x] holds! The technical flaw here, from a constructive standpoint, is that we claimed to prove [exists x, P x] using a proof of [~ ~ (exists x, P x)]. Allowing ourselves to remove double negations from arbitrary statements is equivalent to assuming the excluded middle, as shown in one of the exercises below. Thus, this line of reasoning cannot be encoded in Coq without assuming additional axioms. *) (** **** Exercise: 3 stars (excluded_middle_irrefutable) *) (** The consistency of Coq with the general excluded middle axiom requires complicated reasoning that cannot be carried out within Coq itself. However, the following theorem implies that it is always safe to assume a decidability axiom (i.e., an instance of excluded middle) for any _particular_ Prop [P]. Why? Because we cannot prove the negation of such an axiom; if we could, we would have both [~ (P \/ ~P)] and [~ ~ (P \/ ~P)], a contradiction. *) Theorem excluded_middle_irrefutable: forall (P:Prop), ~ ~ (P \/ ~ P). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, advanced (not_exists_dist) *) (** It is a theorem of classical logic that the following two assertions are equivalent: ~ (exists x, ~ P x) forall x, P x The [dist_not_exists] theorem above proves one side of this equivalence. Interestingly, the other direction cannot be proved in constructive logic. Your job is to show that it is implied by the excluded middle. *) Theorem not_exists_dist : excluded_middle -> forall (X:Type) (P : X -> Prop), ~ (exists x, ~ P x) -> (forall x, P x). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 5 stars, optional (classical_axioms) *) (** For those who like a challenge, here is an exercise taken from the Coq'Art book by Bertot and Casteran (p. 123). Each of the following four statements, together with [excluded_middle], can be considered as characterizing classical logic. We can't prove any of them in Coq, but we can consistently add any one of them as an axiom if we wish to work in classical logic. Prove that all five propositions (these four plus [excluded_middle]) are equivalent. *) Definition peirce := forall P Q: Prop, ((P->Q)->P)->P. Definition double_negation_elimination := forall P:Prop, ~~P -> P. Definition de_morgan_not_and_not := forall P Q:Prop, ~(~P /\ ~Q) -> P\/Q. Definition implies_to_or := forall P Q:Prop, (P->Q) -> (~P\/Q). (* FILL IN HERE *) (** [] *) (** $Date: 2017-04-26 17:33:43 -0400 (Wed, 26 Apr 2017) $ *) QuickChick-2.1.0/sf-experiment/Makefile000066400000000000000000000175771476030541200200010ustar00rootroot00000000000000############################################################################# ## v # The Coq Proof Assistant ## ## .merlin @echo "B $(COQLIB)kernel" >> .merlin @echo "B $(COQLIB)lib" >> .merlin @echo "B $(COQLIB)library" >> .merlin @echo "B $(COQLIB)parsing" >> .merlin @echo "B $(COQLIB)pretyping" >> .merlin @echo "B $(COQLIB)interp" >> .merlin @echo "B $(COQLIB)printing" >> .merlin @echo "B $(COQLIB)intf" >> .merlin @echo "B $(COQLIB)proofs" >> .merlin @echo "B $(COQLIB)tactics" >> .merlin @echo "B $(COQLIB)tools" >> .merlin @echo "B $(COQLIB)ltacprof" >> .merlin @echo "B $(COQLIB)toplevel" >> .merlin @echo "B $(COQLIB)stm" >> .merlin @echo "B $(COQLIB)grammar" >> .merlin @echo "B $(COQLIB)config" >> .merlin @echo "B $(COQLIB)ltac" >> .merlin @echo "B $(COQLIB)engine" >> .merlin @echo "B /Users/bcpierce/work/sf/new/lf/full" >> .merlin @echo "S /Users/bcpierce/work/sf/new/lf/full" >> .merlin clean:: rm -f $(OBJFILES) $(OBJFILES:.o=.native) $(NATIVEFILES) find . -name .coq-native -type d -empty -delete rm -f $(VOFILES) $(VOFILES:.vo=.vio) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old) rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex - rm -rf html mlihtml uninstall_me.sh cleanall:: clean rm -f $(patsubst %.v,.%.aux,$(VFILES)) archclean:: rm -f *.cmx *.o printenv: @"$(COQBIN)coqtop" -config @echo 'OCAMLFIND = $(OCAMLFIND)' @echo 'PP = $(PP)' @echo 'COQFLAGS = $(COQFLAGS)' @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' ################### # # # Implicit rules. # # # ################### $(VOFILES): %.vo: %.v $(SHOW)COQC $< $(HIDE)$(COQC) $(COQDEBUG) $(COQFLAGS) $< $(GLOBFILES): %.glob: %.v $(COQC) $(COQDEBUG) $(COQFLAGS) $< $(VFILES:.v=.vio): %.vio: %.v $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $< $(GFILES): %.g: %.v $(GALLINA) $< $(VFILES:.v=.tex): %.tex: %.v $(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ $(HTMLFILES): %.html: %.v %.glob $(COQDOC) $(COQDOCFLAGS) -html $< -o $@ $(VFILES:.v=.g.tex): %.g.tex: %.v $(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ $(GHTMLFILES): %.g.html: %.v %.glob $(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ $(addsuffix .d,$(VFILES)): %.v.d: %.v $(SHOW)'COQDEP $<' $(HIDE)$(COQDEP) $(COQLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) $(addsuffix .beautified,$(VFILES)): %.v.beautified: $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*.v # WARNING # # This Makefile has been automagically generated # Edit at your own risks ! # # END OF WARNING include .depend QuickChick-2.1.0/sf-experiment/Maps.v000066400000000000000000000273521476030541200174200ustar00rootroot00000000000000(** * Maps: Total and Partial Maps *) (** Maps (or dictionaries) are ubiquitous data structures both generally and in the theory of programming languages in particular; we're going to need them in many places in the coming chapters. They also make a nice case study using ideas we've seen in previous chapters, including building data structures out of higher-order functions (from [Basics] and [Poly]) and the use of reflection to streamline proofs (from [IndProp]). We'll define two flavors of maps: _total_ maps, which include a "default" element to be returned when a key being looked up doesn't exist, and _partial_ maps, which return an [option] to indicate success or failure. The latter is defined in terms of the former, using [None] as the default element. *) (* ################################################################# *) (** * The Coq Standard Library *) (** One small digression before we get to maps. Unlike the chapters we have seen so far, this one does not [Require Import] the chapter before it (and, transitively, all the earlier chapters). Instead, in this chapter and from now, on we're going to import the definitions and theorems we need directly from Coq's standard library stuff. You should not notice much difference, though, because we've been careful to name our own definitions and theorems the same as their counterparts in the standard library, wherever they overlap. *) Require Import Coq.Arith.Arith. Require Import Coq.Bool.Bool. Require Import Coq.Strings.String. Require Import Coq.Logic.FunctionalExtensionality. (** Documentation for the standard library can be found at http://coq.inria.fr/library/. The [Search] command is a good way to look for theorems involving objects of specific types. Take a minute now to experiment with it. *) (* ################################################################# *) (** * Identifiers *) (** First, we need a type for the keys that we use to index into our maps. For this purpose, we again use the type [id] from the [Lists] chapter. To make this chapter self contained, we repeat its definition here, together with the equality comparison function for [id]s and its fundamental property. *) Inductive id : Type := | Id : string -> id. Definition beq_id x y := match x,y with | Id n1, Id n2 => if string_dec n1 n2 then true else false end. (** (The function [string_dec] comes from Coq's string library. If you check its result type, you'll see that it does not actually return a [bool], but rather a type that looks like [{x = y} + {x <> y}], called a [sumbool], which can be thought of as an "evidence-carrying boolean." Formally, an element of [sumbool] is either a proof that two things are equal or a proof that they are unequal, together with a tag indicating which. But for present purposes you can think of it as just a fancy [bool].) *) Theorem beq_id_refl : forall id, true = beq_id id id. Proof. intros [n]. simpl. destruct (string_dec n n). - reflexivity. - destruct n0. reflexivity. Qed. (** The following useful property of [beq_id] follows from an analogous lemma about strings: *) Theorem beq_id_true_iff : forall x y : id, beq_id x y = true <-> x = y. Proof. intros [n1] [n2]. unfold beq_id. destruct (string_dec n1 n2). - subst. split. reflexivity. reflexivity. - split. + intros contra. inversion contra. + intros H. inversion H. subst. destruct n. reflexivity. Qed. (** Similarly: *) Theorem beq_id_false_iff : forall x y : id, beq_id x y = false <-> x <> y. Proof. intros x y. rewrite <- beq_id_true_iff. rewrite not_true_iff_false. reflexivity. Qed. (** This useful variant follows just by rewriting: *) Theorem false_beq_id : forall x y : id, x <> y -> beq_id x y = false. Proof. intros x y. rewrite beq_id_false_iff. intros H. apply H. Qed. (* ################################################################# *) (** * Total Maps *) (** Our main job in this chapter will be to build a definition of partial maps that is similar in behavior to the one we saw in the [Lists] chapter, plus accompanying lemmas about its behavior. This time around, though, we're going to use _functions_, rather than lists of key-value pairs, to build maps. The advantage of this representation is that it offers a more _extensional_ view of maps, where two maps that respond to queries in the same way will be represented as literally the same thing (the very same function), rather than just "equivalent" data structures. This, in turn, simplifies proofs that use maps. We build partial maps in two steps. First, we define a type of _total maps_ that return a default value when we look up a key that is not present in the map. *) Definition total_map (A:Type) := id -> A. (** Intuitively, a total map over an element type [A] is just a function that can be used to look up [id]s, yielding [A]s. The function [t_empty] yields an empty total map, given a default element; this map always returns the default element when applied to any id. *) Definition t_empty {A:Type} (v : A) : total_map A := (fun _ => v). (** More interesting is the [update] function, which (as before) takes a map [m], a key [x], and a value [v] and returns a new map that takes [x] to [v] and takes every other key to whatever [m] does. *) Definition t_update {A:Type} (m : total_map A) (x : id) (v : A) := fun x' => if beq_id x x' then v else m x'. (** This definition is a nice example of higher-order programming: [t_update] takes a _function_ [m] and yields a new function [fun x' => ...] that behaves like the desired map. For example, we can build a map taking [id]s to [bool]s, where [Id 3] is mapped to [true] and every other key is mapped to [false], like this: *) Definition examplemap := t_update (t_update (t_empty false) (Id "foo") false) (Id "bar") true. (** This completes the definition of total maps. Note that we don't need to define a [find] operation because it is just function application! *) Example update_example1 : examplemap (Id "baz") = false. Proof. reflexivity. Qed. Example update_example2 : examplemap (Id "foo") = false. Proof. reflexivity. Qed. Example update_example3 : examplemap (Id "quux") = false. Proof. reflexivity. Qed. Example update_example4 : examplemap (Id "bar") = true. Proof. reflexivity. Qed. (** To use maps in later chapters, we'll need several fundamental facts about how they behave. Even if you don't work the following exercises, make sure you thoroughly understand the statements of the lemmas! (Some of the proofs require the functional extensionality axiom, which is discussed in the [Logic] chapter.) *) (** **** Exercise: 1 star, optional (t_apply_empty) *) (** First, the empty map returns its default element for all keys: *) Lemma t_apply_empty: forall A x v, @t_empty A v x = v. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional (t_update_eq) *) (** Next, if we update a map [m] at a key [x] with a new value [v] and then look up [x] in the map resulting from the [update], we get back [v]: *) Lemma t_update_eq : forall A (m: total_map A) x v, (t_update m x v) x = v. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional (t_update_neq) *) (** On the other hand, if we update a map [m] at a key [x1] and then look up a _different_ key [x2] in the resulting map, we get the same result that [m] would have given: *) Theorem t_update_neq : forall (X:Type) v x1 x2 (m : total_map X), x1 <> x2 -> (t_update m x1 v) x2 = m x2. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional (t_update_shadow) *) (** If we update a map [m] at a key [x] with a value [v1] and then update again with the same key [x] and another value [v2], the resulting map behaves the same (gives the same result when applied to any key) as the simpler map obtained by performing just the second [update] on [m]: *) Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x, t_update (t_update m x v1) x v2 = t_update m x v2. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** For the final two lemmas about total maps, it's convenient to use the reflection idioms introduced in chapter [IndProp]. We begin by proving a fundamental _reflection lemma_ relating the equality proposition on [id]s with the boolean function [beq_id]. *) (** **** Exercise: 2 stars, optional (beq_idP) *) (** Use the proof of [beq_natP] in chapter [IndProp] as a template to prove the following: *) Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** Now, given [id]s [x1] and [x2], we can use the [destruct (beq_idP x1 x2)] to simultaneously perform case analysis on the result of [beq_id x1 x2] and generate hypotheses about the equality (in the sense of [=]) of [x1] and [x2]. *) (** **** Exercise: 2 stars (t_update_same) *) (** With the example in chapter [IndProp] as a template, use [beq_idP] to prove the following theorem, which states that if we update a map to assign key [x] the same value as it already has in [m], then the result is equal to [m]: *) Theorem t_update_same : forall X x (m : total_map X), t_update m x (m x) = m. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, recommended (t_update_permute) *) (** Use [beq_idP] to prove one final property of the [update] function: If we update a map [m] at two distinct keys, it doesn't matter in which order we do the updates. *) Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2 (m : total_map X), x2 <> x1 -> (t_update (t_update m x2 v2) x1 v1) = (t_update (t_update m x1 v1) x2 v2). Proof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Partial maps *) (** Finally, we define _partial maps_ on top of total maps. A partial map with elements of type [A] is simply a total map with elements of type [option A] and default element [None]. *) Definition partial_map (A:Type) := total_map (option A). Definition empty {A:Type} : partial_map A := t_empty None. Definition update {A:Type} (m : partial_map A) (x : id) (v : A) := t_update m x (Some v). (** We now straightforwardly lift all of the basic lemmas about total maps to partial maps. *) Lemma apply_empty : forall A x, @empty A x = None. Proof. intros. unfold empty. rewrite t_apply_empty. reflexivity. Qed. Lemma update_eq : forall A (m: partial_map A) x v, (update m x v) x = Some v. Proof. intros. unfold update. rewrite t_update_eq. reflexivity. Qed. Theorem update_neq : forall (X:Type) v x1 x2 (m : partial_map X), x2 <> x1 -> (update m x2 v) x1 = m x1. Proof. intros X v x1 x2 m H. unfold update. rewrite t_update_neq. reflexivity. apply H. Qed. Lemma update_shadow : forall A (m: partial_map A) v1 v2 x, update (update m x v1) x v2 = update m x v2. Proof. intros A m v1 v2 x1. unfold update. rewrite t_update_shadow. reflexivity. Qed. Theorem update_same : forall X v x (m : partial_map X), m x = Some v -> update m x v = m. Proof. intros X v x m H. unfold update. rewrite <- H. apply t_update_same. Qed. Theorem update_permute : forall (X:Type) v1 v2 x1 x2 (m : partial_map X), x2 <> x1 -> (update (update m x2 v2) x1 v1) = (update (update m x1 v1) x2 v2). Proof. intros X v1 v2 x1 x2 m. unfold update. apply t_update_permute. Qed. (** $Date: 2017-03-05 16:25:50 -0500 (Sun, 05 Mar 2017) $ *) QuickChick-2.1.0/sf-experiment/Poly.v000066400000000000000000000206531476030541200174400ustar00rootroot00000000000000(** * Poly: Polymorphism and Higher-Order Functions *) From QuickChick Require Import QuickChick. Import QcDefaultNotation. Open Scope qc_scope. Import GenLow GenHigh. Require Import List ZArith. Import ListNotations. Set Warnings "-notation-overridden,-parsing". (* Require Export Lists. *) (* Inductive list (X:Type) : Type := | nil : list X | cons : X -> list X -> list X. Derive Arbitrary for list. Derive Show for list. Instance list_eq (X : Type) (H : forall (a b : X), Dec (a = b)) (x y : list X) : Dec (x = y). constructor. unfold ssrbool.decidable. repeat (decide equality). apply H. Defined. *) Fixpoint repeat (X : Type) (x : X) (count : nat) : list X := match count with | 0 => nil | S count' => cons x (repeat X x count') end. (** As with [nil] and [cons], we can use [repeat] by applying it first to a type and then to its list argument: *) QuickChick ( (repeat nat 4 2 = cons 4 (cons 4 (nil)))? ). Arguments repeat {X} x count. Notation "x :: y" := (cons x y) (at level 60, right associativity). Notation "[ ]" := nil. Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..). Notation "x ++ y" := (app x y) (at level 60, right associativity). Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X*Y) := match lx, ly with | [], _ => [] | _, [] => [] | x :: tx, y :: ty => (x, y) :: (combine tx ty) end. (** **** Exercise: 2 stars, recommended (split) *) (** The function [split] is the right inverse of [combine]: it takes a list of pairs and returns a pair of lists. In many functional languages, it is called [unzip]. Fill in the definition of [split] below. Make sure it passes the given unit test. *) Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X) * (list Y) := ([],[]). Definition split_combineP l1 l2 := (split (combine l1 l2) = (l1,l2))?. QuickChick (expectFailure split_combineP). Fixpoint filter {X:Type} (test: X->bool) (l:list X) : (list X) := match l with | [] => [] | h :: t => if test h then h :: (filter test t) else filter test t end. (** **** Exercise: 3 stars (partition) *) (** Use [filter] to write a Coq function [partition]: partition : forall X : Type, (X -> bool) -> list X -> list X * list X Given a set [X], a test function of type [X -> bool] and a [list X], [partition] should return a pair of lists. The first member of the pair is the sublist of the original list containing the elements that satisfy the test, and the second is the sublist containing those that fail the test. The order of elements in the two sublists should be the same as their order in the original list. *) Definition partition {X : Type} (test : X -> bool) (l : list X) : list X * list X (* REPLACE THIS LINE WITH ":= _your_definition_ ." *) := ([],[]). (* QuickCheck (fun {X:Type} (l: list X) => checker false). ==> Error: Conversion test raised an anomaly *) From QuickChick Require Import CoArbitrary. Require Import String. Open Scope string. Instance show_natfun : Show (nat -> bool) := {| show f := "{" ++ "0 |-> " ++ (show (f 0) ) ++ ", 1 |-> " ++ (show (f 1) ) ++ ", 2 |-> " ++ (show (f 2) ) ++ ", 3 |-> " ++ (show (f 3) ) ++ ", 4 |-> " ++ (show (f 4)) ++ "}" |}. QuickCheck (fun (test: nat -> bool) (l: list nat) => checker false). Fixpoint map {X Y:Type} (f:X->Y) (l:list X) : (list Y) := match l with | [] => [] | h :: t => (f h) :: (map f t) end. Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X), map f (rev l) = rev (map f l). Admitted. (* LEO: Uh oh -- same issue *) Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X) : (list Y) (* REPLACE THIS LINE WITH ":= _your_definition_ ." *) := []. Definition option_map {X Y : Type} (f : X -> Y) (xo : option X) : option Y := match xo with | None => None | Some x => Some (f x) end. Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y) : Y := match l with | nil => b | h :: t => f h (fold f t b) end. Definition constfun {X: Type} (x: X) : nat->X := fun (k:nat) => x. Definition ftrue := constfun true. Definition fold_length {X : Type} (l : list X) : nat := fold (fun _ n => S n) l 0. Definition fold_length_correctP := fun X (l : list X) => (fold_length l = length (l++l))?. (*! QuickCheck fold_length_correctP. *) Definition fold_length_correctP_bad := fun X (l : list X) => (fold_length l = length (l++l))?. QuickCheck (expectFailure fold_length_correctP). Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** Write down a theorem [fold_map_correct] in Coq stating that [fold_map] is correct, and prove it. *) (* LEO: ... :-? *) Definition prod_curry {X Y Z : Type} (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y). (** As an exercise, define its inverse, [prod_uncurry]. Then prove the theorems below to show that the two are inverses. *) Definition prod_uncurry {X Y Z : Type} (f : X -> Y -> Z) (p : X * Y) : Z (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** As a (trivial) example of the usefulness of currying, we can use it to shorten one of the examples that we saw above: *) (* LEO: Getting even more challenging... *) Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y, prod_curry (prod_uncurry f) x y = f x y. Proof. (* FILL IN HERE *) Admitted. Theorem curry_uncurry : forall (X Y Z : Type) (f : (X * Y) -> Z) (p : X * Y), prod_uncurry (prod_curry f) p = f p. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 4 stars, advanced (church_numerals) *) (** This exercise explores an alternative way of defining natural numbers, using the so-called _Church numerals_, named after mathematician Alonzo Church. We can represent a natural number [n] as a function that takes a function [f] as a parameter and returns [f] iterated [n] times. *) Module Church. Definition nat := forall X : Type, (X -> X) -> X -> X. (** Let's see how to write some numbers with this notation. Iterating a function once should be the same as just applying it. Thus: *) Definition one : nat := fun (X : Type) (f : X -> X) (x : X) => f x. (** Similarly, [two] should apply [f] twice to its argument: *) Definition two : nat := fun (X : Type) (f : X -> X) (x : X) => f (f x). (** Defining [zero] is somewhat trickier: how can we "apply a function zero times"? The answer is actually simple: just return the argument untouched. *) Definition zero : nat := fun (X : Type) (f : X -> X) (x : X) => x. (** More generally, a number [n] can be written as [fun X f x => f (f ... (f x) ...)], with [n] occurrences of [f]. Notice in particular how the [doit3times] function we've defined previously is actually just the Church representation of [3]. *) (** Complete the definitions of the following functions. Make sure that the corresponding unit tests pass by proving them with [reflexivity]. *) (** Successor of a natural number: *) Definition succ (n : nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example succ_1 : succ zero = one. Proof. (* FILL IN HERE *) Admitted. Example succ_2 : succ one = two. Proof. (* FILL IN HERE *) Admitted. (** Addition of two natural numbers: *) Definition plus (n m : nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example plus_1 : plus zero one = one. Proof. (* FILL IN HERE *) Admitted. (** Multiplication: *) Definition mult (n m : nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example mult_1 : mult one one = one. Proof. (* FILL IN HERE *) Admitted. (** Exponentiation: *) (** (_Hint_: Polymorphism plays a crucial role here. However, choosing the right type to iterate over can be tricky. If you hit a "Universe inconsistency" error, try iterating over a different type: [nat] itself is usually problematic.) *) Definition exp (n m : nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example exp_1 : exp two two = plus two two. Proof. (* FILL IN HERE *) Admitted. End Church. QuickChick-2.1.0/sf-experiment/Postscript.v000066400000000000000000000064201476030541200206630ustar00rootroot00000000000000(** * Postscript *) (** Congratulations: We've made it to the end! *) (* ################################################################# *) (** * Looking Back *) (** We've covered quite a bit of ground so far. Here's a quick review... - _Functional programming_: - "declarative" programming style (recursion over persistent data structures, rather than looping over mutable arrays or pointer structures) - higher-order functions - polymorphism *) (** - _Logic_, the mathematical basis for software engineering: logic calculus -------------------- ~ ---------------------------- software engineering mechanical/civil engineering - inductively defined sets and relations - inductive proofs - proof objects *) (** - _Coq_, an industrial-strength proof assistant - functional core language - core tactics - automation *) (* ################################################################# *) (** * Looking Forward *) (** If what you've seen so far has whetted your interest, you have two choices for further reading in the _Software Foundations_ series: - _Programming Language Foundations_ (volume 2, by a similar set of authors to this book) covers material that might be found in a graduate course on the theory of programming languages, including Hoare logic, operational semantics, and type systems. - _Verified Functional Algorithms_ (volume 3, by Andrew Appel) builds on the themes of functional programming and program verification in Coq, addressing a range of topics that might be found in a standard data structures course, with an eye to formal verification. *) (* ################################################################# *) (** * Other sources *) (** Here are some other good places to learn more... - This book includes some optional chapters covering topics that you may find useful. Take a look at the table of contents and the chapter dependency diagram to find them. - If you're interested in real-world applications of formal verification to critical software, see the Postscript chapter of _Programming Language Foundations_. - Here are some great books on functional programming - Learn You a Haskell for Great Good, by Miran Lipovaca [Lipovaca 2011]. - Real World Haskell, by Bryan O'Sullivan, John Goerzen, and Don Stewart [O'Sullivan 2008] - ...and many other excellent books on Haskell, OCaml, Scheme, Racket, Scala, F sharp, etc., etc. - And some deeper resources for Coq: - Verified Functional Algorithms, by Andrew Appel [Chlipala 2013]. - Certified Programming with Dependent Types, by Adam Chlipala [Chlipala 2013]. - Interactive Theorem Proving and Program Development: Coq'Art: The Calculus of Inductive Constructions, by Yves Bertot and Pierre Casteran [Bertot 2004]. *) (* $Date: 2017-05-23 13:45:44 -0400 (Tue, 23 May 2017) $ *) QuickChick-2.1.0/sf-experiment/Preface.v000066400000000000000000000461301476030541200200600ustar00rootroot00000000000000(** * Preface *) (* ################################################################# *) (** * Welcome *) (** This is the entry point in a series of electronic textbooks on various aspects of _Software Foundations_ -- the mathematical underpinnings of reliable software. Topics in the series include basic concepts of logic, computer-assisted theorem proving, the Coq proof assistant, functional programming, operational semantics, logics for reasoning about programs, and static type systems. The exposition is intended for a broad range of readers, from advanced undergraduates to PhD students and researchers. No specific background in logic or programming languages is assumed, though a degree of mathematical maturity will be helpful. The principal novelty of the series is that it is one hundred percent formalized and machine-checked: each text is literally a script for Coq. The books are intended to be read alongside (or inside) an interactive session with Coq. All the details in the text are fully formalized in Coq, and most of the exercises are designed to be worked using Coq. The files in each book are organized into a sequence of core chapters, covering about one semester's worth of material and organized into a coherent linear narrative, plus a number of "offshoot" chapters covering additional topics. All the core chapters are suitable for both upper-level undergraduate and graduate students. This book, _Logical Foundations_, lays groundwork for the others, introducing the reader to the basic ideas of functional programming, constructive logic, and the Coq proof assistant. *) (* ################################################################# *) (** * Overview *) (** Building reliable software is hard. The scale and complexity of modern systems, the number of people involved in building them, and the range of demands placed on them make it extremely difficult to build software that is even more-or-less correct, much less 100%% correct. At the same time, the increasing degree to which information processing is woven into every aspect of society greatly amplifies the cost of bugs and insecurities. Computer scientists and software engineers have responded to these challenges by developing a whole host of techniques for improving software reliability, ranging from recommendations about managing software projects teams (e.g., extreme programming) to design philosophies for libraries (e.g., model-view-controller, publish-subscribe, etc.) and programming languages (e.g., object-oriented programming, aspect-oriented programming, functional programming, ...) to mathematical techniques for specifying and reasoning about properties of software and tools for helping validate these properties. The _Software Foundations_ series is focused on this last set of techniques. The text is constructed around three conceptual threads: (1) basic tools from _logic_ for making and justifying precise claims about programs; (2) the use of _proof assistants_ to construct rigorous logical arguments; (3) _functional programming_, both as a method of programming that simplifies reasoning about programs and as a bridge between programming and logic. Some suggestions for further reading can be found in the [Postscript] chapter. Bibliographic information for all cited works can be found in the file [Bib]. *) (* ================================================================= *) (** ** Logic *) (** Logic is the field of study whose subject matter is _proofs_ -- unassailable arguments for the truth of particular propositions. Volumes have been written about the central role of logic in computer science. Manna and Waldinger called it "the calculus of computer science," while Halpern et al.'s paper _On the Unusual Effectiveness of Logic in Computer Science_ catalogs scores of ways in which logic offers critical tools and insights. Indeed, they observe that, "As a matter of fact, logic has turned out to be significiantly more effective in computer science than it has been in mathematics. This is quite remarkable, especially since much of the impetus for the development of logic during the past one hundred years came from mathematics." In particular, the fundamental tools of _inductive proof_ are ubiquitous in all of computer science. You have surely seen them before, perhaps in a course on discrete math or analysis of algorithms, but in this course we will examine them much more deeply than you have probably done so far. *) (* ================================================================= *) (** ** Proof Assistants *) (** The flow of ideas between logic and computer science has not been unidirectional: CS has also made important contributions to logic. One of these has been the development of software tools for helping construct proofs of logical propositions. These tools fall into two broad categories: - _Automated theorem provers_ provide "push-button" operation: you give them a proposition and they return either _true_ or _false_ (or, sometimes, _don't know: ran out of time_). Although their capabilities are still limited to specific domains, they have matured tremendously in recent years and are used now in a multitude of settings. Examples of such tools include SAT solvers, SMT solvers, and model checkers. - _Proof assistants_ are hybrid tools that automate the more routine aspects of building proofs while depending on human guidance for more difficult aspects. Widely used proof assistants include Isabelle, Agda, Twelf, ACL2, PVS, and Coq, among many others. This course is based around Coq, a proof assistant that has been under development since 1983 and that in recent years has attracted a large community of users in both research and industry. Coq provides a rich environment for interactive development of machine-checked formal reasoning. The kernel of the Coq system is a simple proof-checker, which guarantees that only correct deduction steps are ever performed. On top of this kernel, the Coq environment provides high-level facilities for proof development, including a large library of common definitions and lemmas, powerful tactics for constructing complex proofs semi-automatically, and a special-purpose programming language for defining new proof-automation tactics for specific situations. Coq has been a critical enabler for a huge variety of work across computer science and mathematics: - As a _platform for modeling programming languages_, it has become a standard tool for researchers who need to describe and reason about complex language definitions. It has been used, for example, to check the security of the JavaCard platform, obtaining the highest level of common criteria certification, and for formal specifications of the x86 and LLVM instruction sets and programming languages such as C. - As an _environment for developing formally certified software and hardware_, Coq has been used, for example, to build CompCert, a fully-verified optimizing compiler for C, and CertiKos, a fully verified hypervisor, for proving the correctness of subtle algorithms involving floating point numbers, and as the basis for CertiCrypt, an environment for reasoning about the security of cryptographic algorithms. It is also being used to build verified implementations of the open-source RISC-V processor. - As a _realistic environment for functional programming with dependent types_, it has inspired numerous innovations. For example, the Ynot system embeds "relational Hoare reasoning" (an extension of the _Hoare Logic_ we will see later in this course) in Coq. - As a _proof assistant for higher-order logic_, it has been used to validate a number of important results in mathematics. For example, its ability to include complex computations inside proofs made it possible to develop the first formally verified proof of the 4-color theorem. This proof had previously been controversial among mathematicians because part of it included checking a large number of configurations using a program. In the Coq formalization, everything is checked, including the correctness of the computational part. More recently, an even more massive effort led to a Coq formalization of the Feit-Thompson Theorem -- the first major step in the classification of finite simple groups. By the way, in case you're wondering about the name, here's what the official Coq web site at INRIA (the French national research lab where Coq has mostly been developed) says about it: "Some French computer scientists have a tradition of naming their software as animal species: Caml, Elan, Foc or Phox are examples of this tacit convention. In French, 'coq' means rooster, and it sounds like the initials of the Calculus of Constructions (CoC) on which it is based." The rooster is also the national symbol of France, and C-o-q are the first three letters of the name of Thierry Coquand, one of Coq's early developers. *) (* ================================================================= *) (** ** Functional Programming *) (** The term _functional programming_ refers both to a collection of programming idioms that can be used in almost any programming language and to a family of programming languages designed to emphasize these idioms, including Haskell, OCaml, Standard ML, F##, Scala, Scheme, Racket, Common Lisp, Clojure, Erlang, and Coq. Functional programming has been developed over many decades -- indeed, its roots go back to Church's lambda-calculus, which was invented in the 1930s, well before the first computers (at least the first electronic ones)! But since the early '90s it has enjoyed a surge of interest among industrial engineers and language designers, playing a key role in high-value systems at companies like Jane St. Capital, Microsoft, Facebook, and Ericsson. The most basic tenet of functional programming is that, as much as possible, computation should be _pure_, in the sense that the only effect of execution should be to produce a result: it should be free from _side effects_ such as I/O, assignments to mutable variables, redirecting pointers, etc. For example, whereas an _imperative_ sorting function might take a list of numbers and rearrange its pointers to put the list in order, a pure sorting function would take the original list and return a _new_ list containing the same numbers in sorted order. A significant benefit of this style of programming is that it makes programs easier to understand and reason about. If every operation on a data structure yields a new data structure, leaving the old one intact, then there is no need to worry about how that structure is being shared and whether a change by one part of the program might break an invariant that another part of the program relies on. These considerations are particularly critical in concurrent systems, where every piece of mutable state that is shared between threads is a potential source of pernicious bugs. Indeed, a large part of the recent interest in functional programming in industry is due to its simpler behavior in the presence of concurrency. Another reason for the current excitement about functional programming is related to the first: functional programs are often much easier to parallelize than their imperative counterparts. If running a computation has no effect other than producing a result, then it does not matter _where_ it is run. Similarly, if a data structure is never modified destructively, then it can be copied freely, across cores or across the network. Indeed, the "Map-Reduce" idiom, which lies at the heart of massively distributed query processors like Hadoop and is used by Google to index the entire web is a classic example of functional programming. For purposes of this course, functional programming has yet another significant attraction: it serves as a bridge between logic and computer science. Indeed, Coq itself can be viewed as a combination of a small but extremely expressive functional programming language plus a set of tools for stating and proving logical assertions. Moreover, when we come to look more closely, we find that these two sides of Coq are actually aspects of the very same underlying machinery -- i.e., _proofs are programs_. *) (* ================================================================= *) (** ** Further Reading *) (** This text is intended to be self contained, but readers looking for a deeper treatment of particular topics will find some suggestions for further reading in the [Postscript] chapter. *) (* ################################################################# *) (** * Practicalities *) (* ================================================================= *) (** ** Chapter Dependencies *) (** A diagram of the dependencies between chapters and some suggested paths through the material can be found in the file [deps.html]. *) (* ================================================================= *) (** ** System Requirements *) (** Coq runs on Windows, Linux, and OS X. You will need: - A current installation of Coq, available from the Coq home page. Everything should work with version 8.6. - An IDE for interacting with Coq. Currently, there are two choices: - Proof General is an Emacs-based IDE. It tends to be preferred by users who are already comfortable with Emacs. It requires a separate installation (google "Proof General"). Adventurous users of Coq within Emacs may also want to check out extensions such as [company-coq] and [control-lock]. - CoqIDE is a simpler stand-alone IDE. It is distributed with Coq, so it should be available once you have Coq installed. It can also be compiled from scratch, but on some platforms this may involve installing additional packages for GUI libraries and such. *) (* ================================================================= *) (** ** Exercises *) (** Each chapter includes numerous exercises. Each is marked with a "star rating," which can be interpreted as follows: - One star: easy exercises that underscore points in the text and that, for most readers, should take only a minute or two. Get in the habit of working these as you reach them. - Two stars: straightforward exercises (five or ten minutes). - Three stars: exercises requiring a bit of thought (ten minutes to half an hour). - Four and five stars: more difficult exercises (half an hour and up). Also, some exercises are marked "advanced," and some are marked "optional." Doing just the non-optional, non-advanced exercises should provide good coverage of the core material. Optional exercises provide a bit of extra practice with key concepts and introduce secondary themes that may be of interest to some readers. Advanced exercises are for readers who want an extra challenge and a deeper cut at the material. _Please do not post solutions to the exercises in a public place_. Software Foundations is widely used both for self-study and for university courses. Having solutions easily available makes it much less useful for courses, which typically have graded homework assignments. We especially request that readers not post solutions to the exercises anyplace where they can be found by search engines. *) (* ================================================================= *) (** ** Downloading the Coq Files *) (** A tar file containing the full sources for the "release version" of this book (as a collection of Coq scripts and HTML files) is available at http://www.cis.upenn.edu/~bcpierce/sf. (If you are using the book as part of a class, your professor may give you access to a locally modified version of the files, which you should use instead of the release version.) *) (* ################################################################# *) (** * Note for Instructors *) (** If you plan to use these materials in your own course, you will undoubtedly find things you'd like to change, improve, or add. Your contributions are welcome! In order to keep the legalities simple and to have a single point of responsibility in case the need should ever arise to adjust the license terms, sublicense, etc., we ask all contributors (i.e., everyone with access to the developers' repository) to assign copyright in their contributions to the appropriate "author of record," as follows: - I hereby assign copyright in my past and future contributions to the Software Foundations project to the Author of Record of each volume or component, to be licensed under the same terms as the rest of Software Foundations. I understand that, at present, the Authors of Record are as follows: For Volumes 1 and 2, known until 2016 as "Software Foundations" and from 2016 as (respectively) "Logical Foundations" and "Programming Foundations," the Author of Record is Benjamin Pierce. For Volume 3, "Verified Functional Algorithms", the Author of Record is Andrew W. Appel. For components outside of designated Volumes (e.g., typesetting and grading tools and other software infrastructure), the Author of Record is Benjamin Pierce. To get started, please send an email to Benjamin Pierce, describing yourself and how you plan to use the materials and including (1) the above copyright transfer text and (2) the result of doing "htpasswd -s -n NAME" where NAME is your preferred user name. We'll set you up with access to the subversion repository and developers' mailing lists. In the repository you'll find a file [INSTRUCTORS] with further instructions. *) (* ################################################################# *) (** * Translations *) (** Thanks to the efforts of a team of volunteer translators, _Software Foundations_ can be enjoyed in Japanese at http://proofcafe.org/sf. A Chinese translation is underway. *) (* ################################################################# *) (** * Thanks *) (** Development of the _Software Foundations_ series has been supported, in part, by the National Science Foundation under the NSF Expeditions grant 1521523, _The Science of Deep Specification_. *) (** $Date: 2017-05-23 13:45:44 -0400 (Tue, 23 May 2017) $ *) QuickChick-2.1.0/sf-experiment/ProofObjects.v000066400000000000000000000521141476030541200211110ustar00rootroot00000000000000(** * ProofObjects: The Curry-Howard Correspondence *) (** "_Algorithms are the computational content of proofs_." --Robert Harper *) Set Warnings "-notation-overridden,-parsing". Require Export IndProp. (** We have seen that Coq has mechanisms both for _programming_, using inductive data types like [nat] or [list] and functions over these types, and for _proving_ properties of these programs, using inductive propositions (like [ev]), implication, universal quantification, and the like. So far, we have mostly treated these mechanisms as if they were quite separate, and for many purposes this is a good way to think. But we have also seen hints that Coq's programming and proving facilities are closely related. For example, the keyword [Inductive] is used to declare both data types and propositions, and [->] is used both to describe the type of functions on data and logical implication. This is not just a syntactic accident! In fact, programs and proofs in Coq are almost the same thing. In this chapter we will study how this works. We have already seen the fundamental idea: provability in Coq is represented by concrete _evidence_. When we construct the proof of a basic proposition, we are actually building a tree of evidence, which can be thought of as a data structure. If the proposition is an implication like [A -> B], then its proof will be an evidence _transformer_: a recipe for converting evidence for A into evidence for B. So at a fundamental level, proofs are simply programs that manipulate evidence. *) (** Question: If evidence is data, what are propositions themselves? Answer: They are types! Look again at the formal definition of the [ev] property. *) Print ev. (* ==> Inductive ev : nat -> Prop := | ev_0 : ev 0 | ev_SS : forall n, ev n -> ev (S (S n)). *) (** Suppose we introduce an alternative pronunciation of "[:]". Instead of "has type," we can say "is a proof of." For example, the second line in the definition of [ev] declares that [ev_0 : ev 0]. Instead of "[ev_0] has type [ev 0]," we can say that "[ev_0] is a proof of [ev 0]." *) (** This pun between types and propositions -- between [:] as "has type" and [:] as "is a proof of" or "is evidence for" -- is called the _Curry-Howard correspondence_. It proposes a deep connection between the world of logic and the world of computation: propositions ~ types proofs ~ data values See [Wadler 2015] for a brief history and an up-to-date exposition. Many useful insights follow from this connection. To begin with, it gives us a natural interpretation of the type of the [ev_SS] constructor: *) Check ev_SS. (* ===> ev_SS : forall n, ev n -> ev (S (S n)) *) (** This can be read "[ev_SS] is a constructor that takes two arguments -- a number [n] and evidence for the proposition [ev n] -- and yields evidence for the proposition [ev (S (S n))]." *) (** Now let's look again at a previous proof involving [ev]. *) Theorem ev_4 : ev 4. Proof. apply ev_SS. apply ev_SS. apply ev_0. Qed. (** As with ordinary data values and functions, we can use the [Print] command to see the _proof object_ that results from this proof script. *) Print ev_4. (* ===> ev_4 = ev_SS 2 (ev_SS 0 ev_0) : ev 4 *) (** As a matter of fact, we can also write down this proof object _directly_, without the need for a separate proof script: *) Check (ev_SS 2 (ev_SS 0 ev_0)). (* ===> ev 4 *) (** The expression [ev_SS 2 (ev_SS 0 ev_0)] can be thought of as instantiating the parameterized constructor [ev_SS] with the specific arguments [2] and [0] plus the corresponding proof objects for its premises [ev 2] and [ev 0]. Alternatively, we can think of [ev_SS] as a primitive "evidence constructor" that, when applied to a particular number, wants to be further applied to evidence that that number is even; its type, forall n, ev n -> ev (S (S n)), expresses this functionality, in the same way that the polymorphic type [forall X, list X] expresses the fact that the constructor [nil] can be thought of as a function from types to empty lists with elements of that type. *) (** We saw in the [Logic] chapter that we can use function application syntax to instantiate universally quantified variables in lemmas, as well as to supply evidence for assumptions that these lemmas impose. For instance: *) Theorem ev_4': ev 4. Proof. apply (ev_SS 2 (ev_SS 0 ev_0)). Qed. (** We can now see that this feature is a trivial consequence of the status the Coq grants to proofs and propositions: Lemmas and hypotheses can be combined in expressions (i.e., proof objects) according to the same basic rules used for programs in the language. *) (* ################################################################# *) (** * Proof Scripts *) (** The _proof objects_ we've been discussing lie at the core of how Coq operates. When Coq is following a proof script, what is happening internally is that it is gradually constructing a proof object -- a term whose type is the proposition being proved. The tactics between [Proof] and [Qed] tell it how to build up a term of the required type. To see this process in action, let's use the [Show Proof] command to display the current state of the proof tree at various points in the following tactic proof. *) Theorem ev_4'' : ev 4. Proof. Show Proof. apply ev_SS. Show Proof. apply ev_SS. Show Proof. apply ev_0. Show Proof. Qed. (** At any given moment, Coq has constructed a term with a "hole" (indicated by [?Goal] here, and so on), and it knows what type of evidence is needed to fill this hole. Each hole corresponds to a subgoal, and the proof is finished when there are no more subgoals. At this point, the evidence we've built stored in the global context under the name given in the [Theorem] command. *) (** Tactic proofs are useful and convenient, but they are not essential: in principle, we can always construct the required evidence by hand, as shown above. Then we can use [Definition] (rather than [Theorem]) to give a global name directly to a piece of evidence. *) Definition ev_4''' : ev 4 := ev_SS 2 (ev_SS 0 ev_0). (** All these different ways of building the proof lead to exactly the same evidence being saved in the global environment. *) Print ev_4. (* ===> ev_4 = ev_SS 2 (ev_SS 0 ev_0) : ev 4 *) Print ev_4'. (* ===> ev_4' = ev_SS 2 (ev_SS 0 ev_0) : ev 4 *) Print ev_4''. (* ===> ev_4'' = ev_SS 2 (ev_SS 0 ev_0) : ev 4 *) Print ev_4'''. (* ===> ev_4''' = ev_SS 2 (ev_SS 0 ev_0) : ev 4 *) (** **** Exercise: 1 star (eight_is_even) *) (** Give a tactic proof and a proof object showing that [ev 8]. *) Theorem ev_8 : ev 8. Proof. (* FILL IN HERE *) Admitted. Definition ev_8' : ev 8 (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** [] *) (* ################################################################# *) (** * Quantifiers, Implications, Functions *) (** In Coq's computational universe (where data structures and programs live), there are two sorts of values with arrows in their types: _constructors_ introduced by [Inductive]-ly defined data types, and _functions_. Similarly, in Coq's logical universe (where we carry out proofs), there are two ways of giving evidence for an implication: constructors introduced by [Inductive]-ly defined propositions, and... functions! For example, consider this statement: *) Theorem ev_plus4 : forall n, ev n -> ev (4 + n). Proof. intros n H. simpl. apply ev_SS. apply ev_SS. apply H. Qed. (** What is the proof object corresponding to [ev_plus4]? We're looking for an expression whose _type_ is [forall n, ev n -> ev (4 + n)] -- that is, a _function_ that takes two arguments (one number and a piece of evidence) and returns a piece of evidence! Here it is: *) Definition ev_plus4' : forall n, ev n -> ev (4 + n) := fun (n : nat) => fun (H : ev n) => ev_SS (S (S n)) (ev_SS n H). (** Recall that [fun n => blah] means "the function that, given [n], yields [blah]," and that Coq treats [4 + n] and [S (S (S (S n)))] as synonyms. Another equivalent way to write this definition is: *) Definition ev_plus4'' (n : nat) (H : ev n) : ev (4 + n) := ev_SS (S (S n)) (ev_SS n H). Check ev_plus4''. (* ===> ev_plus4'' : forall n : nat, ev n -> ev (4 + n) *) (** When we view the proposition being proved by [ev_plus4] as a function type, one aspect of it may seem a little unusual. The second argument's type, [ev n], mentions the _value_ of the first argument, [n]. While such _dependent types_ are not found in conventional programming languages, they can be useful in programming too, as the recent flurry of activity in the functional programming community demonstrates. Notice that both implication ([->]) and quantification ([forall]) correspond to functions on evidence. In fact, they are really the same thing: [->] is just a shorthand for a degenerate use of [forall] where there is no dependency, i.e., no need to give a name to the type on the left-hand side of the arrow. *) (** For example, consider this proposition: *) Definition ev_plus2 : Prop := forall n, forall (E : ev n), ev (n + 2). (** A proof term inhabiting this proposition would be a function with two arguments: a number [n] and some evidence [E] that [n] is even. But the name [E] for this evidence is not used in the rest of the statement of [ev_plus2], so it's a bit silly to bother making up a name for it. We could write it like this instead, using the dummy identifier [_] in place of a real name: *) Definition ev_plus2' : Prop := forall n, forall (_ : ev n), ev (n + 2). (** Or, equivalently, we can write it in more familiar notation: *) Definition ev_plus2'' : Prop := forall n, ev n -> ev (n + 2). (** In general, "[P -> Q]" is just syntactic sugar for "[forall (_:P), Q]". *) (* ################################################################# *) (** * Programming with Tactics *) (** If we can build proofs by giving explicit terms rather than executing tactic scripts, you may be wondering whether we can build _programs_ using _tactics_ rather than explicit terms. Naturally, the answer is yes! *) Definition add1 : nat -> nat. intro n. Show Proof. apply S. Show Proof. apply n. Defined. Print add1. (* ==> add1 = fun n : nat => S n : nat -> nat *) Compute add1 2. (* ==> 3 : nat *) (** Notice that we terminate the [Definition] with a [.] rather than with [:=] followed by a term. This tells Coq to enter _proof scripting mode_ to build an object of type [nat -> nat]. Also, we terminate the proof with [Defined] rather than [Qed]; this makes the definition _transparent_ so that it can be used in computation like a normally-defined function. ([Qed]-defined objects are opaque during computation.) This feature is mainly useful for writing functions with dependent types, which we won't explore much further in this book. But it does illustrate the uniformity and orthogonality of the basic ideas in Coq. *) (* ################################################################# *) (** * Logical Connectives as Inductive Types *) (** Inductive definitions are powerful enough to express most of the connectives and quantifiers we have seen so far. Indeed, only universal quantification (and thus implication) is built into Coq; all the others are defined inductively. We'll see these definitions in this section. *) Module Props. (** ** Conjunction To prove that [P /\ Q] holds, we must present evidence for both [P] and [Q]. Thus, it makes sense to define a proof object for [P /\ Q] as consisting of a pair of two proofs: one for [P] and another one for [Q]. This leads to the following definition. *) Module And. Inductive and (P Q : Prop) : Prop := | conj : P -> Q -> and P Q. End And. (** Notice the similarity with the definition of the [prod] type, given in chapter [Poly]; the only difference is that [prod] takes [Type] arguments, whereas [and] takes [Prop] arguments. *) Print prod. (* ===> Inductive prod (X Y : Type) : Type := | pair : X -> Y -> X * Y. *) (** This should clarify why [destruct] and [intros] patterns can be used on a conjunctive hypothesis. Case analysis allows us to consider all possible ways in which [P /\ Q] was proved -- here just one (the [conj] constructor). Similarly, the [split] tactic actually works for any inductively defined proposition with only one constructor. In particular, it works for [and]: *) Lemma and_comm : forall P Q : Prop, P /\ Q <-> Q /\ P. Proof. intros P Q. split. - intros [HP HQ]. split. + apply HQ. + apply HP. - intros [HP HQ]. split. + apply HQ. + apply HP. Qed. (** This shows why the inductive definition of [and] can be manipulated by tactics as we've been doing. We can also use it to build proofs directly, using pattern-matching. For instance: *) Definition and_comm'_aux P Q (H : P /\ Q) := match H with | conj HP HQ => conj HQ HP end. Definition and_comm' P Q : P /\ Q <-> Q /\ P := conj (and_comm'_aux P Q) (and_comm'_aux Q P). (** **** Exercise: 2 stars, optional (conj_fact) *) (** Construct a proof object demonstrating the following proposition. *) Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** [] *) (** ** Disjunction The inductive definition of disjunction uses two constructors, one for each side of the disjunct: *) Module Or. Inductive or (P Q : Prop) : Prop := | or_introl : P -> or P Q | or_intror : Q -> or P Q. End Or. (** This declaration explains the behavior of the [destruct] tactic on a disjunctive hypothesis, since the generated subgoals match the shape of the [or_introl] and [or_intror] constructors. Once again, we can also directly write proof objects for theorems involving [or], without resorting to tactics. *) (** **** Exercise: 2 stars, optional (or_commut'') *) (** Try to write down an explicit proof object for [or_commut] (without using [Print] to peek at the ones we already defined!). *) Definition or_comm : forall P Q, P \/ Q -> Q \/ P (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** [] *) (** ** Existential Quantification To give evidence for an existential quantifier, we package a witness [x] together with a proof that [x] satisfies the property [P]: *) Module Ex. Inductive ex {A : Type} (P : A -> Prop) : Prop := | ex_intro : forall x : A, P x -> ex P. End Ex. (** This may benefit from a little unpacking. The core definition is for a type former [ex] that can be used to build propositions of the form [ex P], where [P] itself is a _function_ from witness values in the type [A] to propositions. The [ex_intro] constructor then offers a way of constructing evidence for [ex P], given a witness [x] and a proof of [P x]. The more familiar form [exists x, P x] desugars to an expression involving [ex]: *) Check ex (fun n => ev n). (* ===> exists n : nat, ev n : Prop *) (** Here's how to define an explicit proof object involving [ex]: *) Definition some_nat_is_even : exists n, ev n := ex_intro ev 4 (ev_SS 2 (ev_SS 0 ev_0)). (** **** Exercise: 2 stars, optional (ex_ev_Sn) *) (** Complete the definition of the following proof object: *) Definition ex_ev_Sn : ex (fun n => ev (S n)) (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** [] *) (* ================================================================= *) (** ** [True] and [False] *) (** The inductive definition of the [True] proposition is simple: *) Inductive True : Prop := | I : True. (** It has one constructor (so every proof of [True] is the same, so being given a proof of [True] is not informative.) *) (** [False] is equally simple -- indeed, so simple it may look syntactically wrong at first glance! *) Inductive False : Prop :=. (** That is, [False] is an inductive type with _no_ constructors -- i.e., no way to build evidence for it. *) End Props. (* ################################################################# *) (** * Equality *) (** Even Coq's equality relation is not built in. It has the following inductive definition. (Actually, the definition in the standard library is a small variant of this, which gives an induction principle that is slightly easier to use.) *) Module MyEquality. Inductive eq {X:Type} : X -> X -> Prop := | eq_refl : forall x, eq x x. Notation "x = y" := (eq x y) (at level 70, no associativity) : type_scope. (** The way to think about this definition is that, given a set [X], it defines a _family_ of propositions "[x] is equal to [y]," indexed by pairs of values ([x] and [y]) from [X]. There is just one way of constructing evidence for each member of this family: applying the constructor [eq_refl] to a type [X] and a value [x : X] yields evidence that [x] is equal to [x]. *) (** **** Exercise: 2 stars (leibniz_equality) *) (** The inductive definition of equality corresponds to _Leibniz equality_: what we mean when we say "[x] and [y] are equal" is that every property on [P] that is true of [x] is also true of [y]. *) Lemma leibniz_equality : forall (X : Type) (x y: X), x = y -> forall P:X->Prop, P x -> P y. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** We can use [eq_refl] to construct evidence that, for example, [2 = 2]. Can we also use it to construct evidence that [1 + 1 = 2]? Yes, we can. Indeed, it is the very same piece of evidence! The reason is that Coq treats as "the same" any two terms that are _convertible_ according to a simple set of computation rules. These rules, which are similar to those used by [Compute], include evaluation of function application, inlining of definitions, and simplification of [match]es. *) Lemma four: 2 + 2 = 1 + 3. Proof. apply eq_refl. Qed. (** The [reflexivity] tactic that we have used to prove equalities up to now is essentially just short-hand for [apply refl_equal]. In tactic-based proofs of equality, the conversion rules are normally hidden in uses of [simpl] (either explicit or implicit in other tactics such as [reflexivity]). But you can see them directly at work in the following explicit proof objects: *) Definition four' : 2 + 2 = 1 + 3 := eq_refl 4. Definition singleton : forall (X:Set) (x:X), []++[x] = x::[] := fun (X:Set) (x:X) => eq_refl [x]. End MyEquality. Definition quiz6 : exists x, x + 3 = 4 := ex_intro (fun z => (z + 3 = 4)) 1 (refl_equal 4). (* ================================================================= *) (** ** Inversion, Again *) (** We've seen [inversion] used with both equality hypotheses and hypotheses about inductively defined propositions. Now that we've seen that these are actually the same thing, we're in a position to take a closer look at how [inversion] behaves. In general, the [inversion] tactic... - takes a hypothesis [H] whose type [P] is inductively defined, and - for each constructor [C] in [P]'s definition, - generates a new subgoal in which we assume [H] was built with [C], - adds the arguments (premises) of [C] to the context of the subgoal as extra hypotheses, - matches the conclusion (result type) of [C] against the current goal and calculates a set of equalities that must hold in order for [C] to be applicable, - adds these equalities to the context (and, for convenience, rewrites them in the goal), and - if the equalities are not satisfiable (e.g., they involve things like [S n = O]), immediately solves the subgoal. *) (** _Example_: If we invert a hypothesis built with [or], there are two constructors, so two subgoals get generated. The conclusion (result type) of the constructor ([P \/ Q]) doesn't place any restrictions on the form of [P] or [Q], so we don't get any extra equalities in the context of the subgoal. _Example_: If we invert a hypothesis built with [and], there is only one constructor, so only one subgoal gets generated. Again, the conclusion (result type) of the constructor ([P /\ Q]) doesn't place any restrictions on the form of [P] or [Q], so we don't get any extra equalities in the context of the subgoal. The constructor does have two arguments, though, and these can be seen in the context in the subgoal. _Example_: If we invert a hypothesis built with [eq], there is again only one constructor, so only one subgoal gets generated. Now, though, the form of the [refl_equal] constructor does give us some extra information: it tells us that the two arguments to [eq] must be the same! The [inversion] tactic adds this fact to the context. *) (** $Date: 2017-04-26 17:33:43 -0400 (Wed, 26 Apr 2017) $ *) QuickChick-2.1.0/sf-experiment/Rel.v000066400000000000000000000304131476030541200172320ustar00rootroot00000000000000(** * Rel: Properties of Relations *) (** This short (and optional) chapter develops some basic definitions and a few theorems about binary relations in Coq. The key definitions are repeated where they are actually used (in the \CHAPV2{Smallstep} chapter of _Programming Language Foundations_), so readers who are already comfortable with these ideas can safely skim or skip this chapter. However, relations are also a good source of exercises for developing facility with Coq's basic reasoning facilities, so it may be useful to look at this material just after the [IndProp] chapter. *) Set Warnings "-notation-overridden,-parsing". Require Export IndProp. (** A binary _relation_ on a set [X] is a family of propositions parameterized by two elements of [X] -- i.e., a proposition about pairs of elements of [X]. *) Definition relation (X: Type) := X -> X -> Prop. (** Confusingly, the Coq standard library hijacks the generic term "relation" for this specific instance of the idea. To maintain consistency with the library, we will do the same. So, henceforth the Coq identifier [relation] will always refer to a binary relation between some set and itself, whereas the English word "relation" can refer either to the specific Coq concept or the more general concept of a relation between any number of possibly different sets. The context of the discussion should always make clear which is meant. *) (** An example relation on [nat] is [le], the less-than-or-equal-to relation, which we usually write [n1 <= n2]. *) Print le. (* ====> Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m *) Check le : nat -> nat -> Prop. Check le : relation nat. (** (Why did we write it this way instead of starting with [Inductive le : relation nat...]? Because we wanted to put the first [nat] to the left of the [:], which makes Coq generate a somewhat nicer induction principle for reasoning about [<=].) *) (* ################################################################# *) (** * Basic Properties *) (** As anyone knows who has taken an undergraduate discrete math course, there is a lot to be said about relations in general, including ways of classifying relations (as reflexive, transitive, etc.), theorems that can be proved generically about certain sorts of relations, constructions that build one relation from another, etc. For example... *) (* ----------------------------------------------------------------- *) (** *** Partial Functions *) (** A relation [R] on a set [X] is a _partial function_ if, for every [x], there is at most one [y] such that [R x y] -- i.e., [R x y1] and [R x y2] together imply [y1 = y2]. *) Definition partial_function {X: Type} (R: relation X) := forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2. (** For example, the [next_nat] relation defined earlier is a partial function. *) Print next_nat. (* ====> Inductive next_nat (n : nat) : nat -> Prop := nn : next_nat n (S n) *) Check next_nat : relation nat. Theorem next_nat_partial_function : partial_function next_nat. Proof. unfold partial_function. intros x y1 y2 H1 H2. inversion H1. inversion H2. reflexivity. Qed. (** However, the [<=] relation on numbers is not a partial function. (Assume, for a contradiction, that [<=] is a partial function. But then, since [0 <= 0] and [0 <= 1], it follows that [0 = 1]. This is nonsense, so our assumption was contradictory.) *) Theorem le_not_a_partial_function : ~ (partial_function le). Proof. unfold not. unfold partial_function. intros Hc. assert (0 = 1) as Nonsense. { apply Hc with (x := 0). - apply le_n. - apply le_S. apply le_n. } inversion Nonsense. Qed. (** **** Exercise: 2 stars, optional *) (** Show that the [total_relation] defined in earlier is not a partial function. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 2 stars, optional *) (** Show that the [empty_relation] that we defined earlier is a partial function. *) (* FILL IN HERE *) (** [] *) (* ----------------------------------------------------------------- *) (** *** Reflexive Relations *) (** A _reflexive_ relation on a set [X] is one for which every element of [X] is related to itself. *) Definition reflexive {X: Type} (R: relation X) := forall a : X, R a a. Theorem le_reflexive : reflexive le. Proof. unfold reflexive. intros n. apply le_n. Qed. (* ----------------------------------------------------------------- *) (** *** Transitive Relations *) (** A relation [R] is _transitive_ if [R a c] holds whenever [R a b] and [R b c] do. *) Definition transitive {X: Type} (R: relation X) := forall a b c : X, (R a b) -> (R b c) -> (R a c). Theorem le_trans : transitive le. Proof. intros n m o Hnm Hmo. induction Hmo. - (* le_n *) apply Hnm. - (* le_S *) apply le_S. apply IHHmo. Qed. Theorem lt_trans: transitive lt. Proof. unfold lt. unfold transitive. intros n m o Hnm Hmo. apply le_S in Hnm. apply le_trans with (a := (S n)) (b := (S m)) (c := o). apply Hnm. apply Hmo. Qed. (** **** Exercise: 2 stars, optional *) (** We can also prove [lt_trans] more laboriously by induction, without using [le_trans]. Do this.*) Theorem lt_trans' : transitive lt. Proof. (* Prove this by induction on evidence that [m] is less than [o]. *) unfold lt. unfold transitive. intros n m o Hnm Hmo. induction Hmo as [| m' Hm'o]. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional *) (** Prove the same thing again by induction on [o]. *) Theorem lt_trans'' : transitive lt. Proof. unfold lt. unfold transitive. intros n m o Hnm Hmo. induction o as [| o']. (* FILL IN HERE *) Admitted. (** [] *) (** The transitivity of [le], in turn, can be used to prove some facts that will be useful later (e.g., for the proof of antisymmetry below)... *) Theorem le_Sn_le : forall n m, S n <= m -> n <= m. Proof. intros n m H. apply le_trans with (S n). - apply le_S. apply le_n. - apply H. Qed. (** **** Exercise: 1 star, optional *) Theorem le_S_n : forall n m, (S n <= S m) -> (n <= m). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional (le_Sn_n_inf) *) (** Provide an informal proof of the following theorem: Theorem: For every [n], [~ (S n <= n)] A formal proof of this is an optional exercise below, but try writing an informal proof without doing the formal proof first. Proof: (* FILL IN HERE *) [] *) (** **** Exercise: 1 star, optional *) Theorem le_Sn_n : forall n, ~ (S n <= n). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** Reflexivity and transitivity are the main concepts we'll need for later chapters, but, for a bit of additional practice working with relations in Coq, let's look at a few other common ones... *) (* ----------------------------------------------------------------- *) (** *** Symmetric and Antisymmetric Relations *) (** A relation [R] is _symmetric_ if [R a b] implies [R b a]. *) Definition symmetric {X: Type} (R: relation X) := forall a b : X, (R a b) -> (R b a). (** **** Exercise: 2 stars, optional *) Theorem le_not_symmetric : ~ (symmetric le). Proof. (* FILL IN HERE *) Admitted. (** [] *) (** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together imply [a = b] -- that is, if the only "cycles" in [R] are trivial ones. *) Definition antisymmetric {X: Type} (R: relation X) := forall a b : X, (R a b) -> (R b a) -> a = b. (** **** Exercise: 2 stars, optional *) Theorem le_antisymmetric : antisymmetric le. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional *) Theorem le_step : forall n m p, n < m -> m <= S p -> n <= p. Proof. (* FILL IN HERE *) Admitted. (** [] *) (* ----------------------------------------------------------------- *) (** *** Equivalence Relations *) (** A relation is an _equivalence_ if it's reflexive, symmetric, and transitive. *) Definition equivalence {X:Type} (R: relation X) := (reflexive R) /\ (symmetric R) /\ (transitive R). (* ----------------------------------------------------------------- *) (** *** Partial Orders and Preorders *) (** A relation is a _partial order_ when it's reflexive, _anti_-symmetric, and transitive. In the Coq standard library it's called just "order" for short. *) Definition order {X:Type} (R: relation X) := (reflexive R) /\ (antisymmetric R) /\ (transitive R). (** A preorder is almost like a partial order, but doesn't have to be antisymmetric. *) Definition preorder {X:Type} (R: relation X) := (reflexive R) /\ (transitive R). Theorem le_order : order le. Proof. unfold order. split. - (* refl *) apply le_reflexive. - split. + (* antisym *) apply le_antisymmetric. + (* transitive. *) apply le_trans. Qed. (* ################################################################# *) (** * Reflexive, Transitive Closure *) (** The _reflexive, transitive closure_ of a relation [R] is the smallest relation that contains [R] and that is both reflexive and transitive. Formally, it is defined like this in the Relations module of the Coq standard library: *) Inductive clos_refl_trans {A: Type} (R: relation A) : relation A := | rt_step : forall x y, R x y -> clos_refl_trans R x y | rt_refl : forall x, clos_refl_trans R x x | rt_trans : forall x y z, clos_refl_trans R x y -> clos_refl_trans R y z -> clos_refl_trans R x z. (** For example, the reflexive and transitive closure of the [next_nat] relation coincides with the [le] relation. *) Theorem next_nat_closure_is_le : forall n m, (n <= m) <-> ((clos_refl_trans next_nat) n m). Proof. intros n m. split. - (* -> *) intro H. induction H. + (* le_n *) apply rt_refl. + (* le_S *) apply rt_trans with m. apply IHle. apply rt_step. apply nn. - (* <- *) intro H. induction H. + (* rt_step *) inversion H. apply le_S. apply le_n. + (* rt_refl *) apply le_n. + (* rt_trans *) apply le_trans with y. apply IHclos_refl_trans1. apply IHclos_refl_trans2. Qed. (** The above definition of reflexive, transitive closure is natural: it says, explicitly, that the reflexive and transitive closure of [R] is the least relation that includes [R] and that is closed under rules of reflexivity and transitivity. But it turns out that this definition is not very convenient for doing proofs, since the "nondeterminism" of the [rt_trans] rule can sometimes lead to tricky inductions. Here is a more useful definition: *) Inductive clos_refl_trans_1n {A : Type} (R : relation A) (x : A) : A -> Prop := | rt1n_refl : clos_refl_trans_1n R x x | rt1n_trans (y z : A) : R x y -> clos_refl_trans_1n R y z -> clos_refl_trans_1n R x z. (** Our new definition of reflexive, transitive closure "bundles" the [rt_step] and [rt_trans] rules into the single rule step. The left-hand premise of this step is a single use of [R], leading to a much simpler induction principle. Before we go on, we should check that the two definitions do indeed define the same relation... First, we prove two lemmas showing that [clos_refl_trans_1n] mimics the behavior of the two "missing" [clos_refl_trans] constructors. *) Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X), R x y -> clos_refl_trans_1n R x y. Proof. intros X R x y H. apply rt1n_trans with y. apply H. apply rt1n_refl. Qed. (** **** Exercise: 2 stars, optional (rsc_trans) *) Lemma rsc_trans : forall (X:Type) (R: relation X) (x y z : X), clos_refl_trans_1n R x y -> clos_refl_trans_1n R y z -> clos_refl_trans_1n R x z. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** Then we use these facts to prove that the two definitions of reflexive, transitive closure do indeed define the same relation. *) (** **** Exercise: 3 stars, optional (rtc_rsc_coincide) *) Theorem rtc_rsc_coincide : forall (X:Type) (R: relation X) (x y : X), clos_refl_trans R x y <-> clos_refl_trans_1n R x y. Proof. (* FILL IN HERE *) Admitted. (** [] *) (** $Date: 2017-04-26 17:33:43 -0400 (Wed, 26 Apr 2017) $ *) QuickChick-2.1.0/sf-experiment/Tactics.v000066400000000000000000000014501476030541200201010ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". Require Export Poly. (* BCP: Some more properties we might check earlier... *) Theorem beq_nat_sym : forall (n m : nat), beq_nat n m = beq_nat m n. Proof. (* FILL IN HERE *) Admitted. (** [] *) Theorem beq_nat_trans : forall n m p, beq_nat n m = true -> beq_nat m p = true -> beq_nat n p = true. Proof. (* FILL IN HERE *) Admitted. Definition split_combine_statement : Prop (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Theorem split_combine : split_combine_statement. Proof. (* FILL IN HERE *) Admitted. Theorem filter_exercise : forall (X : Type) (test : X -> bool) (x : X) (l lf : list X), filter test l = x :: lf -> test x = true. Proof. (* FILL IN HERE *) Admitted. (** [] *) QuickChick-2.1.0/src/000077500000000000000000000000001476030541200143215ustar00rootroot00000000000000QuickChick-2.1.0/src/.dir-locals.el000066400000000000000000000003271476030541200167540ustar00rootroot00000000000000((coq-mode . ((eval . (progn (make-local-variable 'coq-prog-args) (setq coq-prog-args `("-emacs" "-R" , (expand-file-name (locate-dominating-file buffer-file-name ".dir-locals.el")) "QuickChick" ))))))) QuickChick-2.1.0/src/.gitignore000066400000000000000000000000221476030541200163030ustar00rootroot00000000000000*.v.d *.glob *.vo QuickChick-2.1.0/src/Checker.v000066400000000000000000000342721476030541200160640ustar00rootroot00000000000000Set Implicit Arguments. Require Import String. Require Import List. Require Import RoseTrees. Require Import Show. Require Import State. Require Import Producer Generators. Require Import Classes. Require Import DependentClasses. (* Note : Simple Callbacks fall under strict positivity of result... *) Inductive CallbackKind := | Counterexample | NotCounterexample. Inductive SmallResult := MkSmallResult : option bool -> bool -> string -> bool -> list string -> option string -> SmallResult. Inductive Callback : Type := | PostTest : CallbackKind -> (State -> SmallResult -> nat) -> Callback | PostFinalFailure : CallbackKind -> (State -> SmallResult -> nat) -> Callback. Record Result := MkResult { ok : option bool; (* Test case result - maybe == discard *) expect : bool; (* If false, property should fail *) reason : string; (* Error message *) interrupted : bool; (* ? *) stamp : list string; (* Collected values for this test case *) callbacks : list Callback; result_tag : option string (* Tag - for better shrinking *) }. Definition debug_stamps s {A : Type} (r : Result) (x : A) := trace (s ++ (ShowFunctions.string_concat ( (ShowFunctions.intersperse " @ "%string (stamp r)))) ++ nl) x. (* I WANT RECORD UPDATES :'( *) Definition succeeded := MkResult (Some true ) true "" false nil nil None. Definition failed := MkResult (Some false) true "" false nil nil None. Definition rejected := MkResult ( None ) true "" false nil nil None. Definition updExpect (res : Result) (e' : bool) : Result := match res with | MkResult o e r i s c t => MkResult o e' r i s c t end. Definition updReason (r : Result) (s' : string) : Result := match r with | MkResult o e _ i s c t => MkResult o e s' i s c t end. Definition updOk (r : Result) o' : Result := match r with | MkResult _ e r i s c t => MkResult o' e r i s c t end. Definition addCallback (res : Result) (c : Callback) : Result := match res with | MkResult o e r i s cs t => MkResult o e r i s (cons c cs) t end. Definition addCallbacks (res : Result) (cs : list Callback) : Result := match res with | MkResult o e r i s cs' t => MkResult o e r i s (cs ++ cs') t end. Definition addStamps res ss := match res with | MkResult o e r i s cs t => MkResult o e r i (ss ++ s) cs t end. (* LEO: Should we check if there already exists a tag? *) Definition setTag (r : Result) (t' : string) : Result := match r with | MkResult o e r i s cs _ => MkResult o e r i s cs (Some t') end. (* CH: The name of this should change; we no longer call checkers props *) Record QProp : Type := MkProp { unProp : Rose Result }. Definition Checker : Type := G QProp. Class Checkable (A : Type) : Type := { checker : A -> Checker }. (* mapping and lifting functions *) Definition liftBool (b : bool) : Result := if b then succeeded else updReason failed "Falsifiable". Definition mapProp {P : Type} {_ : Checkable P} (f : QProp -> QProp) (prop : P) : Checker := fmap f (checker prop). Definition mapRoseResult {P : Type} {_ : Checkable P} (f : Rose Result -> Rose Result) (prop : P) : Checker := mapProp (fun p => match p with MkProp t => MkProp (f t) end) prop. Definition mapTotalResult {prop : Type} {_ : Checkable prop} (f : Result -> Result) : prop -> Checker := mapRoseResult (fmapRose f). Global Instance testResult : Checkable Result := {| (* Left a protectResults out! *) checker r := ret (MkProp (returnRose r)) |}. Global Instance testBool : Checkable bool := {| checker b := checker (liftBool b) |}. (* ZP/CH: what's the relation between unit and discards? *) Global Instance testUnit : Checkable unit := {| checker := fun _ => checker rejected |}. Global Instance testProp : Checkable QProp := {| checker p := returnGen p |}. Global Instance testGenProp (P : Type) `{Checkable P} : Checkable (G P) := {| checker p := bindGen p checker |}. Global Instance testChecker : Checkable Checker := {| checker x := x |}. (* Checker Combinators *) (* The following function on its own does not have a decreasing argument... Fixpoint props {prop A : Type} {t : Checkable prop} (pf : A -> prop) (shrinker : A -> list A) (x : A) := MkRose (checker (pf x)) (List.map (props pf shrinker) (shrinker x)). *) Fixpoint props' {prop A : Type} {t : Checkable prop} (n : nat) (pf : A -> prop) (shrinker : A -> list A) (x : A) := match n with | O => MkRose (checker (pf x)) (lazy nil) | S n' => MkRose (checker (pf x)) (lazy (List.map (props' n' pf shrinker) (shrinker x))) end. (* Arbitrary choice for number of shrinks.. *) Definition props {prop A : Type} `{Checkable prop} (pf : A -> prop) (shrinker : A -> list A) (x : A) : Rose Checker := props' 1000 pf shrinker x. Definition shrinking {prop A : Type} `{Checkable prop} (shrinker : A -> list A) (x0 : A) (pf : A -> prop) : Checker := fmap (fun x => MkProp (joinRose (fmapRose unProp x))) (promote (props pf shrinker x0)). Definition shrinkingNondet {prop A : Type} `{Checkable prop} (n : nat) (shrinker : A -> list A) (x0 : A) (pf : A -> prop) : Checker := fmap (fun x => MkProp (repeatRose n (joinRose (fmapRose unProp x)))) (promote (props pf shrinker x0)). Definition callback {prop : Type} `{Checkable prop} (cb : Callback) : prop -> Checker := mapTotalResult (fun r => addCallback r cb). Definition printTestCase {prop : Type} `{Checkable prop} (s : string) (p : prop) : Checker := (* The following newline was causing an unwanted extra new line *) callback (PostFinalFailure Counterexample (fun _st _res => trace (s (* ++ nl*)) 0)) p. Definition whenFail {prop : Type} `{Checkable prop} (str : string) : prop -> Checker := callback (PostFinalFailure Counterexample (fun _st _sr => trace (str ++ nl) 0)). Definition whenFail' {prop : Type} `{Checkable prop} (str : unit -> string) : prop -> Checker := callback (PostFinalFailure Counterexample (fun _st _sr => trace (str tt ++ nl) 0)). Notation "x 'WHENFAIL' y" := (whenFail' (fun _ => x) y) (at level 55). Definition expectFailure {prop: Type} `{Checkable prop} (p: prop) := mapTotalResult (fun res => updExpect res false) p. (* NOTE: Ignoring the nat argument. Use label or collect ONLY *) Definition cover {prop : Type} {_ : Checkable prop} (b : bool) (n : nat) (s : string) : prop -> Checker := if b then mapTotalResult (fun res => let '(MkResult o e r i st c t) := res in MkResult o e r i (s :: st) c t) else checker. Definition classify {prop : Type} {_ : Checkable prop} (b : bool) (s : string) : prop -> Checker := cover b 0 s. Definition label {prop : Type} {_ : Checkable prop} (s : string) : prop -> Checker := classify true s. Definition collect {A prop : Type} `{_ : Show A} {_ : Checkable prop} (x : A) : prop -> Checker := label (show x). Definition tag {prop : Type} {_ : Checkable prop} (t : string) : prop -> Checker := mapTotalResult (fun res => setTag res t). Definition implication {prop : Type} `{Checkable prop} (b : bool) (p : prop) : Checker := if b then checker p else (returnGen (MkProp (returnRose rejected))). Definition forAll {A prop : Type} {_ : Checkable prop} `{Show A} (gen : G A) (pf : A -> prop) : Checker := bindGen gen (fun x => printTestCase (show x ++ newline) (pf x)). Definition forAllMaybe {A prop : Type} {_ : Checkable prop} `{Show A} (gen : G (option A)) (pf : A -> prop) : Checker := bindGen gen (fun mx => match mx with | Some x => printTestCase (show x ++ newline) (pf x) | None => checker tt end ). Definition forAllProof {A prop : Type} {C : Checkable prop} `{S : Show A} (gen : G A) (pf : forall (x : A), semProd gen x -> prop) : Checker := @bindPf G ProducerGen _ _ gen (fun x H => printTestCase (show x ++ newline) (pf x H)). Arguments forAllProof {A} {prop} {C} {S} _ _. Definition forAllShrink {A prop : Type} {_ : Checkable prop} `{Show A} (gen : G A) (shrinker : A -> list A) (pf : A -> prop) : Checker := bindGen gen (fun x : A => shrinking shrinker x (fun x' => printTestCase (show x' ++ newline) (pf x'))). Definition forAllShrinkNonDet {A prop : Type} {_ : Checkable prop} `{Show A} (n : nat) (gen : G A) (shrinker : A -> list A) (pf : A -> prop) : Checker := bindGen gen (fun x : A => shrinkingNondet n shrinker x (fun x' => printTestCase (show x' ++ newline) (pf x'))). Definition forAllShrinkShow {A prop : Type} {_ : Checkable prop} (gen : G A) (shrinker : A -> list A) (show' : A -> string) (pf : A -> prop) : Checker := bindGen gen (fun x => shrinking shrinker x (fun x' => printTestCase (show' x') (pf x'))). Global Instance testFun {A prop : Type} `{Show A} `{Arbitrary A} `{_ : Checkable prop} : Checkable (A -> prop) := { checker f := forAllShrink arbitrary shrink f }. Global Instance testProd {A : Type} {prop : A -> Type} `{Show A} `{Arbitrary A} `{forall x : A, Checkable (prop x)} : Checkable (forall (x : A), prop x) := {| checker f := forAllShrink arbitrary shrink (fun x => checker (f x)) |}. Global Instance testPolyFun {prop : Type -> Type} {_ : Checkable (prop nat)} : Checkable (forall T, prop T) := { checker f := printTestCase "" (f nat) }. Global Instance testPolyFunSet {prop : Set -> Type} {_ : Checkable (prop nat)} : Checkable (forall T, prop T) := { checker f := printTestCase "" (f nat) }. (* LEO: TODO: Prove conjoin checker *) Definition addCallbacks' r result := addCallbacks result (callbacks r). Definition addStamps' r result := (* debug_stamps "Before_adding: " result ( debug_stamps "Adding_stamps: " r ( *) let res := addStamps result (stamp r) in (* debug_stamps "After_adding: " res *) res. Fixpoint conjAux (f : Result -> Result) l := match l with | nil => (MkRose (f succeeded) (lazy nil)) | cons res rs => let '(MkRose r _) := res in match ok r with | Some true => (conjAux (fun r' => addStamps' r (addCallbacks' r (f r')) ) rs) | Some false => res | None => let res' := conjAux (fun r' => (addCallbacks' r (f r'))) rs in let '(MkRose r' rs) := res' in match ok r' with | Some true => MkRose (updOk r' None) (lazy nil) | Some false => res' | None => res' end end end. Definition mapGen {A B} (f : A -> G B) (l : list A) : G (list B) := bindGen (foldProd (fun acc a => bindGen (f a) (fun b => returnGen (cons b acc))) l nil) (fun l => returnGen (rev l)). Definition conjoin (l : list Checker) : Checker := (* trace ("Beginnning conjoin" ++ nl) ( *) bindGen (mapGen (liftM unProp) l) (fun rs => (returnGen (MkProp (let res := conjAux (fun x => x) rs in let '(MkRose r _) := res in (* debug_stamps "Conjoin result: " r *) res )))). Definition fmapRose' A B (r : Rose A) (f : A -> B) := fmapRose f r. Definition expectFailureError := updReason failed "Expect failure cannot occur inside a disjunction". Definition disjAux (p q : Rose Result) : Rose Result := joinRose (fmapRose' p (fun result1 => if expect result1 then match ok result1 with | Some true => returnRose result1 | Some false => joinRose (fmapRose' q (fun result2 => if expect result2 then match ok result2 with | Some true => returnRose result2 | Some false => returnRose (MkResult (ok result2) (expect result2) (if string_dec (reason result2) EmptyString then reason result1 else reason result2) (orb (interrupted result1) (interrupted result2)) (stamp result1 ++ stamp result2) (callbacks result1 ++ cons (PostFinalFailure Counterexample (fun _ _ => trace newline 0)) nil ++ callbacks result2 ) (result_tag result2)) | None => returnRose result2 (* Leo: What to do here? *) end else returnRose expectFailureError)) | None => joinRose (fmapRose' p (fun result2 => if expect result2 then match ok result2 with | Some true => returnRose result2 | _ => returnRose result1 (* Not sure here as well *) end else returnRose expectFailureError)) end else returnRose expectFailureError)). Definition disjoin (l : list Checker) : Checker := bindGen (mapGen (liftM unProp) l) (fun rs => (returnGen (MkProp ( fold_right disjAux (returnRose failed) rs )))). Module QcNotation. Export QcDefaultNotation. Declare Scope Checker_scope. Notation "x ==> y" := (implication x y) (at level 55, right associativity) : Checker_scope. (* TODO: Figure out pretty printing too *) Notation "'FORALL' x : T , c" := (forAllShrink (@arbitrary T _) shrink (fun x => c)) (at level 200, x name, T at level 200, c at level 200, right associativity (* , format "'[' 'exists' '/ ' x .. y , '/ ' p ']'" *) ) : type_scope. Notation "'FORALL' x | P , c" := (forAllShrink (genST (fun x => P)) shrink (fun y => match y with | Some x => c | _ => checker tt end)) (at level 200, x name, P at level 200, c at level 200, right associativity) : type_scope. End QcNotation. QuickChick-2.1.0/src/CheckerProofs.v000066400000000000000000001127721476030541200172570ustar00rootroot00000000000000Require Import String. Require Import List. Require Import RoseTrees. Require Import Show. Require Import State. Require Import Producer Generators Enumerators. Require Import Classes. Require Import DependentClasses. Require Import Checker. Require Import Decidability. Require Import TacticsUtil. From Ltac2 Require Import Ltac2. Section TypeClasses. Class DecOptSizeMonotonic (P : Prop) {H : DecOpt P} := mon : forall s1 s2 b, s1 <= s2 -> decOpt s1 = Some b -> decOpt s2 = Some b. Class DecOptDecidable (P : Prop) {H : DecOpt P} := { wit : exists s a, decOpt s = Some a }. Class DecOptSoundPos (P : Prop) {H : DecOpt P} := sound : forall s, decOpt s = Some true -> P. Class DecOptCompletePos (P : Prop) {H : DecOpt P} := complete : P -> exists s, decOpt s = Some true. Class DecOptSoundNeg (P : Prop) {H : DecOpt P} := sound_neg : forall s, decOpt s = Some false -> ~ P. Class DecOptCompleteNeg (P : Prop) {H : DecOpt P} := complete_neg : ~ P -> exists s, decOpt s = Some false. Class DecOptCorrectPos (P : Prop) {H : DecOpt P} := { corr_sound : forall s, decOpt s = Some true -> P; corr_complete : P -> exists s, decOpt s = Some true }. Class DecOptCorrectNeg (P : Prop) {H : DecOpt P} := { corr_sound' : forall s, decOpt s = Some false -> ~ P; corr_complete' :~ P -> exists s, decOpt s = Some false }. Global Instance decSizeMonotonic (P : Prop) {_ : Dec P} : DecOptSizeMonotonic P. Proof. intro; intros; eapply H1. Qed. Global Instance decSoundPos (P : Prop) {_ : Dec P} : DecOptSoundPos P. Proof. intros s. unfold decOpt, dec_decOpt, Decidability.dec. destruct H. destruct dec; eauto. congruence. Qed. Global Instance decCompletePos (P : Prop) {_ : Dec P} : DecOptCompletePos P. Proof. intros s. unfold decOpt, dec_decOpt, Decidability.dec. destruct H. exists 0. destruct dec; eauto. congruence. Qed. Global Instance decCorrectPos (P : Prop) {_ : Dec P} : DecOptCorrectPos P. Proof. constructor. - intros s. unfold decOpt, dec_decOpt, Decidability.dec. destruct H. destruct dec; eauto. congruence. - intros s. unfold decOpt, dec_decOpt, Decidability.dec. destruct H. exists 0. destruct dec; eauto. congruence. Qed. Global Instance decCompleteNeg (P : Prop) {_ : Dec P} : DecOptCompleteNeg P. Proof. intros s. unfold decOpt, dec_decOpt, Decidability.dec. destruct H. exists 0. destruct dec; eauto. congruence. Qed. Global Instance decCorrectNeg (P : Prop) {_ : Dec P} : DecOptCorrectNeg P. Proof. constructor. - intros s. unfold decOpt, dec_decOpt, Decidability.dec. destruct H. destruct dec; eauto. congruence. - intros s. unfold decOpt, dec_decOpt, Decidability.dec. destruct H. exists 0. destruct dec; eauto. congruence. Qed. Global Instance decSoundNeg (P : Prop) {_ : Dec P} : DecOptSoundNeg P. Proof. intros s. unfold decOpt, dec_decOpt, dec. destruct H. destruct dec; eauto. congruence. Qed. Global Instance decOptSoundNeg (P : Prop) {H : DecOpt P} {Hm : DecOptSizeMonotonic P} {Hc : DecOptCompletePos P} : DecOptSoundNeg P. Proof. intros s Hopt HP. eapply Hc in HP. destruct HP. edestruct (Compare_dec.le_lt_dec s x). + eapply Hm in Hopt; eauto. congruence. + eapply Hm in H0 > [ | eapply PeanoNat.Nat.lt_le_incl; eassumption ]. congruence. Qed. Lemma reflect_decOpt (P : Prop) {Hd : Dec P} {Hm : DecOptSizeMonotonic P} {Hc : DecOptCompletePos P} {Hs : DecOptCorrectPos P} s b : decOpt s = Some b -> Bool.reflect P b. Proof. intros Heq. destruct b. - constructor. eapply Hs. eassumption. - constructor. intros HP. eapply decOptSoundNeg in Heq; now eauto. Qed. End TypeClasses. Section Lemmas. Lemma checker_backtrack_spec l : checker_backtrack l = Some true <-> exists f, List.In f l /\ f tt = Some true. Proof. unfold checker_backtrack. generalize false at 2. induction l. - intros b. destruct b; split; try (intros; congruence). * intros H. inv H. inv H0. inv H. * intros H. inv H. inv H0. inv H. - intros b. split. + intros H. destruct (a tt) eqn:Hdec. * destruct b0. exists a. split; eauto. now left. eapply IHl in H. destruct H. inv H. eexists; split; eauto. now right. * eapply IHl in H. destruct H. inv H. eexists; split; eauto. now right. + intros H. inv H. inv H0. inv H. rewrite H1. reflexivity. destruct (a tt). destruct b0. reflexivity. * eapply IHl. eexists. split; eauto. * eapply IHl. eexists. split; eauto. Qed. Lemma checker_backtrack_spec_false l : checker_backtrack l = Some false <-> (forall f, List.In f l -> f tt = Some false). Proof. unfold checker_backtrack. induction l. - split; eauto. intros Heq; intros f Hin; inv Hin. - destruct (a tt) eqn:Hdec. * destruct b. -- split. congruence. intros Hin. assert (Hc : a tt = Some false). { eapply Hin. now left. } congruence. -- split. ++ intros Haux f Hin. inv Hin; eauto. eapply IHl; eauto. ++ intros Hin. eapply IHl. intros. eapply Hin. now right. * split. -- intros H1 f Hin. revert H1. clear. intros H1; induction l. congruence. destruct (a tt). ++ destruct b. congruence. eauto. ++ eauto. -- intros Hall. assert (Hc : a tt = Some false). { eapply Hall. now left. } congruence. Qed. Lemma destruct_match_true_l (check b : option bool): match check with | Some true => b | Some false => Some false | None => None end = Some true -> check = Some true /\ b = Some true. Proof. intros H. destruct check as [ [ | ] | ]; eauto; discriminate. Qed. Lemma destruct_match_false_l (check b : option bool): match check with | Some false => b | Some true => Some false | None => None end = Some true -> check = Some false /\ b = Some true. Proof. intros H. destruct check as [ [ | ] | ]; eauto; discriminate. Qed. Lemma destruct_match_true_r (check b : option bool): check = Some true -> b = Some true -> match check with | Some true => b | Some false => Some false | None => None end = Some true. Proof. intros H1 H2. destruct check as [ [ | ] | ]; eauto; discriminate. Qed. Lemma exists_match check k s1 : check s1 = Some true -> (forall s1 s2, s1 <= s2 -> check s1 = Some true -> check s2 = Some true) -> (exists s, k (max s1 s) = Some true) -> (exists (s : nat) , match check s with | Some true => k s | Some false => Some false | None => None end = Some true). Proof. intros Hch Hmon Hk. destruct Hk as [s2 Hk]. eexists (max s1 s2). erewrite Hmon > [ | | eassumption ]. eassumption. lia. Qed. Lemma exists_match_decOpt P {_ : DecOpt P} { _ : DecOptSizeMonotonic P } s1 k : decOpt s1 = Some true -> (exists s, k (max s1 s) = Some true) -> (exists (s : nat), match decOpt s with | Some true => k s | Some false => Some false | None => None end = Some true). Proof. intros. eapply exists_match; eauto. Qed. Lemma checker_backtrack_spec_exists (l : nat -> list (unit -> option bool)) : (exists (f : nat -> (unit -> option bool)), (forall s, List.In (f s) (l s)) /\ exists s, f s tt = Some true) -> exists s, checker_backtrack (l s) = Some true. Proof. intros [f [Hall [s Heq]]]. eexists s. eapply checker_backtrack_spec. eexists. split; eauto. Qed. Lemma exists_Sn (P : nat -> Prop) : (exists n, P (S n)) -> exists n, P n. Proof. intros [n H]. eexists; eauto. Qed. Lemma exfalso_none_some_false (P : Prop) : (fun (_ : unit) => None) tt = Some false -> P. Proof. congruence. Qed. Lemma enumerating_complete' A (e : E A) ch {Hm : SizeMonotonic e} {Hc : Correct A e} : (forall x s1 s2, (s1 <= s2) -> ch s1 x = Some true -> ch s2 x = Some true) -> (exists x s, ch s x = Some true) -> (exists (s : nat), enumerating e (ch s) s = Some true). Proof. intros Hmon [x [s Hch]]. unfold enumerating. assert (Hin : semProd e x). { eapply Hc. reflexivity. } destruct Hin as [s' [_ Hsem]]. simpl in *. unfold semEnumSize in *. assert (Hsem' : LazyList.In_ll x (Enumerators.run e (max s s'))). { eapply Hm > [| simpl; eassumption ]. lia. } clear Hsem. exists (max s s'). revert Hsem'. generalize (Enumerators.run e (max s s')), false. induction l; intros b Hin; inv Hin; simpl. - erewrite Hmon > [ reflexivity | | eassumption ]. lia. - destruct (ch (Nat.max s s') a); eauto. destruct b0; eauto. Qed. Lemma enumeratingOpt_complete' A (e : E (option A)) ch P {Hm : SizeMonotonicOpt e} {Hc : CorrectST P e} : (forall x s1 s2, (s1 <= s2) -> ch s1 x = Some true -> ch s2 x = Some true) -> (exists x, P x /\ exists s, ch s x = Some true) -> (exists (s : nat), enumeratingOpt e (ch s) s = Some true). Proof. intros Hmon [x [Hp [s Hch]]]. unfold enumeratingOpt. assert (Hin : semProdOpt e x). { eapply Hc. eassumption. } destruct Hin as [s' [_ Hsem]]. simpl in *. unfold semEnumSize in *. assert (Hsem' : LazyList.In_ll (Some x) (Enumerators.run e (max s s'))). { eapply Hm > [| simpl; eassumption ]. lia. } clear Hsem. exists (max s s'). revert Hsem'. generalize (Enumerators.run e (max s s')), false. induction l; intros b Hin; inv Hin; simpl. - erewrite Hmon > [ reflexivity | | eassumption ]. lia. - destruct a; eauto. destruct (ch (Nat.max s s') a); eauto. destruct b0; eauto. Qed. Lemma enumeratingOpt_complete_simpl' A (e : E (option A)) ch {Hm : SizeMonotonicOpt e} {Hc : Correct (option A) e} : (forall x s1 s2, (s1 <= s2) -> ch s1 x = Some true -> ch s2 x = Some true) -> (exists x s, ch s x = Some true) -> (exists (s : nat), enumeratingOpt e (ch s) s = Some true). Proof. intros Hmon [x [s Hch]]. unfold enumeratingOpt. assert (Hin : semProd e (Some x)). { eapply Hc. reflexivity. } destruct Hin as [s' [_ Hsem]]. simpl in *. unfold semEnumSize in *. assert (Hsem' : LazyList.In_ll (Some x) (Enumerators.run e (max s s'))). { eapply Hm > [| simpl; eassumption ]. lia. } clear Hsem. exists (max s s'). revert Hsem'. generalize (Enumerators.run e (max s s')), false. induction l; intros b Hin; inv Hin; simpl. - erewrite Hmon > [ reflexivity | | eassumption ]. lia. - destruct a; eauto. destruct (ch (Nat.max s s') a); eauto. destruct b0; eauto. Qed. Lemma exists_match' check k s1 : check s1 = Some true -> (forall s1 s2, (s1 <= s2) -> check s1 = Some true -> check s2 = Some true) -> (forall s1 s2, (s1 <= s2) -> k s1 = Some true -> k s2 = Some true) -> (exists s, k s = Some true) -> (exists (s : nat) , match check s with | Some true => k s | Some false => Some false | None => None end = Some true). Proof. intros Hch Hmon Hmon' Hk. destruct Hk as [s2 Hk]. eexists (max s1 s2). erewrite Hmon > [ | | eassumption ]. eapply Hmon' > [ | eassumption ]. lia. lia. Qed. Lemma exists_match_false' check k s1 : check s1 = Some false -> (forall s1 s2, (s1 <= s2) -> check s1 = Some false -> check s2 = Some false) -> (forall s1 s2, (s1 <= s2) -> k s1 = Some true -> k s2 = Some true) -> (exists s, k s = Some true) -> (exists (s : nat) , match check s with | Some false => k s | Some true => Some false | None => None end = Some true). Proof. intros Hch Hmon Hmon' Hk. destruct Hk as [s2 Hk]. eexists (max s1 s2). erewrite Hmon > [ | | eassumption ]. eapply Hmon' > [ | eassumption ]. lia. lia. Qed. End Lemmas. (** Monotonicity *) Ltac2 revert_params (l : ident list) := List.iter (fun x => try (revert $x)) l. Ltac2 intro_params (l : ident list) := List.iter (fun x => try (intro $x)) (List.rev l). Ltac2 rec in_list_last (_ : unit) := match! goal with | [ |- List.In _ (Datatypes.cons _ Datatypes.nil) ] => now left | [ |- List.In _ (Datatypes.cons _ _) ] => right; in_list_last () end. Ltac2 simpl_minus_methods (_ : unit) := ltac1:(with_strategy opaque [enumSizeST enum decOpt enumSized] simplstar). Ltac2 find_size_mon_inst (_ : unit) := first [ tci | eapply sizedSizeMonotonicOpt; tci | eapply sizedSizeMonotonic; tci ]. Ltac2 find_size_fp_inst (_ : unit) := first [ tci | eapply sizedSizeFP; tci ]. Ltac2 handle_checker_mon_t (ih : ident) (heq : ident) := first [ (* decOpt matcing *) let heq1 := Fresh.in_goal heq in let heq' := Control.hyp heq in (* because apply .... in $heq doesn't work *) first [ assert ($heq1 := destruct_match_true_l _ _ $heq') | assert ($heq1 := destruct_match_false_l _ _ $heq') ]; clear $heq; let heq1 := Control.hyp heq1 in let hdec := Fresh.in_goal (id_of_string "Hdec") in destruct $heq1 as [$hdec $heq]; first [ (* other decOpt *) match! goal with | [ h : @decOpt ?p _ ?s = Some _ |- _ ] => eapply (@mon $p _ _) in $h > [ | eassumption ]; let hdec' := Control.hyp hdec in rewrite $hdec'; clear $hdec end | (* rec call *) let ih := Control.hyp ih in eapply $ih in $hdec > [ | first [ eassumption | now eapply le_S_n; eauto ] | eassumption ]; let hdec' := Control.hyp hdec in rewrite $hdec'; clear $hdec ] | (* input matching *) match! goal with | [h : match ?m with _ => _ end = Some true |- _ ] => destruct $m; try (congruence) end (* | (* enumerating *) *) (* XXX all enumerators should be OPT. This case should not arise *) (* eapply enumerating_monotonic > *) (* [ now find_size_mon_inst () *) (* | eassumption *) (* | intro; clear $heq; simpl_minus_methods (); intro $heq *) (* | eassumption ] *) | (* enumeratingOpt *) eapply enumeratingOpt_monotonic > [ now find_size_mon_inst () | now find_size_fp_inst () | eassumption | intro; simpl_minus_methods (); clear $heq; intro $heq | eassumption ] | reflexivity ]. Ltac2 rec base_case_mont_aux (t : unit) (path : unit -> unit) := match! goal with | [h : List.In _ Datatypes.nil |- _ ] => let h := Control.hyp h in destruct $h | [h : List.In _ (Datatypes.cons ?g Datatypes.nil) |- _ ] => let h := Control.hyp h in destruct $h > [ subst; congruence | base_case_mont_aux () path ] | [h : List.In _ (Datatypes.cons ?g ?gs) |- _ ] => let h := Control.hyp h in try (destruct $h > [ eexists; split > [ path () ; left ; reflexivity | subst; now repeat (simpl_minus_methods (); handle_checker_mon_t @IH1 @Heq) ] | ]); base_case_mont_aux () (fun _ => path (); right) end. Ltac2 rec ind_case_mont_aux (ih : ident) (heq : ident) (path : unit -> unit) := match! goal with | [h : List.In _ Datatypes.nil |- _ ] => let h := Control.hyp h in destruct $h | [h : List.In _ (Datatypes.cons ?g ?gs) |- _ ] => let h := Control.hyp h in destruct $h > [ eexists; split > [ path () ; left ; reflexivity | subst; now repeat (simpl_minus_methods (); handle_checker_mon_t @IH1 @Heq) ] | ind_case_mont_aux ih heq (fun _ => path (); right) ] end. Ltac2 base_case_mont (t : unit) := base_case_mont_aux () (fun _ => ()). Ltac2 ind_case_mont (ih : ident) (heq : ident) := ind_case_mont_aux ih heq (fun _ => ()). Ltac2 handle_checker_mon_f (ih : ident) (heqb : ident) := first [ congruence | (* decOpt matching *) let heqb := Fresh.in_goal @heqb in match! goal with | [ _ : match ?e with | Some _ => match _ with | true => _ | false => _ end | None => _ end = Some false |- _ ] => (destruct $e as [ [ | ] | ] eqn:$heqb > [ | | congruence ]); first [ match! goal with | [ h : @decOpt ?p _ ?s = Some _ |- _ ] => eapply (@mon $p _ _) in $h > [ | eassumption ]; let heqb' := Control.hyp heqb in rewrite $heqb'; clear $heqb; try reflexivity end | let ih := Control.hyp ih in eapply $ih in $heqb > [ | now eapply le_S_n; eauto | eassumption ]; let heqb' := Control.hyp heqb in rewrite $heqb'; clear $heqb; try reflexivity ] end | (* input matching *) match! goal with | [ _ : match ?e with _ => _ end = Some false |- _ ] => destruct $e; try reflexivity end (* | (* enumerating *) *) (* XXX all enumerators should be OPT. This case should not arise *) (* eapply enumerating_monotonic > *) (* [ now find_size_mon_inst () *) (* | eassumption *) (* | intro; simpl_minus_methods (); clear $heqb; intro $heqb *) (* | eassumption ] *) | (* enumeratingOpt *) eapply enumeratingOpt_monotonic > [ now find_size_mon_inst () | now find_size_fp_inst () | eassumption | intro; simpl_minus_methods (); clear $heqb; intro $heqb | eassumption ] ]. Ltac2 rec base_case_monf_aux (heqb : ident) (path : unit -> unit) := match! goal with | [h : List.In _ Datatypes.nil |- _ ] => let h := Control.hyp h in destruct $h | [h : List.In _ (Datatypes.cons ?g ?gs) |- _ ] => let h := Control.hyp h in first [ (destruct $h > [ eapply checker_backtrack_spec_false in Hdec (* TODO fix name ... *) > [ | path (); now left ]; subst; simpl_minus_methods (); now repeat (handle_checker_mon_f @dummy heqb) | base_case_monf_aux heqb (fun _ => path (); right) ] ) | base_case_monf_aux heqb (fun _ => path (); right) ] end. Ltac2 base_case_monf (heqb : ident) := base_case_monf_aux heqb (fun _ => ()). (* Zoe : if it has inductive cases this is required... *) Ltac2 base_case_monf_None (_ : unit) := apply exfalso_none_some_false; (eapply checker_backtrack_spec_false with (f := (fun (_ : unit) => @None bool))) > [ eassumption | in_list_last () ]. Ltac2 rec ind_case_monf_aux (t : unit) (path : unit -> unit) := match! goal with | [h : List.In _ Datatypes.nil |- _ ] => let h := Control.hyp h in destruct $h | [h : List.In _ (Datatypes.cons ?g ?gs) |- _ ] => let h := Control.hyp h in destruct $h > [ eapply checker_backtrack_spec_false in Hdec (* TODO fix name ... *) > [ | path (); now left ] | ind_case_monf_aux () (fun _ => path (); right) ] end. Ltac2 ind_case_monf (ih : ident) (heqb : ident) := (ind_case_monf_aux () (fun _ => ())); subst; repeat (simpl_minus_methods (); handle_checker_mon_f ih heqb). Ltac2 derive_mon_aux (l : ident list) := (induction s1 as [ | s1 IH1 ]; (intro_params l; intros s2 b s2' s1' Hleq Hleq' Hdec); destruct b) > [ (* base case true *) (destruct s2; (* simplify and apply checker_backtrack_spec *) apply checker_backtrack_spec in Hdec; destruct Hdec as [f [Hin Heq]]; apply checker_backtrack_spec) > [ first [ eassumption | now base_case_mont () ] | now base_case_mont () ] | (* base case false *) first [ now base_case_monf_None () | (destruct s2; eapply checker_backtrack_spec_false; intros f Hin) > [ first [ eassumption | now base_case_monf @Heq ] | now base_case_monf @Heq ] ] | (* ind case true *) destruct s2 > [ lia | ]; (* simplify and apply checker_backtrack_spec *) apply checker_backtrack_spec in Hdec; destruct Hdec as [f [Hin Heq]]; apply checker_backtrack_spec; now ind_case_mont @IH1 @Heq | (* ind case false *) destruct s2 > [ lia | ]; eapply checker_backtrack_spec_false; intros f Hin; now ind_case_monf @IH1 @Heq ]. Ltac2 derive_mon (_ : unit) := match! goal with | [ |- DecOptSizeMonotonic ?e ] => match Constr.Unsafe.kind e with | Constr.Unsafe.App ty args => let l := constrs_to_idents (Array.to_list args) in intros s1 s2 b Hleq; unfold decOpt; simpl_minus_methods (); assert (Hleq' := &Hleq); revert Hleq Hleq'; generalize &s1 at 2 3 as s1'; generalize &s2 at 2 3 as s2'; revert s2 b; revert_params l; derive_mon_aux l | _ => () end end. (* For deriving monotonicity inside the completness proof *) Ltac2 derive_mon_true (l : ident list) := (intro s1; induction s1 as [ | s1 IH1 ]; intros s2 s2' s1' Hleq Hleq'; intro_params l; intro Hdec) > [ (* base case true *) (destruct s2; (* simplify and apply checker_backtrack_spec *) apply checker_backtrack_spec in Hdec; destruct Hdec as [f [Hin Heq]]; apply checker_backtrack_spec) > [ first [ eassumption | now base_case_mont () ] | now base_case_mont () ] | (* ind case true *) destruct s2 > [ lia | ]; (* (* simplify and apply checker_backtrack_spec *) *) apply checker_backtrack_spec in Hdec; destruct Hdec as [f [Hin Heq]]; apply checker_backtrack_spec; now ind_case_mont @IH1 @Heq ]. (** Soundness *) Ltac2 find_CorrectST_inst (_ : unit) := match! goal with | [ |- CorrectST _ (sizedEnum (@enumSizeST ?t ?pred ?inst)) ] => eapply (@size_CorrectST $t $pred E _ _) > [ tci | find_size_mon_inst () | eauto 20 with typeclass_instances ] end. Ltac2 handle_checker_match_sound (ih : ident) (heq : ident) := first [ (* match is the current inductive type *) let heq1 := Fresh.in_goal heq in let heq' := Control.hyp heq in assert ($heq1 := destruct_match_true_l _ _ $heq'); clear $heq; let heq1 := Control.hyp heq1 in let ih := Control.hyp ih in let hdec := Fresh.in_goal (id_of_string "Hdec") in destruct $heq1 as [$hdec $heq]; eapply $ih in $hdec | (* match is an other inductive type *) let heq1 := Fresh.in_goal heq in let heq' := Control.hyp heq in first [ assert ($heq1 := destruct_match_true_l _ _ $heq') | assert ($heq1 := destruct_match_false_l _ _ $heq') ]; clear $heq; let heq1 := Control.hyp heq1 in let hdec := Fresh.in_goal (id_of_string "Hdec") in destruct $heq1 as [$hdec $heq]; (* TODO match hdec directly *) match! goal with | [ h : @decOpt ?p _ ?s = Some true |- _ ] => eapply (@sound $p _ _) in $h | [ h : @decOpt ?p _ ?s = Some false |- _ ] => eapply (@sound_neg $p _ _) in $h end | (* match is an input *) match! goal with | [h : match ?m with _ => _ end = Some true |- _ ] => destruct $m; try (congruence) end | (* enumeratingOpt constrained *) match! goal with | [h : enumeratingOpt _ _ _ = Some true |- _ ] => eapply enumeratingOpt_sound in $h > [ | find_CorrectST_inst () ]; let h' := Control.hyp h in destruct $h' as [? [? $h ]] end | (* enumeratingOpt simpl *) match! goal with | [h : enumeratingOpt _ _ _ = Some true |- _ ] => eapply enumeratingOpt_sound_simpl in $h; let h' := Control.hyp h in destruct $h' as [? $h] end ]. Ltac2 eauto_using t := ltac1:(t |- eauto using t) (Ltac1.of_constr t). Ltac2 rec base_case_sound (heq : ident) (ty : constr) := match! goal with | [h : List.In _ Datatypes.nil |- _ ] => let h := Control.hyp h in destruct $h | [h : List.In _ (Datatypes.cons ?g Datatypes.nil) |- _ ] => let h := Control.hyp h in (destruct $h > [ subst; congruence | base_case_sound heq ty]) | [h : List.In _ (Datatypes.cons ?g ?gs) |- _ ] => let h := Control.hyp h in let hdummy := Fresh.in_goal (id_of_string "Hdummy") in (destruct $h > [ subst; repeat (handle_checker_match_sound hdummy heq); subst; first [ eauto_using ty | now (pose $ty; eauto 20) ] | base_case_sound heq ty ]) end. Ltac2 rec ind_case_sound (ih : ident) (heq : ident) (ty : constr) := match! goal with | [h : List.In _ Datatypes.nil |- _ ] => let h := Control.hyp h in destruct $h | [h : List.In _ (Datatypes.cons ?g ?gs) |- _ ] => let h := Control.hyp h in (destruct $h > [ subst; repeat (handle_checker_match_sound ih heq); subst; first [ eauto_using ty | now (pose $ty; eauto 20) ] | ind_case_sound ih heq ty ]) end. Ltac2 derive_sound (_ : unit) := match! goal with | [ |- DecOptSoundPos ?e ] => match Constr.Unsafe.kind e with | Constr.Unsafe.App ty args => let l := constrs_to_idents (Array.to_list args) in intros s; unfold decOpt; simpl_minus_methods (); (* assert (Hleq' := &Hleq); revert Hleq Hleq'; *) generalize &s at 1 as s'; revert_params l; ((induction s as [ | s IH1 ]); intro_params l; intros s' Hdec; eapply checker_backtrack_spec in Hdec; destruct Hdec as [f [Hin Htrue]]) > [ base_case_sound @Htrue ty | ind_case_sound @IH1 @Htrue ty ] | _ => () end end. (** Completeness *) Ltac2 make_prod (bs : constr array) (c : constr) := let bs := Array.map (fun b => let t := Constr.type b in Constr.Binder.make (Some (constr_to_ident b)) t) bs in Array.fold_left (fun t b => Constr.Unsafe.make (Constr.Unsafe.Prod b t)) c bs. (* Proves monotonicity assertion inside completness proof *) Ltac2 prove_mon (_ : unit) := match! goal with | [ |- ex ?p ] => match Constr.Unsafe.kind p with | Constr.Unsafe.Lambda b eq => match Constr.Unsafe.kind eq with | Constr.Unsafe.App t eq_args => let app := Array.get eq_args 1 in match Constr.Unsafe.kind app with | Constr.Unsafe.App aux args => let make_eq (lhs : constr) := let a := Array.copy eq_args in Array.set a 1 lhs; Constr.Unsafe.make (Constr.Unsafe.App t a) in let make_impl (t1 : constr) (t2 : constr) := let b := Constr.Binder.make None t1 in Constr.Unsafe.make (Constr.Unsafe.Prod b t2) in let inner_term (t1 : constr) (t2 : constr) := make_impl (make_eq t1) (make_eq t2) in let len := Int.sub (Array.length args) 2 in let inps := Array.sub args 2 len in let args (s1 : constr) (s2 : constr) (offs : int) := let ind := Array.mapi (fun i _ => Constr.Unsafe.make (Constr.Unsafe.Rel (Int.add i offs))) inps in let a := Array.make 2 s1 in Array.set a 1 s2; Array.append a ind in let term (s1 : constr) (s2 : constr) (offs : int) := Constr.Unsafe.make (Constr.Unsafe.App aux (args s1 s2 offs)) in let prod_term (t1 : constr) (t2 : constr) := make_prod inps (inner_term t1 t2) in let mon (s1 : constr) (s2 : constr) (s1' : constr) (s2' : constr) := let t1 := (term s1' s1 1) in let t2 := (term s2' s2 2) in prod_term t1 t2 in let l := constrs_to_idents (Array.to_list inps) in assert (Hmon : forall (s1 : nat) (s2 s2' s1': nat), s1 <= s2 -> s1' <= s2' -> ltac2:(let s1 := Control.hyp @s1 in let s1' := Control.hyp @s1' in let s2 := Control.hyp @s2 in let s2' := Control.hyp @s2' in let t := mon s1 s2 s1' s2' in exact $t)) > [ List.iter clear_dependent l; now derive_mon_true l | ] | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a lambda")))) end end. Ltac2 prove_ih (ih : ident) := match! goal with | [ |- ex ?p ] => match Constr.Unsafe.kind p with | Constr.Unsafe.Lambda b eq => match Constr.Unsafe.kind eq with | Constr.Unsafe.App t eq_args => let m := Array.get eq_args 1 in match Constr.Unsafe.kind m with | Constr.Unsafe.Case _ _ _ a _ => match Constr.Unsafe.kind a with | Constr.Unsafe.App f args => let make_app (a : constr) := let args' := Array.copy args in let _ := Array.set args' 0 a in let _ := Array.set args' 1 a in let a := Constr.Unsafe.App f args' in Constr.Unsafe.make a in let ih := Fresh.in_goal (id_of_string "IH") in let s := Fresh.in_goal (id_of_string "s") in (* Create the IH and prove it from the context. *) (* Kind of hacky because I don't know how to create a cpattern from the term. *) assert ($ih : exists (k : nat), ltac2:(let b := Control.hyp @k in let t := make_app b in exact $t) = Some true) by eassumption | _ => () (* Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an app")))) *) end | _ => () (* Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a case")))) *) end | _ => () (* Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an app")))) *) end | _ => () (* Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a lambda")))) *) end end. Ltac2 destructIH (_ : unit) := match! goal with | [ h : (exists s, _ = Some true) |- _ ] => let h' := Control.hyp h in destruct $h' end. Ltac2 rec handle_checker (hmon : ident) := first [ exists 0 ; reflexivity | match! goal with | [ |- exists s, match @decOpt ?p ?i _ with _ => _ end = Some true ] => let hc := Fresh.in_goal (id_of_string "Hc") in let s := Fresh.in_goal (id_of_string "s") in assert ($hc := @complete $p _ _ (ltac2:(now eauto))); let hc1 := Control.hyp hc in destruct $hc1 as [$s $hc]; let s1 := Control.hyp s in eapply exists_match' with (s1 := $s1) > [ eapply (@mon $p _ _) > [ | eassumption ]; lia | intros; eapply (@mon $p _ _) > [ | eassumption ]; lia | let heq := Fresh.in_goal (id_of_string "_heq") in intros ? ? ? $heq; now repeat (simpl_minus_methods (); handle_checker_mon_t hmon heq) | handle_checker hmon ] end | match! goal with | [ |- exists s, match @decOpt ?p ?i _ with _ => _ end = Some true ] => let hc := Fresh.in_goal (id_of_string "Hc") in let s := Fresh.in_goal (id_of_string "s") in assert ($hc := @complete_neg $p _ _ (ltac2:(now eauto))); let hc1 := Control.hyp hc in destruct $hc1 as [$s $hc]; let s1 := Control.hyp s in eapply exists_match_false' with (s1 := $s1) > [ eapply (@mon $p _ _) > [ | eassumption ]; lia | intros; eapply (@mon $p _ _) > [ | eassumption ]; lia | let heq := Fresh.in_goal (id_of_string "_heq") in intros ? ? ? $heq; now repeat (simpl_minus_methods (); handle_checker_mon_t hmon heq) | handle_checker hmon ] end | (* let ih := Fresh.in_goal (id_of_string "IH") in *) (* let s := Fresh.in_goal (id_of_string "s") in *) (* prove_ih ih; *) (* let ih1 := Control.hyp ih in *) (* destruct $ih1 as [$s $ih]; *) (* let s1 := Control.hyp s in *) (* TODO remove comments when stable *) eapply exists_match' > [ () | let hmon := Control.hyp hmon in intros; eapply $hmon > [| | eassumption ] > [ lia | lia ] | let heq := Fresh.in_goal (id_of_string "_heq") in intros ? ? ? $heq; now repeat (simpl_minus_methods (); handle_checker_mon_t hmon heq) | handle_checker hmon ]; eassumption | (* enumeratingOpt constrained *) eapply enumeratingOpt_complete' > [ now find_size_mon_inst () | now find_CorrectST_inst () | let heq := Fresh.in_goal (id_of_string "_heq") in intros ? ? ? ? $heq; now repeat (simpl_minus_methods (); handle_checker_mon_t hmon heq) | eexists; split > [ | handle_checker hmon ] ]; eassumption | (* enumeratingOpt constrained alt *) eapply enumeratingOpt_complete' > [ now find_size_mon_inst () | now find_CorrectST_inst () | let heq := Fresh.in_goal (id_of_string "_heq") in intros ? ? ? ? $heq; now repeat (simpl_minus_methods (); handle_checker_mon_t hmon heq) | eexists; split > [ eassumption | handle_checker hmon ] ] | (* enumeratingOpt simpl *) eapply enumeratingOpt_complete_simpl' > [ now find_size_mon_inst () | tci | let heq := Fresh.in_goal (id_of_string "_heq") in intros ? ? ? ? $heq; now repeat (simpl_minus_methods (); handle_checker_mon_t hmon heq) | eexists; handle_checker hmon ] ]. Ltac2 rec path_aux (m : int) (n : int) := match Int.equal n m with | true => left | false => right; path_aux m (Int.add n 1) end. Ltac2 rec path (n : int) := path_aux n 0. Ltac2 handle_base_case (hmon : ident) := handle_checker hmon. Ltac2 rec solve_ind_case (hmon : ident) (n : int) := first [ now eexists; split > [ intros ?; path n; reflexivity | simpl_minus_methods (); repeat (destructIH ()); handle_checker hmon ] | solve_ind_case hmon (Int.add n 1) ]. Ltac2 rec handle_ind_case (hmon : ident) := match! goal with | [ |- ?e ] => match Constr.Unsafe.kind e with | Constr.Unsafe.App ex p => let pr := Array.get p 1 in match Constr.Unsafe.kind pr with | Constr.Unsafe.Lambda b eq => match Constr.Unsafe.kind eq with | Constr.Unsafe.App t eq_args => let app := Array.get eq_args 1 in match Constr.Unsafe.kind app with | Constr.Unsafe.App aux args => set (auxt := ltac2:(exact $aux)); let succ (c : constr) := match Constr.Unsafe.kind (constr:(S 0)) with | Constr.Unsafe.App s n => let n' := Array.copy n in let _ := Array.set n' 0 c in Constr.Unsafe.make (Constr.Unsafe.App s n') | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end in let args' := Array.copy args in let _ := Array.set args' 1 (succ (Array.get args 1)) in let aux' := Control.hyp @auxt in let app' := Constr.Unsafe.make (Constr.Unsafe.App aux' args') in let eq_args' := Array.copy eq_args in let _ := Array.set eq_args' 1 app' in let pr' := Constr.Unsafe.make (Constr.Unsafe.Lambda b (Constr.Unsafe.make (Constr.Unsafe.App t eq_args'))) in let p' := Array.make 2 (Array.get p 0) in let _ := Array.set p' 1 pr' in let e' := Constr.Unsafe.make (Constr.Unsafe.App ex p') in let s := Fresh.in_goal (id_of_string "s") in let hyp := Fresh.in_goal (id_of_string "Hyp") in assert (Hsuff : ltac2:(exact $e')) > [ | destruct Hsuff as [$s $hyp]; let s1 := Control.hyp s in let hmon := Control.hyp hmon in eexists (S $s1); eapply $hmon > [ | | eassumption ]; lia ]; eapply checker_backtrack_spec_exists; solve_ind_case hmon 0 | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a lambda")))) end | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end end. Ltac2 derive_complete (_ : unit ) := intros __H; unfold decOpt; simpl_minus_methods (); prove_mon (); induction __H; first [ now handle_base_case @Hmon | now handle_ind_case @Hmon ]. (* Ltac tactics *) Ltac derive_mon := ltac2:(derive_mon ()). Ltac derive_sound := ltac2:(derive_sound ()). Ltac derive_complete := ltac2:(derive_complete ()). QuickChick-2.1.0/src/Classes.v000066400000000000000000000357031476030541200161150ustar00rootroot00000000000000From Coq Require Import List Morphisms Recdef ZArith Znat Arith. From QuickChick Require Import Sets Tactics Producer Generators Enumerators. Set Bullet Behavior "Strict Subproofs". Local Open Scope set_scope. (** Apply a function n times *) Fixpoint appn {A} (f : A -> A) (n : nat) : A -> A := fun x => match n with | 0%nat => x | S n' => f (appn f n' x) end. Infix "^" := appn (at level 30, right associativity) : fun_scope. (** Instance Hierarchy GenSized | | Gen Shrink \ / \ / Arbitrary *) (** * Generator-related classes *) (* begin gen_sized_class *) Class GenSized (A : Type) := { arbitrarySized : nat -> G A }. (* end gen_sized_class *) (* begin gen_class *) Class Gen (A : Type) := { arbitrary : G A }. (* end gen_class *) (** Shrink class *) Class Shrink (A : Type) := { shrink : A -> list A }. (** Arbitrary Class *) Class Arbitrary (A : Type) `{Gen A} `{Shrink A}. Class EnumSized (A : Type) := { enumSized : nat -> E A }. Class Enum (A : Type) := { enum : E A }. (* ZP: This is not longer usefull *) (* (** * Sizes of types *) Class Sized (A : Type) := { size : A -> nat }. Class CanonicalSized (A : Type) `{Sized A} := { zeroSized : set A; succSized : set A -> set A; zeroSized_spec : zeroSized <--> [ set x : A | size x = 0 ]; succSized_spec : forall n, succSized [ set x : A | size x <= n ] <--> [ set x : A | size x <= S n ] }. Lemma size_ind (A : Type) `{Hyp : Sized A} : forall (P : A -> Prop), (forall y, (forall x, size x < size y -> P x) -> P y) -> (forall x, P x). Proof. intros P H1. intros x. assert (Hin : [ set y : A | size y <= size x] x); eauto. revert Hin. generalize (size x). intros n. revert x. induction n. - intros x Hl. apply H1. intros x1 Hlt. ssromega. - intros x Hleq. eapply H1. intros x1 Hlt. eapply IHn. ssromega. Qed. Lemma size_lfp (A : Type) `{Hyp : CanonicalSized A} : [set x : A | True ] <--> \bigcup_(s : nat) [set x : A | size x <= s ]. Proof. intros a; split; eauto. intros _. exists (size a). split; eauto. constructor. Qed. Lemma succ_lfp (A : Type) `{Hyp : CanonicalSized A} `{Proper _ (respectful set_eq set_eq) succSized} s : [set x : A | size x <= s ] <--> (succSized ^ s) zeroSized. Proof. induction s. simpl. - rewrite zeroSized_spec. split; intros; ssromega. - simpl. rewrite <- succSized_spec. rewrite IHs. reflexivity. Qed. *) (* Lemma succ_lfp' (A : Type) `{Hyp : CanonicalSized A} : *) (* \bigcup_(s : nat) (succSized ^ s) zeroSized <--> [ set x : A | True ]. *) (* Proof. *) (* intros. split; eauto. *) (* intros _. *) (* eapply set_eq_trans. *) (* Focus 2. symmetry. *) (* eapply succ_lfp. *) (* simpl. *) (* rewrite succ_lfp at 2. *) (* split. *) (* split. rewrite IHs. firstorder. *) (* IHs. *) (* firstorder. reflexivity. split; intros; eauto. *) (* exists (size a). *) (* remember (size a) as s. *) (* revert a Heqs. induction s; intros. *) (* - split. constructor. *) (* simpl. eapply zeroSized_spec. now eauto. *) (* - split. constructor. *) (* simpl. *) (* eapply (succSized_spec. *) (* eassumption. *) (* eapply size_ind. *) (* [set x : A | True ] <--> . *) (** * Correctness classes *) (** Correctness of sized generators *) Class CorrectSized {A : Type} {G} `{Producer G} (g : nat -> G A) := { prodCorrectSized : [ set n | exists s, semProd (g s) n ] <--> [set : A] }. (** Correctness of generators *) Class Correct (A : Type) {G} `{Producer G} (g : G A) := { prodCorrect : semProd g <--> [set : A] }. (** * Monotonic generators *) (** Monotonicity of size parametric generators *) Class GenSizedMonotonic (A : Type) `{GenSized A} `{forall s, SizeMonotonic (arbitrarySized s)}. (** Monotonicity of size parametric generators v2 *) Class GenSizedSizeMonotonic (A : Type) `{GenSized A} `{SizedMonotonic A G arbitrarySized}. Class GenMonotonic (A : Type) `{Gen A} `{@SizeMonotonic A G ProducerGen arbitrary}. (** Monotonicity of size parametric generators *) Class EnumSizedMonotonic (A : Type) `{EnumSized A} `{forall s, @SizeMonotonic A E ProducerEnum (enumSized s)}. (** Monotonicity of size parametric generators v2 *) Class EnumSizedSizeMonotonic (A : Type) `{EnumSized A} `{@SizedMonotonic A E ProducerEnum enumSized}. Class EnumMonotonic (A : Type) `{Enum A} `{@SizeMonotonic A E ProducerEnum enum}. (** * Correct generators *) Class GenSizedCorrect (A : Type) `{GenSized A} `{@CorrectSized A G ProducerGen arbitrarySized}. Class GenCorrect (A : Type) `{Gen A} `{@Correct A G ProducerGen arbitrary}. (* Monotonic and Correct generators *) Class GenMonotonicCorrect (A : Type) `{Gen A} `{@SizeMonotonic A G ProducerGen arbitrary} `{@Correct A G ProducerGen arbitrary}. Class EnumSizedCorrect (A : Type) `{EnumSized A} `{@CorrectSized A E ProducerEnum enumSized}. Class EnumCorrect (A : Type) `{Enum A} `{@Correct A E ProducerEnum enum}. (* Monotonic and Correct generators *) Class EnumMonotonicCorrect (A : Type) `{Enum A} `{@SizeMonotonic A E ProducerEnum enum} `{@Correct A E ProducerEnum enum}. (** Coercions *) #[global] Instance GenSizedMonotonicOfSizeMonotonic (A : Type) (Hgen : GenSized A) (Hmon : forall s, @SizeMonotonic A G ProducerGen (arbitrarySized s)) : @GenSizedMonotonic A Hgen Hmon := {}. #[global] Instance GenMonotonicOfSizeMonotonic (A : Type) (Hgen : Gen A) (Hmon : @SizeMonotonic A G ProducerGen arbitrary) : @GenMonotonic A Hgen Hmon := {}. #[global] Instance GenSizedCorrectOfSizedCorrect (A : Type) (Hgen : GenSized A) `{Hcor : @CorrectSized A G ProducerGen arbitrarySized} : @GenSizedCorrect A Hgen Hcor := {}. #[global] Instance GenMonotonicCorrectOfMonotnicCorrect (A : Type) (Hgen : Gen A) (Hmon : @SizeMonotonic A G ProducerGen arbitrary) `{Hcor : @Correct A G ProducerGen arbitrary} : @GenMonotonicCorrect A Hgen Hmon Hcor := {}. #[global] Instance GenSizedSizeMonotonicOfSizedMonotonic (A : Type) (Hgen : GenSized A) (Hmon : @SizedMonotonic A G ProducerGen arbitrarySized) : @GenSizedSizeMonotonic A Hgen ProducerGen Hmon := {}. #[global] Instance GenOfGenSized {A} `{GenSized A} : Gen A := {| arbitrary := sized arbitrarySized |}. #[global] Instance ArbitraryOfGenShrink {A} `{Gen A} `{Shrink A} : Arbitrary A := {}. Generalizable Variables PSized PMon PSMon PCorr. #[global] Instance GenMonotonicOfSized (A : Type) `{H : GenSized A} `{@GenSizedMonotonic A H PMon} `{@GenSizedSizeMonotonic A H ProducerGen PSMon} : @GenMonotonic A (@GenOfGenSized A H) (@sizedSizeMonotonic G ProducerGen _ A (@arbitrarySized A H) PMon PSMon) := {}. #[global] Instance GenCorrectOfSized (A : Type) {H : GenSized A} `{@GenSizedMonotonic A H PMon} `{@GenSizedSizeMonotonic A H ProducerGen PSMon} `{@GenSizedCorrect A H PCorr} : Correct A arbitrary. Proof. constructor. unfold arbitrary, GenOfGenSized. eapply set_eq_trans. - eapply semSized_alt; now eauto with typeclass_instances. - destruct PCorr. rewrite <- prodCorrectSized0. split. intros [n [? H3]]. eexists. eassumption. intros [s H4]. eexists; split; eauto. reflexivity. Qed. (* Lemma nat_set_ind (A : Type) `{GenSized A} `{Hyp : CanonicalSized A} : (semProd (arbitrarySized 0) <--> zeroSized) -> (forall (s : nat) (elems : set A), semProd (arbitrarySized s) <--> elems -> semProd (arbitrarySized (s.+1)) <--> succSized elems) -> (forall s : nat, semProd (arbitrarySized s) <--> (fun x : A => size x <= s)). Proof. intros HO IH. intros n; induction n. - eapply set_eq_trans with (B := (fun x : A => size x = 0)). rewrite -zeroSized_spec //=. intros s. destruct (size s). now firstorder. split; intros; ssromega. - rewrite -succSized_spec. eauto. Qed. *) #[global] Instance EnumSizedMonotonicOfSizeMonotonic (A : Type) (Hgen : EnumSized A) (Hmon : forall s, @SizeMonotonic A E ProducerEnum (enumSized s)) : @EnumSizedMonotonic A Hgen Hmon := {}. #[global] Instance EnumMonotonicOfSizeMonotonic (A : Type) (Hgen : Enum A) (Hmon : @SizeMonotonic A E ProducerEnum enum) : @EnumMonotonic A Hgen Hmon := {}. #[global] Instance EnumSizedCorrectOfSizedCorrect (A : Type) (Hgen : EnumSized A) `{Hcor : @CorrectSized A E ProducerEnum enumSized} : @EnumSizedCorrect A Hgen Hcor := {}. #[global] Instance EnumCorrectOfCorrect (A : Type) (Hgen : Enum A) `{Hcor : @Correct A E ProducerEnum enum} : @EnumCorrect A Hgen Hcor := {}. #[global] Instance EnumMonotonicCorrectOfMonotnicCorrect (A : Type) (Hgen : Enum A) (Hmon : @SizeMonotonic A E ProducerEnum enum) `{Hcor : @Correct A E ProducerEnum enum} : @EnumMonotonicCorrect A Hgen Hmon Hcor := {}. #[global] Instance EnumSizedSizeMonotonicOfSizedMonotonic (A : Type) (Hgen : EnumSized A) (Hmon : @SizedMonotonic A E ProducerEnum enumSized) : @EnumSizedSizeMonotonic A Hgen Hmon := {}. #[global] Instance EnumOfEnumSized {A} `{EnumSized A} : Enum A := {| enum := sized enumSized |}. (* #[global] Instance EnumOfGenShrink {A} `{Gen A} `{Shrink A} : Arbitrary A := {}. *) #[global] Instance EnumMonotonicOfSized (A : Type) `{H : EnumSized A} `{@EnumSizedMonotonic A H PMon} `{@EnumSizedSizeMonotonic A H PSMon} : @EnumMonotonic A (@EnumOfEnumSized A H) (@sizedSizeMonotonic E ProducerEnum _ A (@enumSized A H) PMon PSMon) := {}. #[global] Instance EnumCorrectOfSized' (A : Type) {H : EnumSized A} `{@EnumSizedMonotonic A H PMon} `{@EnumSizedSizeMonotonic A H PSMon} `{@EnumSizedCorrect A H PCorr} : Correct A enum. Proof. constructor. unfold arbitrary, EnumOfEnumSized. eapply set_eq_trans. - eapply semSized_alt; eauto with typeclass_instances. - destruct PCorr. rewrite <- prodCorrectSized0. split. intros [n [? H3]]. eexists. eassumption. intros [s H4]. eexists; split; eauto. reflexivity. Qed. #[global] Instance EnumCorrectOfSized (A : Type) (H1 : EnumSized A) (H3 : forall s : nat, SizeMonotonic (enumSized s)) (H4 : SizedMonotonic enumSized) (H5 : CorrectSized enumSized) : Correct A enum. Proof. eapply EnumCorrectOfSized'; eauto. constructor; eauto. constructor; eauto. constructor; eauto. Qed. Lemma enumerating_complete A (e : E A) {Hc : Correct A e} ch : (exists x, ch x = Some true) -> exists s, enumerating e ch s = Some true. Proof. intros [x Hch]. unfold enumerating. assert (Hin : semProd e x). { eapply Hc. reflexivity. } destruct Hin as [s [_ Hsem]]. simpl in *. unfold semEnumSize in *. exists s. revert Hsem. generalize (Enumerators.run e s), false. induction l; intros b Hin; inv Hin; simpl. - rewrite Hch. reflexivity. - destruct (ch a); eauto. destruct b0; eauto. Qed. Lemma lazylist_backtrack_opt_is_true A (l: LazyList.LazyList (option A)) ch b : lazylist_backtrack_opt l ch true = Some b -> b = true. Proof. induction l. - simpl. congruence. - simpl in *. destruct a. + destruct (ch a) eqn:Heq. destruct b0. congruence. now eauto. now eauto. + eauto. Qed. Lemma lazylist_backtrack_opt_is_false A (l: LazyList.LazyList (option A)) ch b : lazylist_backtrack_opt l ch b = Some false -> b = false. Proof. revert b; induction l; intros b. - simpl. destruct b; try congruence. - simpl in *. destruct a. + destruct (ch a) eqn:Heq. destruct b0. congruence. now eauto. intros Hin. eapply H in Hin. congruence. + intros Hn. eapply lazylist_backtrack_opt_is_true in Hn. congruence. Qed. Lemma lazylist_backtrack_opt_true A (l: LazyList.LazyList (option A)) ch b : lazylist_backtrack_opt l ch b = Some true <-> exists x, LazyList.In_ll (Some x) l /\ ch x = Some true. Proof. revert b; induction l; intros b. - simpl. split; intros Hc; try congruence. destruct b; congruence. destruct Hc. inv H; exfalso; eauto. - split. + intros Hl. simpl in *. destruct a. destruct (ch a) eqn:Heq. * destruct b0. -- eexists. split; eauto. -- eapply H in Hl. destruct Hl. inv H0. eexists; split; eauto. * eapply H in Hl. destruct Hl. inv H0. eexists; split; eauto. * eapply H in Hl. destruct Hl. inv H0. eexists; split; eauto. + intros Hc; inv Hc. inv H0. simpl in *. destruct a. * inv H1. inv H3. rewrite H2. reflexivity. destruct (ch a) eqn:Heq. destruct b0. reflexivity. eapply H. eexists. now split; eauto. eapply H. eexists. now split; eauto. * inv H1. congruence. eapply H. eexists. now split; eauto. Qed. Lemma lazylist_backtrack_opt_false A (l: LazyList.LazyList (option A)) ch : lazylist_backtrack_opt l ch false = Some false <-> (forall x, LazyList.In_ll (Some x) l -> ch x = Some false) /\ ~ LazyList.In_ll None l. Proof. induction l. - simpl. split; intros Hc. split; eauto. intros. now inv H. reflexivity. - split. + intros Hl. simpl in *. destruct a. * destruct (ch a) eqn:Heq. destruct b. congruence. -- eapply H in Hl. inv Hl. split. intros. inv H2; eauto. inv H3. eassumption. intros Hc; inv Hc. congruence. eauto. -- eapply lazylist_backtrack_opt_is_false in Hl. congruence. * eapply lazylist_backtrack_opt_is_false in Hl. congruence. + intros [H1 H2]. simpl. destruct a. * destruct (ch a) eqn:Heq. destruct b. rewrite H1 in Heq. congruence. now left. eapply H. split. intros. eapply H1. right. eassumption. intros Hc. eapply H2. right. eassumption. rewrite H1 in Heq. congruence. now left. * exfalso. eapply H2. now left. Qed. Lemma enumeratingOpt_monotonic A (e : E (option A)) {Hc : SizeMonotonicOpt e} {Hfp : SizeFP e} ch1 ch2 s1 s2 b : s1 <= s2 -> (forall x, ch1 x = Some b -> ch2 x = Some b) -> enumeratingOpt e ch1 s1 = Some b -> enumeratingOpt e ch2 s2 = Some b. Proof. intros Hleq Hall Hen. specialize (Hc _ _ Hleq). specialize (Hfp _ _ Hleq). unfold enumeratingOpt in *. unfold semProdSizeOpt in *. simpl in *. unfold semEnumSize in *. revert Hc Hfp Hen. generalize (run e s1), (run e s2). intros l1 l2 Hs1 Hs2 Hl. destruct b. - eapply lazylist_backtrack_opt_true in Hl. destruct Hl. destruct H. eapply lazylist_backtrack_opt_true. eexists. split. eapply Hs1. eassumption. eapply Hall. eassumption. - eapply lazylist_backtrack_opt_false in Hl. destruct Hl. eapply lazylist_backtrack_opt_false. split. intros x Hin. eapply Hall. eapply H. eapply Hs2. eassumption. eassumption. intros Hc. eapply H0. eapply Hs2. eassumption. eassumption. Qed. QuickChick-2.1.0/src/CoArbitrary.v000066400000000000000000000415451476030541200167420ustar00rootroot00000000000000From Coq Require Import PArith List ChoiceFacts Lia ssreflect ssrbool ssrfun. From QuickChick Require Import Compat Classes RandomQC Generators Sets. Import ListNotations. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (* LL: TODO: Add proof obligation that the result paths be prefix free? *) Class CoArbitrary (A : Type) : Type := { coarbitrary : A -> positive; coarbReverse : positive -> option A; coarbCorrect : forall a, coarbReverse (coarbitrary a) = Some a }. #[global] Instance coArbPos : CoArbitrary positive. Proof. refine {| coarbitrary x := x; coarbReverse x := Some x |}. auto. Qed. Lemma nat_lemma : forall a : nat, Some (Init.Nat.pred (Pos.to_nat (Pos.of_nat (S a)))) = Some a. Proof. intros; apply f_equal. rewrite Nat2Pos.id; auto. Qed. #[global] Instance coqArbNat : CoArbitrary nat. Proof. refine {| coarbitrary x := Pos.of_nat (S x); coarbReverse p := Some (Coq.Init.Peano.pred (Pos.to_nat p)) |}. apply nat_lemma. Qed. Local Open Scope positive. Fixpoint posToPathAux (p : positive) : SplitPath := match p with | xH => [] | xI p' => posToPathAux p' ++ [Left; Right] | xO p' => posToPathAux p' ++ [Left; Left ] end. Definition posToPath (p : positive) : SplitPath := posToPathAux p ++ [Right]. Fixpoint pathToPosAux (p : SplitPath) (f : positive -> positive) : option positive := match p with | [Right] => Some (f xH) | Left :: Right :: p' => pathToPosAux p' (fun p => xI (f p)) | Left :: Left :: p' => pathToPosAux p' (fun p => xO (f p)) | _ => None end. Definition pathToPos p := pathToPosAux p (fun x => x). (* Eval compute in (pathToPos (posToPath 1)). Eval compute in (pathToPos (posToPath 2)). Eval compute in (pathToPos (posToPath 3)). Eval compute in (pathToPos (posToPath 4)). Eval compute in (pathToPos (posToPath 5)). Eval compute in (pathToPos (posToPath 6)). Eval compute in (pathToPos (posToPath 7)). Eval compute in (pathToPos (posToPath 8)). Eval compute in (pathToPos (posToPath 9)). *) Definition list_ind' (A : Type) (P : list A -> Prop) : P [] -> (forall (a : A), P [a]) -> (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) -> forall (l : list A), P l := fun H0 H1 H2 => fix aux (l : list A) : P l := match l with | [] => H0 | [x] => H1 x | a :: b :: l' => H2 a b l' (aux l') end. Lemma aux1 : forall l p f, pathToPosAux (l ++ [Right]) f = Some p -> exists f', forall l', pathToPosAux (l ++ l') f = pathToPosAux l' f' /\ f' xH = p. induction l using list_ind'; intros. + simpl in *; inversion H; subst. exists f; intros. split; auto. + simpl in H; destruct a; inversion H. + pose proof IHl p; clear IHl. destruct a; destruct b; simpl in *. - pose proof (H0 (fun p0 => xO (f p0))); clear H0. apply H1 in H; clear H1. assumption. - pose proof (H0 (fun p0 => xI (f p0))); clear H0. apply H1 in H; clear H1. assumption. - inversion H. - inversion H. Qed. Lemma posPathInj : forall p, pathToPos (posToPath p) = Some p. induction p; unfold posToPath, pathToPos in *; simpl in *. - apply aux1 in IHp. inversion IHp as [f' Hyp]; clear IHp. rewrite <- app_assoc; simpl. pose proof Hyp [Left; Right; Right] as H; clear Hyp. inversion H as [H0 H1]; clear H. rewrite H0; clear H0. simpl; subst; auto. - apply aux1 in IHp. inversion IHp as [f' Hyp]; clear IHp. rewrite <- app_assoc; simpl. pose proof Hyp [Left; Left; Right] as H; clear Hyp. inversion H as [H0 H1]; clear H. rewrite H0; clear H0. simpl; subst; auto. - auto. Qed. Fixpoint lengthSplit {A : Type} (l l' : list A) : option (list A * list A) := match l, l' with | [], x => Some ([], x) | _::xs, y::ys => option_map (fun (p : list A * list A) => let (l1,l2) := p in (y::l1, l2)) (lengthSplit xs ys) | _, _ => None end. Lemma lengthSplit1 : forall {A : Type} (l l' : list A), le (length l) (length l') -> exists p, lengthSplit l l' = Some p. induction l as [ | x xs IHxs]. + intros; exists ([], l'); auto. + intros l' LE; destruct l' as [ | b bs] eqn:LEq. - inversion LE. - pose proof IHxs bs as IH; clear IHxs. assert (LE' : le (length xs) (length bs)) by (simpl in *; lia). (* Overkill? :) *) clear LE. apply IH in LE'; clear IH. inversion LE' as [pair Split]; clear LE'. destruct pair as [l1 l2] eqn:Pair. simpl. rewrite Split. exists (b :: l1, l2). simpl. auto. Qed. Lemma lengthSplit2 : forall {A : Type} (l l' l1 l2 : list A), lengthSplit l l' = Some (l1, l2) -> l1 ++ l2 = l'. induction l. + intros l' l1 l2 Hyp; simpl in Hyp; inversion_clear Hyp; auto. + intros l' l1 l2 Hyp. simpl in Hyp. destruct l' as [ | y ys] eqn:L'. - inversion Hyp. - destruct l1 eqn:L1. * destruct (lengthSplit l ys); simpl in *. + destruct p; congruence. + congruence. * pose proof IHl ys l0 l2; clear IHl. destruct (lengthSplit l ys) eqn:LenSplit; simpl in *. + inversion Hyp. destruct p. inversion H1. subst. rewrite H; auto. + inversion Hyp. Qed. Lemma lengthSplit3 : forall {A : Type} (l l' l1 l2 : list A), lengthSplit l l' = Some (l1, l2) -> length l1 = length l. induction l as [ | x xs IHxs]. + intros; simpl in H; inversion H; auto. + intros l' l1 l2 Split. simpl in Split. destruct l'. - inversion Split. - destruct l1. * destruct (lengthSplit xs l'). + simpl in *. destruct p. inversion Split. + simpl in *. inversion Split. * simpl in *. destruct (lengthSplit xs l') eqn:LenSplit. + simpl in *. destruct p. inversion Split; subst; clear Split. pose proof (IHxs l' l1 l2 LenSplit) as Hyp; clear IHxs. auto. + simpl in *. inversion Split. Qed. Lemma lengthPathEven : forall p, exists n, length (posToPathAux p) = (2 * n)%nat. induction p. + inversion IHp as [n Hyp]; clear IHp. simpl. exists (S n). rewrite length_app. rewrite Hyp. simpl. lia. + inversion IHp as [n Hyp]; clear IHp. simpl. exists (S n). rewrite length_app. rewrite Hyp. simpl. lia. + exists (O). simpl. auto. Qed. Lemma evenPathAux : forall l l' l'' lApp f n p, length l = (2 * n)%nat -> pathToPosAux (l ++ l' ++ l'') f = Some p -> exists f', pathToPosAux (l ++ l') f = pathToPosAux l' f' /\ pathToPosAux (l ++ l' ++ lApp) f = pathToPosAux (l' ++ lApp) f'. induction l using list_ind'. + intros. exists f. auto. + intros. simpl in *. lia. + intros l' l'' lApp f n p Len Valid. destruct n. - simpl in Len. congruence. - simpl in Len; assert (length l = (2 * n)%nat) by lia. destruct a eqn:A; destruct b eqn:B; simpl in *. * unfold pathToPos in Valid. simpl in Valid. pose proof (IHl l' l'' lApp (fun p => xO (f p)) n p H Valid) as Hyp; clear IHl H. inversion Hyp as [f' HF]; clear Hyp. exists f'. auto. * unfold pathToPos in Valid. simpl in Valid. pose proof (IHl l' l'' lApp (fun p => xI (f p)) n p H Valid) as Hyp; clear IHl H. inversion Hyp as [f' HF]; clear Hyp. exists f'. auto. * inversion Valid. * inversion Valid. Qed. Lemma pathBeginsLeft : forall l1 l2 f x, l1 <> [] -> l2 <> [] -> pathToPosAux (l1 ++ l2) f = Some x -> head l1 = Some Left. destruct l1. + intros. exfalso; apply H; auto. + intros. destruct s. - auto. - simpl in H1. destruct (l1 ++ l2) eqn:Contra. * destruct l1; destruct l2; try solve [unfold not; exfalso; auto]; simpl in *; congruence. * congruence. Qed. Lemma listAppNeq : forall (A : Type) (l1 l2 l3 l4 : list A), (forall (x y : A), {x = y} + {x <> y}) -> length l1 = length l2 -> l1 <> l2 -> l1 ++ l3 <> l2 ++ l4. induction l1. + intros. destruct l2. - unfold not in H0. exfalso; apply H0; auto. - simpl in H; inversion H. + intros l2 l3 l4 EqDec Len Neq. destruct l2 as [ | b l2 ]. - simpl in Len. congruence. - destruct (EqDec a b). * subst. simpl in Len. inversion Len as [ Len']; clear Len. simpl. pose proof (IHl1 l2 l3 l4 EqDec Len') as Contra; clear IHl1. assert (l1 <> l2) by (unfold not; intros; congruence). apply Contra in H. unfold not in *. intros. apply H. inversion H0. auto. * unfold not; intros. inversion H. congruence. Qed. Lemma PosToPathPrefixFreeAux : forall (x y : positive), (x <> y) -> le (length (posToPathAux y)) (length(posToPathAux x)) -> PrefixFree [posToPath x; posToPath y]. intros x y H Leq. apply FreeCons; [ apply FreeCons ; [ constructor | intros p Contra; inversion Contra] | ]. intros. inversion H0; subst; clear H0; [ | inversion H2]. unfold posToPath in *; simpl in *; repeat rewrite <- app_assoc in *. pose proof (lengthSplit1 Leq) as Hyp. inversion Hyp as [pair Split]; clear Hyp. destruct pair as [l0 l1]. pose proof (lengthSplit2 Split) as AppHyp. pose proof (lengthSplit3 Split) as LenHyp. pose proof (lengthPathEven y) as Hyp; inversion Hyp as [n LenN]; subst; clear Hyp. assert (XHyp : pathToPosAux (l0 ++ l1 ++ [Right]) (fun x => x) = Some x); [ rewrite app_assoc; rewrite AppHyp; apply posPathInj | ]. rewrite <- LenHyp in LenN. pose proof (evenPathAux [Right] LenN XHyp) as Even. inversion Even as [f' HF]; clear Even. inversion HF as [HF1 HF2]; clear HF. rewrite <- AppHyp in H1. rewrite <- app_assoc in H1. destruct (list_eq_dec Direction_eq_dec (posToPathAux y) l0). - subst. apply app_inv_head in H1. destruct l1. * simpl in AppHyp; rewrite app_nil_r in AppHyp. assert (posToPathAux y ++ [Right] = posToPathAux x ++ [Right]) by (rewrite AppHyp; auto). assert (posToPath y = posToPath x) by (unfold posToPath; auto). assert (pathToPos (posToPath y) = pathToPos (posToPath x)) by (rewrite H2; auto). repeat rewrite posPathInj in H3. congruence. * assert (Contra : hd_error (s :: l1) = Some Left). eapply pathBeginsLeft. + unfold not; intros; congruence. + instantiate (1 := [Right]); unfold not; intros; congruence. + instantiate (1:= x); instantiate (1:=f'). rewrite <- HF2. apply XHyp. simpl in Contra. inversion Contra; subst. simpl in H1. congruence. - eapply listAppNeq. * apply Direction_eq_dec. * instantiate (1 := l0). instantiate (1 := posToPathAux y). eauto. * eassumption. * eapply H1. Qed. Lemma prefixFreeCommutative : forall l1 l2, PrefixFree [l1;l2] -> PrefixFree [l2;l1]. intros. inversion H. apply FreeCons. + apply FreeCons. - constructor. - intros. inversion H4. + intros. subst. eapply H3. - instantiate (1 := l2); left; auto. - inversion H4. * subst. inversion H4. subst. instantiate (1:= p1); instantiate (1 := p2). auto. * inversion H0. - inversion H0. Qed. Lemma PosToPathPrefixFree : forall (x y : positive), (x <> y) -> PrefixFree [posToPath x; posToPath y]. intros. destruct (Compare_dec.le_ge_dec (length (posToPathAux y)) (length (posToPathAux x))). + apply (PosToPathPrefixFreeAux H l). + apply prefixFreeCommutative. apply (@PosToPathPrefixFreeAux y x). - unfold not in *; intros; exfalso; auto. - auto. Qed. Function rangeNat (p : nat) : list nat := match p with | O => [] | S n' => p :: (rangeNat n') end. Definition rangePos (p : positive) : list positive := map Pos.of_nat (rangeNat (Pos.to_nat p)). Lemma ltInRange : forall m n, le n m -> n <> O -> In n (rangeNat m). induction m; intros. + inversion H. simpl. auto. + simpl. inversion H. - left; auto. - right; subst. apply IHm; auto. Qed. Lemma posLtInRange : forall max pos, Pos.le pos max -> In pos (rangePos max). intros. apply in_map_iff. exists (Pos.to_nat pos). split. - apply Pos2Nat.id. - apply ltInRange. + apply Pos2Nat.inj_le; auto. + pose proof (Pos2Nat.is_succ pos) as Contra; inversion_clear Contra; congruence. Qed. Lemma rangeNatLt : forall n m, In m (rangeNat n) -> lt m (S n) /\ m <> O. induction n; intros. + simpl in H. inversion H. + inversion H. - split. * subst. unfold lt. apply le_n. * congruence. - apply IHn in H0; inversion H0; clear H0; split. * unfold lt in *. apply le_S. auto. * auto. Qed. Lemma rangePosPrefixFree : forall p, PrefixFree (map posToPath (rangePos p)). intros. unfold rangePos. induction (Pos.to_nat p) as [ | n IHn]. + constructor. + simpl. apply FreeCons; auto. intros p' InP' p1 p2 App. apply in_map_iff in InP'. clear IHn. inversion InP' as [x xHyp]; clear InP'. inversion xHyp as [Pos2Path InX]; clear xHyp. subst. apply in_map_iff in InX. inversion InX as [y yHyp]; clear InX. inversion yHyp as [Pos2PathY InY]; clear yHyp. apply rangeNatLt in InY. inversion InY as [LtYSn YNotO]; clear InY. remember (match n with | O => 1 | S _ => Pos.succ (Pos.of_nat n) end) as m. assert (Neq : x <> m). unfold not; intros; subst. destruct y. - congruence. - destruct n. * lia. * assert (Pos.to_nat (Pos.of_nat (S y)) = Pos.to_nat (Pos.succ (Pos.of_nat (S n)))) by (rewrite H; auto). rewrite Pos2Nat.inj_succ in H0. rewrite Nat2Pos.id in H0. rewrite Nat2Pos.id in H0. + subst; lia. + congruence. + congruence. pose proof (@PosToPathPrefixFree x m) as Hyp. apply Hyp in Neq; clear Hyp. inversion Neq. eapply H2. + left; auto. + eauto. Qed. Definition posFunToPathFun (f : positive -> RandomSeed) (p : SplitPath) : RandomSeed := match pathToPos p with | Some a => f a | None => newRandomSeed end. Theorem coarbComplete' : forall (max : positive) (f : positive -> RandomSeed) , exists seed, forall p, p <= max -> varySeed (posToPath p) seed = f p. intros. pose proof (SplitPathCompleteness (map posToPath (rangePos max)) (posFunToPathFun f) (rangePosPrefixFree max)). inversion H; clear H. exists x. intros. pose proof H0 (posToPath p). rewrite H1. + unfold posFunToPathFun. rewrite posPathInj. reflexivity. + apply in_map_iff. exists p. split; auto. apply posLtInRange. auto. Qed. Definition funToPosFun {A : Type} `{_ : CoArbitrary A} (f : A -> RandomSeed) (p : positive) : RandomSeed := match coarbReverse p with | Some a => f a | None => newRandomSeed end. Definition coarbLe {A : Type} `{_ : CoArbitrary A} (x y : A) : Prop := Pos.le (coarbitrary x) (coarbitrary y). Lemma coarbLePreservesLe : forall {A : Type} `{_ : CoArbitrary A} (x y : A), coarbLe x y -> Pos.le (coarbitrary x) (coarbitrary y). by []. Qed. Theorem coarbComplete : forall {A : Type} `{_ : CoArbitrary A} (max : A) (f : A -> RandomSeed), exists seed, forall a, coarbLe a max -> varySeed (posToPath (coarbitrary a)) seed = f a. intros. pose proof (coarbComplete' (coarbitrary max) (funToPosFun f)) as Hyp. inversion Hyp as [seed HSeed]; clear Hyp. exists seed. intros a HLe. pose proof (HSeed (coarbitrary a)) as HCo; clear HSeed. apply coarbLePreservesLe in HLe. apply HCo in HLe; clear HCo. rewrite HLe; clear HLe. unfold funToPosFun. rewrite coarbCorrect. reflexivity. Qed. #[global] Instance genFun {A B : Type} `{_ : CoArbitrary A} `{_ : Gen B} : Gen (A -> B) := {| arbitrary := reallyUnsafePromote (fun a => variant (posToPath (coarbitrary a)) arbitrary); |}. #[global] Instance shrinkFunNil {A B : Type} : Shrink (A -> B) := {| shrink x := nil |}. Section arbFun_completeness. Variables A B : Type. Hypothesis choice : FunctionalChoice_on A RandomSeed. Local Open Scope set_scope. (* begin arbFunCorrect *) Theorem arbFunComplete `{CoArbitrary A, Arbitrary B} (max:A) (f:A-> B) (s:nat) : s = Pos.to_nat (coarbitrary max) -> (semGenSize arbitrary s <--> setT) -> exists seed, forall a, coarbLe a max -> run arbitrary s seed a = f a. (* end arbFunCorrect *) Proof. move=> eqsize semB. have/choice [fseed fseedP]: forall a, exists seed : RandomSeed, run arbitrary s seed = f a. by move => a; case: (semB (f a))=> _ /(_ I) [seed ?]; exists seed. case: (coarbComplete max fseed) => seed Hseed. pose proof (randomSplitAssumption seed seed) as Hyp. move : Hyp => [seed' Hsplit]. exists seed' => a le_a; rewrite -fseedP -Hseed //=. apply (@promoteVariant A B a (fun a => posToPath (coarbitrary a)) arbitrary s seed' seed seed Hsplit). Qed. End arbFun_completeness. QuickChick-2.1.0/src/Compat.v.cppo000066400000000000000000000016211476030541200166730ustar00rootroot00000000000000From Coq Require Import List Arith. Module Nat. #if COQ_VERSION >= (8, 17, 0) Notation div_div := Nat.Div0.div_div. Notation div_lt_upper_bound := Nat.Div0.div_lt_upper_bound. #else Lemma div_0_l : forall a : nat, 0 / a = 0. Proof. intros []; reflexivity. Qed. Lemma div_div : forall a b c : nat, (a/b)/c = a/(b*c). Proof. intros a b c. destruct (Nat.eq_dec b 0) as [->|Hb]. - apply div_0_l. - destruct (Nat.eq_dec c 0) as [->|Hc]. + rewrite Nat.mul_0_r. reflexivity. + now apply Nat.div_div. Qed. Lemma div_lt_upper_bound : forall a b q : nat, a < b*q -> a/b < q. Proof. intros a b q. destruct (Nat.eq_dec b 0) as [->|Hb]. - cbn. intros H; contradiction (Nat.nlt_0_r a H). - now apply Nat.div_lt_upper_bound. Qed. #endif End Nat. #if COQ_VERSION < (8, 20, 0) Lemma length_app (A : Type) (xs ys : list A) : length (xs ++ ys) = length xs + length ys. Proof. apply app_length. Qed. #endif QuickChick-2.1.0/src/Decidability.v000066400000000000000000000161501476030541200171010ustar00rootroot00000000000000From ExtLib Require Import RelDec. From Coq Require Import Ascii List NArith String ZArith ssreflect ssrbool. From QuickChick Require Import Checker Generators Producer. Set Bullet Behavior "Strict Subproofs". (* Class wrapper around "decidable" *) (* begin decidable_class *) Class Dec (P : Prop) : Type := { dec : decidable P }. (* end decidable_class *) Class DecOpt (P : Prop) := { decOpt : nat -> option bool }. Axiom checkable_size_limit : nat. Extract Constant checkable_size_limit => "10000". (* Discard tests that run further than the limit *) (* For proofs, the size parameter will need to be taken into account to prove limit results. We just add it to the large, practical constant. *) #[global] Instance decOpt__checkable {P} `{DecOpt P} : Checkable P := {| checker _ := sized (fun s => match decOpt (checkable_size_limit + s) with | Some b => checker b | None => checker tt end ) |}. #[global] Instance dec_decOpt {P} `{Dec P} : DecOpt P := {| decOpt := fun _ => match @dec P _ with | left _ => Some true | right _ => Some false end |}. (* Note: maybe this should become thunked? *) Definition checker_backtrack (l : list (unit -> option bool)) : option bool := let fix aux l b := match l with | t :: ts => match t tt with | Some true => Some true | Some false => aux ts b | None => aux ts true end | nil => if b then None else Some false end in aux l false. (* Additional Checkable instance *) #[global] Instance testDec {P} `{H : Dec P} : Checkable P. Proof. constructor. destruct H. destruct dec0. - intros; exact (checker true). - intros; exact (checker false). Defined. #[global] Instance Checkable_opt {p} `{Checkable p} : Checkable (option p) := { checker m := match m with | Some x => checker x | None => checker tt end }. #[global] Instance Dec_neg {P} {H : Dec P} : Dec (~ P). Proof. constructor. unfold decidable. destruct H as [D]; destruct D; auto. Defined. #[global] Instance Dec_conj {P Q} {H : Dec P} {I : Dec Q} : Dec (P /\ Q). Proof. constructor. unfold decidable. destruct H as [D]; destruct D; destruct I as [D]; destruct D; auto; right; intro; destruct H; contradiction. Defined. #[global] Instance Dec_disj {P Q} {H : Dec P} {I : Dec Q} : Dec (P \/ Q). Proof. constructor. unfold decidable. destruct H as [D]; destruct D; destruct I as [D]; destruct D; auto; right; intro; destruct H; contradiction. Defined. (* BCP: Not clear this is a good idea, but... *) (* Leo: Should be ok with really low priority *) #[global] Instance Dec_impl {P Q} {H : Dec P} {I : Dec Q} : Dec (P -> Q) | 100. Proof. constructor. unfold decidable. destruct H as [D]. destruct D; destruct I as [D]; destruct D; auto. left. intros. contradiction. Defined. #[global] Instance Dec_In {A} (Eq: forall (x y : A), Dec (x = y)) (x : A) (l : list A) : Dec (In x l) := {| dec := in_dec (fun x' y' => @dec _ (Eq x' y')) x l |}. Class Dec_Eq (A : Type) := { dec_eq : forall (x y : A), decidable (x = y) }. Theorem dec_if_dec_eq {A} (x y: A): Dec (x = y) -> {x = y} + {x <> y}. Proof. intros. inversion H as [D]. unfold decidable in D. assumption. Defined. #[global] Hint Resolve dec_if_dec_eq: eq_dec. Ltac dec_eq := repeat match goal with | [ |- _ ] => solve [auto with eq_dec] | [ |- Dec _ ] => constructor | [ |- Dec_Eq _ ] => constructor | [ |- context[decidable _] ] => unfold decidable | [ H: context[decidable _] |- _ ] => unfold decidable in H | [ |- forall x y, {x = y} + {x <> y} ] => decide equality | [ |- {?x = ?y} + {?x <> ?y} ] => multimatch goal with | [ H: forall x y, Dec _ |- _ ] => apply H | [ H: Dec_Eq _ |- _ ] => apply H | [ |- _ ] => decide equality end end. #[global] Instance Dec_Eq_implies_DecEq {A} `{H : Dec_Eq A} (x y : A) : Dec (x = y). Proof. constructor. dec_eq. Defined. #[global] Instance Dec_Eq_implies_RelDecEq {A} `{Dec_Eq A} : RelDec (@eq A) := {| rel_dec x y := match dec_eq x y with | left _ => true | right _ => false end |}. (* Lifting common decidable instances *) #[global] Instance Dec_eq_unit : Dec_Eq unit. Proof. dec_eq. Defined. #[global] Instance Dec_eq_bool : Dec_Eq bool. Proof. dec_eq. Defined. #[global] Instance Dec_eq_nat : Dec_Eq nat. Proof. dec_eq. Defined. #[global] Instance Dec_eq_Z : Dec_Eq Z. Proof. dec_eq. Defined. #[global] Instance Dec_eq_N : Dec_Eq N. Proof. dec_eq. Defined. #[global] Instance Dec_eq_opt (A : Type) `{Dec_Eq A} : Dec_Eq (option A). Proof. dec_eq. Defined. #[global] Instance Dec_eq_prod (A B : Type) `{Dec_Eq A} `{Dec_Eq B} : Dec_Eq (A * B). Proof. dec_eq. Defined. #[global] Instance Dec_eq_sum (A B : Type) `{Dec_Eq A} `{Dec_Eq B} : Dec_Eq (A + B). Proof. dec_eq. Defined. #[global] Instance Dec_eq_list (A : Type) `{Dec_Eq A} : Dec_Eq (list A). Proof. dec_eq. Defined. #[global] Instance list_Dec_Eq X (_ : Dec_Eq X) : Dec_Eq (list X). Proof. dec_eq. Defined. #[global] Hint Resolve ascii_dec: eq_dec. #[global] Hint Resolve string_dec: eq_dec. #[global] Instance Dec_eq_ascii : Dec_Eq ascii. Proof. dec_eq. Defined. #[global] Instance Dec_eq_string : Dec_Eq string. Proof. dec_eq. Defined. (* Everything that uses the Decidable Class *) Require Import DecidableClass. #[global] Instance dec_class_dec P (H : Decidable P): Dec P. Proof. constructor; destruct H; destruct Decidable_witness. - left; auto. apply Decidable_spec; auto. - right => H; eauto. apply Decidable_spec in H. inversion H. Defined. (* Example foo (m n : nat) := match @dec (m = n) _ with | left _ => 0 | right _ => 1 end. (* Eval compute in foo 0 1. *) Example bar (m n : nat) := if (m=n)? then 0 else 1. (* Eval compute in bar 0 1. *) *) (* Not sure about the level or binding, but good idea *) Notation "P '?'" := (match (@dec P _) with | left _ => true | right _ => false end) (at level 100). Notation "P '??' n" := (@decOpt P _ n) (at level 100). Definition implicationOpt (m : option bool) (p : unit -> option bool) : option bool := match m with | Some true => p tt | Some false => None | None => None end. Notation "x ?==>? y" := (implicationOpt (Some x) (fun tt => y)) (at level 55, right associativity). Notation "x ==>? y" := (implicationOpt x (fun tt => y)) (at level 55, right associativity). #[global] Hint Resolve Dec_eq_unit : eq_dec. #[global] Hint Resolve Dec_eq_bool : eq_dec. #[global] Hint Resolve Dec_eq_nat : eq_dec. #[global] Hint Resolve Dec_eq_Z : eq_dec. #[global] Hint Resolve Dec_eq_N : eq_dec. #[global] Hint Resolve Dec_eq_opt : eq_dec. #[global] Hint Resolve Dec_eq_prod : eq_dec. #[global] Hint Resolve Dec_eq_sum : eq_dec. #[global] Hint Resolve Dec_eq_list : eq_dec. #[global] Hint Resolve Dec_eq_ascii : eq_dec. #[global] Hint Resolve Dec_eq_string : eq_dec. QuickChick-2.1.0/src/DependentClasses.v000066400000000000000000000373121476030541200177420ustar00rootroot00000000000000From Coq Require Import String List ssreflect ssrbool. From QuickChick Require Import Producer Generators Enumerators Tactics Sets Classes. Import ListNotations. Import QcDefaultNotation. Open Scope qc_scope. Local Open Scope string. Local Open Scope set_scope. Set Bullet Behavior "Strict Subproofs". (** * Correctness of dependent generators *) Class CorrectSizedST {A : Type} (P : A -> Prop) {G} `{Producer G} (g : nat -> G (option A)) := { corrST : [ set x | exists s, semProdOpt (g s) x ] <--> P }. Class CorrectST {A : Type} (P : A -> Prop) {G} `{Producer G} (g : G (option A)) := { corr : semProdOpt g <--> P }. (** * Dependent sized generators *) (* begin genSTSized_class *) Class GenSizedSuchThat (A : Type) (P : A -> Prop) := { arbitrarySizeST : nat -> G (option A) }. (* end genSTSized_class *) (** * Monotonicity of denendent sized generators *) Class GenSizedSuchThatMonotonic (A : Type) `{GenSizedSuchThat A} `{forall s, SizeMonotonic (arbitrarySizeST s)}. Class GenSizedSuchThatMonotonicOpt (A : Type) `{GenSizedSuchThat A} `{forall s, SizeMonotonicOpt (arbitrarySizeST s)}. Class GenSizedSuchThatSizeMonotonic (A : Type) `{GenSizedSuchThat A} `{@SizedMonotonic _ G ProducerGen arbitrarySizeST}. Class GenSizedSuchThatSizeMonotonicOpt (A : Type) `{GenSizedSuchThat A} `{@SizedMonotonicOpt A G ProducerGen arbitrarySizeST}. (** * Correctness of denendent sized generators *) Class GenSizedSuchThatCorrect (A : Type) (P : A -> Prop) `{GenSizedSuchThat A P} `{@CorrectSizedST A P G ProducerGen arbitrarySizeST}. (** * Dependent generators *) (* begin genST_class *) Class GenSuchThat (A : Type) (P : A -> Prop) := { arbitraryST : G (option A) }. (* end genST_class *) Notation "'genSizedST' x" := ((@arbitrarySizeST _ x _)) (at level 10). Notation "'genST' x" := ((@arbitraryST _ x _)) (at level 10). (** * Monotonicity of denendent generators *) Class GenSuchThatMonotonic (A : Type) (P : A -> Prop) `{GenSuchThat A P} `{@SizeMonotonic (option A) G ProducerGen arbitraryST}. Class GenSuchThatMonotonicOpt (A : Type) (P : A -> Prop) `{GenSuchThat A P} `{@SizeMonotonicOpt A G ProducerGen arbitraryST}. (** * Correctness of dependent generators *) Class GenSuchThatCorrect {A : Type} (P : A -> Prop) `{GenSuchThat A P} `{@CorrectST A P G ProducerGen arbitraryST}. Class GenSuchThatMonotonicCorrect (A : Type) (P : A -> Prop) `{GenSuchThat A P} `{@SizeMonotonicOpt A G ProducerGen arbitraryST} `{@CorrectST A P G ProducerGen arbitraryST}. (** Coercions *) #[global] Instance GenSizedSuchThatMonotonicOptOfSizeMonotonic (A : Type) (P : A -> Prop) (Hgen : GenSizedSuchThat A P) (Hmon : forall s : nat, SizeMonotonicOpt (arbitrarySizeST s)) : @GenSizedSuchThatMonotonicOpt A P Hgen Hmon := {}. #[global] Instance GenSizedSuchThatSizeMonotonicOptOfSizedMonotonic (A : Type) (P : A -> Prop) (Hgen : GenSizedSuchThat A P) (Hmon : SizedMonotonicOpt arbitrarySizeST) : @GenSizedSuchThatSizeMonotonicOpt A P Hgen Hmon := {}. #[global] Instance GenSizedSuchThatCorrectOptOfSizedSuchThatCorrect (A : Type) (P : A -> Prop) (H : GenSizedSuchThat A P) (Hcorr : CorrectSizedST P arbitrarySizeST) : @GenSizedSuchThatCorrect A P H Hcorr := {}. #[global] Instance GenSuchThatMonotonicOptOfSizeMonotonic (A : Type) (P : A -> Prop) (Hgen : GenSuchThat A P) (Hmon : SizeMonotonicOpt arbitraryST) : @GenSuchThatMonotonicOpt A _ Hgen Hmon := {}. #[global] Instance GenSuchThatCorrectOptOfSuchThatCorrect (A : Type) (P : A -> Prop) (H : GenSuchThat A P) (Hcorr : CorrectST P (genST P)) : @GenSuchThatCorrect A P H Hcorr := {}. #[global] Instance GenSuchThatMonotonicCorrectOptOfSuchThatCorrect (A : Type) (P : A -> Prop) (H : GenSuchThat A P) (Hcorr : CorrectST P (genST P)) (Hmon : SizeMonotonicOpt (genST P)) : @GenSuchThatMonotonicCorrect A P H Hmon Hcorr := {}. #[global] Instance SizeMonotonicOptofSizeMonotonic {A} (g : G (option A)) {H : SizeMonotonic g} : SizeMonotonicOpt g. Proof. intros s1 s2 Hs a. eapply monotonic; eauto. Qed. (** * Coercions from sized to unsized generators *) (* Generators *) (* begin GenSuchThatOfBounded *) #[global] Instance GenSuchThatOfBounded (A : Type) (P : A -> Prop) (H : GenSizedSuchThat A P) : GenSuchThat A P := { arbitraryST := sized arbitrarySizeST }. (* end GenSuchThatOfBounded *) Generalizable Variables PSized PMon PSMon PCorr. (* Monotonicity *) #[global] Instance GenSuchThatMonotonicOfSized (A : Type) (P : A -> Prop) {H : GenSizedSuchThat A P} `{@GenSizedSuchThatMonotonic A P H PMon} `{@GenSizedSuchThatSizeMonotonic A P H PSMon} : @GenSuchThatMonotonic A P (GenSuchThatOfBounded _ _ H) (@sizedSizeMonotonic G ProducerGen _ _ _ PMon PSMon) := {}. #[global] Instance SizeMonotonicOptOfBounded' (A : Type) (P : A -> Prop) {H : GenSizedSuchThat A P} `{@GenSizedSuchThatMonotonicOpt A P H PMon} `{@GenSizedSuchThatSizeMonotonicOpt A P H PSMon} : SizeMonotonicOpt (genST P). Proof. unfold arbitraryST, GenSuchThatOfBounded. red. red in PMon. do 2 red. intros. unfold semProdSizeOpt in *. red in PMon. apply semSizedSize in H3. apply semSizedSize. unfold SizedMonotonicOpt in PSMon. destruct (PSMon s1 s1 s2 H2 a). apply H3. apply (PMon s2 s1 s2); auto. do 3 red. eauto. rewrite /semGenSize => //=. exists x. eauto. Qed. (* begin SizeMonotonicOptOfBounded *) #[global] Instance SizeMonotonicOptOfBounded (A : Type) (P : A -> Prop) (H1 : GenSizedSuchThat A P) (H3 : forall s : nat, SizeMonotonicOpt (arbitrarySizeST s)) (H4 : SizedMonotonicOpt arbitrarySizeST) (* XXX change name *) : SizeMonotonicOpt (genST P). (* end SizeMonotonicOptOfBounded *) Proof. eapply SizeMonotonicOptOfBounded'. constructor; eauto. constructor; eauto. Qed. #[global] Instance GenSuchThatMonotonicOptOfSized' (A : Type) (P : A -> Prop) {H : GenSizedSuchThat A P} `{@GenSizedSuchThatMonotonicOpt A P H PMon} `{@GenSizedSuchThatSizeMonotonicOpt A P H PSMon} : GenSuchThatMonotonicOpt A P := {}. (* Correctness *) #[global] Instance SuchThatCorrectOfBounded' (A : Type) (P : A -> Prop) {H : GenSizedSuchThat A P} `{@GenSizedSuchThatMonotonicOpt A P H PMon} `{@GenSizedSuchThatSizeMonotonicOpt A P H PSMon} `{@GenSizedSuchThatCorrect A P H PCorr} : CorrectST P arbitraryST. Proof. constructor; unfold arbitraryST, GenSuchThatOfBounded. split. - intros [s [_ H4]]. eapply semSizedSizeGen in H4. eapply PCorr. eexists; eauto. eexists; eauto. split; eauto. reflexivity. - intros Hp. eapply PCorr in Hp. destruct Hp as [s [x [_ Hs]]]. eexists (max s x). split. reflexivity. eapply semSizedSizeGen. eapply PMon; [ | eapply PSMon; [ | eassumption ]]. ssromega. ssromega. Qed. (* begin SuchThatCorrectOfBounded *) #[global] Instance SuchThatCorrectOfBounded (A : Type) (P : A -> Prop) (H1 : GenSizedSuchThat A P) (H3 : forall s : nat, SizeMonotonicOpt (arbitrarySizeST s)) (H4 : SizedMonotonicOpt arbitrarySizeST) (* XXX change name *) (H5 : CorrectSizedST P arbitrarySizeST) : CorrectST P arbitraryST. (* end SuchThatCorrectOfBounded *) Proof. eapply SuchThatCorrectOfBounded'; eauto. constructor; eauto. constructor; eauto. constructor; eauto. Qed. (* Dependent Sized Enumerators *) (** * Dependent sized generators *) (* begin genSTSized_class *) Class EnumSizedSuchThat (A : Type) (P : A -> Prop) := { enumSizeST : nat -> E (option A) }. (* end genSTSized_class *) (** * Monotonicity of denendent sized generators *) Class EnumSizedSuchThatMonotonic (A : Type) `{EnumSizedSuchThat A} `{forall s, SizeMonotonic (enumSizeST s)}. Class EnumSizedSuchThatMonotonicOpt (A : Type) `{EnumSizedSuchThat A} `{forall s, SizeMonotonicOpt (enumSizeST s)}. Class EnumSizedSuchThatSizeMonotonic (A : Type) `{EnumSizedSuchThat A} `{@SizedMonotonic _ E ProducerEnum enumSizeST}. Class EnumSizedSuchThatSizeMonotonicOpt (A : Type) `{EnumSizedSuchThat A} `{@SizedMonotonicOpt A E ProducerEnum enumSizeST}. (** * Correctness of denendent sized generators *) Class EnumSizedSuchThatCorrect (A : Type) (P : A -> Prop) `{EnumSizedSuchThat A P} `{@CorrectSizedST A P E ProducerEnum enumSizeST}. (** * Dependent generators *) (* begin genST_class *) Class EnumSuchThat (A : Type) (P : A -> Prop) := { enumSuchThat : E (option A) }. (* end genST_class *) Notation "'enumST' x" := (@enumSuchThat _ x _) (at level 70). (** * Monotonicity of denendent generators *) Class EnumSuchThatMonotonic (A : Type) (P : A -> Prop) `{EnumSuchThat A P} `{@SizeMonotonic (option A) E ProducerEnum enumSuchThat}. Class EnumSuchThatMonotonicOpt (A : Type) (P : A -> Prop) `{EnumSuchThat A P} `{@SizeMonotonicOpt A E ProducerEnum enumSuchThat}. (** * Correctness of dependent generators *) Class EnumSuchThatCorrect {A : Type} (P : A -> Prop) `{EnumSuchThat A P} `{@CorrectST A P E ProducerEnum enumSuchThat}. Class EnumSuchThatMonotonicCorrect (A : Type) (P : A -> Prop) `{EnumSuchThat A P} `{@SizeMonotonicOpt A E ProducerEnum enumSuchThat} `{@CorrectST A P E ProducerEnum enumSuchThat}. (** Coercions *) #[global] Instance EnumSizedSuchThatMonotonicOptOfSizeMonotonic (A : Type) (P : A -> Prop) (Hgen : EnumSizedSuchThat A P) (Hmon : forall s : nat, SizeMonotonicOpt (enumSizeST s)) : @EnumSizedSuchThatMonotonicOpt A P Hgen Hmon := {}. #[global] Instance EnumSizedSuchThatSizeMonotonicOptOfSizedMonotonic (A : Type) (P : A -> Prop) (Hgen : EnumSizedSuchThat A P) (Hmon : SizedMonotonicOpt enumSizeST) : @EnumSizedSuchThatSizeMonotonicOpt A P Hgen Hmon := {}. #[global] Instance EnumSizedSuchThatCorrectOptOfSizedSuchThatCorrect (A : Type) (P : A -> Prop) (H : EnumSizedSuchThat A P) (Hcorr : CorrectSizedST P enumSizeST) : @EnumSizedSuchThatCorrect A P H Hcorr := {}. #[global] Instance EnumSuchThatMonotonicOptOfSizeMonotonic (A : Type) (P : A -> Prop) (Hgen : EnumSuchThat A P) (Hmon : SizeMonotonicOpt enumSuchThat) : @EnumSuchThatMonotonicOpt A _ Hgen Hmon := {}. #[global] Instance EnumSuchThatCorrectOptOfSuchThatCorrect (A : Type) (P : A -> Prop) (H : EnumSuchThat A P) (Hcorr : CorrectST P (enumST P)) : @EnumSuchThatCorrect A P H Hcorr := {}. #[global] Instance SizeMonotonicOptofSizeMonotonicEnum {A} (g : E (option A)) {H : SizeMonotonic g} : SizeMonotonicOpt g. Proof. intros s1 s2 Hs a. eapply monotonic; eauto. Qed. #[global] Instance EnumSuchThatMonotonicCorrectOptOfSuchThatCorrect (A : Type) (P : A -> Prop) (H : EnumSuchThat A P) (Hcorr : CorrectST P (enumST P)) (Hmon : SizeMonotonicOpt (enumST P)) : @EnumSuchThatMonotonicCorrect A P H Hmon Hcorr := {}. (** * Coercions from sized to unsized generators *) (* Enumerators *) (* begin EnumSuchThatOfBounded *) #[global] Instance EnumSuchThatOfBounded (A : Type) (P : A -> Prop) (H : EnumSizedSuchThat A P) : EnumSuchThat A P := { enumSuchThat := sized enumSizeST }. (* end EnumSuchThatOfBounded *) (* Monotonicity *) #[global] Instance EnumSuchThatMonotonicOfSized (A : Type) (P : A -> Prop) {H : EnumSizedSuchThat A P} `{@EnumSizedSuchThatMonotonic A P H PMon} `{@EnumSizedSuchThatSizeMonotonic A P H PSMon} : @EnumSuchThatMonotonic A P (EnumSuchThatOfBounded _ _ H) (@sizedSizeMonotonic E ProducerEnum _ _ _ PMon PSMon) := {}. #[global] Instance SizeMonotonicOptOfBoundedEnum' (A : Type) (P : A -> Prop) {H : EnumSizedSuchThat A P} `{@EnumSizedSuchThatMonotonicOpt A P H PMon} `{@EnumSizedSuchThatSizeMonotonicOpt A P H PSMon} : SizeMonotonicOpt (enumST P). Proof. unfold enumSuchThat, EnumSuchThatOfBounded. eapply sizedSizeMonotonicOpt; eauto with typeclass_instances. Qed. (* begin SizeMonotonicOptOfBounded *) #[global] Instance SizeMonotonicOptOfBoundedEnum (A : Type) (P : A -> Prop) (H1 : EnumSizedSuchThat A P) (H3 : forall s : nat, SizeMonotonicOpt (enumSizeST s)) (H4 : SizedMonotonicOpt enumSizeST) (* XXX change name *) : SizeMonotonicOpt (enumST P). (* end SizeMonotonicOptOfBounded *) Proof. eapply SizeMonotonicOptOfBoundedEnum'. constructor; eauto. constructor; eauto. Qed. #[global] Instance EnumSuchThatMonotonicOptOfSized' (A : Type) (P : A -> Prop) {H : EnumSizedSuchThat A P} `{@EnumSizedSuchThatMonotonicOpt A P H PMon} `{@EnumSizedSuchThatSizeMonotonicOpt A P H PSMon} : EnumSuchThatMonotonicOpt A P := {}. Lemma size_CorrectST {A : Type} (P : A -> Prop) {G} {PG : Producer G} {PS: @ProducerSemantics G PG} (g : nat -> G (option A)) {Hm1 : forall s, SizeMonotonicOpt (g s)} {Hm2 : SizedMonotonicOpt g} {_ : CorrectSizedST P g} : CorrectST P (sized g). Proof. inv H. constructor. intros x. split; intros Hin. - eapply corrST0. inv Hin. inv H0. eapply semSizedSize in H2. eexists. eexists; split; eauto. - eapply corrST0 in Hin. inv Hin. inv H0. inv H1. eexists (max x0 x1). split; eauto. eapply semSizedSize. eapply Hm1; [ | eapply Hm2; [ | eassumption ]]; ssromega. Qed. (* Correctness *) #[global] Instance SuchThatCorrectOfBoundedEnum' (A : Type) (P : A -> Prop) {H : EnumSizedSuchThat A P} `{@EnumSizedSuchThatMonotonicOpt A P H PMon} `{@EnumSizedSuchThatSizeMonotonicOpt A P H PSMon} `{@EnumSizedSuchThatCorrect A P H PCorr} : CorrectST P enumSuchThat. Proof. constructor; unfold enumSuchThat, EnumSuchThatOfBounded. eapply size_CorrectST; eauto with typeclass_instances. Qed. (* begin SuchThatCorrectOfBounded *) #[global] Instance SuchThatCorrectOfBoundedEnum (A : Type) (P : A -> Prop) (H1 : EnumSizedSuchThat A P) (H3 : forall s : nat, SizeMonotonicOpt (enumSizeST s)) (H4 : SizedMonotonicOpt enumSizeST) (* XXX change name *) (H5 : CorrectSizedST P enumSizeST) : CorrectST P enumSuchThat. (* end SuchThatCorrectOfBounded *) Proof. eapply SuchThatCorrectOfBoundedEnum'; eauto. constructor; eauto. constructor; eauto. constructor; eauto. Qed. Lemma enumeratingOpt_sound A P (e : E (option A)) {Hc : CorrectST P e} ch s : enumeratingOpt e ch s = Some true -> exists x, P x /\ ch x = Some true. Proof. unfold enumeratingOpt. assert (Hs : forall x, LazyList.In_ll (Some x) (Enumerators.run e s) -> P x). { intros. eapply Hc. eexists. split; eauto. reflexivity. simpl. eassumption. } revert Hs. generalize (Enumerators.run e s), false. clear. induction l; intros b Hyp Heq; simpl in *. - destruct b; congruence. - destruct a; eauto. destruct (ch a) as [ [| ] | ] eqn:Heq'; eauto. Qed. Lemma enumeratingOpt_complete A P (e : E (option A)) {Hc : CorrectST P e} ch x : P x -> ch x = Some true -> exists s, enumeratingOpt e ch s = Some true. Proof. unfold enumeratingOpt. intros Hp Heq. assert (Hs : semProdOpt e x). { eapply Hc. eassumption. } destruct Hs as [s [_ Hs]]. simpl in *. unfold semEnumSize in Hs. exists s. revert Hs Heq. generalize (Enumerators.run e s), false. clear. induction l; intros b Hin Heq; simpl in *. - exfalso; eauto. - inv Hin. + rewrite Heq. reflexivity. + destruct a; eauto. destruct (ch a) as [ [| ] | ] eqn:Heq'; eauto. Qed. Lemma enumeratingOpt_sound_simpl A (e : E (option A)) ch s : enumeratingOpt e ch s = Some true -> exists x, ch x = Some true. Proof. unfold enumeratingOpt. generalize (Enumerators.run e s), false. clear. induction l; intros b Heq; simpl in *. - destruct b; congruence. - destruct a; eauto. destruct (ch a) as [ [| ] | ] eqn:Heq'; eauto. Qed. QuickChick-2.1.0/src/EnumProofs.v000066400000000000000000001462471476030541200166230ustar00rootroot00000000000000From Coq Require Import String Lia List ssreflect ssrbool ssrfun. Import ListNotations. From Ltac2 Require Import Ltac2. Set Warnings "-notation-overwritten, -parsing". From mathcomp Require Import ssrnat eqtype seq. Set Bullet Behavior "Strict Subproofs". From QuickChick Require Import Tactics TacticsUtil Instances Classes DependentClasses Sets Producer Enumerators Checker Decidability CheckerProofs. Local Open Scope set_scope. Section Lemmas. Lemma semProdSizeOpt_bicupNone A s (S : set A) : \bigcup_(x in [:: returnEnum (@None A)]) semProdSizeOpt x s \subset S. Proof. intros x Hin. inv Hin. inv H. inv H0. - inv H1. congruence. inv H. - inv H. Qed. Lemma list_subset_cons {A} (h : A) (t : seq A) (s : set A) : s h -> t \subset s -> (h :: t) \subset s. Proof. intros H1 H2 x Hin. inv Hin; eauto. Qed. Lemma list_subset_nil {A} (s : set A) : [::] \subset s. Proof. intros x Hin. inv Hin. Qed. Lemma exists_oneOf_hd A (x : A) g' (g : nat -> E A) (l : nat -> seq (E A)) : (exists s : nat, semProd (g s) x) -> exists s : nat, semProd (oneOf_ g' ((g s) :: (l s))) x. Proof. intros Hin. inv Hin. eexists. eapply semOneof. now eauto with typeclass_instances. eexists. split; eauto. now left. Qed. Lemma exists_oneOf_tl A (x : A) g' (g : nat -> E A) (l : nat -> seq (E A)) : (exists s : nat, match l s with | nil => False | g1 :: gs => semProd (oneOf_ g' (g1 :: gs)) x end) -> exists s : nat, semProd (oneOf_ g' ((g s) :: (l s))) x. Proof. intros Hin. inv Hin. eexists. eapply semOneof. now eauto with typeclass_instances. destruct (l x0) eqn:Heq. - exfalso; eauto. - eapply semOneof in H > [ | now eauto with typeclass_instances ]. rewrite Heq. inv H. destruct H0. eexists. split > [ | eassumption ]. now right; eauto. Qed. Lemma exists_bind A B (x : A) (g : E B) (f : nat -> B -> E A) : Correct B g -> SizeMonotonic g -> (forall a s, SizeMonotonic (f a s)) -> (exists z s, semProd (f s z) x) -> exists s : nat, semProd (bindEnum g (f s)) x. Proof. intros Hc Hs1 Hs2 He. inv He. inv H. inv H0. inv H. assert (Hin : [set : B] x0) by reflexivity. eapply Hc in Hin. inv Hin. inv H. exists x1, (Nat.max x2 x3). split. reflexivity. eapply (@semBindSize E ProducerEnum _ B A). eexists. split. eapply Hs1 > [ | eassumption ]. now ssromega. eapply Hs2 > [ | eassumption ]. now ssromega. Qed. Lemma exists_return A (x : A) : exists s : nat, semProd (returnEnum x) x. Proof. exists 0. eapply (@semReturn E _ ProducerSemanticsEnum); reflexivity. Qed. Lemma exists_bind_Sized_alt A B (g : nat -> E B) (f : B -> nat -> E A) (x : A) (z : B) (s' : nat) : SizedMonotonic g -> (forall s, SizeMonotonic (g s)) -> (forall a, SizedMonotonic (f a)) -> (forall a s, SizeMonotonic (f a s)) -> semProd (g s') z -> (exists s, semProd (f z s) x) -> exists s : nat, semProd (bindEnum (g s) (fun x => f x s)) x. Proof. intros Hs Hs' Hsf Hsf' Hprod Hex. inv Hex. inv Hprod. inv H. destruct H0. exists (Nat.max s' x0). inv H1. exists (Nat.max x1 x2). split. reflexivity. eapply (@semBindSize E ProducerEnum _ B A). eexists. split. eapply Hs > [ | eapply Hs' > [ | eassumption ] ]. ssromega. ssromega. eapply Hsf > [ | eapply Hsf' > [ | eassumption ] ]. ssromega. ssromega. Qed. Lemma semProd_mon {A} (g : nat -> E A) {_ : SizedMonotonic g} : forall s1 s2, (s1 <= s2)%coq_nat -> semProd (g s1) \subset semProd (g s2). Proof. intros s1 s2 Hleq. intros x Hin. inv Hin. inv H0. eexists x0. split; eauto. eapply H > [ | eassumption ]. destruct (leqP s1 s2); eauto. Qed. Lemma exists_enum_hd A (g : nat -> E (option A)) (gs : nat -> list (E (option A))) x : (exists s, semProdOpt (g s) x) -> exists s, semProdOpt (enumerate (g s :: gs s)) x. Proof. intros [s He]. exists s. eapply (@enumerate_correct_opt A). eexists. split. now left. eassumption. Qed. Lemma exists_enum_tl A (g : nat -> E (option A)) (gs : nat -> list (E (option A))) x : (exists s, semProdOpt (enumerate (gs s)) x) -> exists s, semProdOpt (enumerate (g s :: gs s)) x. Proof. intros [s He]. exists s. eapply (@enumerate_correct_opt A). eapply (@enumerate_correct_opt A) in He. destruct He as [z [Hin Hsem]]. eexists. split. now right; eauto. eassumption. Qed. Lemma exists_bind_Opt A B (x : A) (g : E B) (f : B -> nat -> E (option A)) z : Correct B g -> SizeMonotonic g -> (forall a s, SizeMonotonicOpt (f a s)) -> (exists s, semProdOpt (f z s) x) -> exists s : nat, semProdOpt (bindEnum g (fun x => f x s)) x. Proof. intros Hc Hs1 Hs2 He. inv He. inv H. inv H0. inv H. assert (Hin : [set : B] z) by reflexivity. eapply Hc in Hin. inv Hin. inv H. exists x0, (Nat.max x1 x2). split. reflexivity. eapply (@semBindSize E ProducerEnum _ B). eexists. split. eapply Hs1 > [ | eassumption ]. now ssromega. eapply Hs2 > [ | eassumption ]. now ssromega. Qed. Lemma exists_return_Opt A (x : A) : exists s : nat, semProdOpt (returnEnum (Some x)) x. Proof. exists 0. eapply (@semReturn E _ ProducerSemanticsEnum); reflexivity. Qed. Lemma exists_bindOpt_Opt A B (x : A) (g : E (option B)) (f : B -> nat -> E (option A)) z : SizeMonotonicOpt g -> (forall a s, SizeMonotonicOpt (f a s)) -> semProdOpt g z -> (exists s, semProdOpt (f z s) x) -> exists s : nat, semProdOpt (bindOpt g (fun x => f x s)) x. Proof. intros Hc Hs1 Hs2 He. destruct He as [s1 He]. exists s1. eapply (@semOptBindOpt E _ _ B); eauto with typeclass_instances. eexists. split; eassumption. Qed. Lemma exists_bindOpt_Opt_Sized A B (x : A) (g : nat -> E (option B)) (f : B -> nat -> E (option A)) z : SizedMonotonicOpt g -> (forall s, SizeMonotonicOpt (g s)) -> (forall a, SizedMonotonicOpt (f a)) -> (forall a s, SizeMonotonicOpt (f a s)) -> (exists s, semProdOpt (g s) z) -> (exists s, semProdOpt (f z s) x) -> exists s : nat, semProdOpt (bindOpt (g s) (fun z => f z s)) x. Proof. intros Hs1 Hs1' Hs2 Hs2' Hg Hf. destruct Hg as [s1 He]. destruct Hf. exists (max x0 s1). eapply (@semOptBindOpt E _ _ B); eauto with typeclass_instances. inv He. inv H. inv H0. inv H1. eexists. split. eexists. split. reflexivity. eapply Hs1 > [ | eassumption ]. ssromega. eexists. split. reflexivity. eapply Hs2 > [ | eassumption ]. ssromega. Qed. Lemma exists_match_DecOpt {B} P {_ : DecOpt P} (k : nat -> E (option B)) z : DecOptSizeMonotonic P -> DecOptCompletePos P -> SizedMonotonicOpt k -> P -> (exists s, semProdOpt (k s) z) -> exists (s : nat), semProdOpt (match decOpt s.+1 with | Some true => k s | Some false => failEnum | None => returnEnum None end) z. Proof. intros Hmon Hcom Hmonk Hp [s1 [s [_ He]]]. eapply Hcom in Hp. destruct Hp as [s2 Hdec]. eexists (max s1 s2). eapply Hmon in Hdec. rewrite Hdec. eexists. split. reflexivity. eapply Hmonk > [ | eassumption ]. ssromega. ssromega. Qed. Lemma exists_match_DecOpt_neg {B} P {_ : DecOpt P} (k : nat -> E (option B)) z : DecOptSizeMonotonic P -> DecOptCompleteNeg P -> SizedMonotonicOpt k -> ~ P -> (exists s, semProdOpt (k s) z) -> exists (s : nat), semProdOpt (match decOpt s.+1 with | Some false => k s | Some true => failEnum | None => returnEnum None end) z. Proof. intros Hmon Hcom Hmonk Hp [s1 [s [_ He]]]. eapply Hcom in Hp. destruct Hp as [s2 Hdec]. eexists (max s1 s2). eapply Hmon in Hdec. rewrite Hdec. eexists. split. reflexivity. eapply Hmonk > [ | eassumption ]. ssromega. ssromega. Qed. Lemma semProdSizeOpt_semProdOpt {A} {G : Type -> Type} {_ : Producer G} (e1 e2 : E (option A)) : (forall s, semProdSizeOpt e1 s \subset semProdSizeOpt e2 s) -> semProdOpt e1 \subset semProdOpt e2. Proof. intros H x Hin. inv Hin. inv H0. eexists. split; eauto. eapply H. eassumption. Qed. Global Instance SizeMonotonicOpt_failEnum A : @SizeMonotonicOpt A E _ failEnum. Proof. intros s1 s2 Hleq. eapply subset_refl. Qed. Lemma semProdOpt_failEnum A : semProdOpt failEnum <--> (@set0 A). Proof. intro x; split; intros H1. inv H1. inv H. now inv H1. now inv H1. Qed. Lemma semProdOpt_return_None {A} : semProdOpt (returnEnum None) <--> (@set0 A). Proof. intro x; split; intro H; inv H. inv H0. inv H1. congruence. inv H0. Qed. Lemma SizeMonotonicOptFP_proof A (g : nat -> E (option A)) : (forall s s1 s2, (s1 <= s2)%coq_nat -> (* monotonic Opt *) (semProdSizeOpt (g s1) s \subset semProdSizeOpt (g s2) s) /\ (* sizeFP *) (~ semProdSize (g s1) s None -> semProdSize (g s1) s <--> semProdSize (g s2) s) /\ (* Antimonotonic None *) (isNone :&: semProdSize (g s2) s \subset isNone :&: semProdSize (g s1) s)) -> SizedMonotonicOptFP g. Proof. intros H. constructor. intro; intros. eapply H; eauto. intro; intros. eapply H; eauto. intro; intros. eapply H; eauto. Qed. End Lemmas. Ltac2 guarded_subset_refl (_ : unit) := match! goal with | [ |- ?s \subset ?s ] => now eapply subset_refl end. (** ** Enum **) Ltac2 simpl_minus_enumSized (_ : unit) := ltac1:(with_strategy opaque [enumSized] simplstar). Ltac2 simpl_enumSized (_ : unit) := unfold enumSized; simpl_minus_enumSized (). Ltac2 find_size_mon_inst (_ : unit) := first [ tci | eapply sizedSizeMonotonicOpt; tci | eapply sizedSizeMonotonic; tci ]. (*** Sized Monotonicity *) Ltac2 rec enum_sized_mon (ih : ident) := first [ (* ret *) guarded_subset_refl () | (* bind *) eapply (@semBindSize_subset_compat _ _ ProducerSemanticsEnum) > [ let x := Fresh.in_goal (id_of_string "x") in intros $x; first [ now eapply subset_refl (* for calls to enum *) | let ih' := Control.hyp ih in (* for recursive calls *) eapply $ih'; now ssromega ] | let x := Fresh.in_goal (id_of_string "x") in let s := Fresh.in_goal (id_of_string "s") in intros $x $s; enum_sized_mon ih ] ]. Ltac2 rec find_enum (_ : unit) := first [ now eapply incl_bigcup_list_nil | eapply incl_bigcup_compat_list > [ now eapply subset_refl | find_enum () ] | eapply incl_bigcup_list_hd; now eapply subset_refl | eapply incl_bigcup_list_tl; find_enum () ]. Ltac2 base_case_size_mon (_ : unit) := destruct s2 > [ guarded_subset_refl () | simpl_enumSized (); first [ guarded_subset_refl () | rewrite !&Hone; now find_enum () ] ]. Ltac2 rec enums_sized_mon (ih : ident) := first [ now eapply incl_bigcup_list_nil | eapply incl_bigcup_compat_list > [ now enum_sized_mon @IHs1 | enums_sized_mon ih ] ]. Ltac2 ind_case_sized_mon (_ : unit) := destruct s2 > [ now ssromega | simpl_enumSized (); first [ now enum_sized_mon @IHs1 | rewrite !&Hone; now enums_sized_mon @IHs1 ] ]. Ltac2 derive_enum_SizedMonotonic (_ : unit) := assert (Hone := @semOneofSize E _ ProducerSemanticsEnum); match! goal with | [ |- @SizedMonotonic ?t _ _ (@enumSized _ ?inst) ] => (intros s s1; revert s; induction s1 as [| s1 IHs1 ]; intros s s2 Hleq) > [ now base_case_size_mon () | now ind_case_sized_mon () ] end. (*** Size monotonicity *) Ltac2 rec enum_size_mon (ih : ident) := first [ (* ret *) eapply returnGenSizeMonotonic; tci | (* bind *) eapply bindMonotonic > [ tci | first [ now find_size_mon_inst () (* for calls to enum *) | let ih' := Control.hyp ih in (* for recursive calls *) eapply $ih'; now ssromega ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; enum_size_mon ih ] ]. Ltac2 rec enums_size_mon (t : constr) (ih : ident) := first [ now eapply (@list_subset_nil (E $t)) | eapply (@list_subset_cons (E $t)) > [ now enum_size_mon ih | enums_size_mon t ih ] ]. Ltac2 derive_enum_SizeMonotonic (_ : unit) := intros s; match! goal with | [ |- @SizeMonotonic ?t _ _ _ ] => induction s as [ | s IHs ]; simpl_enumSized (); first [ eapply oneofMonotonic > [ tci | now enum_size_mon @IHs | now enums_size_mon t @IHs ] | now enum_size_mon @IHs ] end. (*** Correct *) Ltac2 find_corr_inst (_ : unit) := first [ tci | match! goal with | [ |- Correct ?ty (sizedEnum enumSized) ] => eapply (@EnumCorrectOfSized $ty _) > [ tci | now find_size_mon_inst () | tci ] end ]. Ltac2 solve_sized_mon (hs : ident) := (* let t := Fresh.in_goal (id_of_string "t") in *) (* let s := Fresh.in_goal (id_of_string "s") in *) (* let s1 := Fresh.in_goal (id_of_string "s1") in *) (* let s2 := Fresh.in_goal (id_of_string "s2") in *) (* let hleq := Fresh.in_goal (id_of_string "Hleq") in *) intros ? ? ? ? ?; now enum_sized_mon hs. Ltac2 solve_size_mon (hs : ident) := intros ? ?; now enum_size_mon hs. Ltac2 if_exists tac := match! goal with | [|- exists s, semProd _ _ ] => tac end. Ltac2 rec enum_size_correct (_ : unit) := first [ (* return *) now eapply exists_return; eauto | (* bind non rec *) match! goal with | [ |- exists _ : nat, semProd (bindEnum (* enum *) _ _) _ ] => eapply exists_bind > [ now find_corr_inst () | now find_size_mon_inst () | now solve_size_mon @Hsize | now eexists; enum_size_correct () ] end | (* bind rec *) match! goal with | [|- exists z, semProd (bindEnum (_ _) _) _ ] => eapply exists_bind_Sized_alt > [ tci | now find_size_mon_inst () | now solve_sized_mon @Hsized | now solve_size_mon @Hsize | | now enum_size_correct () ]; eassumption end ]. Ltac2 destructIH (_ : unit) := match! goal with | [ h : (exists s, semProd _ _) |- _ ] => let h' := Control.hyp h in destruct $h' end. Ltac2 rec try_solve_correct (_ : unit) := first [ eapply exists_oneOf_hd; now enum_size_correct () | eapply exists_oneOf_tl; try_solve_correct () ]. Ltac2 derive_enum_Correct (_ : unit) := match! goal with | [ |- @CorrectSized ?typ _ _ ?en ] => simpl_enumSized (); match! goal with | [ |- @CorrectSized _ _ _ ?en_simpl ] => (* get the enum body *) set (_aux_enum := ltac2:(exact $en_simpl)); let hsize := Fresh.in_goal (id_of_string "Hsize") in let hsized := Fresh.in_goal (id_of_string "Hsized") in let ind := Fresh.in_goal (id_of_string "t") in (* Derive monotonicity instances *) assert ($hsized : SizedMonotonic $en) > [ tci | ]; assert ($hsize : forall s, SizeMonotonic ($en s)) > [ tci | ]; econstructor; intro $ind; split > [ intro; exact I | intros _ ]; let ind' := Control.hyp ind in induction $ind'; eapply exists_Sn; repeat (destructIH ()); simpl_enumSized (); first [ enum_size_correct () | try_solve_correct () ] end end. (** ** EnumST **) Ltac2 simpl_minus_enumSizeST (_ : unit) := ltac1:(with_strategy opaque [enumSizeST enum decOpt enumSizeST] simplstar). Ltac2 simpl_enumSizeST (_ : unit) := unfold enumSizeST; simpl_minus_enumSizeST (). Ltac2 get_ty (e : constr) := match Constr.Unsafe.kind e with | Constr.Unsafe.Lambda b app => match Constr.Unsafe.kind app with | Constr.Unsafe.App ty args => ty | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a function")))) end. Ltac2 get_args (pred : constr) := match Constr.Unsafe.kind pred with | Constr.Unsafe.Lambda b app => match Constr.Unsafe.kind app with | Constr.Unsafe.App ty args => List.filter (fun x => match Constr.Unsafe.kind x with | Constr.Unsafe.Rel _ => (* the arg we are enumeting *) false | Constr.Unsafe.Var _ => (* other args *) true | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Internal error : args must be free or bound vars")))) end) (Array.to_list args) | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a function")))) end. Ltac2 revert_params (pred : constr) := let args := get_args pred in let l := constrs_to_idents args in List.iter (fun x => try (revert $x)) l. Ltac2 intro_params (pred : constr) := let args := get_args pred in let l := constrs_to_idents args in List.iter (fun x => try (intro $x)) (List.rev l). (*** Sized monotonic *) Ltac2 rec enumST_sized_mon (ih : ident) := first [ (* ret *) guarded_subset_refl () | (* dec matching *) match! goal with | [ |- semProdSizeOpt (match @decOpt ?p ?i ?s1 with _ => _ end) _ \subset semProdSizeOpt (match decOpt ?s2 with _ => _ end) _ ] => let hdec := Fresh.in_goal (id_of_string "Hdec") in destruct (@decOpt $p $i $s1) eqn:$hdec > [ ((erewrite (@CheckerProofs.mon $p $i _ $s1 $s2) > [ | | first [ eassumption | ssromega ] ]) > [ enumST_sized_mon ih | ssromega ]) | rewrite (@semReturnSizeOpt_None E _ ProducerSemanticsEnum); now eapply sub0set ] end | (* input matching *) match! goal with | [ |- semProdSizeOpt (match ?p with _ => _ end) _ \subset _ ] => destruct $p; enumST_sized_mon ih end | (* bindOpt *) eapply (@semBindOptSizeOpt_subset_compat E _ ProducerSemanticsEnum) > [ first [ now eapply subset_refl (* for calls to enum *) | let ih' := Control.hyp ih in (* for recursive calls *) eapply $ih'; now ssromega ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; enumST_sized_mon ih ] | (* bind *) eapply (@semBindSizeOpt_subset_compat E _ ProducerSemanticsEnum) > [ now eapply subset_refl | let x := Fresh.in_goal (id_of_string "x") in intros $x; enumST_sized_mon ih ] | () ]. Ltac2 rec find_enumST (ih : ident) := first [ now eapply incl_bigcup_list_nil | now eapply semProdSizeOpt_bicupNone | eapply incl_bigcup_compat_list > [ (now enumST_sized_mon ih) | find_enumST ih ] | eapply incl_bigcup_list_tl; find_enumST ih ]. Ltac2 base_case_st_size_mon (s2 : constr) := destruct $s2 > [ first [ guarded_subset_refl () | rewrite !enumerate_correct_size_opt; find_enumST @dummy ] | rewrite !enumerate_correct_size_opt; find_enumST @dummy ]. Ltac2 ind_case_st_sized_mon (s2 : constr) (ih : ident) := destruct $s2 > [ now ssromega | rewrite !enumerate_correct_size_opt; find_enumST ih ]. Ltac2 derive_enumST_SizedMonotonic (_ : unit) := match! goal with | [ |- SizedMonotonicOpt (@enumSizeST ?typ ?pred ?inst) ] => (* assert (Henum := @enumerate_correct_size $typ); *) let s := Fresh.in_goal (id_of_string "s") in let s1 := Fresh.in_goal (id_of_string "s1") in let s2 := Fresh.in_goal (id_of_string "s2") in let s1i := Fresh.in_goal (id_of_string "s1i") in let s2i := Fresh.in_goal (id_of_string "s2i") in let hleq := Fresh.in_goal (id_of_string "Hleq") in let hleqi := Fresh.in_goal (id_of_string "Hleqi") in let ihs1 := Fresh.in_goal (id_of_string "ihs1") in intros $s $s1 $s2 $hleq; simpl_enumSizeST (); let hleq' := Control.hyp hleq in let s1' := Control.hyp s1 in let s2' := Control.hyp s2 in assert ($hleqi := $hleq'); revert $hleqi $hleq; generalize $s2' at 1 3; generalize $s1' at 1 3; revert $s $s2; revert_params pred; (induction $s1' as [| $s1 $ihs1 ]; intro_params pred; intros $s $s2 $s1i $s2i $hleqi $hleq) > [ base_case_st_size_mon s2' | ind_case_st_sized_mon s2' ihs1 ] end. Ltac2 rec enumST_antimon (ih : ident) := first [ (* ret *) guarded_subset_refl () | (* dec matching *) match! goal with | [ |- _ :&: semProdSize (match @decOpt _ _ ?s2 with _ => _ end) _ \subset _ :&: semProdSize (match @decOpt ?p ?i ?s1 with _ => _ end) _ ] => let hdec := Fresh.in_goal (id_of_string "Hdec") in destruct (@decOpt $p $i $s1) eqn:$hdec > [ (erewrite (@CheckerProofs.mon $p $i _ $s1 $s2) > [ | | first [ eassumption | ssromega ] ]) > [ enumST_antimon ih | ssromega ] | now eapply semProdSize_return_None ] end | (* input matching *) match! goal with | [ |- _ :&: semProdSize (match ?p with _ => _ end) _ \subset _ ] => destruct $p; enumST_antimon ih end | (* bindOpt *) eapply semBindOptSize_isNone_subset_compat > [ first [ intros; now eapply subset_refl (* for calls to enum *) | let ih' := Control.hyp ih in (* for recursive calls *) eapply $ih'; now ssromega ] | first [ intros; now eapply subset_refl (* for calls to enum *) | let ih' := Control.hyp ih in (* for recursive calls *) eapply $ih'; now ssromega ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; enumST_antimon ih ] (* | (* bind *) *) (* eapply (@semBindSizeOpt_subset_compat E _ ProducerSemanticsEnum) > *) (* [ now eapply subset_refl *) (* | let x := Fresh.in_goal (id_of_string "x") in *) (* intros $x; enumST_sized_mon ih *) (* ] *) | () ]. Ltac2 rec base_case_antimon (_ : unit) := match! goal with | [|- ?s1 :&: ?s2 \subset ?s3 :&: (@bigcup ?t ?u (seq_In (cons _ (cons _ _))) ?g)] => eapply (@incl_bigcup_list_tl_inter $t $u); base_case_antimon () | [|- _ \subset _ :&: (@bigcup ?t ?u (seq_In (cons _ nil)) _)] => eapply semProdSize_bigcup_isNone end. Ltac2 rec ind_case_antimon (ih : ident) := match! goal with | [|- ?s1 :&: ?s2 \subset ?s3 :&: (@bigcup ?t ?u (@seq_In _ (@nil _)) _)] => now eapply subset_refl | [|- ?s1 :&: ?s2 \subset ?s3 :&: (@bigcup ?t ?u _ _)] => eapply (@incl_bigcup_compat_list_inter $t $u) > [ enumST_antimon ih | ind_case_antimon ih ] end. Ltac2 rec base_case_fp (_ : unit) := match! goal with | [|- (@bigcup ?t ?u (seq_In (cons _ (cons _ _))) ?g) _] => eapply (@in_bigcup_list_tl $t $u); base_case_fp () | [|- (@bigcup ?t ?u (seq_In (cons _ nil)) _) _] => eapply in_bigcup_list_hd; eapply semReturnSizeEnum; reflexivity end. Ltac2 rewrite_eqs (eqs: constr list) := List.iter (fun eq => try (rewrite $eq)) eqs. Ltac2 rec pick_enum (cnt : int) := if Int.equal cnt 0 then (eapply in_bigcup_list_hd) else (eapply in_bigcup_list_tl; pick_enum (Int.sub cnt 1)). Ltac2 rec find_none (eqs : constr list) (binds : constr list) := first [ (* ret *) eapply semReturnSizeEnum; reflexivity | (* dec matching *) match! goal with | [ |- semEnumSize (match @decOpt ?p ?i ?s1 with _ => _ end) _ _ ] => rewrite_eqs eqs; simpl_minus_methods (); find_none eqs binds end (* | (* input matching *) () *) (* match! goal with *) (* | [ |- _ :&: semProdSize (match ?p with _ => _ end) _ \subset _ ] => *) (* destruct $p; enumST_antimon ih *) (* end *) | (* bindOpt *) first [ eapply semProdSize_bindOpt_1; eassumption | eapply semProdSize_bindOpt_2 > [ let h := List.hd binds in eapply $h | simpl_minus_methods (); find_none eqs (List.tl binds) ] ] | () ]. Ltac2 rec solve_ih_hyp (hnin : constr) (cnt : int) (typ : constr) (eqs : constr list) (binds : constr list) := let hc := Fresh.in_goal (id_of_string "Hc") in intros $hc; eapply $hnin; eapply (@enumerate_correct_size' $typ); pick_enum cnt; simpl_minus_methods (); find_none eqs binds. Ltac2 rec enumST_fp (ih : constr) (hnin: constr) (cnt : int) (typ : constr) (eqs : constr list) (binds : constr list) := first [ (* ret *) reflexivity | (* dec matching *) match! goal with | [ |- semEnumSize (match @decOpt ?p ?i ?s1 with _ => _ end) _ <--> semEnumSize (match @decOpt _ _ ?s2 with _ => _ end) _ ] => let hdec := Fresh.in_goal (id_of_string "Hdec") in (* destruct decOpt *) destruct (@decOpt $p $i $s1) eqn:$hdec (* ; simpl_minus_methods () *) > [ (* is Some *) (erewrite (@CheckerProofs.mon $p $i _ $s1 $s2) > [ | | first [ eassumption | ssromega ] ]) > [ let hdec := Control.hyp hdec in enumST_fp ih hnin cnt typ (hdec :: eqs) binds | ssromega ] | (* is None *) let hdec := Control.hyp hdec in exfalso; eapply $hnin; match! goal with | [ |- semEnumSize (enumerate ?lst) ?s _ ] => eapply (@enumerate_correct_size' _ $lst $s); pick_enum cnt; find_none (hdec :: eqs) (List.rev binds) end ] end | (* input matching *) match! goal with | [ |- semEnumSize (match ?p with _ => _ end) _ <--> _ ] => destruct $p; simpl_minus_methods (); enumST_fp ih hnin cnt typ eqs binds end | (* bindOpt *) (eapply semBindOptSize_subset_compat_eq; simpl_minus_methods ()) > [ first [ eapply $ih > [ lia | lia | solve_ih_hyp hnin cnt typ eqs (List.rev binds) ] | reflexivity ] | let x := Fresh.in_goal (id_of_string "x") in let hin := Fresh.in_goal (id_of_string "Hin") in intros $x $hin; let hin := Control.hyp hin in enumST_fp ih hnin cnt typ eqs (hin :: binds) ] | () ]. Ltac2 rec ind_case_fp (ih : constr) (hnin : constr) (cnt : int) (typ : constr) := match! goal with | [|- (@bigcup ?t ?u (seq_In (cons _ _)) ?g) <--> _] => eapply incl_bigcup_compat_list_eq > [ simpl_minus_methods (); enumST_fp ih hnin cnt typ [] [] | ind_case_fp ih hnin (Int.add cnt 1) typ ] | [|- (@bigcup ?t ?u (seq_In nil)) _ <--> _ ] => reflexivity end. Ltac2 derive_enumST_SizedMonotonicFP (_ : unit) := match! goal with | [ |- SizedMonotonicOptFP (@enumSizeST ?typ ?pred ?inst) ] => eapply SizeMonotonicOptFP_proof; let s := Fresh.in_goal (id_of_string "s") in let s1 := Fresh.in_goal (id_of_string "s1") in let s2 := Fresh.in_goal (id_of_string "s2") in let s1i := Fresh.in_goal (id_of_string "s1i") in let s2i := Fresh.in_goal (id_of_string "s2i") in let hleq := Fresh.in_goal (id_of_string "Hleq") in let hleqi := Fresh.in_goal (id_of_string "Hleqi") in let ihs1 := Fresh.in_goal (id_of_string "ihs1") in intros $s $s1 $s2 $hleq; simpl_enumSizeST (); let hleq' := Control.hyp hleq in let s1' := Control.hyp s1 in let s2' := Control.hyp s2 in assert ($hleqi := $hleq'); revert $hleqi $hleq; generalize $s2' at 1 3 5 7; generalize $s1' at 1 3 5 7 9; revert $s $s2; revert_params pred; (induction $s1' as [| $s1 $ihs1 ]; intro_params pred; intros $s $s2 $s1i $s2i $hleqi $hleq) > [ (* base cases *) split > [ | split ] > [ (* mon *) now base_case_st_size_mon s2' | (* fp *) let hnin := Fresh.in_goal (id_of_string "hnin") in intros $hnin; first [ destruct $s2'; reflexivity | exfalso; let hnin' := Control.hyp hnin in eapply $hnin'; eapply (@enumerate_correct_size' $typ); base_case_fp () | let hnin' := Control.hyp hnin in let dummy := Control.hyp hnin in (* XXX says not focused when using ; after destruct *) destruct $s2'> [ rewrite !enumerate_correct_size'; ind_case_fp dummy hnin' 0 typ | rewrite !enumerate_correct_size'; ind_case_fp dummy hnin' 0 typ ] ] (* | () ] *) | (* antimon *) first [ destruct $s2'; now eapply subset_refl | rewrite !enumerate_correct_size'; now base_case_antimon () | destruct $s2' > [ rewrite !enumerate_correct_size'; ind_case_antimon @dummy | rewrite !enumerate_correct_size'; ind_case_antimon @dummy ] ] ] | (* inuctive cases *) split > [ | split ] > [ (* mon *) ind_case_st_sized_mon s2' ihs1 | (* fp *) let hnin := Fresh.in_goal (id_of_string "hnin") in intros $hnin; destruct $s2' > [ lia | let hnin' := Control.hyp hnin in let ihs1' := Control.hyp ihs1 in rewrite !enumerate_correct_size'; now ind_case_fp ihs1' hnin' 0 typ ] | (* antimon *) destruct $s2' > [ lia | rewrite !enumerate_correct_size'; ind_case_antimon ihs1 ] ] ] end. (* Size Monotonicity *) Ltac2 rec enumST_size_mon (ih : ident) := first [ (* fail *) eapply SizeMonotonicOpt_failEnum; tci | (* ret *) eapply returnGenSizeMonotonicOpt; tci | (* bindOpt *) eapply bindOptMonotonicOpt > [ tci | first [ (* for calls to enum in params *) tci | (* for call to existing enum instances. XXX not sure why typeclass resulotion doesn't work *) eapply sizedSizeMonotonicOpt; tci | (* for recursive calls *) let ih' := Control.hyp ih in eapply $ih' ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; enumST_size_mon ih ] | (* bind *) eapply bindMonotonicOpt > [ tci | first [ (* for calls to enum in params *) tci | (* for call to existing enum instances. XXX not sure why typeclass resulotion doesn't work *) eapply sizedSizeMonotonic; tci | (* for recursive calls *) let ih' := Control.hyp ih in eapply $ih' ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; enumST_size_mon ih ] | (* input/dec matching *) match! goal with | [ |- SizeMonotonicOpt (match ?p with _ => _ end) ] => destruct $p; enumST_size_mon ih end | () ]. Ltac2 rec enumsST_size_mon (ih : ident) (t : constr) := first [ now eapply (@list_subset_nil (E (option $t))) | eapply (@list_subset_cons (E (option $t))) > [ enumST_size_mon ih | enumsST_size_mon ih t ] ]. Ltac2 derive_enumST_SizeMonotonic (_ : unit) := let s := Fresh.in_goal (id_of_string "s") in let ihs := Fresh.in_goal (id_of_string "Ihs") in let si := Fresh.in_goal (id_of_string "si") in intro $s; let s' := Control.hyp s in match! goal with | [ |- SizeMonotonicOpt (@enumSizeST ?typ ?pred ?inst _) ] => simpl_enumSizeST (); generalize $s' at 1; revert_params pred; induction $s' as [ | $s $ihs ]; intro_params pred; intros $si; eapply enumerate_SizeMonotonicOpt; enumsST_size_mon @IHs typ end. (* Size Monotonicity + FP *) Ltac2 rec enumST_size_fp (ih : ident) (typ : constr) := first [ (* ret *) eapply returnGenSizeFP; tci | (* fail *) eapply (@SizeFP_failEnum $typ) | (* bindOpt. *) match! goal with |[|- SizeFP (@bindOpt _ _ ?a ?b _ _) ] => eapply (@bindOptSizeFP $a $b) > [ first [ tci | eapply sizedSizeFP; tci | let ih' := Control.hyp ih in eapply $ih' ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; enumST_size_fp ih typ ] end | (* input/dec matching *) match! goal with | [ |- SizeFP (match ?p with _ => _ end) ] => destruct $p; enumST_size_fp ih typ end | () ]. Ltac2 rec enumsST_size_fp (ih : ident) (t : constr) := first [ now eapply (@list_subset_nil (E (option $t))) | eapply (@list_subset_cons (E (option $t))) > [ enumST_size_fp ih t | enumsST_size_fp ih t ] ]. Ltac2 derive_enumST_SizeMonotonicFP (_ : unit) := let s := Fresh.in_goal (id_of_string "s") in let ihs := Fresh.in_goal (id_of_string "Ihs") in let si := Fresh.in_goal (id_of_string "si") in intro $s; let s' := Control.hyp s in match! goal with | [ |- SizeMonotonicOptFP (@enumSizeST ?typ ?pred ?inst _) ] => simpl_enumSizeST (); generalize $s' at 1; revert_params pred; (induction $s' as [ | $s $ihs ]; intro_params pred; intros $si; eapply enumerate_SizeMonFP) > [ enumsST_size_fp ihs typ | enumsST_size_mon ihs typ | enumsST_size_fp ihs typ | enumsST_size_mon ihs typ ] end. (** Correctness *) (* TODO duplicate *) Ltac2 make_prod (bs : constr array) (c : constr) := let bs := Array.map (fun b => let t := Constr.type b in Constr.Binder.make (Some (constr_to_ident b)) t) bs in Array.fold_left (fun t b => Constr.Unsafe.make (Constr.Unsafe.Prod b t)) c bs. (* To derive monotonicity inside the correctness proof *) Ltac2 rec enumST_sound (ty : constr) (ih : ident) := match! goal with (* match decOpt pos *) | [ h : semProdOpt (match @decOpt ?p ?i ?s with _ => _ end) ?x |- _ ] => let hdec := Fresh.in_goal (id_of_string "Hdec") in let b := Fresh.in_goal (id_of_string "b") in destruct (@decOpt $p $i $s) as [ $b | ] eqn:$hdec > [ | now enumST_sound ty ih (* return None *) ]; let b' := Control.hyp b in destruct $b' > [ | now eapply semProdOpt_failEnum in $h; inv $h ]; eapply (@CheckerProofs.sound $p) in $hdec > [ | tci ]; enumST_sound ty ih (* match decOpt neg *) | [ h : semProdOpt (match @decOpt ?p ?i ?s with _ => _ end) ?x |- _ ] => let hdec := Fresh.in_goal (id_of_string "Hdec") in let b := Fresh.in_goal (id_of_string "b") in destruct (@decOpt $p $i $s) as [ $b | ] eqn:$hdec > [ | now enumST_sound ty ih (* return None *) ]; let b' := Control.hyp b in destruct $b' > [ now eapply semProdOpt_failEnum in $h; inv $h | ]; eapply (@CheckerProofs.sound_neg $p) in $hdec > [ | tci ]; enumST_sound ty ih (* match input *) | [ h : semProdOpt (match ?n with _ => _ end) ?x |- _ ] => destruct $n; try (now eapply semProdOpt_failEnum in $h; inv $h); enumST_sound ty ih (* return Some *) | [ h : semProdOpt (returnEnum (Some _)) _ |- _ ] => eapply (@semReturnOpt E _ _) in $h; inv $h; first [ now (pose $ty; eauto) | now (pose $ty; eauto 20) ] (* return None*) | [ h : semProdOpt (returnEnum (@None ?a)) _ |- _ ] => eapply (@semProdOpt_return_None $a) in $h; inv $h (* fail *) | [ h : semProdOpt failEnum _ |- _ ] => eapply semProdOpt_failEnum in $h; inv $h (* bindOpt *) | [ h : semProdOpt (bindOpt _ _) _ |- _ ] => eapply (@semOptBindOpt E _ _) in $h > [ let h' := Control.hyp h in destruct $h' as [? [$h ?]]; first [ let ih' := Control.hyp ih in eapply $ih' in $h | match! goal with | [h : semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ |- _ ] => eapply (@SuchThatCorrectOfBoundedEnum $t $pred $inst) in $h > [ | tci | tci | tci ] end | match! goal with | [h : semProdOpt enum _ |- _ ] => clear $h end ]; enumST_sound ty ih | find_size_mon_inst () | intro; now enumST_size_mon @Hmon ] (* bind *) | [ h : semProdOpt (bindEnum _ _) _ |- _ ] => eapply (@semOptBind E _ _) in $h > [ let h' := Control.hyp h in destruct $h' as [? [? ?]]; enumST_sound ty ih | find_size_mon_inst () | intro; now enumST_size_mon @Hmon ] | [ |- _ ] => () end. Ltac2 rec sound_enums (ty : constr) (ih : ident) := match! goal with | [ h : (\bigcup_(x in (seq_In (_ :: _))) _) _ |- _ ] => eapply in_bigcup_list_cons in $h; let h' := Control.hyp h in destruct $h' as [ | ] > [ enumST_sound ty ih | sound_enums ty ih ] | [ h : (\bigcup_(x in seq_In Datatypes.nil) _) _ |- _ ] => apply bigcup_nil_set0 in $h; inv $h end. Ltac2 derive_sound_enumST (ty : constr) (pred : constr) := let s := Fresh.in_goal (id_of_string "s") in let si := Fresh.in_goal (id_of_string "si") in let ihs := Fresh.in_goal (id_of_string "ihs") in let hgen := Fresh.in_goal (id_of_string "Hgen") in intros [$s $hgen]; revert $hgen; let s' := Control.hyp s in match! goal with [ |- semProdOpt _ ?x -> _ ] => (generalize $s' at 1; revert_params pred; generalize $x; induction $s' as [ | $s $ihs]; intro; intro_params pred; intros $si $hgen; eapply &Henum in $hgen) > [ sound_enums ty ihs | sound_enums ty ihs ] end. Definition empty_enum {A} : E (option A) := MkEnum (fun _ => LazyList.lnil). Ltac2 make_semEnum (t : constr) (enum : constr) (s : constr) := let c := constr:(@semProdSizeOpt E _ ltac2:(exact $t) empty_enum ltac2:(exact $s)) in match Constr.Unsafe.kind c with | Constr.Unsafe.App sem sargs => let sargs' := Array.copy sargs in let _ := Array.set sargs' 3 enum in Constr.Unsafe.make (Constr.Unsafe.App sem sargs') | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end. Ltac2 mon_expr (tapp : constr) (inst : constr) := match! goal with | [ |- CorrectSizedST _ ?f ] => match Constr.Unsafe.kind f with | Constr.Unsafe.Lambda b app => match Constr.Unsafe.kind app with | Constr.Unsafe.App aux args => let len := Int.sub (Array.length args) 2 in let inps := Array.sub args 2 len in let args' (s1 : constr) (s2 : constr) (offs : int) := let ind := Array.mapi (fun i _ => Constr.Unsafe.make (Constr.Unsafe.Rel (Int.add i offs))) inps in let a := Array.make 2 s1 in Array.set a 1 s2; Array.append a ind in let aux_app s1 s2 offs := Constr.Unsafe.make (Constr.Unsafe.App aux (args' s1 s2 offs)) in (* SizeMonotonic *) let dummy_app s1 s2 := let args' := Array.copy args in let _ := Array.set args' 0 s1 in let _ := Array.set args' 1 s1 in Constr.Unsafe.make (Constr.Unsafe.App aux args') in let dummy_term := constr:(SizeMonotonicOpt (ltac2:(let t := dummy_app '0 '0 in exact $t))) in let make_term s1 s2 := match Constr.Unsafe.kind dummy_term with | Constr.Unsafe.App mon margs => let margs' := Array.copy margs in Array.set margs' 3 (aux_app s1 s2 1); make_prod inps (Constr.Unsafe.make (Constr.Unsafe.App mon margs')) | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end in assert (_Hmon : forall (_s1 _s2 : nat), ltac2:(let s1 := Control.hyp @_s1 in let s2 := Control.hyp @_s2 in let t := make_term s1 s2 in exact $t)) > [ let s := Fresh.in_goal (id_of_string "s") in let si := Fresh.in_goal (id_of_string "si") in let ihs := Fresh.in_goal (id_of_string "IHs") in intros $si $s; let s' := Control.hyp s in revert $si; induction $s' as [ | $s $ihs ]; intros $si; Array.iter (fun _ => intro) inps; eapply enumerate_SizeMonotonicOpt; now enumsST_size_mon ihs tapp | ]; (* SizedMonotonic, generalized *) let subset (t1 : constr) (t2 : constr) := let dummy := constr:(set_incl (@set0 (ltac2:(exact $tapp))) set0) in match Constr.Unsafe.kind dummy with | Constr.Unsafe.App sub sargs => let sargs' := Array.copy sargs in let _ := Array.set sargs' 1 t1 in let _ := Array.set sargs' 2 t2 in Constr.Unsafe.make (Constr.Unsafe.App sub sargs') | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end in let mon s1 s2 s1' s2' s := make_prod inps (subset (make_semEnum tapp (aux_app s1' s1 1) s) (make_semEnum tapp (aux_app s2' s2 1) s)) in assert (_Hmons : forall (s1 s2 s2' s1' s: nat), (s1 <= s2)%coq_nat -> (s1' <= s2')%coq_nat -> ltac2:(let s1 := Control.hyp @s1 in let s1' := Control.hyp @s1' in let s2 := Control.hyp @s2 in let s2' := Control.hyp @s2' in let s' := Control.hyp @s in let t := mon s1 s2 s1' s2' s' in exact $t)) > [ let s1 := Fresh.in_goal (id_of_string "s1") in let s2 := Fresh.in_goal (id_of_string "s2_") in let ihs1 := Fresh.in_goal (id_of_string "ihs1") in intros $s1; simpl_enumSizeST (); let s1' := Control.hyp s1 in (induction $s1' as [| $s1 $ihs1 ]; intros $s2 ? ? ? ? ? ; Array.iter (fun _ => intro) inps) > [ let s2' := Control.hyp s2 in EnumProofs.base_case_st_size_mon s2' | let s2' := Control.hyp s2 in EnumProofs.ind_case_st_sized_mon s2' ihs1 ] | ] | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a function")))) end end. Ltac2 destructIH_opt (_ : unit) := match! goal with | [ h : (exists s, semProdOpt _ _) |- _ ] => let h' := Control.hyp h in destruct $h' as [ ? $h]; destruct $h' as [? [? $h]] end. (* Ltac2 rec enumST_complete (ty : constr):= *) (* let hmons := Control.hyp @_Hmons in *) (* first *) (* [ (* return *) *) (* now eapply exists_return_Opt *) (* | (* match decOpt *) *) (* (eapply (@exists_match_DecOpt $ty) > [ | | | | enumST_complete ty ]) > *) (* [ (* decOpt mon *) now eauto with typeclass_instances *) (* | (* decOpt complete *) now eauto with typeclass_instances *) (* | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons *) (* | (* P *) now eauto ] *) (* | (* bindOpt rec call *) *) (* (eapply exists_bindOpt_Opt_Sized > [ | | | | | enumST_complete ty ]) > *) (* [ (* sizedMon *) *) (* intro; intros; eapply $hmons; ssromega *) (* | (* sizeMon *) now find_size_mon_inst () *) (* | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons *) (* | (* sizeMon *) intros ? ?; now enumST_size_mon @_Hmon *) (* | eexists; eexists; split > [ reflexivity *) (* | eapply $hmons > [ eapply Peano.le_n | | eassumption ]; ssromega ] ] *) (* | (* bindOpt sized *) *) (* (eapply exists_bindOpt_Opt_Sized > [ | | | | | enumST_complete ty ]) > *) (* [ now eauto with typeclass_instances *) (* | intros _; now find_size_mon_inst () *) (* | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons *) (* | (* sizeMon *) intros ? ?; now enumST_size_mon @_Hmon *) (* | match! goal with *) (* | [ |- exists _, semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ ] => *) (* exists 0; eapply (@size_CorrectST $t $pred E _ _) > [ | | | eassumption ]; *) (* now eauto with typeclass_instances *) (* end ] *) (* | (* bind *) *) (* match! goal with *) (* | [ |- exists _ : nat, semProdOpt (bindEnum enum _) _ ] => *) (* (eapply exists_bind_Opt > [ | | | enumST_complete ty ]) > *) (* [ now eauto with typeclass_instances *) (* | now find_size_mon_inst () *) (* | intros ? ?; now enumST_size_mon @_Hmon ] *) (* end *) (* | ( ) ]. *) Ltac2 rec enumST_complete (ty : constr):= let hmons := Control.hyp @_Hmons in simpl_minus_methods (); first [ (* return *) subst; now eapply exists_return_Opt | (* match decOpt for eq *) (eapply (@exists_match_DecOpt $ty) > [ | | | ltac1:(now eapply Logic.eq_refl) | enumST_complete ty ]) > [ (* decOpt mon *) tci | (* decOpt complete *) tci | (* sizedMon *) intros ? ? ? ?; enumST_sized_mon @_Hmons | enumST_complete ty ] | (* match decOpt *) (eapply (@exists_match_DecOpt $ty) > [ | | | | enumST_complete ty ]) > [ (* decOpt mon *) tci | (* decOpt complete *) tci | (* sizedMon *) intros ? ? ? ?; enumST_sized_mon @_Hmons | (* P *) now eauto ] | (* match decOpt neg *) (eapply (@exists_match_DecOpt_neg $ty) > [ | | | | enumST_complete ty ]) > [ (* decOpt mon *) tci | (* decOpt complete *) tci | (* sizedMon *) intros ? ? ? ?; enumST_sized_mon @_Hmons | (* ~ P *) now eauto ] | (* bindOpt rec call *) (eapply exists_bindOpt_Opt_Sized > [ | | | | | now enumST_complete ty ]) > [ (* sizedMon *) intro; intros; eapply $hmons; ssromega | (* sizeMon *) now find_size_mon_inst () | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon | eexists; eexists; split > [ reflexivity | eapply $hmons > [ eapply Peano.le_n | | eassumption ]; ssromega ] ] | (* bindOpt rec call alt *) eapply exists_bindOpt_Opt_Sized > [ (* sizedMon *) intro; intros; eapply $hmons; ssromega | (* sizeMon *) now find_size_mon_inst () | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon | eexists; eexists; split > [ reflexivity | eapply $hmons > [ eapply Peano.le_n | | eassumption ]; ssromega ] | now enumST_complete ty ] | (* bindOpt sized eq *) eapply exists_bindOpt_Opt_Sized > [ tci | intros _; now find_size_mon_inst () | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon | match! goal with | [ |- exists _, semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ ] => exists 0; eapply (@size_CorrectST $t $pred E _ _) > [ | | | ltac1:(now eapply Logic.eq_refl) ]; tci end | now enumST_complete ty ] | (* bindOpt sized *) (eapply exists_bindOpt_Opt_Sized > [ | | | | | now enumST_complete ty ]) > [ tci | intros _; now find_size_mon_inst () | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon | match! goal with | [ |- exists _, semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ ] => exists 0; eapply (@size_CorrectST $t $pred E _ _) > [ | | | first [ eassumption | reflexivity ] ]; tci end ] | (* bindOpt sized simple *) (eapply exists_bindOpt_Opt_Sized > [ | | | | | now enumST_complete ty ]) > [ tci | intros _; now find_size_mon_inst () | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon | match! goal with | [ |- exists _, semProdOpt enum _ ] => exists 0; eapply enumOptCorrect > [ tci | reflexivity ] end ] | (* bindOpt sized alt *) eapply exists_bindOpt_Opt_Sized > [ tci | intros _; now find_size_mon_inst () | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon | match! goal with | [ |- exists _, semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ ] => exists 0; eapply (@size_CorrectST $t $pred E _ _) > [ | | | first [ eassumption | reflexivity ] ]; tci end | now enumST_complete ty ] | (* bind *) match! goal with | [ |- exists _ : nat, semProdOpt (bindEnum enum _) _ ] => eapply exists_bind_Opt > [ tci | now find_size_mon_inst () | intros ? ?; enumST_size_mon @_Hmon | now enumST_complete ty ] (* LTAC2 feature request branch grouping *) | [ |- exists _ : nat, semProdOpt (bindEnum (sizedEnum enumSized) _) _ ] => eapply exists_bind_Opt > [ tci | now find_size_mon_inst () | intros ? ?; enumST_size_mon @_Hmon | now enumST_complete ty ] end | ( ) ]. Ltac2 rec try_solve_complete (ty : constr) := first [ eapply exists_enum_hd; now enumST_complete ty | eapply exists_enum_tl; try_solve_complete ty ]. Ltac2 derive_complete_enumST (ty : constr) (inst : constr) := let ind := Fresh.in_goal (id_of_string "ind") in intros $ind; let ind' := Control.hyp ind in induction $ind'; eapply exists_Sn; repeat (destructIH_opt ()); try_solve_complete ty. Ltac2 derive_enumST_Correct (_ : unit) := match! goal with | [ |- CorrectSizedST _ (@enumSizeST ?tapp ?pred ?inst) ] => assert (Henum := @enumerate_correct_opt $tapp); simpl_enumSizeST (); (* derive monotonicity *) mon_expr tapp inst; let ty := get_ty pred in let x := Fresh.in_goal (id_of_string "x") in split; intros $x; split > [ derive_sound_enumST ty pred | derive_complete_enumST tapp inst ] end. (* Ltac tactics *) Ltac derive_enum_SizeMonotonic := ltac2:(derive_enum_SizeMonotonic ()). Ltac derive_enum_SizedMonotonic := ltac2:(derive_enum_SizedMonotonic ()). Ltac derive_enum_Correct := ltac2:(derive_enum_Correct ()). Ltac derive_enumST_SizeMonotonic := ltac2:(derive_enumST_SizeMonotonic ()). Ltac derive_enumST_SizedMonotonic := ltac2:(derive_enumST_SizedMonotonic ()). Ltac derive_enumST_Correct := ltac2:(derive_enumST_Correct ()). Ltac derive_enumST_SizeMonotonicFP := ltac2:(derive_enumST_SizeMonotonicFP ()). Ltac derive_enumST_SizedMonotonicFP := ltac2:(derive_enumST_SizedMonotonicFP ()). QuickChick-2.1.0/src/Enumerators.v000066400000000000000000000567041476030541200170300ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". From Coq Require Import ZArith List RelationClasses ssreflect ssrfun ssrbool. From mathcomp Require Import ssrnat. From ExtLib.Structures Require Export Functor Applicative Monad. Import MonadNotation. Open Scope monad_scope. From QuickChick Require Import Sets Tactics Producer LazyList RandomQC. Local Open Scope set_scope. Set Bullet Behavior "Strict Subproofs". Inductive EnumType (A:Type) : Type := MkEnum : (nat -> LazyList A) -> EnumType A. Arguments MkEnum {A}. Definition E := EnumType. (** * Primitive generator combinators *) Definition run {A : Type} (g : E A) := match g with MkEnum f => f end. Definition returnEnum {A : Type} (x : A) : E A := MkEnum (fun _ => retLazyList x). Definition bindEnum {A B : Type} (g : E A) (k : A -> E B) : E B := MkEnum (fun n => x <- run g n;; run (k x) n). Definition failEnum {A : Type} : E A := MkEnum (fun _ => lnil). #[global] Instance MonadEnum : Monad E := { ret := @returnEnum ; bind := @bindEnum }. Definition sizedEnum {A : Type} (f : nat -> E A) : E A := MkEnum (fun n => run (f n) n). Definition resizeEnum {A : Type} (n : nat) (g : E A) : E A := match g with | MkEnum m => MkEnum (fun _ => m n) end. Definition semEnumSize {A : Type} (g : E A) (s : nat) : set A := fun x => In_ll x (run g s). Definition chooseEnum {A : Type} {le} `{ChoosableFromInterval A le} (range : A * A) : E A := MkEnum (fun _ => enumR range). Definition sampleEnum (A : Type) (g : E A) : list A := LazyList_to_list (run g 5). #[global] Program Instance ProducerEnum : Producer E := { super := MonadEnum; sample := sampleEnum; sized := @sizedEnum; resize := @resizeEnum; choose := @chooseEnum; semProdSize := @semEnumSize; (* Probably belongs in another class for modularity? *) bindPf := fun {A B : Type} (g : E A) (k : forall (a : A), (fun (A : Type) (g : E A) => \bigcup_(size in [set: nat]) semEnumSize g size) A g a -> E B) => MkEnum (fun n => _) }. Next Obligation. remember (run g n) as l. refine (bindLazyListPf l _) => x In. rewrite /semEnumSize /E in k. specialize (k x). assert ((\bigcup_(size in [set: nat]) In_ll^~ (run g size)) x). { exists n; split; unfold setT; auto. rewrite -Heql; auto. } specialize (k H). inversion k. apply (X n). Defined. (* begin semReturn *) Lemma semReturnEnum {A} (x : A) : semProd (ret x) <--> [set x]. (* end semReturn *) Proof. rewrite /semProd /semProdSize /= /semEnumSize /= bigcup_const ?codom_const //. - split; auto. + intros [Eq | Contra]; [subst; reflexivity | inversion Contra]. - do 2! constructor. Qed. Lemma semReturnSizeEnum A (x : A) (s : nat) : semProdSize (ret x) s <--> [set x]. Proof. rewrite /semProdSize /= /semEnumSize. simpl; split; auto. move => [Eq | []]; subst; reflexivity. Qed. Lemma semBindSizeEnum A B (g : E A) (f : A -> E B) (s : nat) : semEnumSize (bindEnum g f) s <--> \bigcup_(a in semEnumSize g s) semEnumSize (f a) s. Proof. rewrite /semEnumSize /bindEnum /=. unfold bindLazyList. generalize (run g s). induction l. - simpl. split; intros; try contradiction. inv H. destruct H0. contradiction. - simpl in *. intros z; split; intros H1. + eapply lazy_in_app_or in H1. inv H1. * eexists. split. left. reflexivity. eassumption. * eapply H in H0. inv H0. destruct H2. eexists. split. right. eassumption. eassumption. + inv H1. destruct H0. inv H0. * eapply lazy_append_in_l. eassumption. * eapply lazy_append_in_r. eapply H. eexists. split; eauto. Qed. #[global] Instance bindOptSizeFP {A B} (g : E (option A)) (f : A -> E (option B)) {Hsg : SizeFP g} {Hsf : forall x, SizeFP (f x)} : SizeFP (bindOpt g f). Proof. simpl. move => s1 s2 Hs Hnin. specialize (Hsg _ _ Hs). simpl in *. rewrite !semBindSizeEnum. split. - intros [z [Hin1 Hin2]]. destruct z. + eexists. split. eapply Hsg; [ | eassumption ]. intros Hc1. eapply Hnin. eapply semBindSizeEnum. eexists. split. eassumption. simpl. eapply semReturnSizeEnum. reflexivity. simpl. eapply (Hsf _ _ _ Hs); [ | eassumption ]. intros Hc1. eapply Hnin. eapply semBindSizeEnum. eexists. split. eassumption. simpl. eassumption. + exfalso. eapply Hnin. eapply semBindSizeEnum. eexists. split. eassumption. simpl. eapply semReturnSizeEnum. reflexivity. - intros [z [Hin1 Hin2]]. destruct z. + eexists. split. eapply Hsg; [ | eassumption ]. intros Hc1. eapply Hnin. eapply semBindSizeEnum. eexists. split. eassumption. simpl. eapply semReturnSizeEnum. reflexivity. simpl. eapply (Hsf _ _ _ Hs); [ | eassumption ]. intros Hc1. eapply Hnin. eapply semBindSizeEnum. eexists. split. eapply Hsg; [| eassumption ]. intros Hc. eapply Hnin. eapply semBindSizeEnum. eexists. split. eassumption. simpl. eapply semReturnSizeEnum. reflexivity. simpl. eassumption. + simpl in *. exfalso. eapply Hnin. eapply Hsg in Hin1. eapply semBindSizeEnum. eexists. split. eassumption. simpl. eapply semReturnSizeEnum. reflexivity. intros Hc. eapply Hnin. eapply semBindSizeEnum. eexists. split. eassumption. eapply semReturnSizeEnum. reflexivity. Qed. Lemma semChooseSizeEnum A {le} `{ChoosableFromInterval A le} (a1 a2 : A) : le a1 a2 -> forall size, semProdSize (choose (a1,a2)) size <--> [set a | le a1 a /\ le a a2]. Proof. move=> /= le_a1a2 m n //=; rewrite (enumRCorrect n a1 a2) //=. Qed. Lemma semChooseSizeEnumNat (a1 a2 : nat) : a1 <= a2 -> forall size, semProdSize (choose (a1,a2)) size <--> [set a | a1 <= a <= a2]. Proof. move => /leP H size. rewrite (semChooseSizeEnum nat _ _ H). intros a; apply lele_coq_ssr. Qed. #[global] Instance chooseUnsized {A} {le} `{RandomQC.ChoosableFromInterval A le} (a1 a2 : A) : Unsized (choose (a1, a2)). Proof. by []. Qed. Lemma semChooseEnum A {le} `{RandomQC.ChoosableFromInterval A le} (a1 a2 : A) : le a1 a2 -> (semProd (choose (a1,a2)) <--> [set a | le a1 a /\ le a a2]). Proof. move=> /= le_a1a2. rewrite <- (unsized_alt_def 1). move => m /=. rewrite (enumRCorrect m a1 a2) //. Qed. Lemma semChooseEnumNat (a1 a2 : nat) : a1 <= a2 -> semProd (choose (a1,a2)) <--> [set a | a1 <= a <= a2]. Proof. move => /leP H. rewrite (semChooseEnum nat (H := ChooseNat) _ _ H). intros a; apply lele_coq_ssr. Qed. Lemma semSizedEnum A (f : nat -> E A) : semProd (sized f) <--> \bigcup_n semEnumSize (f n) n. Proof. by []. Qed. Lemma semSizedSizeEnum A (f:nat->E A) s : semEnumSize (sized f) s <--> semEnumSize (f s) s. Proof. by []. Qed. Lemma semResizeEnum A n (g : E A) : semProd (resize n g) <--> semEnumSize g n . Proof. by case: g => g; rewrite /semProd /semProdSize /= /semEnumSize /= bigcup_const. Qed. Lemma semResizeSizeEnum A (s n : nat) (g : E A) : semEnumSize (resize n g) s <--> semEnumSize g n. Proof. by case: g => g; rewrite /semEnumSize. Qed. #[global] Instance ProducerSemanticsEnum : @ProducerSemantics E ProducerEnum := { semReturn := @semReturnEnum; semReturnSize := @semReturnSizeEnum; semBindSize := @semBindSizeEnum; semChoose := @semChooseEnum; semChooseSize := @semChooseSizeEnum; (* semChooseSizeEmpty := @semChooseSizeEmptyEnum; *) semSized := @semSizedEnum; semSizedSize := @semSizedSizeEnum; semResize := @semResizeEnum; semResizeSize := @semResizeSizeEnum }. (* This should use urns! *) Fixpoint pickDrop {A : Type} (xs : list (E (option A))) n : E (option A) * list (E (option A)) := match xs with | nil => (ret None, nil) | x :: xs => match n with | O => (x, xs) | S n' => let '(x', xs') := pickDrop xs n' in (x', x::xs') end end. Fixpoint enumerateFuel {A : Type} (fuel : nat) (tot : nat) (gs : list (E (option A))) : E (option A) := match fuel with | O => ret None | S fuel' => bind (choose (0, tot-1)) (fun n => let '(g, gs') := pickDrop gs n in bind g (fun ma => match ma with | Some a => ret (Some a) | None => enumerateFuel fuel' (tot - 1) gs' end )) end. Definition enumerate' {A : Type} (gs : list (E (option A))) : E (option A) := enumerateFuel (length gs) (length gs) gs. Definition enumerate {A : Type} (gs : list (E (option A))) : E (option A) := MkEnum (fun s => join_list_lazy_list (map (fun g => run g s) gs)). Lemma enumerate_correct_size {A} (lst : list (E (option A))) s : isSome :&: semProdSize (enumerate lst) s <--> \bigcup_(x in lst) (fun g => isSome :&: semProdSize g s) x. Proof. unfold enumerate. induction lst. - rewrite bigcup_nil_set0. simpl. intros x; split; intros H; inv H. inv H1. - simpl in *. split. + intros H1. inv H1. unfold semEnumSize in *. simpl in *. eapply lazy_in_app_or in H0. inv H0. * eexists. split. now left. split; eassumption. * assert (Hin : a0 \in \bigcup_(x in lst) ((fun u : option A => u) :&: In_ll^~ (run x s))). { eapply IHlst. split; eassumption. } inv Hin. inv H3. eexists. split. right. eassumption. eassumption. + intros [b [H1 H2]]. inv H2. inv H1. * split. eassumption. simpl. unfold semEnumSize in *. simpl in *. eapply lazy_append_in_l. eassumption. * split. eassumption. eapply lazy_append_in_r. eapply IHlst. eexists. split; eassumption. Qed. Lemma enumerate_correct {A} (lst : list (E (option A))) : isSome :&: semProd (enumerate lst) <--> \bigcup_(x in lst) (fun g => isSome :&: semProd g) x. Proof. unfold enumerate. induction lst. - rewrite bigcup_nil_set0. simpl. intros x; split; intros H; inv H. inv H1. inv H2. inv H4. - simpl in *. split. + intros H1. inv H1. inv H0. inv H2. unfold semEnumSize in *. simpl in *. eapply lazy_in_app_or in H4. inv H4. * eexists. split. now left. split; try eassumption. eexists; split; eauto. * assert (Hin : a0 \in (\bigcup_(x0 in lst) ((fun u : option A => u) :&: semProd x0))). { eapply IHlst. split; eauto. eexists; split; eassumption. } inv Hin. inv H6. inv H8. eexists. split. right. eassumption. eassumption. + intros [b [H1 H2]]. inv H2. inv H1. * split. eassumption. simpl. unfold semProd in *. simpl in *. inv H0. inv H3. eexists. split. eassumption. eapply lazy_append_in_l. eassumption. * assert (Hin : a0 \in ((fun u : option A => u) :&: semProd (MkEnum (fun s : nat => join_list_lazy_list (map (run^~ s) lst))))). { eapply IHlst. eexists. split; eauto. } inv Hin. inv H5. inv H6. split; eauto. eexists; split; eauto. simpl. eapply lazy_append_in_r. eassumption. Qed. Lemma enumerate_correct_size_opt {A} (lst : list (E (option A))) s : semProdSizeOpt (enumerate lst) s <--> \bigcup_(x in lst) (semProdSizeOpt x s). Proof. unfold enumerate. induction lst. - rewrite bigcup_nil_set0. simpl. intros x; split; intros H; inv H. - simpl in *. split. + intros H1. unfold semEnumSize in *. simpl in *. eapply lazy_in_app_or in H1. inv H1. * eexists. split. now left. eassumption. * assert (Hin : a0 \in \bigcup_(x in lst) (semProdSizeOpt x s)). { eapply IHlst. eassumption. } inv Hin. inv H0. eexists. split. right. eassumption. eassumption. + intros [b [H1 H2]]. inv H1. * unfold semEnumSize in *. simpl in *. eapply lazy_append_in_l. eassumption. * simpl. eapply lazy_append_in_r. eapply IHlst. eexists. split; eassumption. Qed. Lemma enumerate_correct_size' {A} (lst : list (E (option A))) s : semProdSize (enumerate lst) s <--> \bigcup_(x in lst) (semProdSize x s). Proof. unfold enumerate. induction lst. - rewrite bigcup_nil_set0. simpl. intros x; split; intros H; inv H. - simpl in *. split. + intros H1. unfold semEnumSize in *. simpl in *. eapply lazy_in_app_or in H1. inv H1. * eexists. split. now left. eassumption. * assert (Hin : a0 \in \bigcup_(x in lst) (semProdSize x s)). { eapply IHlst. eassumption. } inv Hin. inv H0. eexists. split. right. eassumption. eassumption. + intros [b [H1 H2]]. inv H1. * unfold semEnumSize in *. simpl in *. eapply lazy_append_in_l. eassumption. * simpl. eapply lazy_append_in_r. eapply IHlst. eexists. split; eassumption. Qed. Lemma enumerate_correct_opt {A} (lst : list (E (option A))) : semProdOpt (enumerate lst) <--> \bigcup_(x in lst) (semProdOpt x). Proof. unfold enumerate. induction lst. - rewrite bigcup_nil_set0. simpl. intros x; split; intros H; inv H; inv H0; inv H2. - simpl in *. split. + intros H1. unfold semEnumSize in *. inv H1. inv H. simpl in *. eapply lazy_in_app_or in H2. inv H2. * eexists. split. now left. eexists. split; eassumption. * assert (Hin : a0 \in \bigcup_(x in lst) (semProdOpt x)). { eapply IHlst. eexists. split; eassumption. } inv Hin. inv H4. eexists. split. right. eassumption. eassumption. + intros [b [H1 H2]]. inv H1. * unfold semEnumSize in *. simpl in *. inv H2. inv H. eexists. split. reflexivity. simpl. eapply lazy_append_in_l. simpl in *. eassumption. * assert (Hin : semProdOpt (MkEnum (fun s : nat => join_list_lazy_list (map (run^~ s) lst))) a0). { eapply IHlst. inv H2. inv H0. simpl. eexists. split; eauto. } inv Hin. inv H0. simpl. eexists. split. reflexivity. simpl in *. eapply lazy_append_in_r. simpl in *. eassumption. Qed. Lemma enumerate_SizeMonotonicOpt (A : Type) (l : list (E (option A))) : l \subset SizeMonotonicOpt -> SizeMonotonicOpt (enumerate l). Proof. intros Hin. intros s1 s2 Hleq. rewrite !enumerate_correct_size_opt. intros x Hin'. destruct Hin' as [e [Hl Hs]]. eexists. split; eauto. eapply Hin; eauto. Qed. Lemma enumerate_SizeMonotonic (A : Type) (l : list (E (option A))) : l \subset SizeMonotonic -> SizeMonotonic (enumerate l). Proof. intros Hin. intros s1 s2 Hleq. rewrite !enumerate_correct_size'. intros x Hin'. destruct Hin' as [e [Hl Hs]]. eexists. split; eauto. eapply Hin; eauto. Qed. Lemma enumerate_SizeFP (A : Type) (l : list (E (option A))) : l \subset SizeFP -> l \subset SizeMonotonicOpt -> SizeFP (enumerate l). Proof. intros Hin Hmon. intros s1 s2 Hleq Hnin. rewrite !enumerate_correct_size'. intros x; split. - intros [e [Hl Hs]]. eexists. split. eassumption. destruct x. + eapply Hmon; eauto. + exfalso. eapply Hnin. eapply enumerate_correct_size'. eexists. split; eassumption. - intros [e [Hl Hs]]. destruct x. 2:{ exfalso. eapply Hnin. eapply enumerate_correct_size'. eexists. split. eassumption. eapply Hin; try eassumption. intros Hc. eapply Hnin. eapply enumerate_correct_size'. eexists. split; eassumption. } eexists. split. eassumption. eapply Hin; try eassumption. intros Hc. eapply Hnin. eapply enumerate_correct_size'. eexists. split; eassumption. Qed. Lemma enumerate_SizeMonFP (A : Type) (l : list (E (option A))) : l \subset SizeFP -> l \subset SizeMonotonicOpt -> SizeMonotonicOptFP (enumerate l). Proof. intros H1 H2. constructor. eapply enumerate_SizeMonotonicOpt. eassumption. eapply enumerate_SizeFP; eassumption. Qed. Fixpoint lazylist_backtrack {A} (l : LazyList A) (f : A -> option bool) (anyNone : bool) : option bool := match l with | lnil => if anyNone then None else Some false | lcons x xs => match f x with | Some true => Some true | Some false => lazylist_backtrack (xs tt) f anyNone | None => lazylist_backtrack (xs tt) f true end end. Definition enumerating {A} (g : E A) (f : A -> option bool) (n : nat) : option bool := lazylist_backtrack (run g n) f false. Fixpoint lazylist_backtrack_opt {A} (l : LazyList (option A)) (f : A -> option bool) (anyNone : bool) : option bool := match l with | lnil => if anyNone then None else Some false | lcons mx xs => match mx with | Some x => match f x with | Some true => Some true | Some false => lazylist_backtrack_opt (xs tt) f anyNone | None => lazylist_backtrack_opt (xs tt) f true end | None => lazylist_backtrack_opt (xs tt) f true end end. Definition enumeratingOpt {A} (g : E (option A)) (f : A -> option bool) (n : nat) : option bool := lazylist_backtrack_opt (run g n) f false. Lemma enumerating_sound A (e : E A) ch s : enumerating e ch s = Some true -> exists x, ch x = Some true. Proof. unfold enumerating. generalize (Enumerators.run e s), false. induction l; intros b Heq; simpl in *. - destruct b; congruence. - destruct (ch a) as [ [| ] | ] eqn:Heq'; eauto. Qed. Lemma semBindOptSize_isNone_subset_compat (A B : Type) (g g' : E (option A)) (f f' : A -> E (option B)) s : (~ semProdSize g' s None -> semProdSize g' s <--> semProdSize g s) -> isNone :&: semProdSize g s \subset isNone :&: semProdSize g' s -> (forall (x : A), isNone :&: semProdSize (f x) s \subset isNone :&: semProdSize (f' x) s) -> (fun u : option _ => isNone u) :&: semProdSize (bindOpt g f) s \subset (fun u : option _ => isNone u) :&: semProdSize (bindOpt g' f') s. Proof. intros Hyp0 Hyp1 Hyp2 z [Hin1 Hin2]. destruct z. now inv Hin1. simpl in Hin2. split. reflexivity. simpl in *. unfold semEnumSize in *. simpl in *. unfold LazyList.bindLazyList in *. simpl in *. eapply (@lazy_concat_in' (option B)) in Hin2. destruct Hin2 as [l1 [Hinl1 Hinl2]]. assert (Hinl2' := Hinl2). eapply LazyList.lazy_in_map_iff in Hinl2'. destruct Hinl2' as [x [Hrun Hin]]. destruct x. - unfold semProdSizeOpt in *. simpl in *. unfold semEnumSize in *. destruct (In_ll_Dec None (Enumerators.run g' s)). eapply (@LazyList.lazy_concat_in (option B)). 2:{ eapply LazyList.lazy_in_map with (f := fun x : option A => Enumerators.run match x with | Some a0 => f' a0 | None => returnEnum None end s) (x := None). eassumption. } simpl. now left. eapply Hyp0 in H. eapply H in Hin. assert (Hina : ((fun u : option B => isNone u) :&: LazyList.In_ll^~ (Enumerators.run (f a) s)) None). { split; eauto. rewrite Hrun; eassumption. } eapply Hyp2 in Hina. inv Hina. eapply (@LazyList.lazy_concat_in (option B)). eapply H1. eapply LazyList.lazy_in_map with (f := fun x : option A => Enumerators.run match x with | Some a0 => f' a0 | None => returnEnum None end s) (x := Some a). eassumption. - assert (Hin' : LazyList.In_ll None (Enumerators.run g' s)). { eapply Hyp1. split; eauto. } eapply (@LazyList.lazy_concat_in (option B)). eassumption. rewrite <- Hrun. eapply LazyList.lazy_in_map with (f := fun x : option A => Enumerators.run match x with | Some a0 => f' a0 | None => returnEnum None end s) (x := None). eassumption. Qed. Lemma semBindOptSize_subset_compat (A B : Type) (g g' : E (option A)) (f f' : A -> E (option B)) s : semProdSize g s \subset semProdSize g' s -> (forall (x : A), semProdSize g s (Some x) -> semProdSize (f x) s \subset semProdSize (f' x) s) -> semProdSize (bindOpt g f) s \subset semProdSize (bindOpt g' f') s. Proof. intros Hyp0 Hyp1 x H. simpl in *. unfold semEnumSize in *. unfold LazyList.bindLazyList in *. simpl in *. eapply (@lazy_concat_in' (option B)) in H. destruct H as [l1 [Hinl1 Hinl2]]. assert (Hinl2' := Hinl2). eapply LazyList.lazy_in_map_iff in Hinl2'. destruct Hinl2' as [z [Hrun Hin]]. destruct z. - subst. assert (Hin' := Hin). eapply Hyp0 in Hin. eapply Hyp1 in Hinl1. eapply (@LazyList.lazy_concat_in (option B)). eassumption. eapply LazyList.lazy_in_map with (f := fun x : option A => Enumerators.run match x with | Some a0 => f' a0 | None => returnEnum None end s) (x := Some a). eassumption. eassumption. - subst. eapply Hyp0 in Hin. eapply (@LazyList.lazy_concat_in (option B)). eassumption. eapply LazyList.lazy_in_map with (f := fun x : option A => Enumerators.run match x with | Some a0 => f' a0 | None => returnEnum None end s) (x := None). eassumption. Qed. Lemma semBindOptSize_subset_compat_eq (A B : Type) (g g' : E (option A)) (f f' : A -> E (option B)) s : semProdSize g s <--> semProdSize g' s -> (forall (x : A), semProdSize g s (Some x) -> semProdSize (f x) s <--> semProdSize (f' x) s) -> semProdSize (bindOpt g f) s <--> semProdSize (bindOpt g' f') s. Proof. intros H1 H2 a. split. eapply semBindOptSize_subset_compat. rewrite H1. now eapply subset_refl. intros x Hin. rewrite H2; eauto. now eapply subset_refl. eapply semBindOptSize_subset_compat. rewrite H1. now eapply subset_refl. intros x Hin. rewrite H2; eauto. now eapply subset_refl. eapply H1; eassumption. Qed. Lemma semProdSize_bigcup_isNone A s (S : set (option A)) : isNone :&: S \subset isNone :&: (\bigcup_(x in (cons (returnEnum (@None A)) nil)) semProdSize x s). Proof. intros x Hin. inv Hin. destruct x. now inv H. split; eauto. eexists. split; eauto. now left. eapply semReturnSizeEnum. reflexivity. Qed. Lemma semProdSize_return_None A s (S : set (option A)) : isNone :&: S \subset isNone :&: semProdSize (returnEnum None) s. Proof. intros x Hin. inv Hin. destruct x. now inv H. split; eauto. eapply semReturnSizeEnum. reflexivity. Qed. Lemma semProdSize_bindOpt_1 A B (e : E (option A)) (f : A -> E (option B)) s : semProdSize e s None -> semProdSize (bindOpt e f) s None. Proof. unfold semProdSize; simpl. unfold semEnumSize. intros H. simpl. unfold LazyList.bindLazyList. eapply (@LazyList.lazy_concat_in (option B)). 2:{ eapply LazyList.lazy_in_map with (f := fun x : option A => Enumerators.run match x with | Some a0 => f a0 | None => returnEnum None end s) (x := None). eassumption. } simpl. now left. Qed. Lemma semProdSize_bindOpt_2 A B (e : E (option A)) (f : A -> E (option B)) s x : semProdSize e s (Some x) -> semProdSize (f x) s None -> semProdSize (bindOpt e f) s None. Proof. unfold semProdSize; simpl. unfold semEnumSize. intros Hin1 Hin2. simpl in *. unfold LazyList.bindLazyList. eapply (@LazyList.lazy_concat_in (option B)). eassumption. eapply LazyList.lazy_in_map with (f := fun x : option A => Enumerators.run match x with | Some a0 => f a0 | None => returnEnum None end s) (x := Some x). eassumption. Qed. #[global] Instance SizeFP_failEnum {A : Type} : SizeFP (@failEnum (option A)). Proof. intros s1 s2 Hleq Hnin. split; intros. unfold semProdSize in *. simpl in *. unfold semEnumSize in *. simpl in *. eassumption. unfold semProdSize in *. simpl in *. unfold semEnumSize in *. simpl in *. eassumption. Qed. QuickChick-2.1.0/src/ExtractionQC.v.cppo000066400000000000000000000130041476030541200200120ustar00rootroot00000000000000(* THIS FILE IS PREPROCESSED USING cppo MAKE SURE TO EDIT THE .cppo SOURCE OF THIS FILE RATHER THAN THE GENERATED RESULT *) Set Warnings "-notation-overridden,-parsing". Require Import ZArith. Require Import Coq.Strings.Ascii. Require Import Coq.Strings.String. From QuickChick Require Import RandomQC RoseTrees Test Show Checker. Require Import ExtrOcamlBasic. Require Import ExtrOcamlString. Require Import ExtrOcamlNatInt. Require Import ExtrOcamlZBigInt. Extraction Blacklist String List Nat. Extract Inductive Hexadecimal.int => "((Obj.t -> Obj.t) -> (Obj.t -> Obj.t) -> Obj.t) (* Hexadecimal.int *)" [ "(fun x pos _ -> pos (Obj.magic x))" "(fun y _ neg -> neg (Obj.magic y))" ] "(fun i pos neg -> Obj.magic i pos neg)". Extract Inductive Number.int => "((Obj.t -> Obj.t) -> (Obj.t -> Obj.t) -> Obj.t) (* Number.int *)" [ "(fun x dec _ -> dec (Obj.magic x))" "(fun y _ hex -> hex (Obj.magic y))" ] "(fun i dec hex -> Obj.magic i dec hex)". (** Temporary fix for https://github.com/coq/coq/issues/7017. *) (** Scott encoding of [Decimal.int] as [forall r. (uint -> r) -> (uint -> r) -> r]. *) Extract Inductive Decimal.int => "((Obj.t -> Obj.t) -> (Obj.t -> Obj.t) -> Obj.t) (* Decimal.int *)" [ "(fun x pos _ -> pos (Obj.magic x))" "(fun y _ neg -> neg (Obj.magic y))" ] "(fun pos neg i -> Obj.magic i pos neg)". Extract Constant show_nat => "(fun i -> let s = string_of_int i in let rec copy acc i = if i < 0 then acc else copy (s.[i] :: acc) (i-1) in copy [] (String.length s - 1))". Extract Constant show_bool => "(fun i -> let s = string_of_bool i in let rec copy acc i = if i < 0 then acc else copy (s.[i] :: acc) (i-1) in copy [] (String.length s - 1))". Extract Constant show_Z => "(fun i -> let s = Big_int_Z.string_of_big_int i in let rec copy acc i = if i < 0 then acc else copy (s.[i] :: acc) (i-1) in copy [] (String.length s - 1))". Extract Constant show_N => "(fun i -> let s = Big_int_Z.string_of_big_int i in let rec copy acc i = if i < 0 then acc else copy (s.[i] :: acc) (i-1) in copy [] (String.length s - 1))". Extract Constant RandomSeed => "Random.State.t". Extract Constant randomNext => "(fun r -> Random.State.bits r, r)". (* Extract Constant rndGenRange => "SR.genRange".*) Extract Constant randomSplit => "(fun x -> (x,x))". Extract Constant mkRandomSeed => "(fun x -> Random.init x; Random.get_state())". Extract Constant randomRNat => #if OCAML_VERSION >= (4, 13, 0) "(fun (x,y) r -> if y < x then failwith ""choose called with unordered arguments"" else (x + (Random.State.full_int r (y - x + 1)), r))". #else "(fun (x,y) r -> if y < x then failwith ""choose called with unordered arguments"" else (x + (Random.State.int r (y - x + 1)), r))". #endif Extract Constant randomRBool => "(fun _ r -> Random.State.bool r, r)". Extract Constant randomRInt => "(fun (x,y) r -> if Big_int_Z.lt_big_int y x then failwith ""choose called with unordered arguments"" else let range_Z = Big_int_Z.succ_big_int (Big_int_Z.sub_big_int y x) in let range_int = Big_int_Z.int_of_big_int range_Z in (Big_int_Z.add_big_int x (Big_int_Z.big_int_of_int (Random.State.int r range_int)), r))". Extract Constant randomRN => "(fun (x,y) r -> if Big_int_Z.lt_big_int y x then failwith ""choose called with unordered arguments"" else let range_Z = Big_int_Z.succ_big_int (Big_int_Z.sub_big_int y x) in let range_int = Big_int_Z.int_of_big_int range_Z in (Big_int_Z.add_big_int x (Big_int_Z.big_int_of_int (Random.State.int r range_int)), r))". Extract Constant newRandomSeed => "(Random.State.make_self_init ())". Extract Inductive Lazy => "Lazy.t" [lazy]. Extract Constant force => "Lazy.force". (* Extract Constant Test.ltAscii => "(<=)". *) (* Extract Constant Test.strEq => "(=)". *) Extract Constant Test.gte => "(>=)". Extract Constant le_gt_dec => "(<=)". Extract Constant trace => "(fun l -> print_string ( let s = Bytes.create (List.length l) in let rec copy i = function | [] -> s | c :: l -> Bytes.set s i c; copy (i+1) l in Bytes.to_string (copy 0 l)); flush stdout; fun y -> y)". Require Import mathcomp.ssreflect.ssreflect. From mathcomp Require Import ssreflect ssrnat ssrbool div eqtype. Extract Constant divn => "(fun m -> function 0 -> 0 | d -> m / d)". Extract Constant modn => "(fun m -> function 0 -> m | d -> m mod d)". Extract Constant eqn => "(==)". Extract Constant Nat.add => "(+)". Extract Constant Nat.mul => "( * )". Extract Constant Nat.sub => "(-)". Extract Constant Nat.log2 => "(let rec log2 x = if x <= 1 then 0 else 1 + log2 (x / 2) in log2)". Extract Constant Nat.eqb => "(=)". Extract Constant Coq.Init.Nat.eqb => "(=)". Extract Constant Nat.div => "(fun x -> function 0 -> 0 | y -> x / y)". Extract Constant Coq.Init.Nat.div => "(fun x -> function 0 -> 0 | y -> x / y)". Extract Constant Nat.min => "min". Extract Constant Nat.max => "max". Extract Constant Nat.modulo => "(fun x -> function 0 -> x | y -> x mod y)". Extract Constant Nat.leb => "(<=)". Axiom print_extracted_coq_string : string -> unit. Extract Constant print_extracted_coq_string => "fun l -> print_string ( let s = Bytes.create (List.length l) in let rec copy i = function | [] -> s | c :: l -> Bytes.set s i c; copy (i+1) l in Bytes.to_string (copy 0 l))". Axiom withTime : forall {A}, (unit -> A) -> AugmentedTime A. Extract Constant withTime => "(fun f -> let start = Unix.gettimeofday () in let res = f () in let ending = Unix.gettimeofday () in { aug_res = res; aug_time = ((Float.to_int ((ending -. start) *. 1000000.0))) } )". QuickChick-2.1.0/src/GenProofs.v000066400000000000000000001047441476030541200164240ustar00rootroot00000000000000From Coq Require Import String Lia List ssreflect ssrfun ssrbool. Import ListNotations. From Ltac2 Require Import Ltac2. Set Warnings "-notation-overwritten, -parsing". From mathcomp Require Import ssrnat eqtype seq. Set Bullet Behavior "Strict Subproofs". From QuickChick Require Import Tactics TacticsUtil Instances Classes DependentClasses Sets Producer Generators EnumProofs Checker Decidability CheckerProofs. Local Open Scope set_scope. Section Lemmas. Lemma exists_oneOf_hd A (x : A) g' (g : nat -> G A) (l : nat -> seq (G A)) : (exists s : nat, semProd (g s) x) -> exists s : nat, semProd (oneOf_ g' ((g s) :: (l s))) x. Proof. intros Hin. inv Hin. eexists. eapply semOneof. now eauto with typeclass_instances. eexists. split; eauto. now left. Qed. Lemma exists_oneOf_tl A (x : A) g' (g : nat -> G A) (l : nat -> seq (G A)) : (exists s : nat, match l s with | nil => False | g1 :: gs => semProd (oneOf_ g' (g1 :: gs)) x end) -> exists s : nat, semProd (oneOf_ g' ((g s) :: (l s))) x. Proof. intros Hin. inv Hin. eexists. eapply semOneof. now eauto with typeclass_instances. destruct (l x0) eqn:Heq. - exfalso; eauto. - eapply semOneof in H > [ | now eauto with typeclass_instances ]. rewrite Heq. inv H. destruct H0. eexists. split > [ | eassumption ]. now right; eauto. Qed. Lemma exists_freq_hd A (x : A) g' (g : nat -> G A) (l : nat -> seq (nat * G A)) n : (exists s : nat, semProd (g s) x) -> exists s : nat, semProd (freq_ g' ((S n, g s) :: (l s))) x. Proof. intros Hin. inv Hin. eexists. eapply (@semFrequency A). simpl. eexists. split; eauto. now left. eassumption. Qed. Lemma exists_freq_tl A (x : A) g' (g : nat -> G A) (l : nat -> seq (nat * G A)) n : (exists s : nat, match l s with | (S n, g1) :: gs => semProd (freq_ g' ((S n, g1) :: gs)) x | _ => False end) -> exists s : nat, semProd (freq_ g' ((S n, g s) :: (l s))) x. Proof. intros Hin. inv Hin. eexists. eapply (@semFrequency A). simpl. destruct (l x0) eqn:Heq. - exfalso; eauto. - destruct p. destruct n0; try (now (exfalso; eauto)). eapply (@semFrequency A) in H. rewrite Heq. simpl in H. inv H. destruct H0. eexists. split > [ | eassumption ]. now right; eauto. Qed. Lemma exists_bind A B (x : A) (g : G B) (f : nat -> B -> G A) : Correct B g -> SizeMonotonic g -> (forall a s, SizeMonotonic (f a s)) -> (exists z s, semProd (f s z) x) -> exists s : nat, semProd (bindGen g (f s)) x. Proof. intros Hc Hs1 Hs2 He. inv He. inv H. inv H0. inv H. assert (Hin : [set : B] x0) by reflexivity. eapply Hc in Hin. inv Hin. inv H. exists x1, (Nat.max x2 x3). split. reflexivity. eapply (@semBindSize G ProducerGen _ B A). eexists. split. eapply Hs1 > [ | eassumption ]. now ssromega. eapply Hs2 > [ | eassumption ]. now ssromega. Qed. Lemma exists_return A (x : A) : exists s : nat, semProd (returnGen x) x. Proof. exists 0. eapply (@semReturn G _ ProducerSemanticsGen); reflexivity. Qed. Lemma exists_bind_Sized_alt A B (g : nat -> G B) (f : B -> nat -> G A) (x : A) (z : B) (s' : nat) : SizedMonotonic g -> (forall s, SizeMonotonic (g s)) -> (forall a, SizedMonotonic (f a)) -> (forall a s, SizeMonotonic (f a s)) -> semProd (g s') z -> (exists s, semProd (f z s) x) -> exists s : nat, semProd (bindGen (g s) (fun x => f x s)) x. Proof. intros Hs Hs' Hsf Hsf' Hprod Hex. inv Hex. inv Hprod. inv H. destruct H0. exists (Nat.max s' x0). inv H1. exists (Nat.max x1 x2). split. reflexivity. eapply (@semBindSize G ProducerGen _ B A). eexists. split. eapply Hs > [ | eapply Hs' > [ | eassumption ] ]. ssromega. ssromega. eapply Hsf > [ | eapply Hsf' > [ | eassumption ] ]. ssromega. ssromega. Qed. Lemma semProd_mon {A} (g : nat -> G A) {_ : SizedMonotonic g} : forall s1 s2, (s1 <= s2)%coq_nat -> semProd (g s1) \subset semProd (g s2). Proof. intros s1 s2 Hleq. intros x Hin. inv Hin. inv H0. eexists x0. split; eauto. eapply H > [ | eassumption ]. destruct (leqP s1 s2); eauto. Qed. Lemma exists_gen_hd A (g : nat -> G (option A)) (gs : nat -> list (nat * G (option A))) x n : (exists s, semProdOpt (g s) x) -> exists s, semProdOpt (backtrack ((S n, g s) :: gs s)) x. Proof. intros [s He]. exists s. eapply (@backtrack_correct_opt A). eexists. split. split. now left. simpl. lia. eassumption. Qed. Lemma exists_gen_tl A (g : nat -> G (option A)) (gs : nat -> list (nat * G (option A))) x n : (exists s, semProdOpt (backtrack (gs s)) x) -> exists s, semProdOpt (backtrack ((n, g s) :: gs s)) x. Proof. intros [s He]. exists s. eapply (@backtrack_correct_opt A). eapply (@backtrack_correct_opt A) in He. destruct He as [z [Hin Hsem]]. inv Hin. eexists. split. split. now right; eauto. eassumption. eassumption. Qed. Lemma exists_bind_Opt A B (x : A) (g : G B) (f : B -> nat -> G (option A)) z : Correct B g -> SizeMonotonic g -> (forall a s, SizeMonotonicOpt (f a s)) -> (exists s, semProdOpt (f z s) x) -> exists s : nat, semProdOpt (bindGen g (fun x => f x s)) x. Proof. intros Hc Hs1 Hs2 He. inv He. inv H. inv H0. inv H. assert (Hin : [set : B] z) by reflexivity. eapply Hc in Hin. inv Hin. inv H. exists x0, (Nat.max x1 x2). split. reflexivity. eapply (@semBindSize G ProducerGen _ B). eexists. split. eapply Hs1 > [ | eassumption ]. now ssromega. eapply Hs2 > [ | eassumption ]. now ssromega. Qed. Lemma exists_return_Opt A (x : A) : exists s : nat, semProdOpt (returnGen (Some x)) x. Proof. exists 0. eapply (@semReturn G _ ProducerSemanticsGen); reflexivity. Qed. Lemma exists_bindOpt_Opt A B (x : A) (g : G (option B)) (f : B -> nat -> G (option A)) z : SizeMonotonicOpt g -> (forall a s, SizeMonotonicOpt (f a s)) -> semProdOpt g z -> (exists s, semProdOpt (f z s) x) -> exists s : nat, semProdOpt (bindOpt g (fun x => f x s)) x. Proof. intros Hc Hs1 Hs2 He. destruct He as [s1 He]. exists s1. eapply (@semOptBindOpt G _ _ B); eauto with typeclass_instances. eexists. split; eassumption. Qed. Lemma exists_bindOpt_Opt_Sized A B (x : A) (g : nat -> G (option B)) (f : B -> nat -> G (option A)) z : SizedMonotonicOpt g -> (forall s, SizeMonotonicOpt (g s)) -> (forall a, SizedMonotonicOpt (f a)) -> (forall a s, SizeMonotonicOpt (f a s)) -> (exists s, semProdOpt (g s) z) -> (exists s, semProdOpt (f z s) x) -> exists s : nat, semProdOpt (bindOpt (g s) (fun z => f z s)) x. Proof. intros Hs1 Hs1' Hs2 Hs2' Hg Hf. destruct Hg as [s1 He]. destruct Hf. exists (max x0 s1). eapply (@semOptBindOpt G _ _ B); eauto with typeclass_instances. inv He. inv H. inv H0. inv H1. eexists. split. eexists. split. reflexivity. eapply Hs1 > [ | eassumption ]. ssromega. eexists. split. reflexivity. eapply Hs2 > [ | eassumption ]. ssromega. Qed. Lemma exists_match_DecOpt {B} P {_ : DecOpt P} (k : nat -> G (option B)) z : DecOptSizeMonotonic P -> DecOptCompletePos P -> SizedMonotonicOpt k -> P -> (exists s, semProdOpt (k s) z) -> exists (s : nat), semProdOpt (match decOpt s.+1 with | Some true => k s | _ => returnGen None end) z. Proof. intros Hmon Hcom Hmonk Hp [s1 [s [_ He]]]. eapply Hcom in Hp. destruct Hp as [s2 Hdec]. eexists (max s1 s2). eapply Hmon in Hdec. rewrite Hdec. eexists. split. reflexivity. eapply Hmonk > [ | eassumption ]. ssromega. ssromega. Qed. Lemma semProdSizeOpt_semProdOpt {A} {G : Type -> Type} {_ : Producer G} (e1 e2 : G (option A)) : (forall s, semProdSizeOpt e1 s \subset semProdSizeOpt e2 s) -> semProdOpt e1 \subset semProdOpt e2. Proof. intros H x Hin. inv Hin. inv H0. eexists. split; eauto. eapply H. eassumption. Qed. Lemma incl_bigcup_compat_list_pair (T K U : Type) (h1 h2 : T) (t1 : list T) (t2 : list (K * T)) (F : T -> set U) (G : K * T -> set U) k : F h1 \subset G (k, h2) -> \bigcup_(x in t1) F x \subset \bigcup_(x in t2) G x -> \bigcup_(x in h1 :: t1) F x \subset \bigcup_(x in (k, h2) :: t2) G x. Proof. intros Hs1 Hs2. intros x Hin. inv Hin. inv H. inv H0. - eexists. split. now left. eauto. - edestruct Hs2. eexists. split; eauto. destruct H0. eexists. split. now right; eauto. eassumption. Qed. End Lemmas. (** Examples *) (** ** Enum **) Ltac2 simpl_minus_arbitrarySized (_ : unit) := ltac1:(with_strategy opaque [arbitrarySized] simplstar). Ltac2 simpl_arbitrarySized (_ : unit) := unfold arbitrarySized; simpl_minus_arbitrarySized (). (*** Sized Monotonicity *) Ltac2 rec gen_sized_mon (ih : ident) := first [ (* ret *) guarded_subset_refl () | (* bind *) eapply (@semBindSize_subset_compat _ _ ProducerSemanticsGen) > [ let x := Fresh.in_goal (id_of_string "x") in intros $x; first [ now eapply subset_refl (* for calls to enum *) | let ih' := Control.hyp ih in (* for recursive calls *) eapply $ih'; now ssromega ] | let x := Fresh.in_goal (id_of_string "x") in let s := Fresh.in_goal (id_of_string "s") in intros $x $s; gen_sized_mon ih ] ]. Ltac2 rec find_gen (_ : unit) := first [ now eapply incl_bigcup_list_nil | eapply incl_bigcup_compat_list_pair > [ now eapply subset_refl | find_gen () ] | eapply incl_bigcup_list_hd; now eapply subset_refl | eapply incl_bigcup_list_tl; find_gen () ]. Ltac2 base_case_size_mon (_ : unit) := destruct s2 > [ guarded_subset_refl () | simpl_arbitrarySized (); first [ guarded_subset_refl () | rewrite !&Hone, !&Hfreq; now find_gen () ] ]. Ltac2 rec gens_sized_mon (ih : ident) := first [ now eapply incl_bigcup_list_nil | eapply incl_bigcup_compat_list > [ now gen_sized_mon @IHs1 | gens_sized_mon ih ] ]. Ltac2 ind_case_sized_mon (_ : unit) := destruct s2 > [ now ssromega | simpl_arbitrarySized (); first [ now gen_sized_mon @IHs1 | rewrite !&Hfreq; now gens_sized_mon @IHs1 ] ]. Ltac2 derive_gen_SizedMonotonic (_ : unit) := assert (Hone := @semOneofSize G _ ProducerSemanticsGen); match! goal with | [ |- @SizedMonotonic ?t _ _ (@arbitrarySized _ ?inst) ] => assert (Hfreq := (@semFrequencySize $t)); (intros s s1; revert s; induction s1 as [| s1 IHs1 ]; intros s s2 Hleq) > [ now base_case_size_mon () | now ind_case_sized_mon () ] end. (* Size Mon *) Ltac2 rec gen_size_mon (ih : ident) := first [ (* ret *) eapply returnGenSizeMonotonic; tci | (* bind *) eapply bindMonotonic > [ tci | first [ now find_size_mon_inst () (* for calls to enum *) | let ih' := Control.hyp ih in (* for recursive calls *) eapply $ih'; now ssromega ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; gen_size_mon ih ] ]. Ltac2 rec gens_size_mon (t : constr) (ih : ident) := first [ now eapply (@list_subset_nil (G $t)) | eapply (@list_subset_cons (G $t)) > [ now gen_size_mon ih | gens_size_mon t ih ] ]. Ltac2 rec gens_size_mon_pair (t : constr) (ih : ident) := first [ now eapply (@list_subset_nil (nat * G $t)) | eapply (@list_subset_cons (nat * G $t)) > [ now gen_size_mon ih | gens_size_mon_pair t ih ] ]. Ltac2 derive_gen_SizeMonotonic (_ : unit) := intros s; match! goal with | [ |- @SizeMonotonic ?t _ _ _ ] => induction s as [ | s IHs ]; simpl_arbitrarySized (); first [ eapply oneofMonotonic > [ tci | now gen_size_mon @IHs | now gens_size_mon t @IHs ] | now gen_size_mon @IHs | eapply (@frequencySizeMonotonic_alt $t) > [ now gen_size_mon @IHs | now gens_size_mon_pair t @IHs ] ] end. (* Correct *) Ltac2 find_corr_inst (_ : unit) := first [ tci | match! goal with | [ |- Correct ?ty (sizedGen arbitrarySized) ] => eapply (@GenCorrectOfSized $ty _) > [ tci | now find_size_mon_inst () | tci ] end ]. Ltac2 solve_sized_mon (hs : ident) := intros ? ? ? ? ?; now gen_sized_mon hs. Ltac2 solve_size_mon (hs : ident) := intros ? ?; now gen_size_mon hs. Ltac2 rec gen_size_correct (_ : unit) := first [ (* return *) now eapply exists_return; eauto | (* bind non rec *) match! goal with | [ |- exists _ : nat, semProd (bindGen (* enum *) _ _) _ ] => eapply exists_bind > [ now find_corr_inst () | now find_size_mon_inst () | now solve_size_mon @Hsize | now eexists; gen_size_correct () ] end | (* bind rec *) match! goal with | [|- exists z, semProd (bindGen (_ _) _) _ ] => eapply exists_bind_Sized_alt > [ tci | now find_size_mon_inst () | now solve_sized_mon @Hsized | now solve_size_mon @Hsize | | now gen_size_correct () ]; eassumption end ]. Ltac2 rec try_solve_correct (_ : unit) := first [ eapply exists_freq_hd; now gen_size_correct () | eapply exists_freq_tl; try_solve_correct () ]. Ltac2 derive_gen_Correct (_ : unit) := match! goal with | [ |- @CorrectSized ?typ _ _ ?en ] => simpl_enumSized (); match! goal with | [ |- @CorrectSized _ _ _ ?gen_simpl ] => (* get the enum body *) set (_aux_gen := ltac2:(exact $gen_simpl)); let hsize := Fresh.in_goal (id_of_string "Hsize") in let hsized := Fresh.in_goal (id_of_string "Hsized") in let ind := Fresh.in_goal (id_of_string "t") in (* Derive monotonicity instances *) assert ($hsized : SizedMonotonic $en) > [ tci | ]; assert ($hsize : forall s, SizeMonotonic ($en s)) > [ tci | ]; econstructor; intro $ind; split > [ intro; exact I | intros _ ]; let ind' := Control.hyp ind in induction $ind'; eapply exists_Sn; repeat (destructIH ()); simpl_arbitrarySized (); first [ gen_size_correct () | try_solve_correct () ] end end. (* GenST *) Ltac2 simpl_minus_arbitrarySizeST (_ : unit) := ltac1:(with_strategy opaque [arbitrarySizeST arbitrary decOpt] simplstar). Ltac2 simpl_arbitrarySizeST (_ : unit) := unfold arbitrarySizeST; simpl_minus_arbitrarySizeST (). (*** Sized monotonic *) Lemma incl_bigcup_compat_list_P (T U : Type) (h1 h2 : T) (t1 t2 : list T) (F G : T -> set U) (P : T -> Prop) : F h1 \subset G h2 -> P h1 -> P h2 -> \bigcup_(x in t1 :&: P) F x \subset \bigcup_(x in t2 :&: P) G x -> \bigcup_(x in (h1 :: t1) :&: P) F x \subset \bigcup_(x in (h2 :: t2) :&: P) G x. Proof. intros Hs1 Hp1 Hp2 Hs2. intros x Hin. inv Hin. inv H. inv H0. inv H. - eexists. split. constructor. now left. eauto. eauto. - edestruct Hs2. eexists. split; eauto. split. eassumption. eassumption. inv H. inv H3. eexists. split. constructor. now right; eauto. eassumption. eassumption. Qed. Lemma incl_bigcup_list_nil_P (T U : Type) (G : T -> set U) s (P : T -> Prop) : \bigcup_(x in [::] :&: P) G x \subset s. Proof. intros x Hin. inv Hin. inv H. inv H0. inv H. Qed. Lemma incl_bigcup_list_tl_P (T U : Type) (h : T) (t : list T) (G : T -> set U) s (P : T -> Prop) : s \subset \bigcup_(x in t :&: P) G x -> s \subset \bigcup_(x in (h :: t) :&: P) G x. Proof. intros Hyp x Hin. eapply Hyp in Hin. inv Hin. inv H. inv H0. eexists. split. split. now right; eauto. eauto. eauto. Qed. Lemma in_bigcup_list_tl_P (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U) (P : T -> Prop) : (\bigcup_(x in t :&: P) G x) z -> (\bigcup_(x in (h :: t) :&: P) G x) z. Proof. intros Hin. destruct Hin. inv H. inv H0. eexists. split. split. right. eassumption. eassumption. eassumption. Qed. Lemma in_bigcup_list_cons_P (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U) (P : T -> Prop) : (\bigcup_(x in ((h :: t) :&: P)) G x) z -> G h z /\ P h \/ (\bigcup_(x in t :&: P) G x) z. Proof. intros Hin. inv Hin. inv H. inv H0; eauto. inv H; eauto. right. eexists; split; eauto. split; eauto. Qed. Lemma bigcup_nil_set0_P (T U : Type) (F : T -> set U) (P : T -> Prop) : \bigcup_(x in [::] :&: P) F x <--> set0. Proof. split; intros Hin; inv Hin; eauto. inv H. inv H0. inv H. Qed. Ltac2 rec genST_sized_mon (ih : ident) := first [ (* ret *) guarded_subset_refl () | (* dec matching *) match! goal with | [ |- semProdSizeOpt (match @decOpt ?p ?i ?s1 with _ => _ end) _ \subset semProdSizeOpt (match decOpt ?s2 with _ => _ end) _ ] => let hdec := Fresh.in_goal (id_of_string "Hdec") in destruct (@decOpt $p $i $s1) eqn:$hdec > [ ((erewrite (@CheckerProofs.mon $p $i _ $s1 $s2) > [ | | first [ eassumption | ssromega ] ]) > [ genST_sized_mon ih | ssromega ]) | rewrite (@semReturnSizeOpt_None G _ ProducerSemanticsGen); now eapply sub0set ] end | (* input matching *) match! goal with | [ |- semProdSizeOpt (match ?p with _ => _ end) _ \subset _ ] => destruct $p; genST_sized_mon ih end | (* bindOpt *) eapply (@semBindOptSizeOpt_subset_compat G _ ProducerSemanticsGen) > [ first [ now eapply subset_refl (* for calls to gen *) | let ih' := Control.hyp ih in (* for recursive calls *) eapply $ih'; now ssromega ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; genST_sized_mon ih ] | (* bind *) eapply (@semBindSizeOpt_subset_compat G _ ProducerSemanticsGen) > [ now eapply subset_refl | let x := Fresh.in_goal (id_of_string "x") in intros $x; genST_sized_mon ih ] | () ]. Ltac2 rec find_genST (ih : ident) := first [ now eapply incl_bigcup_list_nil_P | eapply incl_bigcup_compat_list_P > [ simpl_minus_arbitrarySizeST (); now genST_sized_mon ih | simpl; ssromega | simpl; ssromega | find_genST ih ] | eapply incl_bigcup_list_tl_P; find_genST ih ]. Ltac2 base_case_st_size_mon (s2 : constr) := destruct $s2 > [ first [ guarded_subset_refl () | rewrite !backtrack_correct_size_opt; simpl_minus_arbitrarySizeST (); find_genST @dummy ] | rewrite !backtrack_correct_size_opt; find_genST @dummy ]. Ltac2 ind_case_st_sized_mon (s2 : constr) (ih : ident) := destruct $s2 > [ now ssromega | rewrite !backtrack_correct_size_opt; simpl_minus_arbitrarySizeST (); find_genST ih ]. Ltac2 derive_genST_SizedMonotonic (_ : unit) := match! goal with | [ |- SizedMonotonicOpt (@arbitrarySizeST ?typ ?pred ?inst) ] => let s := Fresh.in_goal (id_of_string "s") in let s1 := Fresh.in_goal (id_of_string "s1") in let s2 := Fresh.in_goal (id_of_string "s2") in let s1i := Fresh.in_goal (id_of_string "s1i") in let s2i := Fresh.in_goal (id_of_string "s2i") in let hleq := Fresh.in_goal (id_of_string "Hleq") in let hleqi := Fresh.in_goal (id_of_string "Hleqi") in let ihs1 := Fresh.in_goal (id_of_string "ihs1") in intros $s $s1 $s2 $hleq; simpl_arbitrarySizeST (); let hleq' := Control.hyp hleq in let s1' := Control.hyp s1 in let s2' := Control.hyp s2 in assert ($hleqi := $hleq'); revert $hleqi $hleq; generalize $s2' at 1 3; generalize $s1' at 1 3; revert $s $s2; EnumProofs.revert_params pred; (induction $s1' as [| $s1 $ihs1 ]; EnumProofs.intro_params pred; intros $s $s2 $s1i $s2i $hleqi $hleq) > [ base_case_st_size_mon s2' | ind_case_st_sized_mon s2' ihs1 ] end. (* Size Monotonicity *) Ltac2 rec genST_size_mon (ih : ident) := first [ (* ret *) eapply returnGenSizeMonotonicOpt; tci | (* bindOpt *) eapply bindOptMonotonicOpt > [ tci | first [ (* for calls to gen in params *) tci | (* for call to existing gen instances. XXX not sure why typeclass resulotion doesn't work *) eapply sizedSizeMonotonicOpt; tci | (* for recursive calls *) let ih' := Control.hyp ih in eapply $ih' ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; genST_size_mon ih ] | (* bind *) eapply bindMonotonicOpt > [ tci | first [ (* for calls to gen in params *) tci | (* for call to existing gen instances. XXX not sure why typeclass resulotion doesn't work *) eapply sizedSizeMonotonic; tci | (* for recursive calls *) let ih' := Control.hyp ih in eapply $ih' ] | let x := Fresh.in_goal (id_of_string "x") in intros $x; genST_size_mon ih ] | (* input/dec matching *) match! goal with | [ |- SizeMonotonicOpt (match ?p with _ => _ end) ] => destruct $p; genST_size_mon ih end | () ]. Ltac2 rec gensST_size_mon (t : constr) (ih : ident) := first [ now eapply (@list_subset_nil (nat * G (option $t))) | eapply (@list_subset_cons (nat * G (option $t))) > [ simpl_minus_arbitrarySizeST (); genST_size_mon @ih | gensST_size_mon t ih ] ]. Ltac2 derive_genST_SizeMonotonic (_ : unit) := let s := Fresh.in_goal (id_of_string "s") in let ihs := Fresh.in_goal (id_of_string "Ihs") in let si := Fresh.in_goal (id_of_string "si") in intro $s; let s' := Control.hyp s in match! goal with | [ |- SizeMonotonicOpt (@arbitrarySizeST ?typ ?pred ?inst _) ] => simpl_arbitrarySizeST (); generalize $s' at 1; EnumProofs.revert_params pred; induction $s' as [ | $s $ihs ]; EnumProofs.intro_params pred; intros $si; eapply backtrack_SizeMonotonicOpt; gensST_size_mon typ @IHs end. (* Correctness *) Definition empty_gen {A} : G (option A) := MkGen (fun _ _ => None). Ltac2 make_semGen (t : constr) (enum : constr) (s : constr) := let c := constr:(@semProdSizeOpt G _ ltac2:(exact $t) empty_gen ltac2:(exact $s)) in match Constr.Unsafe.kind c with | Constr.Unsafe.App sem sargs => let sargs' := Array.copy sargs in let _ := Array.set sargs' 3 enum in Constr.Unsafe.make (Constr.Unsafe.App sem sargs') | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end. Ltac2 mon_expr (tapp : constr) (inst : constr) := match! goal with | [ |- CorrectSizedST _ ?f ] => match Constr.Unsafe.kind f with | Constr.Unsafe.Lambda b app => match Constr.Unsafe.kind app with | Constr.Unsafe.App aux args => let len := Int.sub (Array.length args) 2 in let inps := Array.sub args 2 len in let args' (s1 : constr) (s2 : constr) (offs : int) := let ind := Array.mapi (fun i _ => Constr.Unsafe.make (Constr.Unsafe.Rel (Int.add i offs))) inps in let a := Array.make 2 s1 in Array.set a 1 s2; Array.append a ind in let aux_app s1 s2 offs := Constr.Unsafe.make (Constr.Unsafe.App aux (args' s1 s2 offs)) in (* SizeMonotonic *) let dummy_app s1 s2 := let args' := Array.copy args in let _ := Array.set args' 0 s1 in let _ := Array.set args' 1 s1 in Constr.Unsafe.make (Constr.Unsafe.App aux args') in let dummy_term := constr:(SizeMonotonicOpt (ltac2:(let t := dummy_app '0 '0 in exact $t))) in let make_term s1 s2 := match Constr.Unsafe.kind dummy_term with | Constr.Unsafe.App mon margs => let margs' := Array.copy margs in Array.set margs' 3 (aux_app s1 s2 1); make_prod inps (Constr.Unsafe.make (Constr.Unsafe.App mon margs')) | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end in assert (_Hmon : forall (_s1 _s2 : nat), ltac2:(let s1 := Control.hyp @_s1 in let s2 := Control.hyp @_s2 in let t := make_term s1 s2 in exact $t)) > [ let s := Fresh.in_goal (id_of_string "s") in let si := Fresh.in_goal (id_of_string "si") in let ihs := Fresh.in_goal (id_of_string "IHs") in intros $si $s; let s' := Control.hyp s in revert $si; induction $s' as [ | $s $ihs ]; intros $si; Array.iter (fun _ => intro) inps; eapply backtrack_SizeMonotonicOpt; now gensST_size_mon tapp ihs | ]; (* SizedMonotonic, generalized *) let subset (t1 : constr) (t2 : constr) := let dummy := constr:(set_incl (@set0 (ltac2:(exact $tapp))) set0) in match Constr.Unsafe.kind dummy with | Constr.Unsafe.App sub sargs => let sargs' := Array.copy sargs in let _ := Array.set sargs' 1 t1 in let _ := Array.set sargs' 2 t2 in Constr.Unsafe.make (Constr.Unsafe.App sub sargs') | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end in let mon s1 s2 s1' s2' s := make_prod inps (subset (make_semGen tapp (aux_app s1' s1 1) s) (make_semGen tapp (aux_app s2' s2 1) s)) in (* print_constr (mon '1 '2 '3 '4); set (s := ltac2:(let t := mon '1 '2 '3 '4 in exact $t)); () *) assert (_Hmons : forall (s1 s2 s2' s1' s: nat), (s1 <= s2)%coq_nat -> (s1' <= s2')%coq_nat -> ltac2:(let s1 := Control.hyp @s1 in let s1' := Control.hyp @s1' in let s2 := Control.hyp @s2 in let s2' := Control.hyp @s2' in let s' := Control.hyp @s in let t := mon s1 s2 s1' s2' s' in exact $t)) > [ let s1 := Fresh.in_goal (id_of_string "s1") in let s2 := Fresh.in_goal (id_of_string "s2_") in let ihs1 := Fresh.in_goal (id_of_string "ihs1") in intros $s1; simpl_arbitrarySizeST (); let s1' := Control.hyp s1 in (induction $s1' as [| $s1 $ihs1 ]; intros $s2 ? ? ? ? ? ; Array.iter (fun _ => intro) inps) > [ let s2' := Control.hyp s2 in base_case_st_size_mon s2' | let s2' := Control.hyp s2 in ind_case_st_sized_mon s2' ihs1 ] | ] | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application")))) end | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a function")))) end end. Ltac2 rec genST_sound (ty : constr) (ih : ident) := match! goal with (* match decOpt *) | [ h : semProdOpt (match @decOpt ?p ?i ?s with _ => _ end) ?x |- _ ] => let hdec := Fresh.in_goal (id_of_string "Hdec") in let b := Fresh.in_goal (id_of_string "b") in destruct (@decOpt $p $i $s) as [ $b | ] eqn:$hdec > [ | now eapply (@semReturnOpt_None G _ _) in $h; inv $h ]; let b' := Control.hyp b in destruct $b' > [ | now eapply (@semReturnOpt_None G _ _) in $h; inv $h ]; eapply (@CheckerProofs.sound $p) in $hdec > [ | tci ]; genST_sound ty ih (* match input *) | [ h : semProdOpt (match ?n with _ => _ end) ?x |- _ ] => destruct $n; try (now eapply (@semReturnOpt_None G _ _) in $h; inv $h); genST_sound ty ih | (* return *) [ h : semProdOpt (returnGen _) _ |- _ ] => eapply (@semReturnOpt G _ _) in $h; inv $h; now (pose $ty; eauto 20) | (* bindOpt *) [ h : semProdOpt (bindOpt _ _) _ |- _ ] => eapply (@semOptBindOpt G _ _) in $h > [ let h' := Control.hyp h in (* let x := Fresh.in_goal (id_of_string "_x") in *) (* let hin1 := Fresh.in_goal (id_of_string "_Hin1") in *) (* let hin2 := Fresh.in_goal (id_of_string "_Hin2") in *) (* XXX there seems to be a bug in fresh, and it fails to freshen after a while. P icking ? for now *) destruct $h' as [? [$h ?]]; first [ let ih' := Control.hyp ih in eapply $ih' in $h | match! goal with | [h : semProdOpt (sizedGen (@arbitrarySizeST ?t ?pred ?inst)) _ |- _ ] => eapply (@SuchThatCorrectOfBounded $t $pred $inst) in $h > [ | tci | tci | tci ] end ]; genST_sound ty ih | find_size_mon_inst () | intro; now genST_size_mon @Hmon ] | (* bind *) [ h : semProdOpt (bindGen _ _) _ |- _ ] => eapply (@semOptBind G _ _) in $h > [ let h' := Control.hyp h in destruct $h' as [? [? ?]]; genST_sound ty ih | find_size_mon_inst () | intro; now genST_size_mon @Hmon ] | [ |- _ ] => () end. Ltac2 rec sound_gens (ty : constr) (ih : ident) := match! goal with | [ h : (\bigcup_(x in ((seq_In (_ :: _)) :&: _)) _) _ |- _ ] => eapply in_bigcup_list_cons_P in $h; simpl_minus_arbitrarySizeST (); let h' := Control.hyp h in destruct $h' as [ [? ?] | ] > [ genST_sound ty ih | sound_gens ty ih ] | [ h : (\bigcup_(x in seq_In Datatypes.nil :&: _) _) _ |- _ ] => apply bigcup_nil_set0_P in $h; inv $h end. Ltac2 derive_sound_genST (ty : constr) (pred : constr) := let s := Fresh.in_goal (id_of_string "s") in let si := Fresh.in_goal (id_of_string "si") in let ihs := Fresh.in_goal (id_of_string "ihs") in let hgen := Fresh.in_goal (id_of_string "Hgen") in intros [$s $hgen]; revert $hgen; let s' := Control.hyp s in match! goal with [ |- semProdOpt _ ?x -> _ ] => (generalize $s' at 1; EnumProofs.revert_params pred; revert x; induction $s' as [ | $s $ihs]; intro; EnumProofs.intro_params pred; intros $si $hgen; eapply &Hback in $hgen) > [ sound_gens ty ihs | sound_gens ty ihs ] end. Ltac2 rec genST_complete (ty : constr):= let hmons := Control.hyp @_Hmons in first [ (* return *) subst; now eapply exists_return_Opt | (* match decOpt for eq *) (eapply (@exists_match_DecOpt $ty) > [ | | | ltac1:(now eapply Logic.eq_refl) | genST_complete ty ]) > [ (* decOpt mon *) tci | (* decOpt complete *) tci | (* sizedMon *) intros ? ? ? ?; genST_sized_mon @_Hmons | genST_complete ty ] | (* match decOpt *) (eapply (@exists_match_DecOpt $ty) > [ | | | | genST_complete ty ]) > [ (* decOpt mon *) tci | (* decOpt complete *) tci | (* sizedMon *) intros ? ? ? ?; genST_sized_mon @_Hmons | (* P *) now eauto ] | (* bindOpt rec call *) (eapply exists_bindOpt_Opt_Sized > [ | | | | | now genST_complete ty ]) > [ (* sizedMon *) intro; intros; eapply $hmons; ssromega | (* sizeMon *) now find_size_mon_inst () | (* sizedMon *) intros ? ? ? ? ?; now genST_sized_mon @_Hmons | (* sizeMon *) intros ? ?; genST_size_mon @_Hmon | eexists; eexists; split > [ reflexivity | eapply $hmons > [ eapply Peano.le_n | | eassumption ]; ssromega ] ] | (* bindOpt sized eq *) eapply exists_bindOpt_Opt_Sized > [ tci | intros _; now find_size_mon_inst () | (* sizedMon *) intros ? ? ? ? ?; now genST_sized_mon @_Hmons | (* sizeMon *) intros ? ?; genST_size_mon @_Hmon | match! goal with | [ |- exists _, semProdOpt (sizedGen (@arbitrarySizeST ?t ?pred ?inst)) _ ] => exists 0; eapply (@size_CorrectST $t $pred G _ _) > [ | | | ltac1:(now eapply Logic.eq_refl) ]; tci end | now genST_complete ty ] | (* bindOpt sized *) (eapply exists_bindOpt_Opt_Sized > [ | | | | | now genST_complete ty ]) > [ tci | intros _; now find_size_mon_inst () | (* sizedMon *) intros ? ? ? ? ?; now genST_sized_mon @_Hmons | (* sizeMon *) intros ? ?; genST_size_mon @_Hmon | match! goal with | [ |- exists _, semProdOpt (sizedGen (@arbitrarySizeST ?t ?pred ?inst)) _ ] => exists 0; eapply (@size_CorrectST $t $pred G _ _) > [ | | | eassumption ]; tci end ] | (* bind *) match! goal with | [ |- exists _ : nat, semProdOpt (bindGen arbitrary _) _ ] => eapply exists_bind_Opt > [ tci | now find_size_mon_inst () | intros ? ?; genST_size_mon @_Hmon | now genST_complete ty ] end | ( ) ]. Ltac2 rec try_solve_complete (ty : constr) := first [ eapply exists_gen_hd; now genST_complete ty | eapply exists_gen_tl; try_solve_complete ty ]. Ltac2 derive_complete_genST (ty : constr) (inst : constr) := let ind := Fresh.in_goal (id_of_string "ind") in intros $ind; let ind' := Control.hyp ind in induction $ind'; eapply exists_Sn; repeat (destructIH_opt ()); try_solve_complete ty. Ltac2 derive_genST_Correct (_ : unit) := match! goal with | [ |- CorrectSizedST _ (@arbitrarySizeST ?tapp ?pred ?inst) ] => assert (Hback := @backtrack_correct_opt $tapp); simpl_arbitrarySizeST (); (* derive monotonicity *) mon_expr tapp inst; let ty := get_ty pred in let x := Fresh.in_goal (id_of_string "x") in split; intros $x; split > [ derive_sound_genST ty pred | derive_complete_genST tapp inst ] end. (* Ltac tactics *) Ltac derive_gen_SizeMonotonic := ltac2:(derive_gen_SizeMonotonic ()). Ltac derive_gen_SizedMonotonic := ltac2:(derive_gen_SizedMonotonic ()). Ltac derive_gen_Correct := ltac2:(derive_gen_Correct ()). Ltac derive_genST_SizeMonotonic := ltac2:(derive_genST_SizeMonotonic ()). Ltac derive_genST_SizedMonotonic := ltac2:(derive_genST_SizedMonotonic ()). Ltac derive_genST_Correct := ltac2:(derive_genST_Correct ()). QuickChick-2.1.0/src/Generators.v000066400000000000000000000700051476030541200166230ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". From Coq Require Import String List ZArith Lia ssreflect ssrfun ssrbool. From mathcomp Require Import ssrnat eqtype seq. From QuickChick Require Import RandomQC RoseTrees Sets Tactics Producer. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Set Bullet Behavior "Strict Subproofs". Import ListNotations. (* Low-level Generators *) Local Open Scope fun_scope. Local Open Scope set_scope. Inductive GenType (A:Type) : Type := MkGen : (nat -> RandomSeed -> A) -> GenType A. Definition G := GenType. (** * Primitive generator combinators *) Definition run {A : Type} (g : G A) := match g with MkGen f => f end. Definition returnGen {A : Type} (x : A) : G A := MkGen (fun _ _ => x). Definition bindGen {A B : Type} (g : G A) (k : A -> G B) : G B := MkGen (fun n r => let (r1,r2) := randomSplit r in run (k (run g n r1)) n r2). #[global] Instance MonadGen : Monad G := { ret := @returnGen ; bind := @bindGen }. Fixpoint createRange (n : nat) (acc : list nat) : list nat := match n with | O => List.rev (cons O acc) | S n' => createRange n' (cons n acc) end. Fixpoint rnds (s : RandomSeed) (n' : nat) : list RandomSeed := match n' with | O => nil | S n'' => let (s1, s2) := randomSplit s in cons s1 (rnds s2 n'') end. Definition sampleGen (A : Type) (g : G A) : list A := match g with | MkGen m => let rnd := newRandomSeed in let l := List.combine (rnds rnd 20) (createRange 10 nil) in List.map (fun (p : RandomSeed * nat) => let (r,n) := p in m n r) l end. Definition sizedGen {A : Type} (f : nat -> G A) : G A := MkGen (fun n r => run (f n) n r). Definition resizeGen {A : Type} (n : nat) (g : G A) : G A := match g with | MkGen m => MkGen (fun _ => m n) end. Definition semGenSize {A : Type} (g : G A) (s : nat) : set A := codom (run g s). Definition chooseGen {A : Type} {le} `{ChoosableFromInterval A le} (range : A * A) : G A := MkGen (fun _ r => fst (randomR range r)). #[global] Program Instance ProducerGen : Producer G := { super := MonadGen; sample := sampleGen; sized := @sizedGen; resize := @resizeGen; choose := @chooseGen; semProdSize := @semGenSize; (* Probably belongs in another class for modularity? *) bindPf := fun {A B : Type} (g : G A) (k : forall (a : A), (fun (A : Type) (g : G A) => \bigcup_(size in [set: nat]) semGenSize g size) A g a -> G B) => MkGen (fun n r => let (r1,r2) := randomSplit r in run (k (run g n r1) _) n r2)}. Next Obligation. unfold semGenSize, codom, bigcup. exists n; split => //=. exists r1; auto. Defined. (* Generator specific sample of a single input. *) Definition sample1 (A : Type) (g : G A) : A := match g with | MkGen m => let rnd := newRandomSeed in m 10 rnd end. Lemma runFmap (A B : Type) (f : A -> B) (g : G A) seed size : run (fmap f g) size seed = f (run g size (fst (randomSplit seed))). Proof. simpl. destruct (randomSplit seed). simpl. auto. Qed. (* Generator specific - shrinking support. *) Definition promote {A : Type} (m : Rose (G A)) : G (Rose A) := MkGen (fun n r => fmapRose (fun g => run g n r) m). (* Generator specific - coarbitrary support. *) Definition variant {A : Type} (p : SplitPath) (g : G A) : G A := match g with | MkGen f => MkGen (fun n r => f n (varySeed p r)) end. Definition reallyUnsafeDelay {A : Type} : G (G A -> A) := MkGen (fun r n g => (match g with MkGen f => f r n end)). Definition reallyUnsafePromote {r A : Type} (m : r -> G A) : G (r -> A) := (bindGen reallyUnsafeDelay (fun eval => returnGen (fun r => eval (m r)))). Lemma promoteVariant : forall {A B : Type} (a : A) (f : A -> SplitPath) (g : G B) size (r r1 r2 : RandomSeed), randomSplit r = (r1, r2) -> run (reallyUnsafePromote (fun a => variant (f a) g)) size r a = run g size (varySeed (f a) r1). Proof. move => A B a p g size r r1 r2 H. rewrite /reallyUnsafePromote /variant. destruct g. rewrite /= H. by []. Qed. Lemma semPromote A (m : Rose (G A)) : semProd (promote m) <--> codom2 (fun size seed => fmapRose (fun g => run g size seed) m). Proof. by rewrite /codom2 curry_codom2l. Qed. Lemma semPromoteSize (A : Type) (m : Rose (G A)) n : semProdSize (promote m) n <--> codom (fun seed => fmapRose (fun g => run g n seed) m). Proof. by []. Qed. Lemma runPromote A (m : Rose (G A)) seed size : run (promote m) seed size = fmapRose (fun (g : G A) => run g seed size) m. Proof. by []. Qed. (* Generator specific - choose and its semantics. *) Lemma semChooseSizeGen A {le} `{ChoosableFromInterval A le} (a1 a2 : A) : le a1 a2 -> forall size, semProdSize (choose (a1,a2)) size <--> [set a | le a1 a /\ le a a2]. Proof. by move=> /= le_a1a2 m n; rewrite (randomRCorrect n a1 a2). Qed. #[global] Instance chooseUnsized {A} {le} `{RandomQC.ChoosableFromInterval A le} (a1 a2 : A) : Unsized (choose (a1, a2)). Proof. by []. Qed. Lemma semChooseGen A {le} `{RandomQC.ChoosableFromInterval A le} (a1 a2 : A) : le a1 a2 -> (semProd (choose (a1,a2)) <--> [set a | le a1 a /\ le a a2]). Proof. move=> /= le_a1a2. rewrite <- (unsized_alt_def 1). move => m /=. rewrite (randomRCorrect m a1 a2) //. Qed. Lemma semChooseSizeGenNat (a1 a2 : nat) : a1 <= a2 -> forall size, (semProdSize (choose (a1,a2)) size <--> [set a | a1 <= a <= a2]). Proof. move => /leP H0 size. rewrite (semChooseSizeGen (H := ChooseNat) H0). intros a; apply lele_coq_ssr. Qed. Lemma semChooseGenNat (a1 a2 : nat) : a1 <= a2 -> (semProd (choose (a1,a2)) <--> [set a | a1 <= a <= a2]). Proof. move => /leP H0. rewrite (semChooseGen (H := ChooseNat) H0). intros a; apply lele_coq_ssr. Qed. Definition thunkGen {A} (f : unit -> G A) : G A := MkGen (fun n r => run (f tt) n r). Lemma semThunkGenSize {A} (f : unit -> G A) s : semProdSize (thunkGen f) s <--> semProdSize (f tt) s. Proof. split; intros [r Hr]; exists r; simpl in *; assumption. Qed. Lemma semThunkGen {A} (f : unit -> G A) : semProd (thunkGen f) <--> semProd (f tt). Proof. split; intros [r Hr]; exists r; simpl in *; assumption. Qed. #[global] Instance thunkGenUnsized {A} (f : unit -> G A) `{@Unsized _ _ ProducerGen (f tt)} : Unsized (thunkGen f). Proof. intros s1 s2. do 2 rewrite semThunkGenSize. apply unsized. Qed. #[global] Instance thunkGenSizeMonotonic {A} (f : unit -> G A) `{@SizeMonotonic _ _ ProducerGen (f tt)} : SizeMonotonic (thunkGen f). Proof. intros s1 s2 Hs. do 2 rewrite semThunkGenSize. by apply monotonic. Qed. #[global] Instance thunkGenSizeMonotonicOpt {A} (f : unit -> G (option A)) `{@SizeMonotonicOpt _ _ ProducerGen (f tt)} : SizeMonotonicOpt (thunkGen f). Proof. intros s1 s2 Hs. unfold semProdSizeOpt. do 2 rewrite semThunkGenSize. by apply monotonicOpt. Qed. (* #[global] Instance thunkGenSizeAntiMonotonicNone {A} (f : unit -> G (option A)) *) (* `{@SizedAntimonotonicNone _ _ ProducerGen (f tt)} : SizedAntimonotonicNone (thunkGen f). *) (* Proof. *) (* intros s1 s2 Hs. *) (* do 2 rewrite semThunkGenSize. *) (* by apply monotonicNone. *) (* Qed. *) Fixpoint pick {A : Type} (def : G A) (xs : list (nat * G A)) n : nat * G A := match xs with | nil => (0, def) | (k, x) :: xs => if (n < k) then (k, x) else pick def xs (n - k) end. (* This should use urns! *) Fixpoint pickDrop {A : Type} (xs : list (nat * G (option A))) n : nat * G (option A) * list (nat * G (option A)) := match xs with | nil => (0, ret None, nil) | (k, x) :: xs => if (n < k) then (k, x, xs) else let '(k', x', xs') := pickDrop xs (n - k) in (k', x', (k,x)::xs') end. Definition sum_fst {A : Type} (gs : list (nat * A)) : nat := foldl (fun t p => t + (fst p)) 0 gs. Definition freq_ {A : Type} (def : G A) (gs : list (nat * G A)) : G A := let tot := sum_fst gs in bindGen (choose (0, tot-1)) (fun n => @snd _ _ (pick def gs n)). (* Definition frequency {A}:= @deprecate (G A -> list (nat * G A) -> G A) "frequency" "freq_" freq_. *) Fixpoint backtrackFuel {A : Type} (fuel : nat) (tot : nat) (gs : list (nat * G (option A))) : G (option A) := match fuel with | O => ret None | S fuel' => bindGen (choose (0, tot-1)) (fun n => let '(k, g, gs') := pickDrop gs n in bindGen g (fun ma => match ma with | Some a => ret (Some a) | None => backtrackFuel fuel' (tot - k) gs' end )) end. Definition backtrack {A : Type} (gs : list (nat * G (option A))) : G (option A) := backtrackFuel (length gs) (sum_fst gs) gs. Definition retryBody {A : Type} (retry : nat -> G (option A) -> G (option A)) (n : nat) (g : G (option A)) : G (option A) := bindGen g (fun x => match x, n with | Some a, _ => returnGen (Some a) | None, O => returnGen None | None, S n' => retry n' g end). (* Rerun a generator [g] until it returns a [Some], or stop after [n+1] tries. *) Fixpoint retry {A : Type} (n : nat) (g : G (option A)) : G (option A) := retryBody retry n g. (* Filter the output of a generator [g], returning [None] when the predicate [p] is [false]. The generator is run once. *) Definition suchThatMaybe1 {A : Type} (g : G A) (p : A -> bool) : G (option A) := fmap (fun x => if p x then Some x else None) g. (* Retry a generator [g : G A] until it returns a value satisfying the predicate, or stop after [size+1] times, where [size] is the current size value. *) Definition suchThatMaybe {A : Type} (g : G A) (p : A -> bool) : G (option A) := sized (fun n => retry n (suchThatMaybe1 g p)). (* Retry a generator [g : G (option A)] until it returns a value satisfying the predicate, or stop after [size+1] times, where [size] is the current size value. *) Definition suchThatMaybeOpt {A : Type} (g : G (option A)) (p : A -> bool) : G (option A) := sized (fun n => retry n (fmap (fun x => match x with | None => None | Some a => if p a then Some a else None end) g)). (* Retry a generator until it returns a value, or stop after [size+1] times. *) Definition retrySized {A : Type} (g : G (option A)) : G (option A) := sized (fun n => retry n g). (* begin semReturn *) Lemma semReturnGen {A} (x : A) : semProd (ret x) <--> [set x]. (* end semReturn *) Proof. rewrite /semProd /semProdSize /= /semGenSize /= bigcup_const ?codom_const //. exact: randomSeed_inhabited. by do 2! constructor. Qed. Lemma semReturnSizeGen A (x : A) (s : nat) : semProdSize (ret x) s <--> [set x]. Proof. rewrite /semProdSize /= /semGenSize. rewrite codom_const; [ reflexivity | apply randomSeed_inhabited ]. Qed. Lemma randomSplit_codom : codom randomSplit <--> setT. Proof. by apply/subset_eqP; split=> // [[s1 s2]] _; apply: randomSplitAssumption. Qed. Lemma semBindSizeGen A B (g : G A) (f : A -> G B) (s : nat) : semGenSize (bindGen g f) s <--> \bigcup_(a in semGenSize g s) semGenSize (f a) s. Proof. rewrite /semGenSize /bindGen /= bigcup_codom -curry_codom2l. by rewrite -[codom (uncurry _)]imsetT -randomSplit_codom -codom_comp. Qed. Lemma semSizedGen A (f : nat -> G A) : semProd (sized f) <--> \bigcup_n semGenSize (f n) n. Proof. by []. Qed. Lemma semSizedSizeGen A (f:nat->G A)s : semGenSize (sized f) s <--> semGenSize (f s) s. Proof. by []. Qed. Lemma semResizeGen A n (g : G A) : semProd (resize n g) <--> semGenSize g n . Proof. by case: g => g; rewrite /semProd /semProdSize /= /semGenSize /= bigcup_const. Qed. Lemma semResizeSizeGen A (s n : nat) (g : G A) : semGenSize (resize n g) s <--> semGenSize g n. Proof. by case: g => g; rewrite /semGenSize. Qed. #[global] Instance ProducerSemanticsGen : @ProducerSemantics G ProducerGen := { semReturn := @semReturnGen; semReturnSize := @semReturnSizeGen; semBindSize := @semBindSizeGen; semChoose := @semChooseGen; semChooseSize := @semChooseSizeGen; semSized := @semSizedGen; semSizedSize := @semSizedSizeGen; semResize := @semResizeGen; semResizeSize := @semResizeSizeGen }. Module QcDefaultNotation. Declare Scope qc_scope. Notation " 'elems' [ x ] " := (elems_ x (cons x nil)) : qc_scope. Notation " 'elems' [ x ; y ] " := (elems_ x (cons x (cons y nil))) : qc_scope. Notation " 'elems' [ x ; y ; .. ; z ] " := (elems_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope. Notation " 'elems' ( x ;; l ) " := (elems_ x (cons x l)) (at level 1, no associativity) : qc_scope. Notation " 'oneOf' [ x ] " := (oneOf_ x (cons x nil)) : qc_scope. Notation " 'oneOf' [ x ; y ] " := (oneOf_ x (cons x (cons y nil))) : qc_scope. Notation " 'oneOf' [ x ; y ; .. ; z ] " := (oneOf_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope. Notation " 'oneOf' ( x ;; l ) " := (oneOf_ x (cons x l)) (at level 1, no associativity) : qc_scope. Notation " 'freq' [ x ] " := (freq_ x nil) : qc_scope. Notation " 'freq' [ ( n , x ) ; y ] " := (freq_ x (cons (n, x) (cons y nil))) : qc_scope. Notation " 'freq' [ ( n , x ) ; y ; .. ; z ] " := (freq_ x (cons (n, x) (cons y .. (cons z nil) ..))) : qc_scope. Notation " 'freq' ( ( n , x ) ;; l ) " := (freq_ x (cons (n, x) l)) (at level 1, no associativity) : qc_scope. End QcDefaultNotation. Section FrequencyProof. (* A rather long frequency proof, probably we can do better *) Lemma not_lt : forall n m, (false = (n < m)) -> (m <= n). Proof. move => n m. by elim: n m=> [| n IHn]; case. Qed. Lemma sum_fstE A x (a : A) l: sum_fst ((x, a) :: l) = x + sum_fst l. Proof. rewrite /sum_fst /=. elim: l 0 x => [n x|[n1 x1] l IHl p q] /=; first by rewrite addnC. by rewrite -IHl; congr foldl; rewrite addnAC. Qed. Lemma sum_fst_eq0P {A} (l : list (nat * A)) : sum_fst l = 0 <-> [seq x <- l | x.1 != 0] = [::]. Proof. by elim: l => [|[[|n] x] l IHl] //=; split=> //; rewrite sum_fstE. Qed. Lemma pick_def : forall {A} (l: list (nat * G A)) n def, sum_fst l <= n -> pick def l n = (0, def). Proof. move=> A l n def Hleq. elim : l n Hleq => //=. case=> //= i p l IHl n Hleq. rewrite sum_fstE in Hleq. remember (n < i). case: b Heqb => Heqb; symmetry in Heqb. - have : (i + sum_fst l) < i by eapply (leq_ltn_trans); eassumption. rewrite -ltn_subRL. by have -> : forall i, (i - i) = 0 by elim. - apply IHl. rewrite -(leq_add2r i) subnK. by rewrite addnC. by apply/not_lt. Qed. Lemma pick_exists : forall {A} (l: list (nat * G A)) n def, n < sum_fst l <-> exists x, List.In x l /\ pick def l n = x /\ fst x <> 0. Proof. move => A l n def. split. - move => Hlt. elim : l n Hlt => //. case => i p xs IHxs n Hlt. rewrite sum_fstE in Hlt. move/(_ (n-i)) : IHxs => IHxs. simpl. remember (n < i). case: b Heqb => [Heqb | /not_lt Heqb]. + exists (i, p). split => //=. by left. split => //=. move => contra; subst. by rewrite ltn0 in Heqb. + rewrite -(ltn_add2r i) [X in _ < X]addnC subnK // in IHxs. move/(_ Hlt) : IHxs => [x [H1 [H2 H3]]]. by exists x; split; [right | split]. - move => [x [HIn [Hpick Hneq]]]. remember (n < sum_fst l). case: b Heqb => //= /not_lt/pick_def H. rewrite H in Hpick. rewrite -Hpick //= in Hneq. Qed. Lemma pick_In : forall {A} (l: list (nat * G A)) x def, List.In x l /\ fst x <> 0 -> exists n, pick def l n = x. Proof. move => A l x def [HIn Hfst]. elim : l HIn => //=. case => //= i g xs IHxs [H1 | H2]; subst. + exists 0. simpl in *. have H : 0 < i by elim : i Hfst IHxs => //=. rewrite H. by split => //=. + move/(_ H2) : IHxs => [n Hpick]. exists (n + i). rewrite -[X in _ < X]add0n ltn_add2r ltn0. by rewrite -[X in _ - X]add0n subnDr subn0. Qed. Lemma pick_imset A (def : G A) l : pick def l @: [set m | m < sum_fst l] <--> [seq x <- l | x.1 != 0]. Proof. elim: l => [|[n x] l IHl] /=. rewrite /sum_fst /=. have->: (fun m => m < 0) <--> set0 by []. by rewrite imset0. case: n => /= [|n]. rewrite -IHl => t; split=> [[y []]|]. by rewrite sum_fstE add0n subn0 => lt_y <-; exists y. by case=> y [lt_y <-]; exists y; split=> //; rewrite subn0. move=> t; split=> /= [[p [lt_p]]|]. case: ifP => [_ <-|lt_pn ?]; first by left. right; rewrite -(IHl t); exists (p - n.+1); split=> //. rewrite sum_fstE in lt_p. by rewrite -(ltn_add2r n.+1) subnK 1?addnC // leqNgt lt_pn. case=> [<-|]; first by exists 0; split => //; rewrite sum_fstE. rewrite -(IHl t); case=> p [lt_p <-]; exists (n.+1 + p); split. by rewrite sum_fstE ltn_add2l. by rewrite ltnNge leq_addr addKn. Qed. Lemma pickDrop_def : forall {A} (l: list (nat * G (option A))) n, sum_fst l <= n -> pickDrop l n = (0, ret None, l). Proof. move=> A l n Hleq. elim : l n Hleq => //=. case=> //= i p l IHl n Hleq. rewrite sum_fstE in Hleq. remember (n < i). case: b Heqb => Heqb; symmetry in Heqb. - have : (i + sum_fst l) < i by eapply (leq_ltn_trans); eassumption. rewrite -ltn_subRL. by have -> : forall i, (i - i) = 0 by elim. - rewrite IHl; auto. rewrite -(leq_add2r i) subnK. by rewrite addnC. by apply/not_lt. Qed. (* Probably needs something about l' and l. *) Lemma pickDrop_exists : forall {A} (l: list (nat * G (option A))) n, n < sum_fst l <-> exists k g l', List.In (k,g) l /\ pickDrop l n = (k,g,l') /\ k <> 0 /\ l <--> [set (k, g)] :|: l' /\ length l' + 1 = length l /\ sum_fst l' + k = sum_fst l. Proof. move => A l n. split. - move => Hlt. elim : l n Hlt => //. case => i p xs IHxs n Hlt. rewrite sum_fstE in Hlt. move/(_ (n-i)) : IHxs => IHxs. simpl. remember (n < i). case: b Heqb => [Heqb | /not_lt Heqb]. + exists i. exists p. exists xs. split => //=. by left. split => //=. split. move => contra; subst. by rewrite ltn0 in Heqb. split. by rewrite cons_set_eq. split. by ssromega. rewrite sum_fstE. by ssromega. + rewrite -(ltn_add2r i) [X in _ < X]addnC subnK // in IHxs. move/(_ Hlt) : IHxs => [k [g [gs [H1 [H2 [H3 [H4 [H5 H6]]]]]]]]. exists k. exists g. exists ((i,p)::gs). split; [right | split; [| split; [| split; [| split]]]]; try (simpl; eauto; by rewrite H2). rewrite !cons_set_eq H4. rewrite setU_assoc (setU_comm [set (i, p)]) -setU_assoc. reflexivity. simpl. by ssromega. simpl. rewrite !sum_fstE. by ssromega. - move => [k [g [gs [HIn [Hpick [Hneq _]]]]]]. remember (n < sum_fst l). case: b Heqb => //= /not_lt/pickDrop_def H. rewrite H in Hpick. inversion Hpick; subst; eauto. Qed. Lemma pickDrop_In : forall {A} (l: list (nat * G (option A))) k x, List.In (k,x) l /\ k <> 0 -> exists n l', pickDrop l n = (k,x,l'). Proof. move => A l k x [HIn Hfst]. elim : l HIn => //=. case => //= i g xs IHxs [H1 | H2]; subst. + exists 0. exists xs. simpl in *. inversion H1; subst; clear H1. have H : 0 < k by elim : k Hfst IHxs => //=. rewrite H. by split => //=. + move/(_ H2) : IHxs => [n [l' Hpick]]. exists (n + i). exists ((i,g)::l'). rewrite -[X in _ < X]add0n ltn_add2r ltn0. rewrite -[X in _ - X]add0n subnDr subn0. by rewrite Hpick. Qed. Lemma pickDrop_In_strong : forall {A} (l: list (nat * G (option A))) k x, List.In (k,x) l /\ k <> 0 -> exists n l', pickDrop l n = (k,x,l') /\ n < sum_fst l /\ length l = length l' + 1. Proof. move => A l k x [HIn Hfst]. elim : l HIn => //=. case => //= i g xs IHxs [H1 | H2]; subst. + exists 0. exists xs. simpl in *. inversion H1; subst; clear H1. have H : 0 < k by elim : k Hfst IHxs => //=. rewrite H. split ; [| split ]; simpl; auto. rewrite sum_fstE. now ssromega. now ssromega. + move/(_ H2) : IHxs => [n [l' [Hpick [Hlt Hlen]]]]. exists (n + i). exists ((i,g)::l'). rewrite -[X in _ < X]add0n ltn_add2r ltn0. rewrite -[X in _ - X]add0n subnDr subn0. rewrite Hpick. simpl. split ; [| split ]; simpl; auto. rewrite sum_fstE. now ssromega. now ssromega. Qed. (* begin semFrequencySize *) Lemma semFrequencySize {A} (l : list (nat * G A)) (def : G A) (size: nat) : semProdSize (freq_ def l) size <--> let l' := [seq x <- l | x.1 != 0] in if l' is nil then semProdSize def size else \bigcup_(x in l') semProdSize x.2 size. (* end semFrequencySize *) Proof. rewrite semBindSize semChooseSizeGenNat //=. case lsupp: {1}[seq x <- l | x.1 != 0] => [|[n g] gs]. move/sum_fst_eq0P: lsupp => suml; rewrite suml. rewrite (@eq_bigcupl _ _ _ [set 0]) ?bigcup_set1 ?pick_def // ?leqn0 ?suml //. by move=> n; split; rewrite leqn0; [move/eqP|] => ->. symmetry; apply: reindex_bigcup. have pos_suml: 0 < sum_fst l. have [] := sum_fst_eq0P l. by rewrite lsupp; case: (sum_fst l) => // /(_ erefl). have->: (fun a : nat => a <= sum_fst l - 1) <--> [set m | m < sum_fst l]. by move=> m /=; rewrite -ltnS subn1 prednK. exact: pick_imset. Qed. (* begin semFrequency *) Lemma semFrequency {A} (l : list (nat * G A)) (def : G A) : semProd (freq_ def l) <--> let l' := [seq x <- l | x.1 != 0] in if l' is nil then semProd def else \bigcup_(x in l') semProd x.2. (* end semFrequency *) Proof. by case lsupp: {1}[seq x <- l | x.1 != 0] => [|[n g] gs] /=; rewrite 1?bigcupC; apply: eq_bigcupr => sz; have := (semFrequencySize l def sz); rewrite lsupp. Qed. Lemma frequencySizeMonotonic {A} (g0 : G A) lg : SizeMonotonic g0 -> List.Forall (fun p => SizeMonotonic (snd p)) lg -> SizeMonotonic (freq_ g0 lg). Proof. intros H1. unfold freq_. intros Hall. eapply bindMonotonicStrong. - eauto with typeclass_instances. - apply unsizedMonotonic. apply chooseUnsized. - intros x Heq. eapply semChooseGenNat in Heq; eauto. move : Heq => /andP [Hep1 Heq2]. destruct (sum_fst lg) eqn:Heq. + rewrite pick_def. eassumption. subst. ssromega. + edestruct (pick_exists lg x g0) as [[[n' g] [Hin [Hp Hg]]] H2]. rewrite Heq. ssromega. eapply List.Forall_forall in Hall; [ | ]. eassumption. subst. rewrite Hp. eassumption. Qed. #[global] Instance frequencySizeMonotonic_alt : forall {A : Type} (g0 : G A) (lg : seq (nat * G A)), SizeMonotonic g0 -> lg \subset [set x | SizeMonotonic x.2 ] -> SizeMonotonic (freq_ g0 lg). Proof. intros A g ls Hm Hin. eapply frequencySizeMonotonic. eassumption. induction ls. now constructor. constructor. eapply Hin. constructor. reflexivity. eapply IHls. eapply subset_trans; eauto. constructor 2. eassumption. Qed. End FrequencyProof. Lemma backtrack_correct_size_opt {A} (lst : list (nat * G (option A))) s : semProdSizeOpt (backtrack lst) s <--> \bigcup_(x in lst :&: (fun x => x.1 <> 0)) (fun g => semProdSizeOpt (snd g) s) x. Proof. unfold backtrack. assert (Hret := @semReturnSize G _ _ (option A)). assert (Hbind := @semBindSize G _ _). simpl in *. assert (sum_fst lst = sum_fst lst)%coq_nat by reflexivity. revert H. assert (Datatypes.length lst = Datatypes.length lst)%coq_nat by reflexivity. revert H. generalize (sum_fst lst) at 1 3. generalize (Datatypes.length lst) at 1 3. intros n1. generalize lst. induction n1; intros l n2 Heq1 Heq2. - simpl. intros x; split; intros Hin. + eapply semReturnSizeOpt_None in Hin; eauto with typeclass_instances. inv Hin. + inv Hin. inv H. destruct l; try (simpl in *; congruence). inv H0. inv H2. - intros x; split; intros Hin. + with_strategy opaque [pickDrop] (simpl in Hin). eapply Hbind in Hin. inv Hin. inv H. eapply semChooseSizeGen in H0; eauto. simpl in *. (* destruct (pickDrop_exists l x). simpl in *. destruct H4. *) (* now lia. *) (* destruct H1. destruct H4. destruct H4. destruct H6. destruct H7. *) (* rewrite H4 in H3. *) (* eapply Hbind in H3. *) (* destruct H2. destruct H3. destruct H2. *) (* destruct x2. *) (* -- eapply Hret in H3. *) (* inv H3. *) (* eexists. split. eassumption. *) (* constructor; eauto. *) (* -- assert (Hsem : (isSome :&: semProdSize *) (* (enumerateFuel n (n.+1 - 1) *) (* x1) s) (Some a)). *) (* { split; eauto. } *) (* assert (Heq' : (n.+1 - 1) = n). *) (* { ssromega. } *) (* rewrite Heq' in Hsem. *) (* eapply IHn in Hsem. *) (* inv Hsem. destruct H9. *) (* eexists. split. *) (* eapply H8. eassumption. *) (* eassumption. *) (* ssromega. *) (* + inv Hin. inv H. inv H1. destruct x; try (now exfalso; eauto). *) (* constructor. now eauto. *) (* simpl. *) (* eapply Hbind. *) (* destruct (pickDrop_In _ _ H0). destruct H4. *) (* destruct H4. *) (* exists x. split. *) (* eapply Enumerators.semChooseSize; eauto. *) (* simpl. now ssromega. *) (* rewrite H4. *) (* eapply Hbind. *) (* exists (Some a). split. *) (* eassumption. *) (* eapply Hret. reflexivity. *) Admitted. (* TODO bring back to life *) Lemma backtrack_correct_opt {A} (lst : list (nat * G (option A))) : semProdOpt (backtrack lst) <--> \bigcup_(x in lst :&: fun x => x.1 <> 0) (semProdOpt x.2). Proof. split; intros H. - inv H. inv H0. assert (Hin : semProdSizeOpt (backtrack lst) x a). { eassumption. } eapply (@backtrack_correct_size_opt A) in Hin. inv Hin. inv H3. eexists. split; eauto. eexists. split; eauto. - destruct H. destruct H. destruct H0. destruct H0. destruct x. simpl in *. inv H. simpl in *. assert (Hin : (\bigcup_(x in lst :&: fun x => x.1 <> 0) (semProdSizeOpt x.2 x0)) a). { eexists. split; eauto. } eapply (@backtrack_correct_size_opt A) in Hin. eexists. split; eauto. Qed. Lemma backtrack_SizeMonotonicOpt (A : Type) (l : list (nat * G (option A))) : l \subset (fun x => SizeMonotonicOpt x.2) -> SizeMonotonicOpt (backtrack l). Proof. intros Hin. intros s1 s2 Hleq. rewrite !backtrack_correct_size_opt. intros x Hin'. destruct Hin' as [e [Hl Hs]]. eexists. split; eauto. eapply Hin; inv Hl; eauto. Qed. Lemma enumerate_SizeMonotonic (A : Type) (l : list (nat * G (option A))) : l \subset (fun x => SizeMonotonic x.2) -> SizeMonotonic (backtrack l). Proof. (* unfold backtrack. *) (* assert (Datatypes.length l = Datatypes.length l)%coq_nat by reflexivity. *) (* revert H. *) (* generalize (Datatypes.length l) at 2 3 4. *) (* intros n. revert l. induction n; intros l Heq Hsub. *) (* - simpl. now eauto with typeclass_instances. *) (* - simpl. *) (* eapply bindMonotonicStrong; eauto with typeclass_instances. *) (* intros x1 Hin. eapply Enumerators.semChoose in Hin; eauto. simpl in *. *) (* destruct (Enumerators.pickDrop_exists l x1). simpl in *. now ssromega. *) (* destruct H. destruct H. destruct H0. destruct H1. *) (* rewrite H. *) (* eapply bindMonotonicStrong; eauto with typeclass_instances. *) (* intros a Hin'. *) (* destruct a; eauto with typeclass_instances. *) (* eapply returnGenSizeMonotonic; eauto with typeclass_instances. *) (* assert (Heq' : (n.+1 - 1) = n). { ssromega. } *) (* rewrite Heq'. eapply IHn. *) (* now ssromega. *) (* eapply subset_trans. eassumption. eassumption. *) (* Qed. *) Admitted. (* TODO bring back to life *) (* Backwards compatibility. *) Definition elements := @elems_ G ProducerGen. Definition liftGen := @liftM G (@super _ ProducerGen). Definition liftGen2 := @liftM2 G (@super _ ProducerGen). Definition liftGen3 := @liftM3 G (@super _ ProducerGen). Definition liftGen4 := @liftProd4 _ ProducerGen. Definition liftGen5 := @liftProd5 _ ProducerGen. Definition sequenceGen := @sequenceProd G ProducerGen. Definition oneof := @oneOf_ G ProducerGen. Definition frequency := @freq_. Definition semGen := @semProd G ProducerGen. QuickChick-2.1.0/src/Instances.v000066400000000000000000000551401476030541200164440ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". From Coq Require Import Arith Basics List Recdef ZArith Lia ssreflect ssrbool. From mathcomp Require Import ssrnat. From QuickChick Require Import Classes Sets Producer Enumerators Generators Tactics. Import ListNotations QcDefaultNotation. Open Scope qc_scope. Set Bullet Behavior "Strict Subproofs". (** Basic generator instances *) #[global] Instance genBoolSized : GenSized bool := {| arbitrarySized x := elems_ true [true; false] |}. #[global] Instance genNatSized : GenSized nat := {| arbitrarySized x := choose (0,x) |}. #[global] Instance genZSized : GenSized Z := {| arbitrarySized x := let z := Z.of_nat x in choose (-z, z)%Z |}. #[global] Instance genNSized : GenSized N := {| arbitrarySized x := let n := N.of_nat x in choose (N0, n) |}. #[global] Instance genListSized {A : Type} `{GenSized A} : GenSized (list A) := {| arbitrarySized x := listOf (arbitrarySized x) |}. (* [3] is a lower priority than [Classes.GenOfGenSized], avoiding an infinite loop in typeclass resolution. *) #[global] Instance genList {A : Type} `{Gen A} : Gen (list A) | 3 := {| arbitrary := listOf arbitrary |}. #[global] Instance genOption {A : Type} `{Gen A} : Gen (option A) | 3 := {| arbitrary := freq [ (1, ret None) ; (7, liftM Some arbitrary)] |}. #[global] Instance genPairSized {A B : Type} `{GenSized A} `{GenSized B} : GenSized (A*B) := {| arbitrarySized x := liftM2 pair (arbitrarySized x) (arbitrarySized x) |}. #[global] Instance genPair {A B : Type} `{Gen A} `{Gen B} : Gen (A * B) := {| arbitrary := liftM2 pair arbitrary arbitrary |}. (* Enumerator #[global] Instances *) #[global] Instance enumBoolSized : EnumSized bool := {| enumSized x := elems_ true [true; false] |}. #[global] Instance enumNatSized : EnumSized nat := {| enumSized x := chooseEnum (0,x) |}. #[global] Instance enumZSized : EnumSized Z := {| enumSized x := let z := Z.of_nat x in chooseEnum (-z, z)%Z |}. #[global] Instance enumNSized : EnumSized N := {| enumSized x := let n := N.of_nat x in chooseEnum (N0, n) |}. #[global] Instance enumListSized {A : Type} `{Enum A} : EnumSized (list A) := {| enumSized x := bindEnum (choose (0,x)) (fun x => vectorOf x enum) |}. (* [3] is a lower priority than [Classes.EnumOfEnumSized], avoiding an infinite loop in typeclass resolution. *) #[global] Instance enumList {A : Type} `{Enum A} : Enum (list A) | 3 := {| enum := listOf enum |}. #[global] Instance enumOption {A : Type} `{Enum A} : Enum (option A) | 3 := {| enum := oneOf [ (ret None) ; (liftM Some enum)] |}. #[global] Instance enumPairSized {A B : Type} `{EnumSized A} `{EnumSized B} : EnumSized (A*B) := {| enumSized x := liftM2 pair (enumSized x) (enumSized x) |}. #[global] Instance enumPair {A B : Type} `{Enum A} `{Enum B} : Enum (A * B) := {| enum := liftM2 pair enum enum |}. #[global] Instance enumOpt {A} (H : Enum A) : Enum (option A) := {| enum := match enum with | MkEnum f => MkEnum (fun n => LazyList.lcons None (fun _ => LazyList.mapLazyList Some (f n))) end |}. (** Shrink#[global] Instances *) #[global] Instance shrinkBool : Shrink bool := {| shrink x := match x with | false => nil | true => cons false nil end |}. #[global] Instance enumOptCorrect A `{EnumCorrect A} : Correct _ (@enum _ (enumOpt _)). Proof. constructor. intros t; split; eauto. - intros. exact I. - intros _. simpl. inv H. inv H0. unfold semProd. simpl. destruct t. + destruct (prodCorrect a). destruct H3. now reflexivity. inv H3. simpl in *. eexists x. split. eassumption. destruct H. simpl in *. destruct enum0. unfold semEnumSize in *. simpl. right. eapply LazyList.lazy_in_map_iff. eexists. split. reflexivity. eassumption. + exists 0. split. reflexivity. destruct H. simpl. destruct enum0. unfold semEnumSize in *. simpl. left. reflexivity. Qed. #[global] Instance enumOpt_SizeMonotonic A `{EnumMonotonic A} : SizeMonotonic (@enum _ (enumOpt _)). Proof. destruct H. destruct enum. simpl in *. intros s1 s2 Hleq [ x |]; simpl. - eapply H0 in Hleq. simpl in *. intros Hin. unfold semEnumSize in *. simpl in *. right. inv Hin; try congruence. eapply LazyList.lazy_in_map_iff. eexists. split. reflexivity. eapply Hleq. eapply LazyList.lazy_in_map_iff in H. destruct H. inv H. inv H2. eassumption. - unfold semEnumSize in *. simpl in *. firstorder. Qed. #[global] Instance enumOpt_SizeFP A `{Enum A} : SizeFP (@enum _ (enumOpt _)). Proof. destruct H. destruct enum. simpl in *. intros s1 s2 Hleq Hnin. simpl. unfold semEnumSize in *. simpl in *. firstorder. Qed. #[global] Instance enumNatSized_CorrectSized : CorrectSized (@enumSized _ enumNatSized). Proof. constructor. intros t; split; eauto. - intros. exact I. - intros _. assert (Hsize := @Enumerators.semChooseSizeEnumNat). simpl in *. exists t. exists t. split. exact I. eapply Hsize. reflexivity. ssromega. Qed. #[global] Instance enumNatSized_SizedMonotonic : SizedMonotonic (@enumSized _ enumNatSized). Proof. intros s s1 s2 Hleq. simpl. intros x Hin. assert (Hsize := @Enumerators.semChooseSizeEnumNat). eapply Hsize in Hin; eauto. simpl in Hin. eapply Hsize. reflexivity. simpl. ssromega. Qed. #[global] Instance enumNatSized_SizeMonotonic s: SizeMonotonic (@enumSized _ enumNatSized s). Proof. intros s1 s2 Hleq. simpl. intros x Hin. assert (Hsize := @Enumerators.semChooseSizeEnumNat). eapply Hsize in Hin; eauto. simpl in Hin. eapply Hsize. reflexivity. simpl. ssromega. Qed. (* TODO. These case be derived automatically. Change the default definitions *) #[global] Instance enumListSized_SizedMonotonic A `{EnumMonotonic A} : SizedMonotonic (@enumSized (list A) enumListSized). Proof. intros s s1 s2 Hleq x Hin. eapply semBindSizeEnum in Hin. destruct Hin as [a [Hin He]]. assert (Hvec := @semVectorOfSize E _ _). eapply Hvec in He. destruct He as [Heq Hin']. eapply semBindSizeEnum. exists a. split. eapply Enumerators.semChooseSizeEnumNat in Hin. simpl in *. eapply Enumerators.semChooseSizeEnumNat. now eauto. simpl. now ssromega. now eauto. eapply Hvec. split; eauto. Qed. #[global] Instance enumListSized_SizeMonotonic A `{EnumMonotonic A} s : SizeMonotonic (@enumSized (list A) enumListSized s). Proof. eapply bindMonotonic; eauto with typeclass_instances. Qed. #[global] Instance enumListSized_CorrectSized A `{EnumMonotonicCorrect A} : CorrectSized (@enumSized (list A) enumListSized). Proof. assert (Hvec := @semVectorOfSize E _ _). constructor. intros l; induction l; simpl. - split; intros Hin; simpl in *. now constructor. eexists 0. eexists 0. split; eauto. eapply semBindSizeEnum. eexists. split. eapply Enumerators.semChooseSizeEnum. now eauto. 2:{ eapply Hvec. split. reflexivity. eapply sub0set. } now eauto. - split; intros Hin. now constructor. destruct IHl as [_ IHl]. edestruct IHl as [x [s1 [Hin1 He]]]. now constructor. eapply semBindSizeEnum in He. destruct He as [y [Hen Hv]]. eapply Hvec in Hv; eauto with typeclass_instances. destruct Hv as [Heq Hinl]. subst. eapply Enumerators.semChooseSizeEnumNat in Hen; eauto. simpl in *. destruct H2. destruct H1. edestruct prodCorrect with (a := a). edestruct H2 as [s2 [ _ Hin'] ]. reflexivity. eexists (x + 1). eexists (s1 + s2). split. reflexivity. eapply semBindSizeEnum. exists (length l+1). split. eapply Enumerators.semChooseSizeEnumNat; eauto. simpl in *. ssromega. eapply Hvec. split. simpl. now ssromega. eapply cons_subset. eapply H0; [| eassumption ]. now ssromega. eapply subset_trans. eassumption. eapply H0. now ssromega. Qed. #[global] Instance enumPairSized_SizedMonotonic A {_ : EnumSized A} { _ : SizedMonotonic (@enumSized A _)} B {_ : EnumSized B} { _ : SizedMonotonic (@enumSized B _)}: SizedMonotonic (@enumSized (A * B) enumPairSized). Proof. intros s s1 s2 Hleq. simpl. rewrite !semBindSizeEnum. eapply incl_bigcup_compat; eauto. intros x. simpl. rewrite !semBindSizeEnum. eapply incl_bigcup_compat; eauto. intros y. eapply subset_refl. Qed. #[global] Instance enumPairSized_SizeMonotonic A {_ : EnumSized A} { _ : forall s, SizeMonotonic (@enumSized A _ s)} B {_ : EnumSized B} { _ : forall s, SizeMonotonic (@enumSized B _ s)} s : SizeMonotonic (@enumSized (A * B) enumPairSized s). Proof. do 2 (eapply bindMonotonic; [ eauto with typeclass_instances .. | intros ? ]). eapply returnGenSizeMonotonic; eauto with typeclass_instances. Qed. #[global] Instance enumPairSized_CorrectSized A {_ : EnumSized A} { _ : forall s, SizeMonotonic (@enumSized A _ s)} { _ : SizedMonotonic (@enumSized A _)} { _ : CorrectSized (@enumSized A _)} B {_ : EnumSized B} { _ : forall s, SizeMonotonic (@enumSized B _ s)} { _ : SizedMonotonic (@enumSized B _)} { _ : CorrectSized (@enumSized B _)}: CorrectSized (@enumSized (A * B) enumPairSized). Proof. constructor. split. { intros. reflexivity. } destruct a. intros _. edestruct H1 as [[_ Hca]]. edestruct H4 as [[_ Hcb]]. destruct Hca as [x1 [s1 [_ Hin1]]]. reflexivity. destruct Hcb as [x2 [s2 [_ Hin2]]]. reflexivity. eexists (x1 + x2). simpl. eexists (s1 + s2). split. reflexivity. simpl. eapply semBindSizeEnum. eexists. split. eapply H0. 2:{ eapply H; [| eassumption ]. ssromega. } ssromega. eapply semBindSizeEnum. eexists. split. eapply H2. 2:{ eapply H3; [| eassumption ]. ssromega. } ssromega. eapply semReturnSizeEnum. reflexivity. Qed. #[global] Instance enumOption_SizeMonotonic A {_ : Enum A} { _ : SizeMonotonic (@enum A _)} : SizeMonotonic (@enum (option A) enumOption). Proof. simpl. eapply oneofMonotonic. - eauto with typeclass_instances. - eapply returnGenSizeMonotonic; eauto with typeclass_instances. - eapply cons_subset. eapply returnGenSizeMonotonic; eauto with typeclass_instances. eapply cons_subset. + eapply bindMonotonic; [ eauto with typeclass_instances .. | intros y ]. eapply returnGenSizeMonotonic; eauto with typeclass_instances. + eapply sub0set. Qed. #[global] Instance enumOption_Correct A {_ : Enum A} { _ : Correct A (@enum A _)}: Correct _ (@enum (option A) enumOption). Proof. constructor. split. intros. reflexivity. intros _. simpl. destruct a. - edestruct H as [ [ _ Hc ] ]. destruct Hc as [x [H1 H2]]. reflexivity. eexists x. split. reflexivity. eapply semOneofSize. eauto with typeclass_instances. eexists. split. right. left. eexists. eapply semBindSizeEnum. eexists. split. eassumption. eapply semReturnSizeEnum. reflexivity. - exists 0. split. reflexivity. eapply semOneofSize. eauto with typeclass_instances. eexists. split. left. reflexivity. eapply semReturnSizeEnum. reflexivity. Qed. Lemma andb_len x1 x2 x3 x4 : (x1 <=? x2)%num && (x3 <=? x4)%num <-> (x1 <= x2)%num /\ (x3 <= x4)%num. Proof. destruct (x1 <=? x2)%num eqn:Heq1; simpl; split; try easy; destruct (x3 <=? x4)%num eqn:Heq2; simpl; try easy. - eapply N.leb_le in Heq1. eapply N.leb_le in Heq2. easy. - intros [H1 H2]. eapply N.leb_nle in Heq2. eauto. - intros [H1 H2]. eapply N.leb_nle in Heq1. eauto. - intros [H1 H2]. eapply N.leb_nle in Heq1. eauto. Qed. #[global] Instance enumNSized_SizedMonotonic : SizedMonotonic (@enumSized _ enumNSized). Proof. intros s s1 s2 Hleq. simpl. intros x Hin. assert (Hsize := Enumerators.semChooseSizeEnum N). apply Hsize in Hin; [ | lia ]. apply Hsize; lia. Qed. #[global] Instance enumNSized_SizeMonotonic s: SizeMonotonic (@enumSized _ enumNSized s). Proof. intros s1 s2 Hleq. simpl. intros x Hin. assert (Hsize := Enumerators.semChooseSizeEnum N). eapply Hsize in Hin; eauto; [ | lia]. apply Hsize; lia. Qed. (* Lemma of_nat_bin t : *) (* (N.of_nat (nat_of_bin t)) = t. *) (* Proof. *) (* destruct t. reflexivity. *) (* simpl. *) (* induction p; simpl. *) (* - admit. *) (* - *) #[global] Instance enumNSized_CorrectSized : CorrectSized (@enumSized _ enumNSized). Proof. constructor. intros t; split; eauto. - intros. exact I. - intros _. assert (Hsize := Enumerators.semChooseSizeEnum N). exists (N.to_nat t). exists 0. split. exact I. eapply Hsize; lia. Qed. #[global] Instance enumBoolSized_SizeMonotonic s: SizeMonotonic (@enumSized _ enumBoolSized s). Proof. intros s1 s2 Hleq. assert ( Heq := @semElementsSize E _ _). simpl in *. rewrite Heq. eapply subset_refl. Qed. #[global] Instance enumBoolSized_CorrectSized : CorrectSized (@enumSized _ enumBoolSized). Proof. constructor. intros t; split; eauto. - intros. exact I. - intros _. destruct t; exists 0; simpl; eapply semElements; eauto with typeclass_instances. now left. right. now left. Qed. #[global] Instance enumBoolSized_SizedMonotonic : SizedMonotonic (@enumSized _ enumBoolSized). Proof. intros s s1 s2 Hleq. simpl. assert ( Heq := @semElementsSize E _ _). simpl in *. rewrite Heq. eapply subset_refl. Qed. (** Shrinking of nat starts to become annoying *) Function shrinkNatAux (x : nat) {measure (fun x => x) x} : list nat := match x with | O => nil | S n => let x' := Nat.div x 2 in x' :: shrinkNatAux x' end. Proof. move => x n Eq; pose proof (Nat.divmod_spec n 1 0 0) as H. assert (H' : (0 <= 1)%coq_nat) by lia; apply H in H'; subst; simpl in *; clear H. destruct (Nat.divmod n 1 0 0) as [q u]; destruct u; simpl in *; lia. Defined. #[global] Instance shrinkNat : Shrink nat := {| shrink := shrinkNatAux |}. (** Shrinking of Z is even more so *) Lemma abs_div2_pos : forall p, Z.abs_nat (Z.div2 (Z.pos p)) = Nat.div2 (Pos.to_nat p). Proof. intros. destruct p. rewrite /Z.div2 /Pos.div2. rewrite /Z.abs_nat. rewrite Pos2Nat.inj_xI. rewrite <- Nat.add_1_r. rewrite Nat.mul_comm. rewrite Nat.div2_div. rewrite Nat.div_add_l; simpl; lia. rewrite /Z.div2 /Pos.div2. rewrite /Z.abs_nat. rewrite Pos2Nat.inj_xO. rewrite Nat.mul_comm. rewrite Nat.div2_div. rewrite Nat.div_mul. reflexivity. lia. reflexivity. Qed. Lemma neg_succ : forall p, Z.neg (Pos.succ p) = Z.pred (Z.neg p). Proof. move => p. rewrite <- Pos.add_1_r. rewrite <- Pos2Z.add_neg_neg. rewrite <- Z.sub_1_r. reflexivity. Qed. Lemma neg_pred : forall p, (p > 1)%positive -> Z.neg (Pos.pred p) = Z.succ (Z.neg p). Proof. move => p Hp. destruct p using Pos.peano_ind. by inversion Hp. rewrite Pos.pred_succ. rewrite neg_succ. rewrite Z.succ_pred. reflexivity. Qed. Lemma abs_succ_neg : forall p, Z.abs_nat (Z.succ (Z.neg p)) = Nat.pred (Pos.to_nat p). Proof. move => p. destruct p using Pos.peano_ind. reflexivity. rewrite -neg_pred /Z.abs_nat. rewrite Pos2Nat.inj_pred. reflexivity. apply Pos.lt_1_succ. apply Pos.lt_gt; apply Pos.lt_1_succ. Qed. Lemma abs_succ_div2_neg : forall p, Z.abs_nat (Z.succ (Z.div2 (Z.neg p))) = Nat.div2 (Pos.to_nat p) \/ Z.abs_nat (Z.succ (Z.div2 (Z.neg p))) = Nat.pred (Nat.div2 (Pos.to_nat p)). Proof. intros. destruct p. left. rewrite /Z.div2 /Pos.div2. rewrite neg_succ. rewrite <- Zsucc_pred. rewrite /Z.abs_nat. rewrite Pos2Nat.inj_xI. rewrite <- Nat.add_1_r. rewrite Nat.mul_comm. rewrite Nat.div2_div. rewrite Nat.div_add_l; simpl; lia. right. rewrite /Z.div2 /Pos.div2. rewrite Pos2Nat.inj_xO. rewrite Nat.mul_comm. rewrite Nat.div2_div. rewrite Nat.div_mul. simpl. apply abs_succ_neg. lia. left. simpl. reflexivity. Qed. Function shrinkZAux (x : Z) {measure (fun x => Z.abs_nat x) x}: list Z := match x with | Z0 => nil | Zpos _ => rev (cons (Z.pred x) (cons (Z.div2 x) (shrinkZAux (Z.div2 x)))) | Zneg _ => rev (cons (Z.succ x) (cons (Z.succ (Z.div2 x)) (shrinkZAux (Z.succ (Z.div2 x))))) end. Proof. move => ? p ?. subst. rewrite abs_div2_pos. rewrite Zabs2Nat.inj_pos. rewrite Nat.div2_div. apply Nat.div_lt. apply Pos2Nat.is_pos. lia. move => ? p ?. subst. destruct (abs_succ_div2_neg p) as [H | H]. rewrite {}H /Z.abs_nat. rewrite Nat.div2_div. apply Nat.div_lt. apply Pos2Nat.is_pos. lia. rewrite {}H /Z.abs_nat. eapply Nat.le_lt_trans. apply Nat.le_pred_l. rewrite Nat.div2_div. apply Nat.div_lt. apply Pos2Nat.is_pos. lia. Qed. #[global] Instance shrinkZ : Shrink Z := {| shrink := shrinkZAux |}. Open Scope program_scope. #[global] Instance shrinkN : Shrink N := {| shrink := map Z.to_N ∘ shrink ∘ Z.of_N |}. Definition shrinkListAux {A : Type} (shr : A -> list A) : list A -> list (list A) := fix shrinkListAux_ (l : list A) : list (list A) := match l with | nil => nil | cons x xs => xs :: map (fun xs' => cons x xs') (shrinkListAux_ xs) ++ map (fun x' => cons x' xs) (shr x ) end. #[global] Instance shrinkList {A : Type} `{Shrink A} : Shrink (list A) := {| shrink := shrinkListAux shrink |}. #[global] Instance shrinkPair {A B} `{Shrink A} `{Shrink B} : Shrink (A * B) := {| shrink := fun (p : A * B) => let (a,b) := p in map (fun a' => (a',b)) (shrink a) ++ map (fun b' => (a,b')) (shrink b) |}. #[global] Instance shrinkOption {A : Type} `{Shrink A} : Shrink (option A) := {| shrink m := match m with | None => [] | Some x => None :: (map Some (shrink x)) end |}. (** Arbitraries are derived automatically! *) (**#[global] Instance correctness *) (* Needed to add this! *) Opaque semProdSize. #[global] Program Instance arbNatMon : @SizeMonotonic nat G ProducerGen (@arbitrary nat _). Next Obligation. rewrite !semSizedSize !semChooseSizeNat // => n /andP [/leP H1 /leP H2]. move : H => /leP => Hle. apply/andP. split; apply/leP; ssromega. Qed. (** Correctness proof about built-in generators *) #[global] Instance boolSizeMonotonic : SizeMonotonic (@arbitrary bool _). Proof. unfold arbitrary, GenOfGenSized. eapply sizedSizeMonotonic; unfold arbitrarySized, genBoolSized. - eauto with typeclass_instances. - intros; eauto with typeclass_instances. - intros n s1 s2 Hs. eapply subset_refl. Qed. #[global] Instance boolSizedMonotonic : SizedMonotonic (@arbitrarySized bool _). Proof. intros n s1 s2 Hs. eapply subset_refl. Qed. #[global] Instance boolCorrect : Correct bool arbitrary. Proof. constructor. unfold arbitrary, GenOfGenSized. rewrite semSized. unfold arbitrarySized, genBoolSized. intros x. split; intros H; try now constructor. exists 0. split. constructor. eapply semElementsSize; eauto with typeclass_instances. destruct x; try solve [left; auto]; right; left; auto. Qed. Local Open Scope set_scope. Lemma arbBool_correct: semProd arbitrary <--> [set: bool]. Proof. rewrite /arbitrary /arbitrarySized /genBoolSized /=. rewrite semSized => n; split=> // _. exists n; split=> //. apply semElementsSize => //=; eauto with typeclass_instances. destruct n; repeat (try solve [left; auto]; right). Qed. Lemma arbNat_correct: semProd arbitrary <--> [set: nat]. Proof. rewrite /arbitrary /=. rewrite semSized => n; split=> // _; exists n; split=> //. by rewrite (semChooseSizeNat _ _ _) /=. Qed. #[global] Instance ArbNatGenCorrect : Correct nat arbitrary. Proof. constructor. now apply arbNat_correct. Qed. Lemma arbInt_correct s : semProdSize arbitrary s <--> [set z | (- Z.of_nat s <= z <= Z.of_nat s)%Z]. Proof. rewrite semSizedSize semChooseSize. by move=> n; split=> [|] [? ?]. ssromega. Qed. Lemma arbBool_correctSize s : semProdSize arbitrary s <--> [set: bool]. Proof. rewrite /arbitrary //=. rewrite semSizedSize semElementsSize //; split=> _ //=; case a=> //=. repeat (try solve [left; auto]; right). repeat (try solve [left; auto]; right). Qed. Lemma arbNat_correctSize s : semProdSize arbitrary s <--> [set n : nat | (n <= s)%coq_nat]. Proof. by rewrite semSizedSize semChooseSizeNat // => n /=; case: leP. Qed. Lemma arbInt_correctSize : semProd arbitrary <--> [set: Z]. Proof. rewrite /arbitrarySized semSized => n; split=> // _; exists (Z.abs_nat n); split=> //. simpl. rewrite Nat2Z.inj_abs_nat (semChooseSize _ _ _); ssromega. Qed. Lemma arbList_correct: forall {A} `{H : Arbitrary A} (P : nat -> A -> Prop) s, (semProdSize arbitrary s <--> P s) -> (semProdSize arbitrary s <--> (fun (l : list A) => length l <= s /\ (forall x, List.In x l -> P s x))). Proof. move => A G S H P s Hgen l. rewrite !/arbitrary /genList. split. - move => /semListOfSize [Hl Hsize]. split => // x HIn //=. apply Hgen. auto. - move => [Hl HP]. apply semListOfSize; eauto with typeclass_instances. split => // x HIn. apply Hgen. auto. Qed. Opaque ret. Opaque liftM. Lemma arbOpt_correct: forall {A} `{H : Arbitrary A} (P : nat -> A -> Prop) s, (semProdSize arbitrary s <--> P s) -> (semProdSize arbitrary s <--> (fun (m : option A) => match m with | None => true | Some x => P s x end)). Proof. move => A G S Arb P s Hgen m. rewrite !/arbitrary /genOption; split. - move => /semFrequencySize [[w g] H2]. move: H2 => [[H2 | [H2 | H2]] H3]; destruct m => //=; apply Hgen => //=; inversion H2; subst; auto; simpl in *. + apply (@semReturnSize Generators.G ProducerGen ProducerSemanticsGen (option A) None s (Some a)) in H3; inversion H3. + apply (@semLiftProdSize _ ProducerGen _ _ _ Some (@arbitrary _ G) s (Some a)) in H3; eauto with typeclass_instances. inversion H3 as [x [H0 H1]]. inversion H1; subst; auto. - destruct m eqn:Hm; simpl in *; move => HP; subst. + apply semFrequencySize; simpl. exists (7, liftM Some arbitrary); split; auto. * right; left; auto. * simpl. apply (@semLiftProdSize _ ProducerGen _ _ _ Some (@arbitrary _ G) s (Some a)); simpl; eauto with typeclass_instances. apply imset_in; apply Hgen; auto. + apply semFrequencySize; simpl. exists (1, ret None); split; auto. * left; auto. * simpl. apply (@semReturnSize Generators.G ProducerGen ProducerSemanticsGen (option A) None s None). constructor. Qed. Lemma arbPair_correctSize {A B} `{Arbitrary A} `{Arbitrary B} (Sa : nat -> set A) (Sb : nat -> set B) s: (semProdSize arbitrary s <--> Sa s) -> (semProdSize arbitrary s <--> Sb s) -> (semProdSize arbitrary s <--> setX (Sa s) (Sb s)). Proof. move => Hyp1 Hyp2 . simpl. rewrite semLiftProd2Size; move => [a b]. split. by move => [[a' b'] [[/= /Hyp1 Ha /Hyp2 Hb] [Heq1 Heq2]]]; subst; split. move => [/Hyp1 Ha /Hyp2 Hb]. eexists; split; first by split; eauto. reflexivity. Qed. QuickChick-2.1.0/src/LazyList.v000066400000000000000000000234771476030541200163000ustar00rootroot00000000000000From Coq Require Import Arith. From ExtLib.Structures Require Export Functor Applicative Monad. Require Import List. Import ListNotations. From QuickChick Require Import Tactics. Import MonadNotation. Open Scope monad_scope. Set Bullet Behavior "Strict Subproofs". (* A lazy list *) (* Laziness is implemented by just thunking the computation for the tail of a cons-cell. Since each such tail is used exactly once, there is no point in using ocaml's 'lazy' that memoizes computation and results in unnecessary overheads. *) Inductive LazyList (A : Type) : Type := | lnil : LazyList A | lcons : A -> (unit -> (LazyList A)) -> LazyList A. Arguments lnil {A}. Arguments lcons {A} _ _. Fixpoint lazy_append {A : Type} (l1 : LazyList A) (l2 : LazyList A) : LazyList A := match l1 with | lnil => l2 | lcons x l1' => lcons x (fun _ => (lazy_append (l1' tt) l2)) end. Fixpoint lazy_append' {A : Type} (l1 : LazyList A) (l2 : unit -> LazyList A) : LazyList A := match l1 with | lnil => l2 tt (* match l2 tt with | lnil => lsing x | l2' => lcons x (fun _ => l2') end *) | lcons x l1' => lcons x (fun _ => (lazy_append' (l1' tt) l2)) end. Fixpoint lazy_take {A : Type} (n : nat) (l : LazyList A) : LazyList A := match n with | 0 => lnil | S n' => match l with | lnil => lnil | lcons h ts => lcons h (fun _ => (lazy_take n' (ts tt))) end end. (* Functor instace for LazyList *) Fixpoint mapLazyList {A B : Type} (f : A -> B) (l : LazyList A) : LazyList B := match l with | lnil => lnil | lcons x l' => lcons (f x) (fun _ => (mapLazyList f (l' tt))) end. #[global] Instance FunctorLazyList : Functor LazyList := { fmap := @mapLazyList }. (* Monad and applicative instances for LazyList *) (* Injecting into a monad must crucially use the singleton constructor. *) Definition retLazyList {A : Type} (a : A) : LazyList A := lcons a (fun _ => lnil). (* lcons _ a (fun _ => (lnil _)). *) Fixpoint concatLazyList {A : Type} (l : LazyList (LazyList A)) : LazyList A := match l with | lnil => lnil | lcons x l' => lazy_append x (concatLazyList (l' tt)) end. Definition bindLazyList {A B : Type} (l : LazyList A) (f : A -> LazyList B) : LazyList B := concatLazyList (mapLazyList f l). #[global] Instance MonadLazyList : Monad LazyList := { ret := @retLazyList; bind := @bindLazyList }. Definition apLazyList {A B : Type} (lab : LazyList (A -> B)) (la : LazyList A) : LazyList B := ab <- lab;; a <- la;; ret (ab a). #[global] Instance ApplicativeLazyList : Applicative LazyList := { pure := @retLazyList; ap := @apLazyList }. Definition apComp {F: Type -> Type} `{Functor F} {A B C : Type} (f : B -> C) (fab : F (A -> B)) : F (A -> C) := fmap (fun g => fun a => f (g a)) fab. (* Guard definition, because ExtLib doesn't have Alternative *) Definition guard (b : bool) : LazyList unit := match b with | true => ret tt | false => lnil end. (* Lazy list in *) Fixpoint In_ll {A : Type} (a : A) (l : LazyList A) : Prop := match l with | lnil => False | lcons h ts => h = a \/ In_ll a (ts tt) end. Fixpoint All_ll {A : Type} (P : A -> Prop) (l : LazyList A) : Prop := match l with | lnil => True | lcons h ts => P h /\ All_ll P (ts tt) end. Lemma lazy_in_map_iff : forall (A B : Type) (f : A -> B) (l : LazyList A) (y : B), In_ll y (mapLazyList f l) <-> (exists x : A, f x = y /\ In_ll x l). Proof. intros A B f l; induction l; intros y; (split; [ intros HIn | intros [x [Hfx HIn] ] ]). - inversion HIn. - inversion HIn. - simpl in *. destruct HIn as [Hf | HIn]. + exists a; split; auto. + apply H in HIn. destruct HIn as [x [Hf HIn]]. exists x; split; auto. - destruct HIn as [Hf | HIn]; subst; simpl in *; auto. right; apply H. exists x; auto. Qed. (* Section Ind. Variable A : Type. Variable P : LazyList A -> Prop. Variable Hnil : P (lnil). Variable Hsing : forall (a : A), P (lsing a). Variable Hcons : forall (a : A) (l : LazyList A), P l -> P (lcons a (fun _ => l)). Fixpoint better_ll_ind (l : LazyList A) : P l := match l with | lnil => Hnil | lsing x => Hsing x | lcons a tl => @Hcons a (tl tt) (better_ll_ind (tl tt)) end. End Ind. *) Lemma lazy_in_app_or : forall (A : Type) (l m : LazyList A) (a : A), In_ll a (lazy_append l m) -> In_ll a l \/ In_ll a m. Proof. intros A l. induction l; intros m h Hyp; simpl in *; auto. - destruct Hyp; subst; simpl in *; auto. rewrite or_assoc. apply H in H0. destruct H0; auto. Qed. Lemma lazy_in_or_app : forall (A : Type) (l m : LazyList A) (a : A), In_ll a l \/ In_ll a m -> In_ll a (lazy_append l m). Proof. intros A l. induction l; intros m h HIn; simpl in *. - destruct HIn as [Contra | HIn]; [ contradiction | auto ]. - destruct HIn as [[HEq | HIn] | HIn]; subst; simpl in *; auto. Qed. Fixpoint LazyList_to_list {A : Type} (l : LazyList A) : list A := match l with | lnil => nil | lcons x x0 => x :: LazyList_to_list (x0 tt) end. Fixpoint list_to_LazyList {A : Type} (l : list A) : LazyList A := match l with | nil => lnil | cons x x0 => lcons x (fun _ => (list_to_LazyList x0)) end. Theorem nil_lazylist : forall A (l : LazyList A), [] = LazyList_to_list l -> l = lnil. Proof. intros A l H. destruct l; simpl in *; auto; inversion H. Qed. Theorem lazy_in_map: forall (A B : Type) (f : A -> B) (l : LazyList A) (x : A), In_ll x l -> In_ll (f x) (fmap f l). Proof. intros A B f l. induction l; intros x HIn. - inversion HIn. - destruct HIn as [Hax | Hin]; subst; auto. + left. auto. + right. auto. Qed. Lemma lazy_append_nil_r : forall {B : Type} (b : B) l, In_ll b l -> In_ll b (lazy_append l lnil). Proof. intros B b l H. induction l. - inversion H. - simpl in *. firstorder. Qed. Lemma lazy_append_sing_r : forall {B : Type} (b x : B) l, In_ll b l -> In_ll b (lazy_append l (lcons x (fun _ => lnil))). Proof. intros B b x l H. induction l. - inversion H. - simpl in *. firstorder. Qed. Lemma lazy_append_in_l : forall {B : Type} ll (b : B) l, In_ll b l -> In_ll b (lazy_append l ll). Proof. intros B ll; induction ll; intros b l0 HIn. - auto using lazy_append_nil_r. - induction l0. + inversion HIn. + simpl in *. firstorder. Qed. Lemma lazy_append_in_r : forall {B : Type} (b : B) l ll, In_ll b ll -> In_ll b (lazy_append l ll). Proof. intros B b l ll H. induction l; simpl; auto. Qed. Lemma lazy_concat_in : forall {B : Type} (b : B) l ll, In_ll b l -> In_ll l ll -> In_ll b (concatLazyList ll). Proof. intros B b l ll Hb Hbll. induction ll; simpl in *; subst; auto. destruct Hbll as [Hal | Hinl]; subst; auto using lazy_append_in_l, lazy_append_in_r. Qed. Fixpoint join_list_lazy_list {A : Type} (l : list (LazyList A)) : LazyList A := match l with | nil => lnil | cons h ts => lazy_append h (join_list_lazy_list ts) end. Fixpoint joint_list_lazy_list_list {A : Type} (l : list (LazyList A)) : list A := match l with | nil => nil | cons h ts => (LazyList_to_list h) ++ (joint_list_lazy_list_list ts) end. Fixpoint lazy_seq {A : Type} (s : A -> A) (lo : A) (len : nat) := match len with | O => lnil | S len' => lcons lo (fun tt => lazy_seq s (s lo) len') end. (* Only in stdlib since 8.18 *) Lemma iter_succ {A : Type} (s : A -> A) (lo : A) (n : nat) : Nat.iter n s (s lo) = s (Nat.iter n s lo). Proof. revert lo; induction n; simpl; intros lo. - reflexivity. - f_equal; apply IHn. Qed. Lemma lazy_seq_spec {A : Type} (s : A -> A) (lo : A) (n : nat) (x : A) : In_ll x (lazy_seq s lo n) <-> exists i, i < n /\ x = Nat.iter i s lo. Proof. revert lo x; induction n; cbn. - split; [ contradiction | intros (i & ? & ?); contradiction (Nat.nlt_0_r i) ]. - intros lo x; split. + intros [ -> | Hx ]. * exists 0. split; [ apply Nat.lt_0_succ | reflexivity ]. * apply IHn in Hx. destruct Hx as (i & Hi & Hx). exists (S i). split. { apply (Nat.succ_lt_mono i n); auto. } { rewrite iter_succ in Hx. auto. } + intros (i & Hi & Hx). destruct i; simpl in Hx; auto. right. apply IHn. exists i. split. * apply Nat.succ_lt_mono; auto. * rewrite iter_succ; auto. Qed. Definition mapLazyListProof {A B : Type} (l : LazyList A) (f : forall (x : A), In_ll x l -> B) : LazyList B. Proof. induction l. - apply lnil. - apply lcons. + apply (f a). left; reflexivity. + specialize (X tt). refine (fun u => _). apply X. intros x In. apply (f x). right; auto. Defined. Definition bindLazyListPf {A B : Type} (l : LazyList A) (f : forall (x : A), In_ll x l -> LazyList B) : LazyList B := (concatLazyList (mapLazyListProof l f)). Fixpoint filter_LazyList {A} (p : A -> bool) (l : LazyList A) := match l with | lnil => lnil | lcons h t => if p h then lcons h (fun tt => filter_LazyList p (t tt)) else filter_LazyList p (t tt) end. From Coq.Logic Require Import ClassicalFacts. Axiom EM : excluded_middle. Lemma In_ll_Dec {A : Type} (* {_ : Dec_Eq A} *) (x : A) l : (LazyList.In_ll x l) \/ (~ LazyList.In_ll x l ). Proof. induction l. - right. intros Hc; inv Hc. - assert (Hem := EM (x = a)). destruct Hem. + left; eauto. left; eauto. + destruct (H tt). * left. right. eassumption. * right. intros Hc. inv Hc; eauto. Qed. Lemma lazy_concat_in' : forall {B : Type} (b : B) ll, LazyList.In_ll b (LazyList.concatLazyList ll) -> exists l, LazyList.In_ll b l /\ LazyList.In_ll l ll. Proof. intros B b ll Hbll. induction ll; simpl in *; subst; auto. - exfalso; eauto. - eapply LazyList.lazy_in_app_or in Hbll. inv Hbll; eauto. eapply H in H0. destruct H0 as [l' [Hin1 Hin2]]. eexists. split; eauto. Qed. QuickChick-2.1.0/src/LiftGenClass.v000066400000000000000000000036501476030541200170320ustar00rootroot00000000000000Require Import QuickChick. Class liftable (A B : Type) := { lift_m : A -> B }. Global Instance lift0 {A} : liftable (G A) (G A) := { lift_m := id }. Global Instance liftN {A B R} `(liftable (G B) R) : liftable (G (A -> B)) (G A -> R):= { lift_m f ga := lift_m (liftGen2 id f ga) }. Definition liftM {A B R} `{liftable (G B) R} (f : A -> B) (g : G A) : R := lift_m (fmap f g). Definition ex1 : G nat := liftM (fun x => x + 3) (returnGen 0). Definition ex2 : G nat := liftM (fun x y => x + y) (returnGen 0) (returnGen 1). Definition ex3 : G nat := liftM (fun x y z => x + y + z) (returnGen 0) (returnGen 1) (returnGen 2). (* Eval cbv -[plus] in ex1. (* = fmap (fun x : nat => x + 3) (returnGen 0) -- fair enough *) Eval cbv -[plus] in ex2. (* = liftGen2 id (fmap (fun x y : nat => x + y) (returnGen 0)) (returnGen 1) where fmap : (nat -> (nat -> nat)) -> G nat -> G (nat -> nat) liftGen2 : ((nat -> nat) -> nat -> nat) -> (G (nat -> nat)) -> G nat -> G nat *) Eval cbv -[plus] in ex3. (* = liftGen2 (fun x : nat -> nat => x) (liftGen2 (fun x : nat -> nat -> nat => x) (fmap (fun x y z : nat => x + y + z) (returnGen 0)) (returnGen 1)) (returnGen 2) *) (* this is not well typed ... wtf? *) Check (liftM (fun x y => x + y + y) (returnGen 0) (returnGen 1) (returnGen 2) : G nat). (* it's even worse ... all kinds of stuff are accepted in Check and Eval *) Eval simpl in (liftM (fun x => x + 1) (returnGen 0) 0 0 : G nat). *) (* liftM nat nat (nat -> nat -> G nat) `{liftable (G nat) (nat -> nat -> G nat)} ... -- but we don't have such an instance! We need to use definitions to get a type error Definition xxx := (liftM (fun x => x + 1) (returnGen 0) 0 0 : G nat). Toplevel input, characters 19-24: Error: Cannot infer the implicit parameter H of liftM. Could not find an instance for "liftable (G nat) (nat -> nat -> G nat)". *) QuickChick-2.1.0/src/MutateCheck.v000066400000000000000000000041661476030541200167140ustar00rootroot00000000000000Require Import QuickChick. Class Mutateable (A : Type) : Type := { mutate : A -> list A }. Require Import List. Import ListNotations. (* Default mutateable instance for lists *) (* Priority 1, in case someone overrides the default to further mutate when the A's are mutateable *) #[global] Instance MutateableList (A : Type) : Mutateable (list A) | 1 := {| mutate l := let fix f l := match l with | [] => [] | x::xs => xs :: map (fun xs' => x :: xs') (f xs) end in f l |}. Example mutate_example : mutate [1;2;3] = [[2;3];[1;3];[1;2]]. Proof. reflexivity. Qed. Require Import Coq.Strings.String. Open Scope string_scope. Definition force {X} (x : X) := x. Definition found_bug r := match r with | Failure _ _ _ _ _ _ _ _ => true | _ => false end. Definition message (kill : bool) (n1 n2 : nat) := (if kill then "Killed" else "Missed") ++ " mutant " ++ (if kill then "" else "[") ++ show n2 ++ (if kill then "" else "]") ++ " (" ++ show n1 ++ " frags)" ++ nl. Open Scope nat. Definition mutateCheckManyWith {A P : Type} {_: Checker.Checkable P} {mutA: Mutateable A} (args : Args) (a : A) (ps : A -> list P) := let mutants := mutate a in Show.trace ("Fighting " ++ show (List.length mutants) ++ " mutants") (List.fold_left (fun n m => match n with (n1,n2) => let kill := List.existsb found_bug (List.map (quickCheckWith args) (ps m)) in let n1' := n1 + (if kill then 1 else 0) in let msg := message kill n1' n2 in Show.trace msg (n1', n2 + 1) end) mutants (0, 0)). Definition mutateCheckMany {A P : Type} {_: Checkable P} `{mutA: Mutateable A} (a : A) (ps : A -> list P) := mutateCheckManyWith stdArgs a ps. Definition mutateCheckWith {A P: Type} {_: Checkable P} {mutA: Mutateable A} (args : Args) (a : A) (p : A -> P):= mutateCheckManyWith args a (fun a => cons (p a) nil). Definition mutateCheck {A P: Type} {_: Checkable P} {mutA: Mutateable A} (a : A) (p : A -> P):= mutateCheckManyWith stdArgs a (fun a => cons (p a) nil). QuickChick-2.1.0/src/Mutation.v000066400000000000000000000116361476030541200163170ustar00rootroot00000000000000From Coq Require Extraction. From Coq Require Import String. From SimpleIO Require Import SimpleIO. (* Simple mutation testing framework for Coq. A Gallina expression [a] with a mutant [b] can be written as follows: a mutant! b (* anonymous mutant *) a mutant: "bug" b (* explicitly named "bug" *) In an interactive session, those expressions both reduce to [a] (mutations are ignored). Multiple mutants [b1, ..., bn] for the same expression can be specified, either anonymous or explicitly named ([mutant!] and [mutant: name] are left-associative): a mutant! b1 mutant! ... mutant! bn a mutant: "firstbug" b1 mutant! b2 In extracted OCaml code however, those mutations can be selected via the environment variable [QC_MUTANT]. *) (* - If [QC_MUTANT] is empty, the program executes normally, without mutations. - If [QC_MUTANT=DISCOVERY], the program executes normally, but also writes identifiers for reachable mutants into a file [./qc-mutants]. - If [QC_MUTANT=(mutantid)] where [(mutantid)] is one of those identifiers, the program executes using that mutation. A typical usage is to run the program once with [DISCOVERY]: $ QC_MUTANT=DISCOVERY ./MyTestProgram Then we can test each mutant using [xargs]: $ cat qc-mutants|xargs -I {} -n 1 env QC_MUTANT={} ./MyTestProgram Mutants can also be enumerated statically by looking for the [__POS__] token in the extracted OCaml source code. The script [quickchick-expectfailure] (under [scripts/]) can be used to ensure a QuickChick test fails. $ cat qc-mutants|xargs -I {} -n 1 env quickchick-expectfailure ./MyTestProgram {} *) (* Sections Mutants can be grouped under a common section declared as a [Local Instance] of the [section] type class. Local Instance this_section : section := "ThisSection"%string. Then mutants where that instance is visible will be named as [ThisSection:mutant_name] (instead of [:mutant_name] by default). *) (* Gotchas: - Definitions should not be simplified using [Eval], since that simplifies the mutants away. - Mutants should not be nested: in [a mutant! (b mutant! c)], [c] will not be discoverable. Other issues: - [quickChickTool], being text-based, can do a richer set of mutations more conveniently: + Changing the type of an expression + Operations that can't be easily described at the granularity of expressions, for example, modifying branches of [match] or changing an infix symbol. *) (** * Implementation. *) Module Magic. Definition section_name : Type := ocaml_string. Definition mutation_id : Type := ocaml_string. Parameter loc : Type. Parameter HERE : loc. Parameter serialize_loc : section_name -> loc -> mutation_id. Parameter serialize_name_ : section_name -> ocaml_string -> mutation_id. Definition serialize_name : section_name -> string -> mutation_id := fun section name => serialize_name_ section (to_ostring name). Extract Constant loc => "string * int * int * int". Extract Inlined Constant HERE => "__POS__". Extract Constant serialize_loc => "fun section (locf,locl,locc,_) -> Printf.sprintf ""%s:%s:%d:%d"" section locf locl locc". Extract Constant serialize_name_ => "fun section name -> Printf.sprintf ""%s:%s"" section name". (* Magically extracted. *) Definition mutation : mutation_id -> bool := fun _ => false. Definition mutate : forall a, (unit -> a) -> (unit -> a) -> mutation_id -> a := fun _ f g l => if mutation l then g tt else f tt. (* [Sys.getenv_opt] also exists but only since OCaml 4.05. *) Extract Constant mutation => "match try Some (Sys.getenv ""QC_MUTANT"") with Not_found -> None with | None -> fun _ -> false | Some ""DISCOVERY"" -> let mutant_log = open_out ""qc-out/qc-mutants"" in let mutants = Hashtbl.create 10 in fun mid -> begin try ignore (Hashtbl.find mutants mid) with | Not_found -> Hashtbl.add mutants mid (); output_string mutant_log mid; output_char mutant_log '\n'; flush mutant_log end; false | Some this_mutant -> (* print_string this_mutant; *) (* Debugging *) fun mid -> mid = this_mutant". End Magic. Module Mutant. Export String. (* Section *) Class section : Type := current_section_ : string. Definition current_section `{section} : ocaml_string := to_ostring current_section_. #[global] Instance default_section : section | 9 := ""%string. End Mutant. Notation MAGIC_LOC := (Magic.serialize_loc Mutant.current_section Magic.HERE). Notation MAGIC_NAME name := (Magic.serialize_name Mutant.current_section name). Notation "a 'mutant!' b" := (Magic.mutate _ (fun _ => a) (fun _ => b) MAGIC_LOC) (at level 98, left associativity). Notation "a 'mutant:' name b" := (Magic.mutate _ (fun _ => a) (fun _ => b) (MAGIC_NAME name)) (at level 98, name at level 0, left associativity). QuickChick-2.1.0/src/Nat_util.v000066400000000000000000000027551476030541200163000ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". From mathcomp Require Import ssreflect ssrnat eqtype seq. From Coq Require Import List ZArith ssreflect ssrfun ssrbool Lia. From QuickChick Require Import Tactics. Import ListNotations. (* TODO rename this file to util.v -- not only for nats *) Lemma max_lub_l_ssr n m p: max n m < p -> n < p. Proof. move /ltP/PeanoNat.Nat.max_lub_lt_iff => [/ltP H1 _]. assumption. Qed. Lemma max_lub_r_ssr n m p: max n m < p -> m < p. Proof. move /ltP/PeanoNat.Nat.max_lub_lt_iff => [_ /ltP H1]. assumption. Qed. Lemma max_lub_ssr n m p : n < p -> m < p -> max n m < p. Proof. move => /ltP H1 /ltP H2. apply/ltP/PeanoNat.Nat.max_lub_lt; eassumption. Qed. (* TODO do implicits for the rest of the file *) Set Implicit Arguments. Unset Strict Implicit. Lemma lt0_False : forall n, ~ n < 0. Proof. firstorder. Qed. Lemma plus_leq_compat_l n m k : n <= m -> n <= m + k. Proof. intros. ssromega. Qed. Lemma plus_leq_compat_r n m k : n <= k -> n <= m + k. Proof. intros. ssromega. Qed. Lemma succ_neq_zero : forall x, S x <> 0. Proof. firstorder. Qed. Lemma isSomeSome {A : Type} (y : A) : Some y. Proof. exact isT. Qed. Lemma ltn0Sn_pair {A : Type} (n : nat) (g : A) : 0 < (n.+1, g).1. Proof. ssromega. Qed. (* Yikes this is stupid, find a workaround *) (* Leo, can you make me a real prop and a real forall in the plugin?? *) Definition prop := Prop. Definition all (A : Type) (f : A -> Prop) : Prop := forall (x : A), f x. QuickChick-2.1.0/src/Producer.v000066400000000000000000001300601476030541200162730ustar00rootroot00000000000000(* We hide the implementation of generators behind this interface. The rest of the framework and user code are agnostic to the internal representation of generators. The proof organization/abstraction tries to follow this code organization/abstraction. We need to expose quite a bit on the proof side for this to work though. *) Set Warnings "-notation-overridden,-parsing". Require Import ZArith List Lia. Require Import mathcomp.ssreflect.ssreflect. From mathcomp Require Import ssrfun ssrbool ssrnat seq eqtype. From ExtLib.Structures Require Export Functor Applicative Monads. Import MonadNotation. Open Scope monad_scope. From QuickChick Require Import Sets Tactics RandomQC. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Set Bullet Behavior "Strict Subproofs". Local Open Scope set_scope. Import ListNotations. (* Rename? *) Class Producer (G : Type -> Type) := { super : Monad G; sample : forall {A}, G A -> list A; sized : forall {A: Type}, (nat -> G A) -> G A; resize : forall {A: Type}, nat -> G A -> G A; choose : forall {A : Type} {le} `{ChoosableFromInterval A le}, (A * A) -> G A; semProdSize : forall {A : Type}, G A -> nat -> set A; semProd : forall {A : Type}, G A -> set A := fun _ g => \bigcup_size semProdSize g size; semProdSizeOpt : forall {A}, G (option A) -> nat -> set A := fun _ g s => somes (semProdSize g s); semProdOpt : forall {A}, G (option A) -> set A := fun _ g => somes (semProd g); bindPf : forall {A B : Type} (g : G A), (forall (a : A), (a \in semProd g) -> G B) -> G B; }. #[global] Existing Instance super. Arguments bindPf {G Producer A B} g. Lemma semProdOpt_equiv {A} {G} `{PG: Producer G} (g : G (option A)) : semProdOpt g <--> \bigcup_s semProdSizeOpt g s. Proof. split; move => [n [Hn H]]; exists n; split; auto. Qed. (** A generator is [Unsized] if its semantics does not depend on the runtime size *) Class Unsized {A} {G} `{Producer G} (g : G A) := unsized : forall s1 s2, semProdSize g s1 <--> semProdSize g s2. (** Sized generators monotonic in the size parameter *) Class SizedMonotonic {A} {G} `{Producer G} (g : nat -> G A) := sizeMonotonic : forall s s1 s2, (s1 <= s2)%coq_nat -> semProdSize (g s1) s \subset semProdSize (g s2) s. (** Sized generators of option type monotonic in the size parameter *) Class SizedMonotonicOpt {A} {G} `{Producer G} (g : nat -> G (option A)) := sizeMonotonicOpt : forall s s1 s2, (s1 <= s2)%coq_nat -> semProdSizeOpt (g s1) s \subset semProdSizeOpt (g s2) s. (** Generators monotonic in the runtime size parameter *) Class SizeMonotonic {A} {G} `{Producer G} (g : G A) := monotonic : forall s1 s2, (s1 <= s2)%coq_nat -> semProdSize g s1 \subset semProdSize g s2. (** Generators monotonic in the runtime size parameter *) Class SizeMonotonicOpt {A} {G} `{Producer G} (g : G (option A)) := monotonicOpt : forall s1 s2, (s1 <= s2)%coq_nat -> semProdSizeOpt g s1 \subset semProdSizeOpt g s2. (** A fixed point is reached when the producer no longer produces None *) Class SizeFP {A} {G} `{Producer G} (g : G (option A)) := sizeFP : forall s1 s2, (s1 <= s2)%coq_nat -> ~ None \in semProdSize g s1 -> semProdSize g s1 <--> semProdSize g s2. Class SizedFP {A} {G} `{Producer G} (g :nat -> G (option A)) := sizedFP : forall s s1 s2, (s1 <= s2)%coq_nat -> ~ None \in semProdSize (g s1) s -> semProdSize (g s1) s <--> semProdSize (g s2) s. Definition isNone {T : Type} (u : option T) := match u with | Some _ => false | None => true end. Class SizedAntimonotonicNone {A} {G} `{Producer G} (g : nat -> G (option A)) := monotonicNone : forall s s1 s2, (s1 <= s2)%coq_nat -> isNone :&: semProdSize (g s2) s \subset isNone :&: semProdSize (g s1) s. (** FP + SizeMon *) Class SizeMonotonicOptFP {A} {G} {H : Producer G} (g : G (option A)) := { IsMon : @SizeMonotonicOpt _ _ H g; IsFP : @SizeFP _ _ H g }. #[global] Existing Instance IsMon. #[global] Existing Instance IsFP. Class SizedMonotonicOptFP {A} {G} {H : Producer G} (g : nat -> G (option A)) := { IsMonSized : @SizedMonotonicOpt _ _ H g; IsFPSized : @SizedFP _ _ H g; IsAntimon : @SizedAntimonotonicNone _ _ _ g }. #[global] Existing Instance IsMonSized. #[global] Existing Instance IsFPSized. #[global] Existing Instance IsAntimon. #[global] Instance SizeMonotonicOptFP_FP {A} {G} (g : G (option A)) `{SizeMonotonicOptFP A G g} : SizeFP g. Proof. inv H0. eassumption. Qed. #[global] Instance SizeMonotonicOptFP_SizeMonotonic {A} {G} (g : G (option A)) `{SizeMonotonicOptFP A G g} : SizeMonotonicOpt g. Proof. inv H0. eassumption. Qed. #[global] Instance SizedMonotonicOptFP_FP {A} {G} (g : nat -> G (option A)) `{SizedMonotonicOptFP A G g} : SizedFP g. Proof. inv H0. eassumption. Qed. #[global] Instance SizedMonotonicOptFP_SizeMonotonic {A} {G} (g : nat -> G (option A)) `{SizedMonotonicOptFP A G g} : SizedMonotonicOpt g. Proof. inv H0. eassumption. Qed. #[global] Instance SizedMonotonicOptFP_Antimonotonic {A} {G} (g : nat -> G (option A)) `{SizedMonotonicOptFP A G g} : SizedAntimonotonicNone g. Proof. inv H0. eassumption. Qed. (* (* TODO: Why does Unsized need _ when A is marked as implict! *) Parameter unsized_alt_def : forall {A} {G} `{Producer G} (g : G A) `{Unsized _ _ g}, forall s, semProdSize g s <--> semProd g. *) #[global] Instance unsizedMonotonic {A} {G} `{PG :Producer G} (g : G A) `{@Unsized A G PG g} : SizeMonotonic g. Proof. intros s1 s2 Hleq. rewrite /unsized /monotonic => a H12. eapply unsized; eauto. Qed. Class ProducerSemantics G `{Producer G} := { semReturn : forall A (x : A), semProd (ret x) <--> [set x]; semReturnSize : forall A (x : A) size, semProdSize (ret x) size <--> [set x]; semBindSize : forall A B (g : G A) (f : A -> G B) (size : nat), semProdSize (bind g f) size <--> \bigcup_(a in semProdSize g size) semProdSize (f a) size; semChoose : forall A {le} `{RandomQC.ChoosableFromInterval A le} (a1 a2 : A), le a1 a2 -> (semProd (choose (a1,a2)) <--> [set a | le a1 a /\ le a a2]); semChooseSize : forall A le `{RandomQC.ChoosableFromInterval A le} (a1 a2 : A), le a1 a2 -> forall size, (semProdSize (choose (a1,a2)) size <--> [set a | le a1 a /\ le a a2]); (* semChooseSizeEmpty : *) (* forall A `{RandomQC.ChoosableFromInterval A} (a1 a2 : A), *) (* ~ (RandomQC.leq a1 a2) -> *) (* forall size, (semProdSize (choose (a1,a2)) size <--> *) (* set0); *) semSized : forall A (f : nat -> G A), semProd (sized f) <--> \bigcup_s semProdSize (f s) s; semSizedSize : forall A (f : nat -> G A) s, semProdSize (sized f) s <--> semProdSize (f s) s; semResize : forall A (n : nat) (g : G A), semProd (resize n g) <--> semProdSize g n; semResizeSize : forall A (s n : nat) (g : G A), semProdSize (resize n g) s <--> semProdSize g n; (* semBindSizeOpt : forall A B (g : G A) (f : A -> G (option B)) (size : nat), semProdSizeOpt (bind g f) size <--> \bigcup_(a in semProdSize g size) semProdSizeOpt (f a) size; *) }. (* *) (* I'm not sure how this universal quantifier will behave *) Section ProducerProofs. Variable G : Type -> Type. Context `{PG: Producer G}. Context `{PS: @ProducerSemantics G PG}. Lemma monad_leftid : forall {A B : Type} (a: A) (f : A -> G B), semProd (bind (ret a) f) <--> semProd (f a). Proof. intros. rewrite /semProd. apply eq_bigcupr => size. rewrite semBindSize semReturnSize bigcup_set1. reflexivity. Qed. Lemma monad_rightid : forall {A : Type} (g : G A), semProd (bind g ret) <--> semProd g. Proof. intros; rewrite /semProd. apply: eq_bigcupr => size; rewrite semBindSize. rewrite (eq_bigcupr _ (fun x => semReturnSize x size)). apply coverE. Qed. Lemma monad_assoc A B C (ga : G A) (fb : A -> G B) (fc : B -> G C) : semProd (bind (bind ga fb) fc) <--> semProd (bind ga (fun a => bind (fb a) fc)). Proof. apply eq_bigcupr => ?; rewrite !semBindSize ?bigcup_flatten. by apply eq_bigcupr => ?; rewrite !semBindSize ?bigcup_flatten. Qed. #[global] Instance unsizedReturn {A} (x : A) : Unsized (ret x). Proof. unfold Unsized => s1 s2. repeat rewrite semReturnSize. firstorder. Qed. #[global] Instance returnGenSizeMonotonic {A} (x : A) : SizeMonotonic (ret x). Proof. unfold Unsized => s1 s2. repeat rewrite semReturnSize. firstorder. Qed. #[global] Instance returnGenSizeMonotonicOpt {A} (x : option A) : SizeMonotonicOpt (ret x). Proof. unfold Unsized => s1 s2 Hs. unfold semProdSizeOpt. repeat rewrite semReturnSize. firstorder. Qed. #[global] Instance returnGenSizeFP {A} (x : (option A)) : SizeFP (ret x). Proof. unfold SizeFP => s1 s2 Hleq Hnin. repeat rewrite semReturnSize. reflexivity. Qed. #[global] Instance bindUnsized {A B} (g : G A) (f : A -> G B) `{@Unsized _ _ PG g} `{forall x, Unsized (f x)} : Unsized (bind g f). Proof. unfold Unsized => s1 s2. rewrite !semBindSize. rewrite (unsized s1 s2). apply eq_bigcupr => x. apply unsized. Qed. (* XXX these will always succeed and they have the same priority *) #[global] Instance bindMonotonic {A B} (g : G A) (f : A -> G B) `{@SizeMonotonic _ _ PG g} `{forall x, SizeMonotonic (f x)} : SizeMonotonic (bind g f). Proof. move => s1 s2 Hs. rewrite !semBindSize => b [a [Hsa Hsb]]. exists a; split => //; eapply monotonic; eauto. Qed. #[global] Instance bindMonotonicOpt {A B} (g : G A) (f : A -> G (option B)) `{@SizeMonotonic _ _ PG g} `{forall x, SizeMonotonicOpt (f x)} : SizeMonotonicOpt (bind g f). Proof. intros s1 s2 Hs. rewrite /semProdSizeOpt /somes. move => b /semBindSize [a [Hg Hf]]. apply semBindSize. exists a; split. - eapply monotonic; eauto. - eapply monotonicOpt; eauto. Qed. #[global] Instance bindMonotonicStrong {A B} (g : G A) (f : A -> G B) `{@SizeMonotonic _ _ PG g} `{forall x, semProd g x -> SizeMonotonic (f x)} : SizeMonotonic (bind g f). Proof. move => s1 s2 Hleq. rewrite !semBindSize => b [a [H3 H4]]. exists a; split => //. - now eapply monotonic; eauto. - eapply H0; eauto. eexists. split; eauto. now constructor. Qed. #[global] Instance bindMonotonicOptStrong {A B} (g : G A) (f : A -> G (option B)) `{@SizeMonotonic _ _ PG g} `{forall x, semProd g x -> SizeMonotonicOpt (f x)} : SizeMonotonicOpt (bind g f). Proof. move => s1 s2 Hleq. rewrite /semProdSizeOpt !semBindSize /somes; move => b [a [H3 H4]]. exists a; split => //. - eapply monotonic; eauto. - eapply H0; eauto. exists s1; split; rewrite /setT; eauto. Qed. Lemma unsized_alt_def : forall A (g : G A) `{@Unsized _ _ PG g}, forall s, semProdSize g s <--> semProd g. Proof. move => A f H s a. split. move => H'. exists s. split; auto => //. move => [s' [_ H']]. eapply unsized; eauto. Qed. Lemma semBindUnsized1 {A B} (g : G A) (f : A -> G B) `{H : @Unsized _ _ PG g} : semProd (bind g f) <--> \bigcup_(a in semProd g) semProd (f a). Proof. rewrite /semProd. setoid_rewrite semBindSize. setoid_rewrite (@unsized_alt_def A g H). move => b. split. - intros [s [_ [a [H1 H2]]]]. exists a. split; exists s; split; by []. - intros [a [[s1 [_ H1]] [s2 [_ H2]]]]. exists s2. split; first by []. exists a. split; by []. Qed. Lemma semBindUnsized2 : forall A B (g : G A) (f : A -> G B), (forall a, Unsized (f a)) -> semProd (bind g f) <--> \bigcup_(a in semProd g) semProd (f a). Proof. move=> A B g f H. rewrite /semProd. setoid_rewrite semBindSize. intro b. split. - intros [s [_ [a [H1 H2]]]]. exists a. split; exists s; split => //. - intros [a [[s1 [_ H1]] [s2 [_ H2]]]]. exists s1. split; first by []. exists a. split; first by []; apply unsized_alt_def; eauto. by eapply unsized_alt_def; eauto. Qed. Lemma semBindSizeMonotonic {A B} (g : G A) (f : A -> G B) `{Hg : @SizeMonotonic _ _ PG g} `{Hf : forall a, SizeMonotonic (f a)} : semProd (bind g f) <--> \bigcup_(a in semProd g) semProd (f a). (* end semBindSizeMonotonic *) Proof. rewrite /semProd. setoid_rewrite semBindSize. intro b. split. - intros [s [_ [a [H1 H2]]]]. exists a. split; exists s; (split; first (compute; by []); first by[]). - intros [a [[s1 [_ H1]] [s2 [_ H2]]]]. exists (max s1 s2). split; first (compute; by []). exists a. split. eapply Hg; last eassumption. lia. eapply Hf; last eassumption. lia. Qed. Lemma semBindSizeMonotonicIncl_r {A B} (g : G A) (f : A -> G (option B)) (s1 : set A) (s2 : A -> set B) : semProd g \subset s1 -> (forall x, semProd (f x) \subset Some @: (s2 x) :|: [set None]) -> semProd (bind g f) \subset Some @: (\bigcup_(a in s1) s2 a) :|: [set None]. Proof. move => H1 H2 [x |] [s [_ /semBindSize [r [Hg Hf]]]]. - left. eexists; split. exists r; split; eauto. + apply H1. exists s; split; rewrite /setT; auto. + destruct (H2 r (Some x)). rewrite /semProd /setT. exists s; split; auto. * move : H => [b [Hb Heq]]. inversion Heq; subst; clear Heq. eauto. * inversion H. + unfold set1; auto. - right; reflexivity. Qed. Lemma semBindSizeMonotonicIncl_l {A B} (g : G A) (f : A -> G (option B)) (s1 : set A) (fs : A -> set B) `{Hg : @SizeMonotonic _ _ PG g} `{Hf : forall a, SizeMonotonicOpt (f a)} : s1 \subset semProd g -> (forall x, Some @: (fs x) \subset semProd (f x)) -> (Some @: \bigcup_(a in s1) (fs a)) \subset semProd (bind g f). Proof. move => H1 H2 y [y' [[x [Hs1 Hfs2]] Heq]]; inversion Heq; subst; clear Heq. eapply H1 in Hs1. assert (Hin2 : (Some @: fs x) (Some y')). { eexists; split; eauto. now constructor. } eapply H2 in Hin2. unfold SizeMonotonic in Hg. edestruct Hs1 as [s [_ Hgen]]. edestruct Hin2 as [s' [_ Hfgen]]. assert (Hin2' : ((fun u : option B => u) :&: semProdSize (f x) s') (Some y')). { split; eauto. } apply Hg with (s2 := s + s') in Hgen; [| now ssromega]. rewrite /semProd. exists (s + s'); split; unfold setT; auto. apply semBindSize. exists x; split; auto. apply monotonicOpt with (s1 := s'); eauto; try ssromega. Qed. Lemma semBindSize_subset_compat {A B : Type} (g g' : G A) (f f' : A -> G B) : (forall s, semProdSize g s \subset semProdSize g' s) -> (forall x s, semProdSize (f x) s \subset semProdSize (f' x) s) -> (forall s, semProdSize (bind g f) s \subset semProdSize (bind g' f') s). Proof. intros Hs1 Hs2 s. rewrite !semBindSize. specialize (Hs1 s). eapply incl_bigcup_compat; eauto. Qed. (* semBindSizeOpt_subset_compat : *) (* forall {A B : Type} (g g' : G A) (f f' : A -> G (option B)), *) (* (forall s, semProdSize g s \subset semProdSize g' s) -> *) (* (forall x s, isSome :&: semProdSize (f x) s \subset isSome :&: semProdSize (f' x) s) -> *) (* (forall s, isSome :&: semProdSize (bind g f) s \subset isSome :&: semProdSize (bind g' f') s); *) Lemma semBindRetFSize : forall (A B : Type) (f : A -> B) (g : G A) (size : nat), semProdSize (x <- g;; ret (f x)) size <--> f @: semProdSize g size. Proof. move => A B f g size b; split. - move => /semBindSize [a [Ha Hfa]]. rewrite /imset. exists a; split; eauto. apply semReturnSize in Hfa. inversion Hfa; subst; clear Hfa. unfold set1; auto. - move => [a [Hb Heq]]; inv Heq; clear Heq. apply semBindSize; exists a; split; auto. apply semReturnSize; unfold set1; auto. Qed. Lemma semBindRetF : forall (A B : Type) (f : A -> B) (g : G A), semProd (x <- g;; ret (f x)) <--> f @: semProd g. Proof. rewrite /semProd. move => A B f g b; split. - move => [size [_ /semBindRetFSize [a [Ha Heq]]]]; inv Heq; clear Heq. exists a; split; unfold set1; auto. exists size; split; unfold setT; auto. - move => [a [[size [_ H]] Heq]]; inv Heq; clear Heq. exists size; split; unfold setT; auto. apply semBindRetFSize. exists a; split; unfold set1; auto. Qed. (* Needs decidability to be agnostic of impl *) (* Instance chooseUnsized A `{RandomQC.ChoosableFromInterval A} (a1 a2 : A) : Unsized (choose (a1, a2)). Proof. unfold Unsized => s1 s2. split => /semChooseSize C. apply semChooseSize. *) Lemma semFmap : forall A B (f : A -> B) (g : G A), semProd (fmap f g) <--> f @: semProd g. Proof. rewrite /fmap /Functor_Monad /liftM. apply semBindRetF. Qed. Lemma semFmapSize : forall A B (f : A -> B) (g : G A) (size : nat), semProdSize (fmap f g) size <--> f @: semProdSize g size. Proof. rewrite /fmap /Functor_Monad /liftM. apply semBindRetFSize. Qed. #[global] Instance fmapUnsized {A B} (f : A -> B) (g : G A) `{@Unsized _ _ PG g} : Unsized (fmap f g). Proof. move => s1 s2; rewrite !semFmapSize => b. by split; move => [a [H1 <-]]; eexists; split; eauto => //; eapply unsized; eauto. Qed. #[global] Instance fmapMonotonic {A B} (f : A -> B) (g : G A) `{@SizeMonotonic _ _ PG g} : SizeMonotonic (fmap f g). Proof. intros s1 s2 Hs. rewrite !semFmapSize. move => b. move => [a [H1 <-]]; eexists; split; eauto => //; eapply monotonic; eauto. Qed. Lemma semSized_alt A (f : nat -> G A) `{H : forall n, SizeMonotonic (f n)} (H' : forall n m s, (n <= m)%coq_nat -> semProdSize (f n) s \subset semProdSize (f m) s) : semProd (sized f) <--> \bigcup_n (semProd (f n)). Proof. rewrite semSized. move => x; split. - move => [n [HT Hs]]. eexists. split; eauto. eexists; eauto. - move => [n [HT [m [_ Hs]]]]. eapply semSized. eexists (m + n). split; [ constructor |]. apply semSizedSize. eapply (H' n). ssromega. eapply (H n); try eassumption. ssromega. Qed. Lemma semSized_opt A (f : nat -> G (option A)) `{H : forall n, SizeMonotonicOpt (f n)} `{H' : @SizedMonotonicOpt _ _ PG f} : isSome :&: semProd (sized f) <--> isSome :&: \bigcup_n (semProd (f n)). Proof. rewrite semSized. rewrite !setI_bigcup_assoc. move => x; split. - move => [n [HT [Hs1 Hs2]]]. eexists. split; eauto. split; eauto. eexists; eauto. - move => [n [HT [Hs1 [m [HT' Hs2]]]]]. eexists (m + n). split. now constructor. split; [ eassumption | ]. destruct x as [ x | ]. + eapply monotonicOpt with (s2 := m + n) in Hs2; [| now ssromega ]. eapply sizeMonotonicOpt with (s1 := n) (s2 := m + n); [now ssromega |]. auto. + inv Hs1. Qed. #[global] Instance sizedSizeMonotonic A (gen : nat -> G A) `{forall n, SizeMonotonic (gen n)} `{@SizedMonotonic _ _ PG gen} : SizeMonotonic (sized gen). Proof. move => s1 s2 Hleq a /semSizedSize H1. eapply semSizedSize. eapply H. eassumption. eapply H0; eassumption. Qed. #[global] Instance sizedSizeMonotonicOpt A (gen : nat -> G (option A)) `{forall n, SizeMonotonicOpt (gen n)} `{@SizedMonotonicOpt _ _ PG gen} : SizeMonotonicOpt (sized gen). Proof. move => s1 s2 Hleq a H1. eapply semSizedSize. eapply H. eassumption. eapply sizeMonotonicOpt; eauto. unfold semProdSizeOpt in *; unfold somes in *. apply semSizedSize in H1. auto. Qed. #[global] Instance sizedSizeFP A (gen : nat -> G (option A)) `{forall n, SizeFP (gen n)} `{@SizedFP _ _ PG gen} `{@SizedAntimonotonicNone _ _ _ gen} : SizeFP (sized gen). Proof. move => s1 s2 Hleq Hn. rewrite !semSizedSize. rewrite H0; [ | eassumption | ]. 2:{ intros Hc. eapply Hn. eapply semSizedSize. eassumption. } rewrite H; [ | eassumption | ]. reflexivity. intros Hc. eapply Hn. eapply semSizedSize. assert (Hnone : None \in isNone :&: semProdSize (gen s2) s1). { split; eauto. } eapply H1 in Hnone; [| eassumption ]. inv Hnone. eassumption. Qed. #[global] Instance unsizedResize {A} (g : G A) n : Unsized (resize n g). Proof. move => s1 s2. rewrite !semResizeSize. split; auto. Qed. End ProducerProofs. Section ProducerHigh. Context {G : Type -> Type}. Context `{PG: Producer G}. Definition vectorOf {A : Type} (k : nat) (g : G A) : G (list A) := foldr (fun m m' => bind m (fun x => bind m' (fun xs => ret (cons x xs))) ) (ret nil) (nseq k g). Definition listOf {A : Type} (g : G A) : G (list A) := sized (fun n => bind (choose (0, n)) (fun k => vectorOf k g)). Definition oneOf_ {A : Type} (def: G A) (gs : list (G A)) : G A := bind (choose (0, length gs - 1)) (nth def gs). Definition elems_ {A : Type} (def : A) (l : list A) := let n := length l in bind (choose (0, n - 1)) (fun n' => ret (List.nth n' l def)). Definition liftProd4 {A1 A2 A3 A4 R} (F : A1 -> A2 -> A3 -> A4 -> R) (m1 : G A1) (m2 : G A2) (m3 : G A3) (m4: G A4) : G R := x1 <- m1;; x2 <- m2;; x3 <- m3;; x4 <- m4;; ret (F x1 x2 x3 x4). Definition liftProd5 {A1 A2 A3 A4 A5 R} (F : A1 -> A2 -> A3 -> A4 -> A5 -> R) (m1 : G A1) (m2 : G A2) (m3 : G A3) (m4: G A4) (m5 : G A5) : G R := x1 <- m1;; x2 <- m2;; x3 <- m3;; x4 <- m4;; x5 <- m5;; ret (F x1 x2 x3 x4 x5). Definition sequenceProd {A : Type} (ms : list (G A)) : G (list A) := foldr (fun m m' => x <- m;; xs <- m';; ret (x :: xs)) (ret nil) ms. Fixpoint foldProd {A B : Type} (f : A -> B -> G A) (l : list B) (a : A) : G A := match l with | nil => ret a | (x :: xs) => bind (f a x) (foldProd f xs) end. Definition bindOpt {A B} (g : G (option A)) (f : A -> G (option B)) : G (option B) := bind g (fun ma => match ma with | None => ret None | Some a => f a end). End ProducerHigh. Module BindOptNotation. Notation "x <-- c1 ;; c2" := (@bindOpt _ _ _ _ c1 (fun x => c2)) (at level 61, c1 at next level, right associativity) : monad_scope. End BindOptNotation. Section ProducerHighProofs. Variable G : Type -> Type. Context `{PG: Producer G}. Context `{PS: @ProducerSemantics G PG}. (* * Semantics *) Lemma semLiftGen {A B} (f: A -> B) (g: G A) : semProd (liftM f g) <--> f @: semProd g. Proof. rewrite imset_bigcup. apply: eq_bigcupr => size. by rewrite semBindSize (eq_bigcupr _ (fun a => semReturnSize (f a) size)). Qed. Ltac solveLiftProdX := intros; split; intros; repeat match goal with | [ H : exists _, _ |- _ ] => destruct H as [? [? ?]] | [ H : semProdSize _ _ _ |- _ ] => try (apply semBindSize in H; destruct H as [? [? ?]]); try (apply semReturnSize in H; subst) end; [ by repeat (eexists; split; [eassumption |]) | repeat (apply semBindSize; eexists; split; try eassumption); by apply semReturnSize ]. Lemma semLiftProdSize {A B} (f: A -> B) (g: G A) size : semProdSize (liftM f g) size <--> f @: (semProdSize g size). Proof. by rewrite semBindSize (eq_bigcupr _ (fun a => semReturnSize (f a) size)). Qed. Program Instance liftProdUnsized {A B} (f : A -> B) (g : G A) `{@Unsized _ _ PG g} : Unsized (liftM f g). Next Obligation. by rewrite ! semLiftProdSize (unsized s1 s2). Qed. Program Instance liftProdMonotonic {A B} (f : A -> B) (g : G A) `{@SizeMonotonic _ _ PG g} : SizeMonotonic (liftM f g). Next Obligation. rewrite ! semLiftProdSize. apply imset_incl. by apply monotonic. Qed. Lemma semLiftProd2Size {A1 A2 B} (f: A1 -> A2 -> B) (g1 : G A1) (g2 : G A2) s : semProdSize (liftM2 f g1 g2) s <--> f @2: (semProdSize g1 s, semProdSize g2 s). Proof. rewrite semBindSize curry_imset2l; apply: eq_bigcupr => x. by rewrite semBindSize; apply: eq_bigcupr => y; rewrite semReturnSize. Qed. Lemma semLiftProd2SizeMonotonic {A1 A2 B} (f: A1 -> A2 -> B) (g1 : G A1) (g2 : G A2) `{@SizeMonotonic _ _ PG g1} `{@SizeMonotonic _ _ PG g2} : semProd (liftM2 f g1 g2) <--> f @2: (semProd g1, semProd g2). Proof. rewrite /semProd. setoid_rewrite semLiftProd2Size. move => b. split. - move => [sb [_ Hb]]. (* point-free reasoning would be nice here *) destruct Hb as [a [[Hb11 Hb12] Hb2]]. exists a. split; [| by apply Hb2]. split; eexists; by split; [| eassumption]. - move => [[a1 a2] [[[s1 [_ G1]] [s2 [_ G2]]] Hf]]. compute in Hf. exists (max s1 s2). split; first by []. exists (a1,a2). split; last by []. split => /=; (eapply monotonic; last eassumption). lia. lia. Qed. Lemma semLiftProd2Unsized1 {A1 A2 B} (f: A1 -> A2 -> B) (g1 : G A1) (g2 : G A2) `{@Unsized _ _ PG g1}: semProd (liftM2 f g1 g2) <--> f @2: (semProd g1, semProd g2). Proof. rewrite /semProd. setoid_rewrite semLiftProd2Size. move=> b. split. - move => [n [_ [[a1 a2] [[/= H2 H3] H4]]]]. exists (a1, a2). split; auto; split; eexists; split; eauto; reflexivity. - move => [[a1 a2] [[[s1 /= [H2 H2']] [s2 [H3 H3']]] H4]]. eexists. split; first by eauto. exists (a1, a2); split; eauto. split; last by eauto. simpl. eapply unsized; eauto; apply (unsized2 H); eauto. Qed. Lemma semLiftProd2Unsized2 {A1 A2 B} (f: A1 -> A2 -> B) (g1 : G A1) (g2 : G A2) `{@Unsized _ _ PG g2}: semProd (liftM2 f g1 g2) <--> f @2: (semProd g1, semProd g2). Proof. rewrite /semProd. setoid_rewrite semLiftProd2Size. move=> b. split. - move => [n [_ [[a1 a2] [[/= H2 H3] H4]]]]. exists (a1, a2). split; auto; split; eexists; split; eauto; reflexivity. - move => [[a1 a2] [[[s1 /= [H2 H2']] [s2 [H3 H3']]] H4]]. eexists. split; first by auto. exists (a1, a2). split; eauto. split; first by eauto. simpl. eapply unsized; eauto. Qed. Lemma semLiftProd3Size : forall {A1 A2 A3 B} (f: A1 -> A2 -> A3 -> B) (g1: G A1) (g2: G A2) (g3: G A3) size, semProdSize (liftM3 f g1 g2 g3) size <--> fun b => exists a1, semProdSize g1 size a1 /\ (exists a2, semProdSize g2 size a2 /\ (exists a3, semProdSize g3 size a3 /\ (f a1 a2 a3) = b)). Proof. solveLiftProdX. Qed. #[global] Program Instance liftM2Unsized {A1 A2 B} (f : A1 -> A2 -> B) (g1 : G A1) `{@Unsized _ _ PG g1} (g2 : G A2) `{@Unsized _ _ PG g2} : Unsized (liftM2 f g1 g2). Next Obligation. rewrite ! semLiftProd2Size. rewrite ! curry_imset2l. by setoid_rewrite (unsized s1 s2). Qed. #[global] Program Instance liftM2Monotonic {A1 A2 B} (f : A1 -> A2 -> B) (g1 : G A1) `{@SizeMonotonic _ _ PG g1} (g2 : G A2) `{@SizeMonotonic _ _ PG g2} : SizeMonotonic (liftM2 f g1 g2). Next Obligation. rewrite ! semLiftProd2Size. rewrite ! curry_imset2l. move => b [a1 [Ha1 [a2 [Ha2 <-]]]]. do 2 (eexists; split; first by eapply (monotonic H1); eauto). reflexivity. Qed. (* CH: Made this more beautiful than the rest *) (* CH: Should anyway use dependent types for a generic liftMN *) Lemma semLiftProd4Size A1 A2 A3 A4 B (f : A1 -> A2 -> A3 -> A4 -> B) (g1 : G A1) (g2 : G A2) (g3 : G A3) (g4 : G A4) s : semProdSize (liftProd4 f g1 g2 g3 g4) s <--> [set b : B | exists a1 a2 a3 a4, semProdSize g1 s a1 /\ semProdSize g2 s a2 /\ semProdSize g3 s a3 /\ semProdSize g4 s a4 /\ f a1 a2 a3 a4 = b]. Proof. split; unfold liftProd4; intros. - repeat match goal with | [ H : semProdSize _ _ _ |- _ ] => try (apply semBindSize in H; destruct H as [? [? ?]]); try (apply semReturnSize in H; subst) end. do 4 eexists. repeat (split; [eassumption|]). assumption. - repeat match goal with | [ H : exists _, _ |- _ ] => destruct H as [? [? ?]] | [ H : and _ _ |- _ ] => destruct H as [? ?] end. repeat (apply semBindSize; eexists; split; [eassumption|]). apply semReturnSize. assumption. Qed. (* begin semLiftProd4SizeMonotonic *) Lemma semLiftProd4SizeMonotonic A1 A2 A3 A4 B (f : A1 -> A2 -> A3 -> A4 -> B) (g1 : G A1) (g2 : G A2) (g3 : G A3) (g4 : G A4) `{@SizeMonotonic _ _ PG g1} `{@SizeMonotonic _ _ PG g2} `{@SizeMonotonic _ _ PG g3} `{@SizeMonotonic _ _ PG g4} : semProd (liftProd4 f g1 g2 g3 g4) <--> [set b : B | exists a1 a2 a3 a4, semProd g1 a1 /\ semProd g2 a2 /\ semProd g3 a3 /\ semProd g4 a4 /\ f a1 a2 a3 a4 = b]. (* end semLiftProd4SizeMonotonic *) Proof. rewrite /semProd. setoid_rewrite semLiftProd4Size. move => b. split. - move => [s [_ [a1 [a2 [a3 [a4 [Ha1 [Ha2 [Ha3 [Ha4 Hb]]]]]]]]]]; subst. exists a1. exists a2. exists a3. exists a4. repeat split; exists s; (split; [reflexivity | eassumption ]). - move => [a1 [a2 [a3 [a4 [[s1 [_ Ha1]] [[s2 [_ Ha2]] [[s3 [_ Ha3]] [[s4 [_ Ha4]] Hb]]]]]]]]; subst. exists (max s1 (max s2 (max s3 s4))). split; first by []. exists a1. exists a2. exists a3. exists a4. repeat split; (eapply monotonic; last eassumption); lia. Qed. #[global] Program Instance liftM4Monotonic {A B C D E} (f : A -> B -> C -> D -> E) (g1 : G A) (g2 : G B) (g3 : G C) (g4 : G D) `{ @SizeMonotonic _ _ PG g1} `{ @SizeMonotonic _ _ PG g2} `{ @SizeMonotonic _ _ PG g3} `{ @SizeMonotonic _ _ PG g4} : SizeMonotonic (liftProd4 f g1 g2 g3 g4). Next Obligation. rewrite ! semLiftProd4Size. move => t /= [a1 [a2 [a3 [a4 [Ha1 [Ha2 [Ha3 [Ha4 H5]]]]]]]]; subst. eexists. eexists. eexists. eexists. repeat (split; try reflexivity); by eapply monotonic; eauto. Qed. Lemma semLiftProd5Size : forall {A1 A2 A3 A4 A5 B} (f: A1 -> A2 -> A3 -> A4 -> A5 -> B) (g1: G A1) (g2: G A2) (g3: G A3) (g4: G A4) (g5: G A5) size, semProdSize (liftProd5 f g1 g2 g3 g4 g5) size <--> fun b => exists a1, semProdSize g1 size a1 /\ (exists a2, semProdSize g2 size a2 /\ (exists a3, semProdSize g3 size a3 /\ (exists a4, semProdSize g4 size a4 /\ (exists a5, semProdSize g5 size a5 /\ (f a1 a2 a3 a4 a5) = b)))). Proof. solveLiftProdX. Qed. Lemma Forall2_cons T U (P : T -> U -> Prop) x1 s1 x2 s2 : List.Forall2 P (x1 :: s1) (x2 :: s2) <-> P x1 x2 /\ List.Forall2 P s1 s2. Proof. split=> [H|[? ?]]; last by constructor. by inversion H. Qed. Lemma semSequenceProdSize A (gs : list (G A)) n : semProdSize (sequenceProd gs) n <--> [set l | length l = length gs /\ List.Forall2 (fun y => semProdSize y n) gs l]. Proof. elim: gs => [|g gs IHgs]. by rewrite semReturnSize /set1; case=> // a l; split=> // [[]]. rewrite /= semBindSize; setoid_rewrite semBindSize; setoid_rewrite semReturnSize. setoid_rewrite IHgs; case=> [| x l]. split; first by case=> ? [? [? [?]]]. by move=> H; inversion H. rewrite Forall2_cons; split; first by case=> y [gen_y [s [[<- ?]]]] [<- <-]. by case=> [[<-] [? ?]]; exists x; split => //; exists l; split. Qed. Lemma Forall2_SizeMonotonic {A} x n (gs : list (G A)) l : (x <= n)%coq_nat -> gs \subset SizeMonotonic -> List.Forall2 (semProdSize^~ x) gs l -> List.Forall2 (semProdSize^~ n) gs l. Proof. intros. induction H1; auto. apply subconsset in H0. destruct H0; auto. constructor; auto. eapply H0; eauto. Qed. Lemma semSequenceProdSizeMonotonic A (gs : list (G A)) : (gs \subset SizeMonotonic) -> semProd (sequenceProd gs) <--> [set l | length l = length gs /\ List.Forall2 semProd gs l]. Proof. intros. rewrite /semProd. setoid_rewrite semSequenceProdSize. move => l. split. - move => [n [ _ [H1 H2]]]. split; auto. induction H2; subst; simpl; constructor. + exists n. split; auto. reflexivity. + apply IHForall2; eauto. apply subconsset in H. destruct H; auto. - move => [H1 H2]. revert gs H H1 H2. induction l; intros gs H H1 H2. + destruct gs; try discriminate. exists 0. split; auto. reflexivity. + destruct gs; try discriminate. apply subconsset in H. move : H => [H3 H4]. inversion H2; subst. destruct H6 as [n [ _ H5]]. eapply IHl in H8; auto. destruct H8 as [x [_ [H7 H8]]]. destruct (le_dec x n) eqn:Hle. { exists n. split; eauto; first by reflexivity. split; auto. constructor; auto. eapply Forall2_SizeMonotonic; eauto. } { exists x. split; first by reflexivity. split; auto. constructor; auto. eapply H3; last by eassumption. lia. } Qed. Lemma semVectorOfSize {A : Type} (k : nat) (g : G A) n : semProdSize (vectorOf k g) n <--> [set l | length l = k /\ l \subset (semProdSize g n)]. Proof. elim: k => [|k IHk]. rewrite /vectorOf /= semReturnSize. by move=> s; split=> [<-|[] /size0nil ->] //; split. rewrite /vectorOf /= semBindSize; setoid_rewrite semBindSize. setoid_rewrite semReturnSize; setoid_rewrite IHk. case=> [|x l]; first by split=> [[? [? [? [?]]]] | []]. split=> [[y [gen_y [l' [[length_l' ?] [<- <-]]]]]|] /=. split; first by rewrite length_l'. exact/subconsset. by case=> [[?]] /subconsset [? ?]; exists x; split => //; exists l. Qed. Lemma semVectorOfUnsized {A} (g : G A) (k : nat) `{@Unsized _ _ PG g}: semProd (vectorOf k g) <--> [set l | length l = k /\ l \subset semProd g ]. Proof. rewrite /semProd. setoid_rewrite semVectorOfSize. move => l; split. - move => [k' [_ [H1 H2]]]. split; auto. exists k'. split; auto. reflexivity. - move => [H1 H2]. exists k. split; first by reflexivity. split; auto. move => a /H2 [x [_ Hx]]. by eapply unsized; eauto. Qed. #[global] Program Instance vectorOfUnsized {A} (k : nat) (g : G A) `{@Unsized _ _ PG g } : Unsized (vectorOf k g). Next Obligation. rewrite ! semVectorOfSize. split; move => [H1 H2]; split => //; by rewrite unsized; eauto. Qed. #[global] Program Instance vectorOfMonotonic {A} (k : nat) (g : G A) `{@SizeMonotonic _ _ PG g } : SizeMonotonic (vectorOf k g). Next Obligation. rewrite ! semVectorOfSize. move => l [H1 H2]; split => // a Ha. by eapply (monotonic H0); eauto. Qed. Lemma lele_coq_ssr i j k : (i <= j /\ j <= k)%coq_nat <-> (i <= j) && (j <= k). Proof. split. - move => [/leP Hij /leP Hjk]. by apply /andP. - move /andP => [/leP Hij /leP Hjk]. done. Qed. Lemma semChooseNat (a1 a2 : nat) : a1 <= a2 -> (semProd (choose (a1,a2)) <--> [set a | a1 <= a <= a2]). Proof. move => /leP H. rewrite (semChoose (A := nat) (H0 := ChooseNat) H). intros a. apply lele_coq_ssr. Qed. Lemma semChooseSizeNat (a1 a2 : nat) : a1 <= a2 -> forall size, (semProdSize (choose (a1,a2)) size <--> [set a | a1 <= a <= a2]). Proof. move => /leP H size. rewrite (semChooseSize (H0 := ChooseNat) H). intros a. apply lele_coq_ssr. Qed. Lemma semListOfSize {A : Type} (g : G A) size : semProdSize (listOf g) size <--> [set l | length l <= size /\ l \subset (semProdSize g size)]. Proof. rewrite /listOf semSizedSize semBindSize; setoid_rewrite semVectorOfSize. assert (Hsiz : Nat.le 0 size) by lia. rewrite semChooseSizeNat // => l; split=> [[n [/andP [? ?] [-> ?]]]| [? ?]] //. by exists (length l). Qed. Lemma semListOfUnsized {A} (g : G A) (k : nat) `{@Unsized _ _ PG g} : semProd (listOf g) <--> [set l | l \subset semProd g ]. Proof. rewrite /semProd. setoid_rewrite semListOfSize. move => l; split. - move => [k' [_ [H1 H2]]]. exists k'. split; auto. reflexivity. - move => Hl. exists (length l). repeat split => //. move => a /Hl [s [_ Ha]]. by eapply unsized; eauto. Qed. #[global] Program Instance listOfMonotonic {A} (g : G A) `{@SizeMonotonic _ _ PG g } : SizeMonotonic (listOf g). Next Obligation. rewrite ! semListOfSize. move => l [/leP H1 H2]; split => //. destruct (@leP (length l) s2); eauto. exfalso. eapply n. lia. move => a /H2 Ha. by eapply monotonic; eauto. Qed. Lemma In_nth_exists {A} (l: list A) x def : List.In x l -> exists n, nth def l n = x /\ (n < length l)%coq_nat. Proof. elim : l => [| a l IHl] //=. move => [H | /IHl [n [H1 H2]]]; subst. exists 0; split => //; lia. exists n.+1; split => //; lia. Qed. Lemma nthE T (def : T) s i : List.nth i s def = nth def s i. Proof. elim: s i => [|x s IHs i]; first by case. by case: i. Qed. Lemma nth_imset T (def : T) l : nth def l @: [set n | n < length l] <--> l. Proof. case: l => [|x l] t; first by split=> //; case=> ?; rewrite ltn0; case. split; first by case=> n [? <-]; rewrite -nthE; apply/List.nth_In/ltP. by case/(In_nth_exists def) => n [? ?]; exists n; split=> //; apply/ltP. Qed. Lemma semOneofSize {A} (l : list (G A)) (def : G A) s : semProdSize (oneOf_ def l) s <--> if l is nil then semProdSize def s else \bigcup_(x in l) semProdSize x s. Proof. case: l => [|g l]. - rewrite semBindSize semChooseSizeNat //. rewrite (eq_bigcupl [set 0]) ?bigcup_set1 // => a; split=> [/andP [? w]|<-] //. change (length [] - 1) with 0 in w. rewrite leqn0 in w. by move: w => /eqP. - rewrite semBindSize semChooseSizeNat //. set X := (fun a : nat => is_true (_ && _)). by rewrite (reindex_bigcup (nth def (g :: l)) X) // /X subn1 nth_imset. Qed. Lemma semOneof {A} (l : list (G A)) (def : G A) : semProd (oneOf_ def l) <--> if l is nil then semProd def else \bigcup_(x in l) semProd x. Proof. by case: l => [|g l]; rewrite 1?bigcupC; apply: eq_bigcupr => sz; apply: semOneofSize. Qed. #[global] Program Instance oneofMonotonic {A} (x : G A) (l : list (G A)) `{ @SizeMonotonic _ _ PG x} `(l \subset SizeMonotonic) : SizeMonotonic (oneOf_ x l). Next Obligation. rewrite !semOneofSize. elim : l H0 => [_ | g gs IH /subconsset [H2 H3]] /=. - by apply monotonic. - specialize (IH H3). move => a [ga [[Hga | Hga] Hgen]]; subst. exists ga. split => //. left => //. eapply monotonic; eauto. exists ga. split. right => //. apply H3 in Hga. by apply (monotonic H1). Qed. Lemma semElementsSize {A} (l: list A) (def : A) s : semProdSize (elems_ def l) s <--> if l is nil then [set def] else l. Proof. rewrite semBindSize. setoid_rewrite semReturnSize. rewrite semChooseSizeNat //=. setoid_rewrite nthE. (* SLOW *) case: l => [|x l] /=. rewrite (eq_bigcupl [set 0]) ?bigcup_set1 // => n. by rewrite leqn0; split=> [/eqP|->]. rewrite -(@reindex_bigcup _ _ _ (nth def (x :: l)) _ (x :: l)) ?coverE //. by rewrite subn1 /= nth_imset. Qed. Lemma semElements {A} (l: list A) (def : A) : (semProd (elems_ def l)) <--> if l is nil then [set def] else l. Proof. rewrite /semProd; setoid_rewrite semElementsSize; rewrite bigcup_const //. by do 2! constructor. Qed. #[global] Program Instance elementsUnsized {A} {def : A} (l : list A) : Unsized (elems_ def l). Next Obligation. rewrite ! semElementsSize. by case: l. Qed. #[global] Instance bindOptMonotonic {A B} (g : G (option A)) (f : A -> G (option B)) {_ : SizeMonotonic g} `{forall x, SizeMonotonic (f x)} : SizeMonotonic (bindOpt g f). Proof. intros s1 s2 Hleq. intros x Hx. unfold bindOpt in *. eapply (@semBindSize G _ _) in Hx. eapply (@semBindSize G _ _). destruct Hx. destruct H1. eexists. split. now eapply H0; eauto. destruct x0; eauto. eapply H; eauto. eapply semReturnSize. eapply semReturnSize in H2. eassumption. Qed. Lemma semReturnSizeOpt (A : Type) (x : A) (size : nat) : semProdSizeOpt (ret (Some x)) size <--> [set x]. Proof. intros x1; simpl; split; intros Hin. - unfold semProdSizeOpt, somes in *. eapply semReturnSize in Hin. inv Hin. reflexivity. - unfold semProdSizeOpt, somes in *. eapply semReturnSize. inv Hin. reflexivity. Qed. Lemma semReturnSizeOpt_None (A : Type) (size : nat) : semProdSizeOpt (ret None) size <--> @set0 A. Proof. intros x1; simpl; split; intros Hin. - unfold semProdOpt, somes in *. eapply semReturnSize in Hin. inv Hin. - inv Hin. Qed. Lemma semReturnOpt (A : Type) (x : A) : semProdOpt (ret (Some x)) <--> [set x]. Proof. intros x1; simpl; split; intros Hin. - unfold semProdOpt, somes in *. eapply semReturn in Hin. inv Hin. reflexivity. - unfold semProdOpt, somes in *. eapply semReturn. inv Hin. reflexivity. Qed. Lemma semReturnOpt_None (A : Type) : semProdOpt (ret None) <--> @set0 A. Proof. intros x1; simpl; split; intros Hin. - unfold semProdOpt, somes in *. eapply semReturn in Hin. inv Hin. - inv Hin. Qed. Lemma semOptBind A B (g : G A) (f : A -> G (option B)) : SizeMonotonic g -> (forall a : A, SizeMonotonicOpt (f a)) -> semProdOpt (bind g f) <--> \bigcup_(a in semProd g) semProdOpt (f a). Proof. intros Hs Hsf. rewrite /semProdOpt /semProd. setoid_rewrite semBindSize. intro b. split. - intros [s [_ [a [H1 H2]]]]. exists a. split; exists s; (split; first (compute; by []); first by[]). - intros [a [[s1 [_ H1]] [s2 [_ H2]]]]. exists (max s1 s2). split; first (compute; by []). exists a. split. eapply Hs; last eassumption. lia. eapply Hsf; last eassumption. lia. Qed. Lemma semOptBindSize A B (g : G A) (f : A -> G (option B)) size : semProdSizeOpt (bind g f) size <--> \bigcup_(a in semProdSize g size) semProdSizeOpt (f a) size. Proof. unfold semProdSizeOpt. rewrite semBindSize; eauto. split. - intros Hin. inv Hin. inv H. eexists. split; eauto. - intros Hin. inv Hin. inv H. eexists. split; eauto. Qed. Lemma semOptBindOpt A B (g : G (option A)) (f : A -> G (option B)) : SizeMonotonicOpt g -> (forall a : A, SizeMonotonicOpt (f a)) -> semProdOpt (bindOpt g f) <--> \bigcup_(a in semProdOpt g) semProdOpt (f a). Proof. intros Hs Hsf. rewrite /semProdOpt /semProd /bindOpt. setoid_rewrite semBindSize. intro b. split. - intros [s [_ [a [H1 H2]]]]. destruct a. 2:{ eapply semReturnSize in H2. inv H2. } exists a. split; exists s; (split; first (compute; by []); first by[]). - intros [a [[s1 [_ H1]] [s2 [_ H2]]]]. exists (max s1 s2). split; first (compute; by []). exists (Some a). split. eapply Hs; last eassumption. lia. eapply Hsf; last eassumption. lia. Qed. Lemma semOptBindOptSize A B (g : G (option A)) (f : A -> G (option B)) size : semProdSizeOpt (bindOpt g f) size <--> \bigcup_(a in semProdSizeOpt g size) semProdSizeOpt (f a) size. Proof. unfold bindOpt. rewrite semOptBindSize; eauto. - split. + intros Hin. inv Hin. inv H. destruct x. eexists. split; eauto. eapply semReturnSizeOpt_None in H1. inv H1. + intros Hin. inv Hin. inv H. eexists. split; eauto. Qed. #[global] Instance bindOptMonotonicOpt {A B} (g : G (option A)) (f : A -> G (option B)) `{@SizeMonotonicOpt _ _ PG g} `{forall x, SizeMonotonicOpt (f x)} : SizeMonotonicOpt (bindOpt g f). Proof. intros s1 s2 Hs. rewrite !semOptBindOptSize. move => b [a [Hg Hf]]. exists a; split. - eapply H; eauto. - eapply H0; eauto. Qed. Lemma semBindOptSizeOpt_subset_compat (A B : Type) (g g' : G (option A)) (f f' : A -> G (option B)) s : semProdSizeOpt g s \subset semProdSizeOpt g' s -> (forall (x : A), semProdSizeOpt (f x) s \subset semProdSizeOpt (f' x) s) -> semProdSizeOpt (bindOpt g f) s \subset semProdSizeOpt (bindOpt g' f') s. Proof. intros Hyp1 Hyp2. rewrite !semOptBindOptSize. eapply incl_bigcup_compat; eauto. Qed. Lemma semBindSizeOpt_subset_compat (A B : Type) (g g' : G A) (f f' : A -> G (option B)) s : semProdSize g s \subset semProdSize g' s -> (forall (x : A), semProdSizeOpt (f x) s \subset semProdSizeOpt (f' x) s) -> semProdSizeOpt (bind g f) s \subset semProdSizeOpt (bind g' f') s. Proof. intros Hyp1 Hyp2. rewrite !semOptBindSize. eapply incl_bigcup_compat; eauto. Qed. End ProducerHighProofs. QuickChick-2.1.0/src/Proofs.v000066400000000000000000000002031476030541200157530ustar00rootroot00000000000000Require Export Sets. Require Export SemChecker. Require Export CheckerProofs. Require Export EnumProofs. Require Export GenProofs. QuickChick-2.1.0/src/QuickChick.v.cppo000066400000000000000000000017341476030541200174730ustar00rootroot00000000000000Require Import Extraction. Require Import Ltac. #if COQ_VERSION >= (8, 16, 0) Declare ML Module "coq-quickchick.plugin". #else Declare ML Module "quickchick_plugin". #endif Axiom _W : nat -> Prop. Axiom _Size : Prop. Require Export Show. Require Export RandomQC. Require Export Sets. Require Export Nat_util. Require Export Producer. Require Export Enumerators. Require Export Generators. Require Export State. Require Export Checker. Require Export Test. Require Export ExtractionQC. Require Export Decidability. Require Export Classes. Require Export Instances. Require Export DependentClasses. Require Export Typeclasses. Require Export Mutation. Global Unset Asymmetric Patterns. Global Set Bullet Behavior "Strict Subproofs". Global Set Warnings "-extraction-reserved-identifier". (* TODO: Figure out better place for these *) (* String and Ascii Instances *) Require Export Ascii String. (* Derive (Arbitrary, Show) for ascii. *) (* Derive (Arbitrary, Show) for string. *) QuickChick-2.1.0/src/RandomQC.v000066400000000000000000000621411476030541200161600ustar00rootroot00000000000000From Coq Require Import Relations RelationClasses BoolOrder ssreflect ssrfun Lia ZArith NArith. From QuickChick Require Import LazyList Tactics. Set Bullet Behavior "Strict Subproofs". (* We axiomatize a random number generator (currently written in OCaml only) *) Axiom RandomSeed : Type. Axiom randomSeed_inhabited : inhabited RandomSeed. Axiom randomNext : RandomSeed -> Z * RandomSeed. Axiom randomGenRange : RandomSeed -> Z * Z. Axiom mkRandomSeed : Z -> RandomSeed. Axiom newRandomSeed : RandomSeed. (* begin randomSplitAssumption *) Axiom randomSplit : RandomSeed -> RandomSeed * RandomSeed. Axiom randomSplitAssumption : forall s1 s2 : RandomSeed, exists s, randomSplit s = (s1,s2). (* end randomSplitAssumption *) CoInductive RandomSeedTree := | RstNode : RandomSeed -> RandomSeedTree -> RandomSeedTree -> RandomSeedTree. Definition root_rst (rst : RandomSeedTree) : RandomSeed := match rst with | RstNode root _ _ => root end. Definition left_rst (rst : RandomSeedTree) : RandomSeedTree := match rst with | RstNode _ t1 _ => t1 end. Definition right_rst (rst : RandomSeedTree) : RandomSeedTree := match rst with | RstNode _ _ t2 => t2 end. Lemma rst_eta : forall rst : RandomSeedTree, rst = RstNode (root_rst rst) (left_rst rst) (right_rst rst). Proof. destruct rst. reflexivity. Qed. CoFixpoint mkSeedTree (s : RandomSeed) : RandomSeedTree := let (s1, s2) := randomSplit s in RstNode s (mkSeedTree s1) (mkSeedTree s2). Lemma mkSeedTreeHelper r : mkSeedTree r = RstNode r (mkSeedTree (randomSplit r).1) (mkSeedTree (randomSplit r).2). Proof. by rewrite [mkSeedTree _]rst_eta /=; case: (randomSplit r). Qed. Inductive SplitDirection := Left | Right. Definition SplitPath := list SplitDirection. Require Import List. Import ListNotations. Fixpoint varySeedAux (p : SplitPath) (rst : RandomSeedTree) : RandomSeed := let '(RstNode s t1 t2) := rst in match p with | [] => s | Left :: p' => varySeedAux p' t1 | Right :: p' => varySeedAux p' t2 end. Definition varySeed (p : SplitPath) (s : RandomSeed) : RandomSeed := varySeedAux p (mkSeedTree s). Inductive SeedTree := | SeedTreeUndef : SeedTree | SeedTreeLeaf : RandomSeed -> SeedTree | SeedTreeNode : SeedTree -> SeedTree -> SeedTree. Inductive SubSeedTree : SeedTree -> RandomSeedTree -> Prop := | SubUndef : forall (rst : RandomSeedTree), SubSeedTree SeedTreeUndef rst | SubLeaf : forall (s : RandomSeed) (rst1 rst2 : RandomSeedTree), SubSeedTree (SeedTreeLeaf s) (RstNode s rst1 rst2) | SubNode : forall (st1 st2 : SeedTree) (rst1 rst2 : RandomSeedTree) (s : RandomSeed), SubSeedTree st1 rst1 -> SubSeedTree st2 rst2 -> SubSeedTree (SeedTreeNode st1 st2) (RstNode s rst1 rst2). Fixpoint varySeed' (st : SeedTree) (p : SplitPath) : option RandomSeed := match st with | SeedTreeUndef => None | SeedTreeLeaf s => match p with | [] => Some s | _ => None end | SeedTreeNode st1 st2 => match p with | [] => None | Left :: p' => varySeed' st1 p' | Right :: p' => varySeed' st2 p' end end. Lemma pathAgreesOnSubTree : forall (st : SeedTree) (rst : RandomSeedTree) (p : SplitPath) (s : RandomSeed), SubSeedTree st rst -> varySeed' st p = Some s -> varySeedAux p rst = s. Proof. induction st. + intros. simpl in H0. congruence. + intros. simpl in H0. destruct p eqn:P. - inversion H. simpl. inversion H0. reflexivity. - inversion H0. + intros. simpl in H0. destruct p eqn:P. - inversion H0. - inversion H; subst. destruct s0 eqn:S0. * simpl. apply IHst1; auto. * simpl. apply IHst2; auto. Qed. Lemma splitExpand st : exists s, SubSeedTree st (mkSeedTree s). Proof. elim: st => [|r|st1 [s1 st_s1] st2 [s2 st_s2]]. + by case: randomSeed_inhabited=> seed; exists seed; apply: SubUndef. + by exists r; rewrite mkSeedTreeHelper; constructor. + have [s eq_s] := randomSplitAssumption s1 s2. by exists s; rewrite mkSeedTreeHelper eq_s; constructor. Qed. Inductive PrefixFree : list SplitPath -> Prop := | FreeNil : PrefixFree [] | FreeCons : forall (p : SplitPath) (l : list SplitPath), PrefixFree l -> (forall (p' : SplitPath), In p' l -> (forall p1 p2, p' ++ p1 = p ++ p2-> False)) -> PrefixFree (p :: l). Lemma prefixFreeSingleton : forall p, PrefixFree [p]. intro. apply FreeCons. + apply FreeNil. + intros. inversion H. Qed. Lemma prefixFreeEmpty : forall l, PrefixFree ([] :: l) -> l = []. intros. destruct l; auto. inversion H. subst. pose proof H3 l. assert (In l (l :: l0)) by (left; auto). eapply H0 in H1. inversion H1. instantiate (2 := []). rewrite app_nil_r; simpl; eauto. Qed. Inductive correspondingSeedTree (l : list SplitPath) (f : SplitPath -> RandomSeed) (st : SeedTree) : Prop := | Corresponding : (forall (p : SplitPath) s, varySeed' st p = Some s -> In p l) -> (forall (p : SplitPath), In p l -> varySeed' st p = Some (f p)) -> PrefixFree l -> correspondingSeedTree l f st. Lemma corrEmptyUndef : forall f, correspondingSeedTree [] f SeedTreeUndef. intro f. apply Corresponding. + intros p s Contra. inversion Contra. + intros p InNil. inversion InNil. + apply FreeNil. Qed. Ltac fireInLeft name := match goal with | [H : In ?X (?X :: ?XS) -> _ |- _ ] => assert (In X (X :: XS)) as name by (left; auto); apply H in name; clear H end. Lemma corrUndefEmpty : forall l f, correspondingSeedTree l f SeedTreeUndef -> l = []. intros l f Corr. inversion Corr as [Vary_In In_Vary Pref]; clear Corr. destruct l as [ | p ps]; auto. clear Vary_In Pref. pose proof (In_Vary p) as Contra; clear In_Vary. fireInLeft Hyp. inversion Hyp. Qed. Lemma PrefixFreeWithNil : forall l, PrefixFree ([] :: l) -> l = []. intros. inversion H; subst. destruct l eqn:L; auto. pose proof (H3 l0). assert (In l0 (l0 :: l1)) by (left; auto). eapply H0 in H1. + inversion H1. + instantiate (1 := l0). instantiate (1 := []). rewrite app_nil_r. auto. Qed. Lemma corrEmptyLeaf : forall s l f, correspondingSeedTree l f (SeedTreeLeaf s) -> l = [[]] /\ s = f []. intros s l f Corr. inversion Corr as [Vary_In In_Vary Pref]; clear Corr. pose proof (Vary_In [] s) as Hyp; clear Vary_In. simpl in Hyp. assert (InNilL : In [] l) by (apply Hyp; auto); clear Hyp. split. + destruct l eqn:L. - inversion InNilL. - destruct s0 eqn : S0. * apply PrefixFreeWithNil in Pref; subst; auto. * pose proof (In_Vary (s1 :: s2)) as Hyp; clear In_Vary. inversion Pref. fireInLeft Hyp'. simpl in Hyp'. inversion Hyp'. + pose proof In_Vary [] as Hyp; clear In_Vary. apply Hyp in InNilL; clear Hyp. simpl in *. congruence. Qed. Lemma corrNodeNonEmpty : forall st1 st2 l p f, correspondingSeedTree l f (SeedTreeNode st1 st2) -> In p l -> p <> []. unfold not; intros st1 st2 l p f Corr InPL PNil; subst. inversion Corr as [_ In_Vary _]; clear Corr. pose proof (In_Vary []) as Hyp; clear In_Vary. apply Hyp in InPL; clear Hyp. simpl in InPL. inversion InPL. Qed. #[local] Hint Resolve corrEmptyUndef corrNodeNonEmpty : core. Definition Direction_eq_dec : forall (d1 d2 : SplitDirection), {d1 = d2} + {d1 <> d2}. decide equality. Qed. Definition eq_dir_b (d1 d2 : SplitDirection) : bool := match d1,d2 with | Left, Left => true | Right, Right => true | _, _ => false end. Lemma eq_dir_b_eq : forall d1 d2, eq_dir_b d1 d2 = true <-> d1 = d2. intros. unfold eq_dir_b. destruct d1; destruct d2; split; auto; intro Contra; inversion Contra. Qed. Definition refineList (d : SplitDirection) (l : list SplitPath) : list SplitPath := map (@tl SplitDirection) (filter (fun p => match hd_error p with | Some d' => eq_dir_b d d' | _ => false end) l). Lemma refineCorrect : forall d l p, In p (refineList d l) -> In (d :: p) l. intros d l p. unfold refineList. rewrite in_map_iff. intros. inversion H; clear H. inversion H0; clear H0. generalize H1; clear H1. rewrite filter_In. intros H0. inversion H0; clear H0. unfold tl in H. destruct x eqn:X. + simpl in H2. inversion H2. + simpl in H2. apply eq_dir_b_eq in H2. subst. auto. Qed. Lemma refineCorrect' : forall d l p, In (d :: p) l -> In p (refineList d l). intros. unfold refineList. apply in_map_iff. exists (d :: p). split; auto. apply filter_In. split; simpl; auto. unfold eq_dir_b; destruct d; auto. Qed. Lemma refinePreservesPrefixFree : forall d l, PrefixFree l -> PrefixFree (refineList d l). intros. induction l. - unfold refineList; constructor. - destruct a eqn:A; subst. * apply prefixFreeEmpty in H. subst. unfold refineList. simpl. constructor. * destruct s eqn:S; destruct d; subst. + unfold refineList; simpl. eapply FreeCons. -- apply IHl. inversion H; auto. -- intros. inversion H; subst; clear H. apply in_map_iff in H0. inversion H0; subst; clear H0. inversion H; subst; clear H. apply filter_In in H2. inversion H2; subst; clear H2. destruct x eqn:X; simpl in *. inversion H0. destruct s eqn:S; simpl in *. pose proof H5 (Left :: l0). eapply H2 in H; auto. simpl. instantiate (1 := p2). instantiate (1:= p1). rewrite H1. auto. inversion H0. + unfold refineList; simpl. apply IHl. inversion H. auto. + unfold refineList; simpl. apply IHl. inversion H. auto. + unfold refineList; simpl. eapply FreeCons. -- apply IHl. inversion H; auto. -- intros. inversion H; subst; clear H. apply in_map_iff in H0. inversion H0; subst; clear H0. inversion H; subst; clear H. apply filter_In in H2. inversion H2; subst; clear H2. destruct x eqn:X; simpl in *. inversion H0. destruct s eqn:S; simpl in *. inversion H0. pose proof H5 (Right :: l0). eapply H2 in H; auto. simpl. instantiate (1 := p2). instantiate (1:= p1). rewrite H1. auto. Qed. Definition refineFunction (f : SplitPath -> RandomSeed) (d : SplitDirection) (arg : SplitPath) : RandomSeed := f (d :: arg). Lemma refineFunCorrect : forall f d p, f (d :: p) = (refineFunction f d) p. auto. Qed. #[local] Hint Rewrite refineFunCorrect : core. #[local] Hint Unfold refineFunction : core. Program Fixpoint addToTree (st : SeedTree) (p : SplitPath) (f : SplitPath -> RandomSeed) (l : list SplitPath) (Corr : correspondingSeedTree l f st) (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)) : SeedTree := match st with | SeedTreeUndef => match p with | [] => SeedTreeLeaf (f p) | Left :: p' => SeedTreeNode (addToTree SeedTreeUndef p' (refineFunction f Left) [] _ _) SeedTreeUndef | Right :: p' => SeedTreeNode SeedTreeUndef (addToTree SeedTreeUndef p' (refineFunction f Right) [] _ _) end | SeedTreeLeaf s => _ (* Contradiction! *) | SeedTreeNode st1 st2 => match p with | [] => SeedTreeLeaf (f p) | Left :: p' => SeedTreeNode (addToTree st1 p' (refineFunction f Left) (refineList Left l) _ _) st2 | Right :: p' => SeedTreeNode st1 (addToTree st2 p' (refineFunction f Right) (refineList Right l) _ _) end end. Next Obligation. apply corrEmptyLeaf in Corr. inversion Corr; clear Corr; subst. pose proof (Pref []). exfalso. eapply H. + left; auto. + instantiate (2 := []). rewrite app_nil_r. simpl. eauto. Qed. Next Obligation. eapply Corresponding; intros. + apply refineCorrect'. inversion Corr as [Vary_In _ _ ]; clear Corr. pose proof (Vary_In (Left :: p) s) as Hyp; clear Vary_In. auto. + apply refineCorrect in H. inversion Corr as [_ In_Vary _]; clear Corr. pose proof (In_Vary (Left :: p)) as Hyp; clear In_Vary. apply Hyp in H; clear Hyp. simpl in H. unfold refineFunction; auto. + inversion Corr. apply refinePreservesPrefixFree. auto. Qed. Next Obligation. eapply Pref. instantiate (1:= Left :: p'0). apply refineCorrect; auto. instantiate (1:= p2). instantiate (1:=p1). simpl. rewrite H0. auto. Qed. Next Obligation. eapply Corresponding; intros. + apply refineCorrect'. inversion Corr as [Vary_In _ _ ]; clear Corr. pose proof (Vary_In (Right :: p) s) as Hyp; clear Vary_In. auto. + apply refineCorrect in H. inversion Corr as [_ In_Vary _]; clear Corr. pose proof (In_Vary (Right :: p)) as Hyp; clear In_Vary. apply Hyp in H; clear Hyp. simpl in H. unfold refineFunction; auto. + inversion Corr. apply refinePreservesPrefixFree. auto. Qed. Next Obligation. eapply Pref. instantiate (1:= Right :: p'0). apply refineCorrect; auto. instantiate (1:= p2). instantiate (1:=p1). simpl. rewrite H0. auto. Qed. Lemma addToTreeCorrect1 : forall (st : SeedTree) (p : SplitPath) (f : SplitPath -> RandomSeed) (l : list SplitPath) (Corr : correspondingSeedTree l f st) (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)), varySeed' (addToTree st p f l Corr Pref) p = Some (f p). intros st p. generalize dependent st. induction p. + intros st f l Corr Pref. unfold addToTree. destruct st. - auto. - exfalso. apply corrEmptyLeaf in Corr. inversion Corr; clear Corr. subst. pose proof Pref [] as Contra; clear Pref. eapply Contra; clear Contra. * left; auto. * instantiate (1 := []). instantiate (1 := []). auto. - simpl. auto. + intros. destruct st; destruct a; simpl. - rewrite refineFunCorrect. apply IHp. - rewrite refineFunCorrect; apply IHp. - exfalso. eapply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr. pose proof (Pref []). eapply H. -- subst; left; auto. -- simpl. instantiate (2:= []); rewrite app_nil_r. instantiate (1 := Left ::p); auto. - exfalso. eapply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr. pose proof (Pref []). eapply H. -- subst; left; auto. -- simpl. instantiate (2:= []); rewrite app_nil_r. instantiate (1 := Right ::p); auto. - rewrite refineFunCorrect; apply IHp. - rewrite refineFunCorrect; apply IHp. Qed. Lemma addToTreeCorrect2 : forall (st : SeedTree) (p : SplitPath) (f : SplitPath -> RandomSeed) (l : list SplitPath) (Corr : correspondingSeedTree l f st) (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)), forall p' seed, varySeed' st p' = Some seed -> varySeed' (addToTree st p f l Corr Pref) p' = Some seed. intros st p. generalize dependent st. induction p as [ | d ds]. + intros. exfalso. eapply Pref. - inversion Corr as [Vary_In In_Vary Pref']; clear Corr. eapply Vary_In; eassumption. - instantiate (1 := []); instantiate (1 := p'); rewrite app_nil_r; auto. + intros st f l Corr Pref p' seed VarySome. destruct st; destruct d; simpl; auto. * exfalso. apply corrUndefEmpty in Corr. subst. inversion VarySome. * exfalso. apply corrUndefEmpty in Corr. subst. inversion VarySome. * exfalso. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr. eapply Pref. instantiate (1 := []); left; auto. instantiate (1:= Left :: ds). instantiate (1 := []). rewrite app_nil_r; simpl; auto. * exfalso. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr. eapply Pref. instantiate (1 := []); left; auto. instantiate (1:= Right :: ds). instantiate (1 := []). rewrite app_nil_r; simpl; auto. * destruct p'. - simpl in VarySome. inversion VarySome. - destruct s. ++ apply IHds; auto. ++ auto. * destruct p'. - simpl in VarySome; inversion VarySome. - destruct s. ++ auto. ++ apply IHds; auto. Qed. Lemma addToTreeCorrect3 : forall (st : SeedTree) (p : SplitPath) (f : SplitPath -> RandomSeed) (l : list SplitPath) (Corr : correspondingSeedTree l f st) (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)), forall p' seed, varySeed' (addToTree st p f l Corr Pref) p' = Some seed -> p = p' \/ varySeed' st p' = Some seed. intros st p. generalize dependent st. induction p. + intros. destruct p'. - left; auto. - right. exfalso. unfold addToTree in H; simpl in H. destruct st; simpl in H. * inversion H. * clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr. subst. eapply Pref. instantiate (1 := []). left; auto. instantiate (1 := []); instantiate (1 := []); auto. * inversion H. + intros. destruct p'; destruct st; destruct a; simpl in *; try solve [match goal with [ H : None = Some _ |- _ ] => inversion H end]. ++ exfalso. clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr. eapply Pref. subst. instantiate (1 := []) ; left; auto. instantiate (1 := (Left :: p)); instantiate (1 := []); rewrite app_nil_r; auto. ++ exfalso. clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr. eapply Pref. subst. instantiate (1 := []) ; left; auto. instantiate (1 := (Right :: p)); instantiate (1 := []); rewrite app_nil_r; auto. ++ destruct s; simpl in *. - assert (p = p' \/ varySeed' SeedTreeUndef p' = Some seed) by (eapply IHp; eauto). inversion H0. * left; subst; auto. * simpl in H1. inversion H1. - inversion H. ++ destruct s; simpl in *. - inversion H. - assert (p = p' \/ varySeed' SeedTreeUndef p' = Some seed) by (eapply IHp; eauto). inversion H0. * left; subst; auto. * simpl in H1. inversion H1. ++ exfalso. clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr. subst. eapply Pref. instantiate (1 := []). - left; auto. - instantiate (1 := Left :: p); instantiate (1 := []); rewrite app_nil_r; auto. ++ exfalso. clear H. apply corrEmptyLeaf in Corr; inversion Corr; subst; clear Corr. subst. eapply Pref. instantiate (1 := []). - left; auto. - instantiate (1 := Right :: p); instantiate (1 := []); rewrite app_nil_r; auto. ++ destruct s eqn:S; simpl in *. - assert (p = p' \/ varySeed' st1 p' = Some seed) by (eapply IHp; eauto). inversion H0. * left; subst; auto. * right; auto. - right; auto. ++ destruct s eqn:S; simpl in *. - right; auto. - assert (p = p' \/ varySeed' st2 p' = Some seed) by (eapply IHp; eauto). inversion H0. * left; subst; auto. * right; auto. Qed. Lemma addToTreeCorrect : forall (st : SeedTree) (p : SplitPath) (f : SplitPath -> RandomSeed) (l : list SplitPath) (Corr : correspondingSeedTree l f st) (Pref : forall p', In p' l -> (forall p1 p2, p ++ p1 = p' ++ p2 -> False)), correspondingSeedTree (p :: l) f (addToTree st p f l Corr Pref). intros. apply Corresponding. + intros p' s VarySome. inversion Corr as [Vary_In In_Vary Pref']. apply addToTreeCorrect3 in VarySome. inversion VarySome. - left; auto. - right. eapply Vary_In; eassumption. + intros p' InP'. inversion Corr as [Vary_In In_Vary Pref']. inversion InP'. - subst. apply addToTreeCorrect1. - apply addToTreeCorrect2. apply In_Vary. auto. + apply FreeCons. - inversion Corr; auto. - intros. eapply Pref. eassumption. instantiate (1 := p1); instantiate (1:= p2); subst; auto. Qed. Lemma PrefixFreeTail : forall a l, PrefixFree (a :: l) -> PrefixFree l. intros. inversion H. auto. Qed. (* LL: Why was it easier to do it like this? :P *) Fixpoint listToTree (l : list SplitPath) (f : SplitPath -> RandomSeed) ( Pref : PrefixFree l) : {s : SeedTree | correspondingSeedTree l f s}. Proof. induction l. + exists SeedTreeUndef. apply corrEmptyUndef. + remember Pref as Pref'. clear HeqPref'. apply PrefixFreeTail in Pref'. apply IHl in Pref'. inversion Pref'; clear Pref'. assert (forall p', In p' l -> forall p1 p2, a ++ p1 = p' ++ p2 -> False) by (inversion Pref; intros; subst; eapply H3; [eassumption | instantiate (1 := p1); instantiate (1 := p2); subst; auto]). exists (addToTree x a f l H H0). apply addToTreeCorrect. Qed. (* begin SplitPathCompleteness *) Theorem SplitPathCompleteness (l : list SplitPath) (f : SplitPath -> RandomSeed) : PrefixFree l -> exists (s : RandomSeed), forall p, In p l -> varySeed p s = f p. (* end SplitPathCompleteness *) intros Pref. pose proof (listToTree l f Pref) as ExSeedTree. inversion ExSeedTree as [st Corr]; clear ExSeedTree. inversion Corr as [Vary_In In_Vary Pref']; clear Corr. pose proof (splitExpand st) as ExRst. inversion ExRst as [rst Sub]; clear ExRst. exists rst. intros p InPL. pose proof (pathAgreesOnSubTree st (mkSeedTree rst) p (f p)) as Hyp. auto. Qed. (* Primitive generator combinators and some basic soundness assumptions about them *) Axiom randomRBool : bool * bool -> RandomSeed -> bool * RandomSeed. Axiom randomRBoolCorrect : forall b b1 b2, Bool.le b1 b2 -> Bool.le b1 b /\ Bool.le b b2 <-> exists seed, (fst (randomRBool (b1, b2) seed)) = b. Axiom randomRNat : nat * nat -> RandomSeed -> nat * RandomSeed. Axiom randomRNatCorrect: forall n n1 n2, n1 <= n2 -> (n1 <= n <= n2 <-> exists seed, (fst (randomRNat (n1, n2) seed)) = n). Axiom randomRInt : Z * Z -> RandomSeed -> Z * RandomSeed. Axiom randomRIntCorrect: forall z z1 z2, Z.le z1 z2 -> (Z.le z1 z /\ Z.le z z2 <-> exists seed, (fst (randomRInt (z1, z2) seed)) = z). Axiom randomRN : N * N -> RandomSeed -> N * RandomSeed. Axiom randomRNCorrect: forall n n1 n2, N.le n1 n2 -> N.le n1 n /\ N.le n n2 <-> exists seed, fst (randomRN (n1, n2) seed) = n. (* A small experiment showing that infinite random trees are a potential model of the randomSplitAssumption *) Module InfiniteTrees. CoInductive RandomSeed : Type := | Node : bool -> RandomSeed -> RandomSeed -> RandomSeed. Definition randomSplit (s : RandomSeed) := match s with | Node b s1 s2 => (s1,s2) end. Lemma randomSplitAssumption : forall s1 s2 : RandomSeed, exists s, randomSplit s = (s1,s2). Proof. move => s1 s2. by exists (Node true s1 s2). Qed. End InfiniteTrees. (* Type class machinery for generating things in intervals *) Class ChoosableFromInterval (A : Type) (le : relation A) : Type := { randomR : A * A -> RandomSeed -> A * RandomSeed; randomRCorrect : forall (a a1 a2 : A), le a1 a2 -> (le a1 a /\ le a a2 <-> exists seed, fst (randomR (a1, a2) seed) = a); enumR : A * A -> LazyList A; enumRCorrect : forall (a a1 a2 : A), le a1 a2 -> (le a1 a /\ le a a2 <-> In_ll a (enumR (a1,a2))) }. (* This is false. #[global] Program Instance ChooseBool : ChoosableFromInterval bool := { randomR := randomRBool; randomRCorrect := randomRBoolCorrect }. *) Definition enumRNat (p : nat * nat) := lazy_seq S (fst p) (S (snd p - fst p)). Lemma iter_S : forall n m, Nat.iter n S m = n + m. Proof. induction n; cbn; [ reflexivity | intros; f_equal; apply IHn ]. Qed. Lemma enumRNatCorrect : forall (a a1 a2 : nat), a1 <= a2 -> (a1 <= a <= a2 <-> In_ll a (enumRNat (a1,a2))). Proof. unfold enumRNat. intros a a1 a2 Hleq1. cbn [fst snd]. rewrite lazy_seq_spec. split. - intros. exists (a - a1). rewrite iter_S. lia. - intros (i & Hi & Ha). rewrite iter_S in Ha. lia. Qed. #[global] Instance ChooseNat : ChoosableFromInterval nat Nat.le := { randomR := randomRNat; randomRCorrect := randomRNatCorrect; enumR := enumRNat; enumRCorrect := enumRNatCorrect }. Definition enumRZ (p : Z * Z) := lazy_seq Z.succ (fst p) (S (Z.to_nat (snd p - fst p))). Lemma iter_Zsucc : forall n m, Nat.iter n Z.succ m = (Z.of_nat n + m)%Z. Proof. induction n; cbn [Nat.iter nat_rect]; [ reflexivity | intros ]. rewrite Nat2Z.inj_succ Z.add_succ_l. f_equal. apply IHn. Qed. Lemma enumRZCorrect : forall (a a1 a2 : Z), (a1 <= a2 -> a1 <= a <= a2 <-> In_ll a (enumRZ (a1,a2)))%Z. Proof. unfold enumRZ. intros a a1 a2 Hleq1. cbn [fst snd]. rewrite lazy_seq_spec. split. - intros. exists (Z.to_nat (a - a1))%Z. rewrite iter_Zsucc. lia. - intros (i & Hi & Ha). rewrite iter_Zsucc in Ha. lia. Qed. #[global] Instance ChooseZ : ChoosableFromInterval Z Z.le := { randomR := randomRInt; randomRCorrect := randomRIntCorrect; enumR := enumRZ; enumRCorrect := enumRZCorrect }. Definition enumRN (p : N * N) := lazy_seq N.succ (fst p) (S (N.to_nat (snd p - fst p))). Lemma iter_Nsucc : forall n m, Nat.iter n N.succ m = (N.of_nat n + m)%N. Proof. induction n; cbn [Nat.iter nat_rect]; [ reflexivity | intros ]. rewrite Nat2N.inj_succ N.add_succ_l. f_equal. apply IHn. Qed. Lemma enumRNCorrect : forall (a a1 a2 : N), (a1 <= a2 -> a1 <= a <= a2 <-> In_ll a (enumRN (a1,a2)))%N. Proof. unfold enumRN. intros a a1 a2 Hleq1. cbn [fst snd]. rewrite lazy_seq_spec. split. - intros. exists (N.to_nat (a - a1))%N. rewrite iter_Nsucc. lia. - intros (i & Hi & Ha). rewrite iter_Nsucc in Ha. lia. Qed. #[global] Instance ChooseN : ChoosableFromInterval N N.le := { randomR := randomRN; randomRCorrect := randomRNCorrect; enumR := enumRN; enumRCorrect := enumRNCorrect }. QuickChick-2.1.0/src/RoseTrees.v000066400000000000000000000042211476030541200164220ustar00rootroot00000000000000(* Lazy Rose Trees *) Require Import List mathcomp.ssreflect.ssreflect. Set Implicit Arguments. Record Lazy (T : Type) := lazy { force : T }. Inductive Rose (A : Type) : Type := MkRose : A -> Lazy (list (Rose A)) -> Rose A. Definition returnRose {A : Type} (x : A) := MkRose x (lazy nil). Fixpoint joinRose {A : Type} (r : Rose (Rose A)) : Rose A := match r with | MkRose (MkRose a ts) tts => MkRose a (lazy ((List.map joinRose (force tts)) ++ (force ts))) end. Definition repeatRose {A : Type} (n : nat) (r : Rose A) := match r with | MkRose a ts => MkRose a (lazy (concat (repeat (force ts) n))) end. Fixpoint fmapRose {A B : Type} (f : A -> B) (r : Rose A) : Rose B := match r with | MkRose x rs => MkRose (f x) (lazy (List.map (fmapRose f) (force rs))) end. Definition bindRose {A B : Type} (m : Rose A) (k : A -> Rose B) : Rose B := joinRose (fmapRose k m). (* (* CH: these seem unused now *) Lemma joinRoseFmapRose : forall {A B} (f: A -> B) (x : Rose A), fmapRose f x = joinRose (fmapRose (fun x0 : A => returnRose (f x0)) x). Proof. fix 4. move=> A B f x. destruct x as [a l]. destruct l as [lst]. induction lst as [|x lst IHlst]. - reflexivity. - inversion IHlst as [Heq]. simpl. rewrite Heq. repeat apply f_equal. apply f_equal2. apply joinRoseFmapRose. reflexivity. Qed. Lemma monadFunctorLaw : (forall A B (f : A -> B) a, fmapRose f a = bindRose a (fun x => returnRose (f x))). Proof. move => A B f a. destruct a. destruct l as [lst]. induction lst as [|x lst Hlst]. + reflexivity. + simpl in Hlst. rewrite /bindRose /= in Hlst. inversion Hlst as [Heq]. simpl. rewrite Heq /bindRose /= app_nil_r. repeat apply f_equal. apply f_equal2. apply joinRoseFmapRose. reflexivity. Qed. (* CH: TODO: need a proper induction principle for rose trees *) Lemma fmapRose_id : forall a (rose : Rose a) f, (forall x : a, f x = x) -> fmapRose f rose = rose. Proof. fix 2. (* <-- nasty *) move => a [r [xs]] f H. induction xs as [|x xs]; simpl in *. - by rewrite H. - inversion IHxs. f_equal. by repeat apply H1. f_equal. f_equal. + by apply fmapRose_id. + by do 2 rewrite H2. Qed. *) QuickChick-2.1.0/src/SemChecker.v000066400000000000000000000735521476030541200165350ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". From Coq Require Import ssreflect ssrbool. From mathcomp Require Import ssrnat eqtype. From QuickChick Require Import Show Sets Generators Producer RoseTrees Checker Classes. Import QcDefaultNotation. Local Open Scope set_scope. Definition resultSuccessful (r : Result) : bool := match r with | MkResult (Some res) expected _ _ _ _ _ => res == expected | _ => true end. Definition successful qp := match qp with | MkProp (MkRose res _) => resultSuccessful res end. (* Maps a Checker to a Prop *) (* begin semCheckerSize *) Definition semCheckerSize (c : Checker) (s : nat): Prop := successful @: semProdSize c s \subset [set true]. (* end semCheckerSize *) (* ZP: Do we want to define semChecker in terms of semCheckerSize? *) (* begin semChecker *) Definition semChecker (c : Checker) : Prop := forall s, semCheckerSize c s. (* end semChecker *) (* Maps a Checkable to a Prop i.e. gives an equivalent proposition to the property under test *) (* begin semCheckableSize *) Definition semCheckableSize {A} `{Checkable A} (a : A) (s : nat) : Prop := semCheckerSize (checker a) s. (* end semCheckableSize *) (* begin semCheckable *) Definition semCheckable {A} `{Checkable A} (a : A) : Prop := semChecker (checker a). (* end semCheckable *) (* another characterization of semChecker *) Lemma semChecker_def2 c : semChecker c <-> (forall qp, semProd c qp -> successful qp = true). Proof. rewrite /semChecker /semCheckerSize /semProd. split; intro H. - intros. destruct H0 as [s [H0 Ho']]. symmetry; eapply (H s). eexists. split; eauto. reflexivity. - intros n b [qp [H1 H2]]. symmetry in H2. rewrite H2. symmetry. apply H. eexists; eauto. split; eauto. reflexivity. Qed. (* CH: This is the definition of Checker I would like to use *) (* ZP : For now semCheckerSize has a similar definition and semChecker is defined in terms of semCheckerSize *) Lemma semChecker_def3 c : semChecker c <-> (successful @: semProd c \subset [set true]). Proof. rewrite semChecker_def2. split; intro H. (* CH: why can't I rewrite with semFmap directly? See tentative instances below *) - intros b H'. unfold imset, bigcup in H'. destruct H' as [qp [H1 H2]]. apply H in H1. by rewrite H1 in H2. - intros. specialize (H (successful qp)). unfold set1 in H. symmetry. apply: H. by eapply imset_in. Qed. Definition genChecker c := @fmap G _ _ _ successful c. Class UnsizedChecker (c : Checker) := { unsizedChecker : forall s1 s2 : nat, semProdSize (genChecker c) s1 <--> semProdSize (genChecker c) s2 }. Class SizeMonotonicChecker (c : Checker) := { monotonicChecker : forall s1 s2, s1 <= s2 -> semProdSize (genChecker c) s1 \subset semProdSize (genChecker c) s2 }. Lemma unsizedChecker_alt_def (c : Checker) `{UnsizedChecker c} : forall s1 s2, semCheckerSize c s1 <-> semCheckerSize c s2. Proof. rewrite /semCheckerSize => s1 s2; split; move : H => [/(_ s1 s2) H]; rewrite /genChecker in H; setoid_rewrite semFmapSize in H; eauto with typeclass_instances; by rewrite H. Qed. Lemma monotonicChecker_alt_def (c : Checker) `{SizeMonotonicChecker c} : forall s1 s2, s1 <= s2 -> semCheckerSize c s2 -> semCheckerSize c s1. Proof. rewrite /semCheckerSize => s1 s2 Hle. move : H => [/(_ s1 s2 Hle) H]. rewrite /genChecker in H; setoid_rewrite semFmapSize in H; eauto with typeclass_instances. move => H1 b H2. apply H1. eauto. Qed. #[global] Program Instance unsizedMonotonicChecker (c : Checker) `{UnsizedChecker c} : SizeMonotonicChecker c. Next Obligation. move => b Hb. pose proof (@unsizedChecker c H s1 s2) as HU. apply HU. apply Hb. Qed. Lemma mapTotalResult_idSize {C} `{Checkable C} (f : Result -> Result) (c : C) s : (forall res, resultSuccessful res = resultSuccessful (f res)) -> (semCheckerSize (mapTotalResult f c) s <-> semCheckableSize c s). Proof. move=> eq_res. rewrite /mapTotalResult /mapRoseResult /mapProp/semCheckableSize /semCheckerSize. split; rewrite semFmapSize. - move => H1 b [[[res l]] /= [H2 H3]]. rewrite -H3 eq_res. apply H1. repeat (eexists; split; eauto). - move => /= H1 b [[[res l]] /= [[[[res' l'] [/= H2 [H3 H4]]] H5]]]; subst. rewrite <- H5, <- eq_res in *. apply H1. eexists. split; eauto. reflexivity. Qed. Lemma mapTotalResult_id {C} `{Checkable C} (f : Result -> Result) (c : C) : (forall res, resultSuccessful res = resultSuccessful (f res)) -> (semChecker (mapTotalResult f c) <-> semCheckable c). Proof. move=> eq_res; split => H' s; eapply mapTotalResult_idSize; eauto. by apply H'. Qed. Lemma semCallback_idSize {C} `{Checkable C} (cb : Callback) (c : C) (s : nat) : semCheckerSize (callback cb c) s <-> semCheckableSize c s. Proof. rewrite /callback. split; move => H'. - apply mapTotalResult_idSize in H' => //; by move => [? ? ? ? ? ?]. - apply mapTotalResult_idSize => //; by move => [? ? ? ? ? ?]. Qed. Lemma semCallback_id {C} `{Checkable C} (cb : Callback) (c : C) : semChecker (callback cb c) <-> semCheckable c. Proof. split => H' s; eapply semCallback_idSize; eauto. by apply H'. Qed. Lemma semWhenFail_idSize {C} `{Checkable C} (str : String.string) (c : C) s : semCheckerSize (whenFail str c) s <-> semCheckableSize c s. Proof. by rewrite /whenFail semCallback_idSize. Qed. Lemma semWhenFail_id {C} `{Checkable C} (str : String.string) (c : C) : semChecker (whenFail str c) <-> semCheckable c. Proof. by rewrite /whenFail semCallback_id. Qed. Lemma semPrintTestCase_idSize {C} `{Checkable C} (str : String.string) (c : C) s : semCheckerSize (printTestCase str c) s <-> semCheckableSize c s. Proof. by rewrite /printTestCase semCallback_idSize. Qed. Lemma semPrintTestCase_id {C} `{Checkable C} (str : String.string) (c : C) : semChecker (printTestCase str c) <-> semCheckable c. Proof. by rewrite /printTestCase semCallback_id. Qed. Lemma semShrinking_idSize {C A} {HCheck : Checkable C} (sh : A -> list A) (x : A) (pf : A -> C) (s : nat) : semCheckerSize (shrinking sh x pf) s <-> semCheckableSize (pf x) s. Proof. unfold semCheckableSize, shrinking, semCheckerSize, semProdSize, props. have [n <-] : exists n, S n = 1000 by eexists; reflexivity. split. - move => H b [[[res [l]]] [/= [seed Hgen] H']]; subst. + destruct (RandomQC.randomSplitAssumption seed seed) as [seed' Hseed']. suff : successful (run (@fmap _ (@Functor_Monad G (@super _ (ProducerGen))) _ _ (fun x0 => {| unProp := joinRose (fmapRose unProp x0) |}) (promote (@props' _ _ HCheck (S n) pf sh x))) s seed'). setoid_rewrite runFmap. rewrite runPromote. simpl. rewrite Hseed'. simpl. rewrite Hgen -H' /=. move => -> //. rewrite <- H => //. eexists. split; try by reflexivity. eexists. reflexivity. - move => H b [[[r [l]]] /= [[seed H1] <-]]. apply H. simpl in *. destruct (RandomQC.randomSplit seed) as [s1 s2]. destruct ((run (checker (pf x)) s s1)) as [[res [l']]] eqn:Heq=> //=. simpl in *. move : H1 => [H1 H2]; subst. eexists. eexists. exists s1. reflexivity. rewrite Heq. reflexivity. Qed. Lemma semShrinking_id {C A} {HCheck : Checkable C} (sh : A -> list A) (x : A) (pf : A -> C) : semChecker (shrinking sh x pf) <-> semCheckable (pf x). Proof. split; move => H s; eapply semShrinking_idSize; first by eauto. by apply H. Qed. (* Program #[global] Instance shrinkingUnsized {C A} `{Checkable C} *) (* (sh : A -> list A) (x : A) (pf : A -> C) *) (* `{UnsizedChecker (checker (pf x))} : UnsizedChecker (shrinking sh x pf). *) (* Next Obligation. *) (* Abort. *) Lemma semCover_idSize {C} `{Checkable C} (b: bool) (n: nat) (str : String.string) (c : C) (s : nat) : semCheckerSize (cover b n str c) s <-> semCheckableSize c s. Proof. split. - rewrite /cover. case: b => //. move => H1. apply mapTotalResult_idSize in H1 => //. by move => [? ? ? ? ? ?]. - move => H1. rewrite /cover. case: b => //. apply mapTotalResult_idSize => //. by move => [? ? ? ? ? ?]. Qed. Lemma semCover_id {C} `{Checkable C} (b: bool) (n: nat) (str : String.string) (c : C) : semChecker (cover b n str c) <-> semCheckable c. Proof. split; move => H' s; eapply semCover_idSize; first by eauto. by apply H'. Qed. Lemma semClassify_idSize {C} `{Checkable C} (b: bool) (str : String.string) (c : C) (s : nat) : semCheckerSize (classify b str c) s <-> semCheckableSize c s. Proof. by rewrite /classify semCover_idSize. Qed. Lemma semClassify_id {C} `{Checkable C} (b: bool) (str : String.string) (c : C) : semChecker (classify b str c) <-> semCheckable c. Proof. by rewrite /classify semCover_id. Qed. Lemma semLabel_idSize {C} `{Checkable C} (str : String.string) (c : C) (s : nat) : semCheckerSize (label str c) s <-> semCheckableSize c s. Proof. by rewrite /label semClassify_idSize. Qed. Lemma semLabel_id {C} `{Checkable C} (str : String.string) (c : C) : semChecker (label str c) <-> semCheckable c. Proof. by rewrite /label semClassify_id. Qed. Lemma semCollect_idSize {C} `{Checkable C} (str : String.string) (c : C) (s : nat) : semCheckerSize (collect str c) s <-> semCheckableSize c s. Proof. by rewrite /collect semLabel_idSize. Qed. Lemma semCollect_id {C} `{Checkable C} (str : String.string) (c : C) : semChecker (collect str c) <-> semCheckable c. Proof. by rewrite /collect semLabel_id. Qed. Open Scope Checker_scope. Lemma semImplicationSize {C} `{Checkable C} (c : C) (b : bool) s : semCheckerSize (implication b c) s <-> (b -> semCheckableSize c s). Proof. case: b; split=> //=; first by move/(_ refl_equal). by move => _ b [x [/semReturnSize <- <-]]. Qed. (* begin semImplication *) Lemma semImplication {C} `{Checkable C} (c : C) (b : bool) : semChecker (implication b c) <-> (b -> semCheckable c). (* end semImplication *) Proof. split; [move => H1 b' s' | move => H1 s b']; eapply semImplicationSize; try by eauto. move => b''. by apply H1. Qed. Lemma implication_unsized : (forall (C : Type) (H : Checkable C) (b : bool) (c : C), UnsizedChecker (checker c) -> forall s1 s2 : nat, semProdSize (genChecker (implication b c)) s1 <--> semProdSize (genChecker (implication b c)) s2). Proof. move => C H b c HC s1 s2. move: HC => [/(_ s1 s2) H0]. rewrite /genChecker in H0 *. rewrite -> !semFmapSize in H0; eauto with typeclass_instances. rewrite !semFmapSize. rewrite /implication. case : b; eauto. apply imset_eq. rewrite !semReturnSize. reflexivity. Qed. #[global] Instance implicationUnsized {C} `{H: Checkable C} b (c : C) `{HC : UnsizedChecker (checker c)} : UnsizedChecker (implication b c) := {| unsizedChecker := implication_unsized C H b c HC |}. Opaque semProdSize. #[global] Program Instance implicationMonotonic {C} `{Checkable C} b (c : C) `{SizeMonotonicChecker (checker c)} : SizeMonotonicChecker (implication b c). Next Obligation. move : H0 => [/(_ s1 s2 H1) H0]. rewrite /genChecker in H0 *. rewrite -> !semFmapSize in H0; eauto with typeclass_instances. rewrite !semFmapSize. rewrite /implication. case : b; eauto. apply imset_incl. rewrite !semReturnSize. by move => ? ?; eauto. Qed. (* equivalences for other combinators *) Lemma semReturnGenSize (qp : QProp) (s: nat) : semCheckerSize (ret qp) s <-> semCheckableSize qp s. Proof. rewrite /semCheckerSize. split. - move => H qp' [x [H1 H2]]. apply H. eexists; split; eauto. - move => H b [x [H1 H2]] //. apply H => //=. eexists; split; eauto. Qed. Lemma semReturnGen (qp : QProp) : semChecker (ret qp) <-> semCheckable qp. Proof. split; move => H s. - by move /(_ s) /semReturnGenSize : H => //. - apply semReturnGenSize; eauto. by apply H. Qed. Opaque bind. Lemma semBindGenSize {A} (gen : G A) (f : A -> Checker) (s: nat): semCheckerSize (bind gen f) s <-> forall a, semProdSize gen s a -> semCheckerSize (f a) s. Proof. unfold semCheckerSize. split. - move => H a Hsize b [qp [H1 <-]]. apply H. exists qp; split => //=. apply (@semBindSize G ProducerGen ProducerSemanticsGen). eexists; split; eauto. - move => H b [qp [/semBindSize [a [H1 H2]] <-]]. eapply H; try eassumption. eexists; split => //; eauto. Qed. Lemma semBindGenUsinzed1 {A} (gen : G A) (f : A -> Checker) `{@Unsized _ _ ProducerGen gen} : (semChecker (bindGen gen f) <-> forall a, semProd gen a -> semChecker (f a)). Proof. split; move => Hgen a. - move => [s [_ H']] s'. eapply unsized in H'. eapply semBindGenSize in Hgen; eauto. - by eapply semBindGenSize; intros; apply Hgen; eexists; split => //; eauto. Qed. Lemma semBindGenUsinzed2 {A} (gen : G A) (f : A -> Checker) `{forall a, UnsizedChecker (f a)} : (semChecker (bindGen gen f) <-> forall a, semProd gen a -> semChecker (f a)). Proof. split; move => Hgen a. - move => [s [_ H']] s'. eapply semBindGenSize in Hgen; last by eauto. eapply unsizedChecker_alt_def; eauto. - by eapply semBindGenSize; intros; apply Hgen; eexists; split => //; eauto. Qed. Lemma semBindGenSizeMonotonic {A} (gen : G A) (f : A -> Checker) `{@SizeMonotonic _ _ ProducerGen gen} `{forall a, SizeMonotonicChecker (f a)} : (semChecker (bindGen gen f) <-> forall a, semProd gen a -> semChecker (f a)). Proof. split; move => Hgen a. - move => [s [_ H']] s'. case_eq (s <= s') => [/leP Hleq | /leP/Compare_dec.not_le/ltP/ltnW Hleq]. + specialize (Hgen s'). eapply semBindGenSize in Hgen; eauto. eapply monotonic; eauto. + specialize (Hgen s). eapply semBindGenSize in Hgen; eauto. eapply monotonicChecker_alt_def; eauto. - by eapply semBindGenSize; intros; apply Hgen; eexists; split => //; eauto. Qed. Lemma semPredQPropSize (c : Checker) (s : nat) : semCheckableSize c s <-> (semCheckerSize c s). Proof. rewrite /semCheckableSize /checker /testChecker /checker /testProp /semCheckerSize. split; move => Hqp qp Hsize; auto. Qed. Lemma semPredQProp (c : Checker) : semCheckable c <-> semChecker c. Proof. split => H s; eapply semPredQPropSize; eauto. Qed. #[global] Instance forAllMonotonic {A C} {_ : Checkable C} `{Show A} (g : G A) (f : A -> C) `{@SizeMonotonic _ _ ProducerGen g} `{forall x, SizeMonotonicChecker (checker (f x))} : SizeMonotonicChecker (forAll g f). Proof. Admitted. Lemma semForAllSize {A C} `{Show A, Checkable C} (g : G A) (f : A -> C) (s:nat) : semCheckerSize (forAll g f) s <-> forall (a : A), a \in semProdSize g s -> semCheckableSize (f a) s. Proof. split=> H'. - rewrite /forAll in H'. move/semBindGenSize : H' => H' a /H' Hgen. by apply semPrintTestCase_idSize in Hgen. - rewrite /forAll in H' *. apply semBindGenSize => g' Hgen. rewrite semPrintTestCase_idSize. by apply H'. Qed. Lemma semForAllUnsized1 {A C} `{Show A, Checkable C} (g : G A) (f : A -> C) `{@Unsized _ _ ProducerGen g} : (semChecker (forAll g f) <-> forall (a : A), a \in semProd g -> semCheckable (f a)). Proof. split=> H'. - move => a [s' [_ Hgen]] s. specialize (H' s). eapply semForAllSize in H'; first by eauto. eapply unsized; eauto. - move => s; eapply semForAllSize; move => a Hgen. apply H'; eexists; split => //; eauto. Qed. Lemma semForAllUnsized2 {A C} `{Show A, Checkable C} (g : G A) (f : A -> C) `{forall a, UnsizedChecker (checker (f a))} : (semChecker (forAll g f) <-> forall (a : A), a \in semProd g -> semCheckable (f a)). Proof. split=> H'. - move => a [s' [_ Hgen]] s. specialize (H' s'). eapply semForAllSize in H'; last by eauto. by eapply unsizedChecker_alt_def; eauto. - move => s; eapply semForAllSize; move => a Hgen. apply H'; eexists; split => //; eauto. Qed. (* begin semForAllSizeMonotonic *) Lemma semForAllSizeMonotonic {A C} `{Show A, Checkable C} (g : G A) (f : A -> C) `{@SizeMonotonic _ _ ProducerGen g} `{forall a, SizeMonotonicChecker (checker (f a))} : (semChecker (forAll g f) <-> forall (a:A), a \in semProd g -> semCheckable (f a)). (* end semForAllSizeMonotonic *) Proof. split; move => Hcheck a. - move => [s [_ H']] s'. case_eq (s <= s') => [/leP Hleq | /leP/Compare_dec.not_le/ltP/ltnW Hleq]. + specialize (Hcheck s'). rewrite -> semForAllSize in Hcheck. apply Hcheck. eapply monotonic; eauto. + specialize (Hcheck s). eapply semForAllSize in Hcheck; eauto. by eapply monotonicChecker_alt_def; eauto. - by eapply semForAllSize; intros; apply Hcheck; eexists; split => //; eauto. Qed. Lemma unsized_printTestCase {A C} `{Checkable C} `{Show A} (c : A -> C) : (forall a, Unsized (checker (c a))) -> (forall a, Unsized (printTestCase (String.append (Show.show a) newline) (c a))). Proof. (* rewrite /UnsizedChecker /unsized. setoid_rewrite semFmapSize. *) (* move => H' a s1 s2. specialize (H' a s1 s2). *) (* by do 2 rewrite semPrintTestCase_idSize. *) (* Qed. *) Abort. (* alternative definitions Definition unsizedChecker (c : Checker) : Prop := forall s1 s2, semCheckerSize c s1 <-> semCheckerSize c s2. (* another characterization of unsizedChecker *) Lemma unsizedChecker_def2 {A : Type} : forall (c : Checker), unsizedChecker c -> forall s, semCheckerSize c s <-> semChecker c. Proof. intros. split; intro H'. - intro s'. rewrite H. eassumption. - by apply H'. Qed. *) (* CH: We could create a super class UCheckable that includes the unsized assumption. And we could use sections to hide all the type class stuff from the paper. *) (* CH: This will be affected by upcoming refactoring; proving it like this only because it appears in ITP submission *) (* Require Import FunctionalExtensionality. Lemma curry_uncurry {A B C : Type} (f : A -> B -> C) : curry (uncurry f) = f. Proof. apply functional_extensionality => x. reflexivity. Qed. Lemma uncurry_curry {A B C : Type} (f : A * B -> C) : uncurry (curry f) = f. Proof. apply functional_extensionality. by intros [a b]. Qed. Lemma mergeBinds' : forall A B C (ga : G A) (gb : G B) (f : A * B -> G C), semGen (bindGen ga (fun x => bindGen gb ((curry f) x))) <--> semGen (bindGen (genPair ga gb) f). Proof. setoid_rewrite mergeBinds. by setoid_rewrite uncurry_curry. Qed. Lemma eq_to_impl : forall (a b : Prop), a = b -> a -> b. Proof. move => a b H. by rewrite H. Qed. (* CH: could we get rid of this in the RBTree example if we used semBindSizeMonotonic instead of semBindUnsized2? *) (* CH: The problem with proving this is the silly print in the middle of things. There are also some technical problems with setoid_rewriting taking ages, and requiring an useless split beforehand. ZP: Got rid of setoid_rewrite. The proof goes through instantly now. *) Lemma mergeForAlls {A B C : Type} `{Checkable C} `{Show A} `{Show B} (ga : G A) (gb : G B) (f : A -> B -> C) : semChecker (forAll ga (fun a => forAll gb (f a))) <-> semChecker (forAll (genPair ga gb) (uncurry f)). Proof. (* ZP : I know that this proof lacks nice point-free reasoning, but it is significantly smaller and typechecks much faster that the previous one *) split. - move => HforAll s. apply semForAllSize; move => [a b] /= /semLiftGen2Size [[a' b'] [[/= Hg1 Hg2] [Heq1 Heq2]]]; subst. specialize (HforAll s). eapply semForAllSize in HforAll. by eapply semForAllSize in HforAll; eauto. by eauto. - move => HforAll s. apply semForAllSize => a Hgena. apply semForAllSize => b Hgenb. specialize (HforAll s). move /semForAllSize/(_ (a, b)) : HforAll => /= HforAll. apply HforAll. apply semLiftGen2Size. exists (a, b); split => //; eauto. Qed. *) Lemma semForAllShrinkSize: forall {A C} `{Checkable C} `{Show A} (gen : G A) (f : A -> C) shrinker (size: nat), semCheckerSize (forAllShrink gen shrinker f) size <-> forall a : A, semProdSize gen size a -> semCheckableSize (f a) size. Proof. move => A C H show gen pf shrink. split. - rewrite /forAllShrink semBindGenSize. move=> H' a /H' Hgen. setoid_rewrite semShrinking_idSize in Hgen. setoid_rewrite semPredQPropSize in Hgen. by apply semPrintTestCase_idSize in Hgen. - move=> H'. rewrite /forAllShrink semBindGenSize. move => a g. rewrite semShrinking_idSize. apply semPredQPropSize. rewrite semPrintTestCase_idSize. by auto. Qed. Lemma semForAllShrinkUnsized1 : forall {A C} `{Checkable C} `{Show A} (gen : G A) (f : A -> C) shrinker `{@Unsized _ _ ProducerGen gen}, (semChecker (forAllShrink gen shrinker f) <-> forall a : A, semProd gen a -> semCheckable (f a)). Proof. split=> H'. - move => a [s' [_ Hgen]] s. specialize (H' s). eapply semForAllShrinkSize in H'; first by eauto. eapply H1; eauto. - move => s; eapply semForAllShrinkSize; move => a Hgen. apply H'; eexists; split => //; eauto. Qed. Lemma semForAllShrinkUnsized2 : forall {A C} `{Checkable C} `{Show A} (gen : G A) (f : A -> C) shrinker `{forall a, UnsizedChecker (checker (f a))}, (semChecker (forAllShrink gen shrinker f) <-> forall a : A, semProd gen a -> semCheckable (f a)). Proof. split=> H'. - move => a [s' [_ Hgen]] s. specialize (H' s'). eapply semForAllShrinkSize in H'; last by eauto. eapply unsizedChecker_alt_def; eauto. - move => s; eapply semForAllShrinkSize; move => a Hgen. apply H'; eexists; split => //; eauto. Qed. Lemma semForAllShrinkMonotonic : forall {A C} `{Checkable C} `{Show A} (gen : G A) (f : A -> C) shrinker `{@SizeMonotonic _ _ ProducerGen gen}, (forall a, SizeMonotonicChecker (checker (f a))) -> (semChecker (forAllShrink gen shrinker f) <-> forall a : A, semProd gen a -> semCheckable (f a)). Proof. move => A C H1 H2 gen f sh Hmon1 Hmon2. split; move => Hcheck a. - move => [s [_ H']] s'. case_eq (s <= s') => [/leP Hleq | /leP/Compare_dec.not_le/ltP/ltnW Hleq]. + specialize (Hcheck s'). rewrite -> semForAllShrinkSize in Hcheck. apply Hcheck. by eapply Hmon1; eauto. + specialize (Hcheck s). eapply semForAllShrinkSize in Hcheck; eauto. by eapply monotonicChecker_alt_def; eauto. - by eapply semForAllShrinkSize; intros; apply Hcheck; eexists; split => //; eauto. Qed. Lemma bool_successful : forall b, resultSuccessful (liftBool b) = b. Proof. intros. destruct b; auto. Qed. Lemma semCheckableBoolSize (b : bool) size : semCheckableSize b size <-> b. Proof. rewrite /semCheckableSize /semCheckerSize /checker /testBool. split. - move => /(_ b) H. suff : [set true] b by move => <- //. eapply H. eexists (MkProp (MkRose (liftBool b) (lazy nil))). split. simpl. by rewrite -> (semReturnSize _ _ _). by eapply bool_successful. - move => Hb b' [qp [/semReturnSize <- <-]] /=. by rewrite bool_successful. Qed. (* begin semCheckableBool *) Lemma semCheckableBool (b : bool) : semCheckable b <-> b. (* end semCheckableBool *) Proof. (* CH: brute-force, please fix ZP : better now? We do case analysis on b bun in a lemma; I don't think we can avoid it *) split; [move => /(_ 0) H | move => H s]; eapply semCheckableBoolSize; eauto. (* LEO: TODO: Why? *) Unshelve. constructor. Qed. #[global] Program Instance boolUnsized (b : bool) : UnsizedChecker (checker b). Next Obligation. rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity. Qed. Opaque ret. Lemma semCheckableResultSize: forall (res: Result) (size: nat), semCheckableSize res size <-> resultSuccessful res. Proof. rewrite /semCheckableSize. rewrite /checker. rewrite /testResult. move => res size. split. - move => /(_ (resultSuccessful res)) H. suff : [set true] (resultSuccessful res) by move <-. apply H. eexists. split. + apply @semReturnSize; eauto with typeclass_instances. reflexivity. + reflexivity. - move => H b [qp' [/semReturnSize <- <-]] //=. Qed. Lemma semCheckableResult : forall (res: Result), semCheckable res <-> resultSuccessful res. Proof. split; [move => /(_ 0) H | move => H s]; eapply semCheckableResultSize; eauto. Unshelve. constructor. Qed. #[global] Program Instance resultUnsized (r : Result) : UnsizedChecker (checker r). Next Obligation. rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity. Qed. Lemma semCheckableUnitSize (t : unit) size : semCheckableSize t size <-> True. Proof. split => // _ qp [qp' [/semReturnSize <- <-]] //. Qed. Lemma semCheckableUnit (t : unit) : semCheckable t <-> True. Proof. split; [move => /(_ 0) H | move => H s]; eapply semCheckableUnitSize; eauto. Unshelve. constructor. constructor. Qed. #[global] Program Instance unitUnsized : UnsizedChecker (checker tt). Next Obligation. rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity. Qed. Lemma semCheckableQPropSize (qp : QProp) size : semCheckableSize qp size <-> successful qp. Proof. rewrite /semCheckableSize /checker /testProp. split. - move => /(_ (successful qp)) H. suff : ([set true] (successful qp)) by move => <-. apply H. eexists. split ; last by reflexivity. apply @semReturnSize; eauto with typeclass_instances. reflexivity. - move => H b [qp' [/semReturnSize <- <-]] //=. Qed. Lemma semCheckableQProp (qp : QProp) : semCheckable qp <-> successful qp. Proof. split; [move => /(_ 0) H | move => H s]; eapply semCheckableQPropSize; eauto. Unshelve. constructor. Qed. #[global] Program Instance qpUnsized (qp : QProp) : UnsizedChecker (checker qp). Next Obligation. rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity. Qed. Lemma semCheckableGenSize: forall (P : Type) {H : Checkable P} (gen: G P) (size : nat), (semCheckableSize gen size) <-> (forall p, semProdSize gen size p -> semCheckableSize p size). Proof. move=> P H gen s. rewrite /semCheckableSize /checker /testGenProp. split. - move => /semBindGenSize Hcheck p Hgen //=; eauto. - move => Hcheck. apply semBindGenSize => a Hgen; eauto. Qed. (* Leo: Finish. Lemma semCheckableFunSize: forall {A C} {H1 : Show A} `{H2 : Arbitrary A} {H3 : Checkable C} (f : A -> C) (size: nat), semCheckableSize f size <-> forall (a : A), semProdSize arbitrary size a -> semCheckableSize (f a) size. Proof. move=> A C H1 H2 H3 f. rewrite /semCheckable /checker /testFun. split. - move => /semForAllShrinkSize H' a' /H' Gen. by auto. - move => H'. apply (@semForAllShrinkSize _ _ H0 H1 (@arbitrary _ H2) (@shrink _ H3)). => a' /H' Hgen. by auto. Qed. Lemma semCheckablePolyFunSize: forall {C : Type -> Type} {H : Checkable (C nat)} (f : forall T, C T) (size : nat), (semCheckableSize f size) <-> (semCheckableSize (f nat) size). Proof. move => C H f s. rewrite /semCheckableSize {2}/checker /testPolyFun. by rewrite semPrintTestCase_idSize. Qed. Lemma semCheckablePolyFunSetSize: forall {C : Set -> Type} {H : Checkable (C nat)} (f : forall T, C T) (size: nat), (semCheckableSize f size) <-> (semCheckableSize (f nat) size). Proof. move => C H f s. rewrite /semCheckableSize {2}/checker /testPolyFun. by rewrite semPrintTestCase_idSize. Qed. #[global] Program Instance uncurryUsized {A B} (f : A -> B -> Checker) p `{UnsizedChecker (f (fst p) (snd p))} : UnsizedChecker (uncurry f p). Next Obligation. by apply unsizedChecker. Qed. (* A typeclass so we can automate the application of the previous theorems and get a readable Prop *) Class Provable (A : Type) {H: Checkable A} : Type := { proposition : nat -> A -> Prop; proposition_equiv : forall a s, proposition s a <-> semCheckableSize a s }. #[global] Program Instance proveResult : Provable Result := {| proposition s r := resultSuccessful r |}. Next Obligation. by rewrite semCheckableResultSize. Qed. #[global] Program Instance proveUnit : Provable unit := {| proposition := fun _ _ => True |}. Next Obligation. by rewrite semCheckableUnitSize. Qed. #[global] Program Instance proveQProp : Provable QProp := {| proposition s qp := successful qp = true |}. Next Obligation. by rewrite semCheckableQPropSize. Qed. #[global] Program Instance proveBool : Provable bool := {| proposition s b := b = true |}. Next Obligation. by rewrite semCheckableBoolSize. Qed. #[global] Program Instance proveGenProp {C} `{Provable C} : Provable (G C) := {| proposition s g := (forall p, semProdSize g s p -> proposition s p) |}. Next Obligation. destruct H0 as [semP proof]. rewrite /proposition. split. - move => H'. apply semCheckableGenSize => p Hgen. apply proof. eapply H'. eassumption. - move => /semCheckableGenSize H' p Hgen. eapply proof. apply H'. by auto. Qed. #[global] Program Instance proveChecker : Provable Checker := {| proposition s g := semCheckerSize g s |}. Next Obligation. split; intros H; by apply semPredQPropSize. Qed. #[global] Program Instance proveFun {A C: Type} `{Arbitrary A} `{Show A} `{Provable C}: Provable (A -> C) := {| proposition s p := (forall a, semProdSize arbitrary s a -> proposition s (p a)) |}. Next Obligation. match goal with | [ Hyp : Provable _ |- _ ] => destruct Hyp as [semP proof] end. rewrite /proposition. split. - move=> H'. apply semCheckableFunSize => a' /H' Hgen. by apply proof. - move=> H' a' Hgen. apply proof. by apply semCheckableFunSize. Qed. #[global] Program Instance provePolyFun {C : Type -> Type} `{Provable (C nat)} : Provable (forall T, C T) := { proposition s f := proposition s (f nat) }. Next Obligation. destruct H0 as [semP proof]. rewrite /proposition. split. - move=> /proof H'. by apply semCheckablePolyFunSize. - move=> /semCheckablePolyFunSize H'. by apply proof. Qed. #[global] Program Instance provePolyFunSet {C : Set -> Type} `{Provable (C nat)} : Provable (forall T, C T) := { proposition s f := proposition s (f nat) }. Next Obligation. destruct H0 as [semP proof]. rewrite /proposition. split. - move=> /proof H'. by apply semCheckablePolyFunSetSize. - move=> /semCheckablePolyFunSetSize H'. by apply proof. Qed. *) QuickChick-2.1.0/src/Sets.v000066400000000000000000000756651476030541200154510ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". From Coq Require Import Classes.RelationClasses Classes.Morphisms List ssreflect. From mathcomp Require Import ssrfun ssrbool seq. From QuickChick Require Import Tactics. Import ListNotations. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (* There are similar definitions in the Ensembles library (Included and Same_set); set_eq is not exactly the same as Same_set though (only logically equivalent). *) Definition set T := T -> Prop. Declare Scope set_scope. Notation "x \in A" := (A x) (at level 70, only parsing) : set_scope. Definition set_eq {A} (m1 m2 : set A) := forall (a : A), m1 a <-> m2 a. Infix "<-->" := set_eq (at level 70, no associativity) : set_scope. Local Open Scope set_scope. Lemma set_eq_trans T B (A C : set T) : A <--> B -> B <--> C -> A <--> C. Proof. by move=> eqAB eqBC; split=> [/eqAB/eqBC|/eqBC/eqAB]. Qed. Lemma set_eq_symm {A} (s1 s2 : set A) : s1 <--> s2 -> s2 <--> s1. Proof. firstorder. Qed. Lemma set_eq_refl {A} (s : set A) : s <--> s. Proof. firstorder. Qed. #[global] Instance : forall T, Equivalence (@set_eq T). Proof. move=> T; constructor=> // [A B eqAB | A B C] x; first by split=> /eqAB. exact: set_eq_trans. Qed. #[global] Instance set_eq_rew A : RelationClasses.RewriteRelation (@set_eq A) := {}. Definition set_incl {A} (m1 m2 : set A) := forall (a : A), m1 a -> m2 a. Infix "\subset" := set_incl (at level 70, no associativity) : set_scope. Notation "[ 'set' x : T | P ]" := (fun x : T => P) (at level 0, x at level 99, only parsing) : set_scope. Notation "[ 'set' x | P ]" := [set x : _ | P] (at level 0, x, P at level 99, format "[ 'set' x | P ]", only parsing) : set_scope. Definition set0 {T} := [set _ : T | False]. Definition setT {T} := [set _ : T | True]. Notation "[ 'set' : T ]" := (@setT T) (at level 0, format "[ 'set' : T ]") : set_scope. Section setOpsDef. Context {T U : Type}. Implicit Types (a x : T) (A B : set T). Definition set1 a := eq a. Definition setU A B := [set x | x \in A \/ x \in B]. Definition setI A B := [set x | x \in A /\ x \in B]. Definition codom (f : T -> U) := [set y | exists x, f x = y]. Definition bigcup A (F : T -> set U) := [set x | exists i, i \in A /\ x \in F i]. Definition bigcap (A : set T) (F : T -> set U) := [set x | forall (i : T), i \in A -> x \in F i]. End setOpsDef. Definition imset {T U} (f : T -> U) A := bigcup A (fun x => set1 (f x)). Definition setX T U (A : set T) (B : set U) := [set x | x.1 \in A /\ x.2 \in B]. Definition imset2 T U V (f : T -> U -> V) A1 A2 := imset (uncurry f) (setX A1 A2). Definition codom2 T U V (f : T -> U -> V) := codom (uncurry f). Notation "[ 'set' a ]" := (set1 a) (at level 0, a at level 99, format "[ 'set' a ]") : set_scope. Notation "[ 'set' a : T ]" := [set (a : T)] (at level 0, a at level 99, format "[ 'set' a : T ]") : set_scope. Notation "A :|: B" := (setU A B) (at level 52, left associativity) : set_scope. Notation "a |: A" := ([set a] :|: A) (at level 52, left associativity) : set_scope. Notation "A :&: B" := (setI A B) (at level 48, left associativity) : set_scope. Notation "f @: A" := (imset f A) (at level 24) : set_scope. Notation "f @2: ( A , B )" := (imset2 f A B) (at level 24, format "f @2: ( A , B )") : set_scope. Notation "\bigcup_ i F" := (bigcup setT (fun i => F)) (at level 41, F at level 41, i at level 0, format "'[' \bigcup_ i '/ ' F ']'") : set_scope. Notation "\bigcup_ ( i : t ) F" := (bigcup (@setT t) (fun i => F)) (at level 41, F at level 41, i at level 50, format "'[' \bigcup_ ( i : t ) '/ ' F ']'", only parsing) : set_scope. Notation "\bigcup_ ( i 'in' A ) F" := (bigcup A (fun i => F)) (at level 41, F at level 41, i, A at level 50, format "'[' \bigcup_ ( i 'in' A ) '/ ' F ']'") : set_scope. Notation "\bigcap_ ( i 'in' A ) F" := (bigcap A (fun i => F)) (at level 41, F at level 41, i, A at level 50, format "'[' \bigcap_ ( i 'in' A ) '/ ' F ']'") : set_scope. Definition lift {T} (S : set T) : set (option T) := Some @: S :|: [set None]. Lemma subset_eqP T (A B : set T) : (A <--> B) <-> (A \subset B /\ B \subset A). Proof. split; first by move=> eqAB; split=> a; rewrite (eqAB a). by case=> subAB subBA a; split; [apply: subAB | apply:subBA]. Qed. Lemma subset_trans T (A1 A2 A3 : set T) : A1 \subset A2 -> A2 \subset A3 -> A1 \subset A3. Proof. now firstorder. Qed. Lemma subset_refl T (A : set T) : A \subset A. Proof. by rewrite /set_incl. Qed. Lemma subset_singl : forall {T} (x y : T), [set x] \subset [set y] <-> y = x. Proof. intros. split; intros H; subst; auto. - apply H; reflexivity. - apply subset_refl. Qed. Lemma subset_respects_set_eq_l : forall (T : Type) (s1 s2 s3 : set T), s1 <--> s3 -> s3 \subset s2 -> s1 \subset s2. Proof. now firstorder. Qed. Lemma subset_respects_set_eq_r : forall (T : Type) (s1 s2 s3 : set T), s3 <--> s2 -> s1 \subset s2 -> s1 \subset s3. Proof. now firstorder. Qed. Lemma subset_respects_set_eq : forall {T : Type} {s1 s2 s1' s2' : set T}, s1 <--> s1' -> s2 <--> s2' -> s1' \subset s2' -> s1 \subset s2. Proof. firstorder. Qed. Lemma imsetT T U (f : T -> U) : f @: setT <--> codom f. Proof. move=> y; split; first by case=> x [_ fx]; exists x. by case=> x fx; exists x. Qed. Lemma imset_id T (A : set T) : id @: A <--> A. Proof. by move=> t; split=> [[x [Ax <-]]|At] //; exists t. Qed. Lemma imset_incl {T U} (A B : set T) (f : T -> U): A \subset B -> f @: A \subset f @: B. Proof. move => H u [x [H1 H2]]. eexists; split; eauto. Qed. Lemma imset_eq {T U} (A B : set T) (f : T -> U): A <--> B -> f @: A <--> f @: B. Proof. move => H u. split; apply imset_incl => t Ht; by apply H. Qed. Lemma imset_in a b x (f : a -> b) (A : set a) : x \in A -> f x \in (f @: A). Proof. intros. unfold imset. exists x. split; by []. Qed. Lemma imset_id_ext T (A : set T) f : (forall x, f x = x) -> f @: A <--> A. Proof. rewrite /imset /bigcup => H x. split. - move => [y [H1 H2]]. rewrite H in H2. inversion H2. subst. assumption. - move => H1. eexists. split. eassumption. by rewrite H. Qed. Lemma imset_eq_ext a b (f g : a -> b) (A : set a) : (forall x, f x = g x) -> f @: A <--> g @: A. Proof. rewrite /imset /bigcup /set1. move => H x. split => [[i [H1 H2]] | [i [H1 H2]]]; eexists; split; try eassumption. congruence. congruence. Qed. Lemma coverE T (A : set T) : \bigcup_(x in A) [set x] <--> A. Proof. exact: imset_id. Qed. Lemma setXT T U : setX [set: T] [set: U] <--> [set: T * U]. Proof. by case. Qed. #[global] Instance set_incl_Proper T U : Proper (@eq (T -> U) ==> set_incl ==> set_incl) imset. Proof. by move=> f ? <- A B subAB y [x [Ax fx]]; exists x; split=> //; apply: subAB. Qed. #[global] Instance set_eq_Proper T U : Proper (@eq (T -> U) ==> set_eq ==> set_eq) imset. Proof. by move=> f ? <- A B /subset_eqP[subAB subBA] y; split; apply: set_incl_Proper. Qed. Lemma sub0set T (A : set T) : set0 \subset A. Proof. by []. Qed. Lemma bigcup_set0 T U (F : T -> set U) : \bigcup_(x in set0) F x <--> set0. Proof. by move=> t; split=> // [[? []]]. Qed. Lemma imset0 T U (f : T -> U) : f @: set0 <--> set0. Proof. exact: bigcup_set0. Qed. Lemma bigcup_set1 T U (F : T -> set U) y : \bigcup_(x in [set y]) F x <--> F y. Proof. by move=> t; split=> [[y' [<-]] | Fyt] //; exists y. Qed. Lemma bigcup_setU_l: forall (U T : Type) (s1 s2 : set U) (f : U -> set T), \bigcup_(i in (s1 :|: s2)) f i <--> \bigcup_(i in s1) f i :|: \bigcup_(i in s2) f i. Proof. firstorder. Qed. Lemma bigcup_const A B (P : set B) : inhabited A -> (\bigcup_(_ : A) P) <--> P. Proof. by case=> a x; split=> [[?] []|Px] //; exists a. Qed. Lemma bigcup_const_2 A (x :A) B (P : set B) : (\bigcup_(_ in [set x]) P) <--> P. Proof. by split=> [[?] []|Px] //; exists x; split => //=. Qed. Lemma bigcupC T U V A B (F : T -> U -> set V) : \bigcup_(i in A) \bigcup_(j in B) F i j <--> \bigcup_(j in B) \bigcup_(i in A) F i j. Proof. wlog suff: T U A B F / \bigcup_(i in A) \bigcup_(j in B) F i j \subset \bigcup_(j in B) \bigcup_(i in A) F i j. by move=> sub; apply/subset_eqP; split; apply: sub. by move=> x [i [Ai [j [Bj ?]]]]; exists j; split=> //; exists i. Qed. Lemma incl_bigcupr T U A (F : T -> set U) G : (forall x, F x \subset G x) -> \bigcup_(x in A) F x \subset \bigcup_(x in A) G x. Proof. by move=> subFG t [x [Ax Fxt]]; exists x; split=> //; apply: subFG. Qed. Lemma eq_bigcupr T U A (F : T -> set U) G : (forall x, F x <--> G x) -> \bigcup_(x in A) F x <--> \bigcup_(x in A) G x. Proof. by move=> eq_FG t; split; apply: incl_bigcupr => {t} x t; rewrite (eq_FG x t). Qed. Lemma incl_bigcupl T U A B (F : T -> set U) : A \subset B -> \bigcup_(x in A) F x \subset \bigcup_(x in B) F x. Proof. by move=> subAB t [x [Ax Fxt]]; exists x; split=> //; apply: subAB. Qed. Lemma eq_bigcupl T U A B (F : T -> set U) : A <--> B -> \bigcup_(x in A) F x <--> \bigcup_(x in B) F x. Proof. by move=> /subset_eqP[? ?]; split; apply: incl_bigcupl. Qed. Lemma incl_bigcup a b (x:a) (A : set a) (f:a->set b) : x \in A -> f x \subset \bigcup_(x in A) f x. Proof. rewrite /set_incl /bigcup. by eauto 3. Qed. Arguments eq_bigcupl [T U A] B F _ _. #[global] Instance eq_bigcup T U : Proper (set_eq ==> pointwise_relation T (@set_eq U) ==> set_eq) bigcup. Proof. move=> A B eqAB F G eqFG a; apply: (@set_eq_trans _ (\bigcup_(i in A) G i)). exact: eq_bigcupr. exact: eq_bigcupl. Qed. Lemma bigcup_flatten T U V A (F : T -> set U) (G : U -> set V) : \bigcup_(x in \bigcup_(y in A) F y) G x <--> \bigcup_(y in A) \bigcup_(x in F y) G x. Proof. move=> t; split=> [[x [[y [Ay Fyx]] Gxt]] | [y [Ay [x [Fyx Gxt]]]]]. by exists y; split=> //; exists x. by exists x; split=> //; exists y. Qed. Lemma codom_apply {A B : Type} {f : A -> B} {x : A} : f x \in codom f. Proof. eexists; eauto. Qed. Lemma codomE T U (f : T -> U) : codom f <--> \bigcup_x [set f x]. Proof. by move=> y; split=> [[x fx]|[x [_ fx]]]; exists x. Qed. Lemma codom_id T : codom id <--> [set: T]. Proof. by move=> x; split=> // _; exists x. Qed. Lemma codom_const A B (x : B) : inhabited A -> codom (fun _ : A => x) <--> [set x]. Proof. by move=> ?; rewrite codomE bigcup_const. Qed. Lemma imset_comp T U V (f : U -> T) (g : V -> U) A : (f \o g) @: A <--> f @: (g @: A). Proof. by rewrite /imset bigcup_flatten; apply: eq_bigcupr => x; rewrite bigcup_set1. Qed. Lemma codom_comp T U V (f : U -> T) (g : V -> U) : codom (f \o g) <--> f @: (codom g). Proof. by rewrite -imsetT imset_comp imsetT. Qed. Lemma curry_imset2l T U V (f : T -> U -> V) A1 A2 : f @2: (A1, A2) <--> \bigcup_(x1 in A1) f x1 @: A2. Proof. move=> a; split. by case=> [[x1 x2] [[/= Ax1 Ax2] fx]]; exists x1; split=> //; exists x2. by case=> [x1 [Ax1 [x2 [Ax2 fx]]]]; exists (x1,x2). Qed. Lemma curry_imset2r T U V (f : T -> U -> V) A1 A2 : f @2: (A1, A2) <--> \bigcup_(x2 in A2) f^~ x2 @: A1. Proof. by rewrite curry_imset2l bigcupC. Qed. Lemma curry_codom2l T U V (f : T -> U -> V) : codom (uncurry f) <--> \bigcup_x1 codom (f x1). Proof. rewrite -imsetT -setXT -/(imset2 f _ _) curry_imset2l. by apply: eq_bigcupr => x; rewrite imsetT. Qed. Lemma imset_bigcup T U V (f : U -> V) A (F : T -> set U) : (f @: \bigcup_(x in A) (F x)) <--> \bigcup_(x in A) f @: F x. Proof. by rewrite /imset bigcup_flatten. Qed. Lemma bigcup_imset T U V (f : T -> U) A (F : U -> set V) : \bigcup_(y in f @: A) (F y) <--> \bigcup_(x in A) F (f x). Proof. by rewrite bigcup_flatten; apply: eq_bigcupr => x; rewrite bigcup_set1. Qed. Lemma bigcup_codom T U V (f : T -> U) (F : U -> set V) : \bigcup_(y in codom f) (F y) <--> \bigcup_x F (f x). Proof. by rewrite -imsetT bigcup_imset. Qed. Coercion seq_In T : seq T -> set T := fun s x => List.In x s. Coercion list_In T : list T -> set T := fun s x => List.In x s. Lemma subnilset T (A : set T) : [::] \subset A. Proof. by []. Qed. Lemma subconsset T (A : set T) x s : x :: s \subset A <-> x \in A /\ s \subset A. Proof. split=> [sub|[Ax sub] a [<-|?]] //; last by apply: sub. split=> [|a sa]; apply: sub; first by left. by right. Qed. Lemma reindex_bigcup I J K (h : J -> I) (F : I -> set K) A B : h @: B <--> A -> \bigcup_(x in A) F x <--> \bigcup_(y in B) F (h y). Proof. move=> surj t; split. case=> x [Ax Fxt]; case: (surj x) => [?]. by case=> // y [By eq_hyx]; exists y; rewrite eq_hyx. case=> y [By Fhyt]; exists (h y); split=> //. by case: (surj (h y)) => Ahy _; apply: Ahy; exists y. Qed. Arguments reindex_bigcup [I J K] h [F A] B _ _. Lemma bigcup_pointwise_incl A B (s : set A) (t : A -> set B) (u : set B) : (forall x, x \in s -> t x \subset u) -> \bigcup_(x in s) t x \subset u. Proof. intros H b [x []]; eapply H; eauto. Qed. #[global] Instance proper_set_incl A : Morphisms.Proper (set_eq ==> set_eq ==> Basics.impl) (@set_incl A). Proof. firstorder. Qed. (** Lemmas about [setU] and [setI] *) #[global] Instance eq_setU U : Proper (set_eq ==> set_eq ==> set_eq) (@setU U). Proof. move=> A B eqAB F G eqFG a. split; by move => [H1 | H2]; firstorder. Qed. #[global] Instance eq_setI U : Proper (set_eq ==> set_eq ==> set_eq) (@setI U). Proof. move=> A B eqAB F G eqFG a. by split; move => [H1 H2]; firstorder. Qed. Lemma setI_comm {U} (s1 s2 : set U) : s1 :&: s2 <--> s2 :&: s1. Proof. firstorder. Qed. Lemma setU_comm {U} (s1 s2 : set U) : s1 :|: s2 <--> s2 :|: s1. Proof. firstorder. Qed. Lemma setI_set0_abs {U} (s : set U) : (s :&: set0) <--> set0. Proof. firstorder. Qed. Lemma setU_set0_neut {U} (s : set U) : (s :|: set0) <--> s. Proof. firstorder. Qed. Lemma setU_set0_neut_eq {A} (s s1 : set A) : s1 <--> set0 -> s <--> s :|: s1. Proof. firstorder. Qed. Lemma setU_set0_l {A} (s1 s2 s3 : set A) : s1 <--> set0 -> s2 <--> s3 -> (s1 :|: s2) <--> s3. Proof. firstorder. Qed. Lemma setU_set0_r {A} (s1 s2 s3 : set A) : s1 <--> set0 -> s3 <--> s2 -> s3 <--> (s1 :|: s2). Proof. firstorder. Qed. Lemma setI_setT_neut {U} (s : set U) : (s :&: setT) <--> s. Proof. firstorder. Qed. Lemma setU_setT_abs {U} (s : set U) : (s :|: setT) <--> setT. Proof. firstorder. Qed. Lemma setU_set_eq_compat {T} (s1 s2 s1' s2' : set T) : s1 <--> s1' -> s2 <--> s2' -> s1 :|: s2 <--> s1' :|: s2'. Proof. by firstorder. Qed. Lemma setU_set_subset_compat : forall (T : Type) (s1 s2 s1' s2' : set T), s1 \subset s1' -> s2 \subset s2' -> s1 :|: s2 \subset s1' :|: s2'. Proof. now firstorder. Qed. Lemma setU_set_incl_r : forall (T : Type) (s1 s2 s2' : set T), s1 \subset s2' -> s1 \subset s2 :|: s2'. Proof. now firstorder. Qed. Lemma setU_assoc {U} (s1 s2 s3 : set U) : (s1 :|: (s2 :|: s3)) <--> ((s1 :|: s2) :|: s3). Proof. firstorder. Qed. Lemma setI_assoc {U} (s1 s2 s3 : set U) : (s1 :&: (s2 :&: s3)) <--> ((s1 :&: s2) :&: s3). Proof. firstorder. Qed. Lemma setI_impl_l {T} (s1 s2 : set T) : s1 \subset s2 -> s1 :&: s2 <--> s1. Proof. firstorder. Qed. Lemma setI_impl_r {T} (s1 s2 : set T) : s2 \subset s1 -> s1 :&: s2 <--> s2. Proof. firstorder. Qed. Lemma setI_set0 {U} (s1 s2 : set U) : (forall x, s1 x -> ~ s2 x) -> (s1 :&: s2) <--> set0. Proof. intros; split; firstorder. Qed. Lemma setI_subset_compat {U} (s1 s2 s1' s2' : set U) : s1 \subset s1' -> s2 \subset s2' -> (s1 :&: s2) \subset (s1' :&: s2'). Proof. firstorder. Qed. Lemma setU_subset_r {U} (s1 s2 s3 : set U) : s1 \subset s3 -> s1 \subset (s2 :|: s3). Proof. firstorder. Qed. Lemma setU_subset_l {U} (s1 s2 s3 : set U) : s1 \subset s2 -> s1 \subset (s2 :|: s3). Proof. firstorder. Qed. Lemma setI_setU_distr {U} (s1 s2 s3 : set U) : ((s1 :|: s2) :&: s3) <--> ((s1 :&: s3) :|: (s2 :&: s3)). Proof. firstorder. Qed. (** Lemmas about [bigcap] *) Lemma bigcap_set0 (T U : Type) (F : T -> set U) : \bigcap_(x in set0) F x <--> setT. Proof. split. - move => _. constructor. - move => _ x H. inversion H. Qed. Lemma incl_bigcapl T U A B (F : T -> set U) : B \subset A -> \bigcap_(x in A) F x \subset \bigcap_(x in B) F x. Proof. by move => Hsub t Hcap x HB; eauto. Qed. Lemma eq_bigcapr (T U : Type) (A : set T) (F G : T -> set U) : (forall x : T, F x <--> G x) -> \bigcap_(x in A) F x <--> \bigcap_(x in A) G x. Proof. by move => H a; split; move => Ha b Hb; eapply H; eauto. Qed. Lemma eq_bigcapl T U A B (F : T -> set U) : A <--> B -> \bigcap_(x in A) F x <--> \bigcap_(x in B) F x. Proof. by move => H a; split; move => Ha b Hb; eapply Ha; eapply H; eauto. Qed. #[global] Instance eq_bigcap T U : Proper (set_eq ==> pointwise_relation T (@set_eq U) ==> set_eq) bigcap. Proof. move=> A B eqAB F G eqFG a. apply: (@set_eq_trans _ (\bigcap_(i in A) G i)). exact: eq_bigcapr. exact: eq_bigcapl. Qed. Lemma eq_bigcup' : forall (T U : Type) (A B : set T) (F G : T -> set U), A <--> B -> (forall x, F x <--> G x) -> \bigcup_(x in A) F x <--> \bigcup_(x in B) G x. Proof. intros. eapply eq_bigcup; eauto. Qed. Lemma incl_bigcup_compat : forall (T U : Type) (A B : set T) (F G : T -> set U), A \subset B -> (forall x : T, F x \subset G x) -> \bigcup_(x in A) F x \subset \bigcup_(x in B) G x. Proof. now firstorder. Qed. Lemma bigcap_setI_l {U T} (s1 s2 : set U) (f : U -> set T) : bigcap (s1 :|: s2) f <--> bigcap s1 f :&: bigcap s2 f. Proof. firstorder. Qed. Lemma bigcap_setU_l {U T} (s1 s2 : set U) (f : U -> set T) : bigcap s1 f \subset bigcap (s1 :&: s2) f. Proof. firstorder. Qed. Lemma bigcap_set1 {U T} (x : U) (f : U -> set T) : bigcap [set x] f <--> f x. Proof. split; move => H. eapply H. reflexivity. intros y Hy. inversion Hy. subst. assumption. Qed. Lemma bigcup_set0_r (T U : Type) (s : set T) (F : T -> set U) : (forall x, F x <--> set0) -> \bigcup_(x in s) F x <--> set0. Proof. firstorder. Qed. Lemma bigcup_set0_l_eq (T U : Type) (s : set T) (F : T -> set U) : s <--> set0 -> \bigcup_(x in s) F x <--> set0. Proof. firstorder. Qed. (** Lemmas about lists *) Lemma nil_set_eq {A : Type} : [::] <--> (@set0 A). Proof. split; move => H; eauto. Qed. Lemma cons_set_eq {A} (x : A) l : (x :: l) <--> [set x] :|: l. Proof. by []. Qed. Lemma singl_set_eq: forall (A : Type) (x : A), [ x ] <--> [ set x ]. Proof. intros A x x'; split; intros H. - inv H. reflexivity. now inv H0. - inv H. now constructor. Qed. Lemma incl_subset {A : Type} (l1 l2 : seq A) : incl l1 l2 -> l1 \subset l2. Proof. intros Hi x; eapply Hi. Qed. Lemma incl_hd_same {A : Type} (a : A) (l1 l2 : seq A) : incl l1 l2 -> incl (a :: l1) (a :: l2). Proof. intros Hin. firstorder. Qed. Lemma setI_bigcup_assoc {A B} (s1 : set B) (s2 : set A) (s3 : A -> set B) : s1 :&: (\bigcup_(x in s2) s3 x) <--> \bigcup_(x in s2) (s1 :&: (s3 x)). Proof. firstorder. Qed. Lemma cons_subset {A : Type} (x : A) (l : seq A) (P : set A) : P x -> l \subset P -> (x :: l) \subset P. Proof. intros Px Pl x' Hin. inv Hin; firstorder. Qed. Lemma nil_subset {A : Type} (P : set A) : [] \subset P. Proof. intros x H; inv H. Qed. Lemma imset_union_incl {U T : Type} (s1 s2 : set U) (f : U -> T) : f @: (s1 :|: s2) \subset (f @: s1) :|: (f @: s2). Proof. firstorder. Qed. Lemma imset_singl_incl {U T : Type} (x : U) (f : U -> T) : f @: [set x] \subset [set (f x)]. Proof. intros y Hin. destruct Hin as [y' [Hin1 Hin2]]. inv Hin1. inv Hin2. reflexivity. Qed. Lemma imset_set0_incl {U T : Type} (f : U -> T) : f @: set0 \subset set0. Proof. firstorder. Qed. Lemma set_eq_set_incl_r {U : Type} (s1 s2 : set U) : s1 <--> s2 -> s2 \subset s1. Proof. firstorder. Qed. Lemma set_eq_set_incl_l {U : Type} (s1 s2 : set U) : s1 <--> s2 -> s1 \subset s2. Proof. firstorder. Qed. Lemma rewrite_set_l {U : Type} (s1 s2 : set U) x : s1 x -> s1 <--> s2 -> s2 x. Proof. firstorder. Qed. Lemma rewrite_set_r {U : Type} (s1 s2 : set U) x : s2 x -> s1 <--> s2 -> s1 x. Proof. firstorder. Qed. Lemma imset_bigcup_incl_l : forall {T U V : Type} (f : U -> V) (A : set T) (F : T -> set U), f @: (\bigcup_(x in A) F x) \subset \bigcup_(x in A) f @: F x. Proof. firstorder. Qed. Lemma in_imset {U T} (f : U -> T) (S : set U) (x : T) : (f @: S) x -> exists y, x = f y. Proof. move => [y [H1 H2]]; eauto. Qed. Lemma union_lift_subset_compat {A} (s1 s2 : set (option A)) (s3 s4 : set A) : s1 \subset lift s3 -> s2 \subset lift s4 -> (s1 :|: s2) \subset lift (s3 :|: s4). Proof. firstorder. Qed. Lemma lift_subset_pres_l {A} (s1 : set (option A)) (s2 s3 : set A) : s1 \subset lift s2 -> s1 \subset lift (s2 :|: s3). Proof. firstorder. Qed. Lemma lift_subset_pres_r {A} (s1 : set (option A)) (s2 s3 : set A) : s1 \subset lift s3 -> s1 \subset lift (s2 :|: s3). Proof. firstorder. Qed. Lemma set_incl_setI_l {A} (s1 s2 s3 : set A) : s1 \subset s3 -> (s1 :&: s2) \subset s3. Proof. firstorder. Qed. Lemma set_incl_setI_r {A} (s1 s2 s3 : set A) : s2 \subset s3 -> (s1 :&: s2) \subset s3. Proof. firstorder. Qed. Lemma set_incl_setU_l {A} (s1 s2 s3 : set A) : s1 \subset s3 -> s2 \subset s3 -> (s1 :|: s2) \subset s3. Proof. firstorder. Qed. Lemma bigcup_set_I_l {A B} (s1 s2 : set A) (s3 : set B) (f : A -> set B) : \bigcup_(x in s1) (f x) \subset s3 -> \bigcup_(x in (s1 :&: s2)) (f x) \subset s3. Proof. firstorder. Qed. Lemma bigcup_set_U {A B} (s1 s2 : set A) (s3 : set B) (f : A -> set B) : \bigcup_(x in s1) (f x) \subset s3 -> \bigcup_(x in s2) (f x) \subset s3 -> \bigcup_(x in (s1 :|: s2)) (f x) \subset s3. Proof. firstorder. Qed. Lemma bigcup_set0_subset {A B} (s : set B) (f : A -> set B) : \bigcup_(x in set0) (f x) \subset s. Proof. firstorder. Qed. Lemma bigcup_cons_subset {A B} l (ls : seq A) (f : A -> set B) s : f l \subset s -> \bigcup_(x in ls) (f x) \subset s -> \bigcup_(x in l :: ls) (f x) \subset s. Proof. intros H1 H2 x [y [Hl Hr]]. inv Hl. - eauto. - eapply H2. eexists; split; eauto. Qed. Lemma bigcup_nil_subset {A B} (f : A -> set B) s : \bigcup_(x in []) (f x) \subset s. Proof. intros x [y [H1 H2]]. inv H1. Qed. Lemma option_subset {A} (s1 : set (option A)) : s1 \subset (isSome :&: s1) :|: [set None]. Proof. intros [x |]; firstorder. Qed. Lemma setU_l_subset {U} (s1 s2 s3 : set U) : s1 \subset s3 -> s2 \subset s3 -> (s1 :|: s2) \subset s3. Proof. firstorder. Qed. Lemma bigcup_lift_lift_bigcup {T U} (s1 : set T) (f : T -> set U) : \bigcup_(x in s1) (lift (f x)) \subset lift (\bigcup_(x in s1) (f x)). Proof. intros x [y [H1 [[z [H2 H3]] | H2]]]. + inv H3. left; eexists; split; eauto. eexists; split; eauto. + inv H2; now right. Qed. Lemma lift_subset_compat {U} (s1 s2 : set U) : s1 \subset s2 -> lift s1 \subset lift s2. Proof. firstorder. Qed. Lemma lift_set_eq_compat {U} (s1 s2 : set U) : s1 <--> s2 -> lift s1 <--> lift s2. Proof. firstorder. Qed. Lemma bigcup_setU_r: forall (U T : Type) (s : set U) (f g : U -> set T), \bigcup_(i in s) (f i :|: g i) <--> \bigcup_(i in s) f i :|: \bigcup_(i in s) g i. Proof. firstorder. Qed. Lemma lift_bigcup_comm : forall (U T : Type) (s : set U) (f : U -> set T), inhabited U -> lift (\bigcup_(i in [set : U]) (f i)) <--> \bigcup_(i in [set : U]) (lift (f i)). Proof. intros U T s f Hin. unfold lift. rewrite !bigcup_setU_r -!imset_bigcup. rewrite bigcup_const; eauto. reflexivity. Qed. Lemma bigcap_setU_distr: forall (U T : Type) (s1 s2 : set U) (f : U -> set T), \bigcap_(i in s1) f i :&: \bigcap_(i in s2) f i <--> \bigcap_(i in s1 :|: s2) f i. Proof. intros. split. - intros [ H1 H2 ] x [ H3 | H3 ]; eauto. - intros H. split; intros x H3; eapply H. now left. now right. Qed. Lemma setI_set_incl : forall (A : Type) (s1 s2 s3 : set A), s1 \subset s2 -> s1 \subset s3 -> s1 \subset s2 :&: s3. Proof. firstorder. Qed. Lemma imset_isSome {A} (s : set A) : Some @: s \subset isSome. Proof. intros y [x [Sx H]]. inv H. eauto. Qed. Lemma bigcup_cons_subset_r : forall (A B : Type) (l : A) (ls : seq A) (f : A -> set B) (s1 s2 : set B), s1 \subset f l -> s2 \subset \bigcup_(x in ls) f x -> s1 :|: s2 \subset \bigcup_(x in (l :: ls)) f x. Proof. intros A B l ls f s1 s2 H1 H2. apply setU_l_subset. - rewrite bigcup_setU_l bigcup_set1. eapply setU_subset_l. eassumption. - rewrite bigcup_setU_l bigcup_set1. eapply setU_subset_r. eassumption. Qed. Lemma bigcup_setI_cons_subset_r : forall (A B : Type) (l : A) (ls : seq A) (f : A -> set B) (s1 s2 : set B) (s3 : set A), s3 l -> s1 \subset f l -> s2 \subset \bigcup_(x in ls :&: s3) f x -> s1 :|: s2 \subset \bigcup_(x in (l :: ls) :&: s3) f x. Proof. intros A B l ls f s1 s2 s3 H1 H2 H3. apply setU_l_subset. - intros x Hs1. eexists l; split; eauto. split; eauto. left; eauto. - intros x Hs1. eapply H3 in Hs1. edestruct Hs1 as [x' [[Hs3 Hls] Hin]]. eexists x'; split; eauto. split; eauto. right; eauto. Qed. Lemma imset_union_set_eq: forall (U T : Type) (s1 s2 : set U) (f : U -> T), f @: (s1 :|: s2) <--> f @: s1 :|: f @: s2. Proof. intros U T s1 s2 f. firstorder. Qed. Lemma imset_bigcup_setI_cons_subset_r : forall (A B : Type) (l : A) (ls : seq A) (f : A -> set (option B)) (s1 s2 : set B) (s3 : set A), s3 l -> Some @: s1 \subset f l -> Some @: s2 \subset \bigcup_(x in ls :&: s3) f x -> Some @: (s1 :|: s2) \subset \bigcup_(x in (l :: ls) :&: s3) f x. Proof. intros A B l ls f s1 s2 s3 H1 H2 H3. rewrite imset_union_set_eq. apply setU_l_subset. - intros x Hs1. eexists l; split; eauto. split; eauto. left; eauto. - intros x Hs1. eapply H3 in Hs1. edestruct Hs1 as [x' [[Hs3 Hls] Hin]]. eexists x'; split; eauto. split; eauto. right; eauto. Qed. Lemma imset_set0_subset {A B} (f : A -> B) (s : set B) : (f @: set0) \subset s. Proof. firstorder. Qed. Lemma setI_set_eq_r {A : Type} (s1 s2 s2' : set A) : s2 <--> s2' -> (s1 :&: s2) <--> (s1 :&: s2'). Proof. intros. rewrite H; reflexivity. Qed. Lemma isSome_subset {A : Type} (s1 s2 s1' s2' : set (option A)) : isSome :&: s1 \subset isSome :&: s2 -> isSome :&: (s1 :|: ([set None] :&: s1')) \subset isSome :&: (s2 :|: ([set None] :&: s2')). Proof. intros Hyp x [H1 H2]. destruct x as [ x | ]; try discriminate. split; eauto. inv H2. left; eauto. eapply Hyp. now split; eauto. inv H. now inv H0. Qed. Lemma bigcup_nil_setI {A B} (f : A -> set B) (l : seq A) s : \bigcup_(x in [] :&: s) (f x) \subset \bigcup_(x in (l :&: s)) (f x). Proof. intros z [y [[Hin1 _] Hin2]]. inv Hin1. Qed. Lemma isSome_set_eq {A} (s : set (option A)) (s' : set A) : s \subset (Some @: s') :|: [set None] -> Some @: s' \subset s -> isSome :&: s <--> Some @: s'. Proof. intros H1 H2 x; split. - intros [H3 H4]. destruct x; try discriminate. eapply H1 in H4. inv H4; try discriminate. eassumption. - intros [y [H3 H4]]. inv H4. split. now eauto. eapply H2. eexists; split; eauto. Qed. Lemma set_eq_isSome_sound {A} (s : set (option A)) (s' : set A) : isSome :&: s <--> Some @: s' -> s \subset (Some @: s') :|: [set None]. Proof. intros H [x| ] Hin. - left. eapply H. eexists; eauto. - right; reflexivity. Qed. Lemma set_eq_isSome_complete {A} (s : set (option A)) (s' : set A) : isSome :&: s <--> Some @: s' -> Some @: s' \subset s. Proof. intros H. rewrite <- H. firstorder. Qed. Definition somes {A} (s : set (option A)) : set A := [set x | Some x \in s]. Lemma somes_subset {A} (s1 s2 : set (option A)) : s1 \subset s2 -> somes s1 \subset somes s2. Proof. intros Hs a. apply Hs. Qed. Lemma bigcup_somes {A B} (sA : set A) (s : A -> set (option B)) : somes (\bigcup_(a in sA) s a) <--> \bigcup_(a in sA) somes (s a). Proof. intro b; split; intros [a Ha]; eexists a; auto. Qed. #[global] Instance proper_somes A : Morphisms.Proper (set_eq ==> set_eq) (@somes A). Proof. firstorder. Qed. Lemma bigcup_setI {T U} (s1 : set T) (s2 : set U) F : \bigcup_(x in s1) (s2 :&: F x) <--> s2 :&: \bigcup_(x in s1) (F x). Proof. firstorder. Qed. Lemma incl_bigcup_compat_list (T U : Type) (h1 h2 : T) (t1 t2 : list T) (F G : T -> set U) : F h1 \subset G h2 -> \bigcup_(x in t1) F x \subset \bigcup_(x in t2) G x -> \bigcup_(x in h1 :: t1) F x \subset \bigcup_(x in h2 :: t2) G x. Proof. intros Hs1 Hs2. intros x Hin. inv Hin. inv H. inv H0. - eexists. split. now left. eauto. - edestruct Hs2. eexists. split; eauto. destruct H3. eexists. split. now right; eauto. eassumption. Qed. Lemma incl_bigcup_list_tl (T U : Type) (h : T) (t : list T) (G : T -> set U) s : s \subset \bigcup_(x in t) G x -> s \subset \bigcup_(x in h :: t) G x. Proof. intros Hyp x Hin. eapply Hyp in Hin. inv Hin. inv H. eexists. split. now right; eauto. eauto. Qed. Lemma incl_bigcup_list_hd (T U : Type) (h : T) (t : list T) (G : T -> set U) s : s \subset G h -> s \subset \bigcup_(x in h :: t) G x. Proof. intros Hyp x Hin. eapply Hyp in Hin. eexists. split. now left. eauto. Qed. Lemma incl_bigcup_list_nil (T U : Type) (G : T -> set U) s : \bigcup_(x in [::]) G x \subset s. Proof. intros x Hin. inv Hin. inv H. inv H0. Qed. Lemma in_bigcup_list_hd (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U) : G h z -> (\bigcup_(x in (h :: t)) G x) z. Proof. intros Hin. eapply incl_bigcup_list_hd. now eapply subset_refl. eassumption. Qed. Lemma in_bigcup_list_tl (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U) : (\bigcup_(x in t) G x) z -> (\bigcup_(x in (h :: t)) G x) z. Proof. intros Hin. eapply incl_bigcup_list_tl. now eapply subset_refl. eassumption. Qed. Lemma in_bigcup_list_cons (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U) : (\bigcup_(x in (h :: t)) G x) z -> G h z \/ (\bigcup_(x in t) G x) z. Proof. intros Hin. inv Hin. inv H. inv H0; eauto. right. eexists; split; eauto. Qed. Lemma bigcup_nil_set0 (T U : Type) (F : T -> set U) : \bigcup_(x in [::]) F x <--> set0. Proof. split; intros Hin; inv Hin; eauto. inv H. inv H0. Qed. Lemma incl_bigcup_compat_list_inter (T U : Type) (h1 h2 : T) (t1 t2 : seq T) (F G : T -> set U) S : S :&: F h1 \subset S :&: G h2 -> S :&: \bigcup_(x in t1) F x \subset S :&: \bigcup_(x in t2) G x -> S :&: \bigcup_(x in (h1 :: t1)) F x \subset S :&: \bigcup_(x in (h2 :: t2)) G x. Proof. intros Hs1 Hs2. intros x Hin. inv Hin. constructor; eauto. inv H0. inv H1. inv H2. - eexists. split. now left. eapply Hs1. split; eauto. - edestruct Hs2. split. eassumption. eexists. split; eauto. destruct H6. destruct H6. eexists. split. right; eauto. eassumption. Qed. Lemma incl_bigcup_list_tl_inter {T U : Type} (h : T) (t : list T) (G : T -> set U) s S : s \subset S :&: (\bigcup_(x in t) G x) -> s \subset S :&: (\bigcup_(x in h :: t) G x). Proof. intros Hyp x Hin. eapply Hyp in Hin. inv Hin. inv H0. inv H1. split. eassumption. eexists. split. now right; eauto. eauto. Qed. Lemma incl_bigcup_compat_list_eq (T U : Type) (h1 h2 : T) (t1 t2 : list T) (F G : T -> set U) : F h1 <--> G h2 -> \bigcup_(x in t1) F x <--> \bigcup_(x in t2) G x -> \bigcup_(x in h1 :: t1) F x <--> \bigcup_(x in h2 :: t2) G x. Proof. intros Hs1 Hs2. split; eapply incl_bigcup_compat_list. - rewrite Hs1. eapply subset_refl. - rewrite Hs2. eapply subset_refl. - rewrite Hs1. eapply subset_refl. - rewrite Hs2. eapply subset_refl. Qed. QuickChick-2.1.0/src/Show.v000066400000000000000000000210071476030541200154300ustar00rootroot00000000000000From Coq Require Import Ascii Basics Decimal List String ZArith. Import ListNotations. Local Open Scope program_scope. Local Open Scope string_scope. Export Coq.Strings.String.StringSyntax. (* This makes just the [%string] key available to [Derive Show]. *) Delimit Scope string_scope with string. Record Time : Set := mkTime {time: nat}. Record AugmentedTime (A: Type) := mkAugTime { aug_res : A; aug_time : Time }. Definition newline := String "010" ""%string. Class Show (A : Type) : Type := { show : A -> string }. Fixpoint show_uint (n : uint) : string := match n with | Nil => "" | D0 n => String "0" (show_uint n) | D1 n => String "1" (show_uint n) | D2 n => String "2" (show_uint n) | D3 n => String "3" (show_uint n) | D4 n => String "4" (show_uint n) | D5 n => String "5" (show_uint n) | D6 n => String "6" (show_uint n) | D7 n => String "7" (show_uint n) | D8 n => String "8" (show_uint n) | D9 n => String "9" (show_uint n) end. Definition show_int (n : int) : string := match n with | Pos n => show_uint n | Neg n => String "-" (show_uint n) end. Definition show_nat (n : nat) : string := show_uint (Nat.to_uint n). Definition show_bool (b : bool) : string := match b with | true => "true" | false => "false" end. Definition show_Z (n : Z) : string := show_int (Z.to_int n). Definition show_N : N -> string := show_Z ∘ Z.of_N. #[global] Instance showUint : Show uint := {| show := show_uint |}. #[global] Instance showInt : Show int := {| show := show_int |}. #[global] Instance showNat : Show nat := {| show := show_nat |}. #[global] Instance showBool : Show bool := {| show := show_bool |}. #[global] Instance showZ : Show Z := {| show := show_Z |}. #[global] Instance showN : Show N := {| show := show_N |}. Fixpoint from_list (s : list ascii) : string := match s with | [] => EmptyString | c :: s' => String c (from_list s') end. Definition unit_digit (n : nat) : ascii := ascii_of_nat ((n mod 10) + 48 (* 0 *)). Definition three_digit (n : nat) : string := let n0 := unit_digit n in let n1 := unit_digit (n / 10) in let n2 := unit_digit (n / 100) in from_list [n2; n1; n0]. Definition digit_of_ascii (c : ascii) : option nat := let n := nat_of_ascii c in if ((48 <=? n)%nat && (n <=? 57)%nat)%bool then Some (n - 48) else None. Definition unthree_digit (c2 c1 c0 : ascii) : option ascii := let doa := digit_of_ascii in match doa c2, doa c1, doa c0 with | Some n2, Some n1, Some n0 => Some (ascii_of_nat (n2 * 100 + n1 * 10 + n0)) | _, _, _ => None end. Fixpoint show_quoted_string (s:string) : string := match s with | EmptyString => """" | String c s' => let quoted_s' := show_quoted_string s' in let n := nat_of_ascii c in if ascii_dec c "009" (* TAB *) then "\t" ++ quoted_s' else if ascii_dec c "010" (* NEWLINE *) then "\n" ++ quoted_s' else if ascii_dec c "013" (* CARRIAGE RETURN *) then "\r" ++ quoted_s' else if ascii_dec c """" (* DOUBLEQUOTE *) then "\""" ++ quoted_s' else if ascii_dec c "\" (* BACKSLASH *) then "\\" ++ quoted_s' else if ((n """\n\014a\127""" *) Fixpoint read_quoted_string (s : string) : option string := match s with | String c s' => if ascii_dec c """" then match s' with | EmptyString => Some EmptyString | _ => None end else if ascii_dec c "\" then match s' with | String c2 s'' => if ascii_dec c2 "n" then option_map (String "010") (read_quoted_string s'') else if ascii_dec c2 "r" then option_map (String "013") (read_quoted_string s'') else if ascii_dec c2 "t" then option_map (String "009") (read_quoted_string s'') else if ascii_dec c2 "\" then option_map (String "\") (read_quoted_string s'') else if ascii_dec c2 """" then option_map (String """") (read_quoted_string s'') else match s'' with | String c1 (String c0 s''') => match unthree_digit c2 c1 c0 with | Some c' => option_map (String c') (read_quoted_string s''') | None => None end | _ => None end | _ => None end else option_map (String c) (read_quoted_string s') | _ => None end. Definition read_string (s : string) : option string := match s with | EmptyString => None | String c s' => read_quoted_string s' end. Fixpoint contents {A : Type} (s : A -> string) (l : list A) : string := match l with | nil => ""%string | cons h nil => s h | cons h t => append (append (s h) "; ") (contents s t) end. #[global] Instance showList {A : Type} `{_ : Show A} : Show (list A) := {| show l := append "[" (append (contents show l) "]") |}. #[global] Instance show_time : Show Time := {| show t := """time"": " ++ ( let s := (show (time t)) in let len := length s in """" ++ (substring 0 (len - 3) s) ++ "." ++ (substring (len-3) len s) ++ "ms""" ) |}. #[global] Instance show_augmented_time {A : Type} `{_ : Show A} : Show (AugmentedTime A) := {| show aut := match aut with mkAugTime _ res tAux => (show (res) ++ ", " ++ show (tAux))%string end |}. #[global] Instance showPair {A B : Type} `{_ : Show A} `{_ : Show B} : Show (A * B) := {| show p := match p with (a,b) => ("(" ++ show a ++ ", " ++ show b ++ ")")%string end |}. #[global] Instance showOpt {A : Type} `{_ : Show A} : Show (option A) := {| show x := match x with | Some x => "Some " ++ (show x) | None => "None" end |}. #[global] Instance showType : Show Type := {| show x := "nat :-)" |}. #[global] Instance showEx {A} `{_ : Show A} P : Show ({x : A | P x}) := {| show ex := let '(exist _ x _) := ex in show x |}. Require Import Ascii. Definition nl : string := String "010" EmptyString. Definition smart_paren (s : string) : string := let fix aux s (b : bool) := match s with | EmptyString => (if b then ")" else "", b) | String a s => let (s', b) := aux s (orb b (nat_of_ascii a =? 32)%nat) in (String a s', b) end in let (s', b) := aux s false in if b then "(" ++ s' else s'. Module ShowFunctions. Class ReprSubset (A : Type) := { representatives : list A }. #[global] Instance repr_bool : ReprSubset bool := {| representatives := [ true; false ] |}. #[global] Instance repr_nat : ReprSubset nat := {| representatives := [ 0 ; 1 ; 2 ; 17 ; 42 ] |}. #[global] Instance repr_option {A} `{_ : ReprSubset A} : ReprSubset (option A) := {| representatives := None :: map Some representatives |}. #[global] Instance repr_list {A} `{_ : ReprSubset A} : ReprSubset (list A) := {| representatives := [] :: map (fun x => [x]) representatives ++ flat_map (fun x : A => map (fun y : A => [x;y]) representatives ) representatives |}%list. #[global] Instance repr_prod {A B} `{_ : ReprSubset A} `{_ : ReprSubset B} : ReprSubset (A * B) := {| representatives := flat_map (fun x : A => map (fun y : B => (x,y)) representatives ) representatives |}. Fixpoint prepend {A : Type} (a : A) (l : list A) := match l with | [] => [] | h::t => a :: h :: prepend a t end. Definition intersperse {A : Type} (a : A) (l : list A) := match l with | [] => [] | h::t => h :: prepend a t end. Definition string_concat (l : list string) : string := fold_left (fun a b => a ++ b) l "". #[global] Instance show_fun {A B} `{_ : Show A} `{_ : ReprSubset A} `{_ : Show B} : Show (A -> B) := {| show f := "{ " ++ string_concat (intersperse " , " (map (fun x => show x ++ " |-> " ++ show (f x)) (@representatives A _))) ++ " }" |}. End ShowFunctions. (* Extraction will map this to something that additionally prints stuff *) Definition trace {A : Type} (s : string) (a : A) : A := a. Definition deprecate {A : Type} (old new: string) (a : A) : A := trace ("Deprecated function: " ++ old ++ ". Use " ++ new ++ " instead.") a. QuickChick-2.1.0/src/ShowFacts.v000066400000000000000000000102201476030541200164040ustar00rootroot00000000000000From Coq Require Import List String Ascii Lia Arith. Import ListNotations. From QuickChick Require Import Compat Show. (* Proof that Show for string round-trips. *) Lemma not_digit_when (c : ascii) (x : nat) : (nat_of_ascii c < 48) \/ (57 < nat_of_ascii c) -> unit_digit x <> c. Proof. assert (mod_fact : x mod 10 < 10). { apply Nat.mod_upper_bound; auto. } intros H e. unfold unit_digit in e. apply (f_equal nat_of_ascii) in e. rewrite nat_ascii_embedding in e. all: lia. Qed. Lemma unit_digit_ascii : forall n, digit_of_ascii (unit_digit n) = Some (n mod 10). Proof. intro. assert (mod_fact : n mod 10 < 10). { apply Nat.mod_upper_bound; auto. } unfold unit_digit. unfold digit_of_ascii. rewrite nat_ascii_embedding. replace (48 <=? n mod 10 + 48) with true. replace (n mod 10 + 48 <=? 57) with true. rewrite Nat.add_sub. auto. { symmetry. apply leb_correct. lia. } { symmetry. apply leb_correct. lia. } { lia. } Qed. Lemma decimal_thousand : forall n, n < 256 -> (n / 100) mod 10 * 100 + (n / 10) mod 10 * 10 + n mod 10 = n. Proof. intros. rewrite Nat.div_mod with (y:=10); auto. rewrite Nat.add_cancel_r. replace 100 with (10*10) by auto. rewrite Nat.mul_assoc. rewrite <- Nat.mul_add_distr_r. rewrite Nat.mul_comm. rewrite Nat.mul_cancel_l; auto. rewrite <- Nat.div_div. rewrite (Nat.div_mod (n/10) 10) at 3; auto. rewrite Nat.add_cancel_r. rewrite Nat.mul_comm. rewrite Nat.mul_cancel_l; auto. rewrite Nat.mod_small; auto. rewrite Nat.div_div. simpl. rewrite (Nat.div_lt_upper_bound n 100 9); auto. lia. Qed. Lemma unthree_three_digit (c : ascii) : let n := nat_of_ascii c in unthree_digit (unit_digit (n / 100)) (unit_digit (n / 10)) (unit_digit n) = Some (ascii_of_nat n). Proof. unfold unthree_digit. do 3 rewrite unit_digit_ascii. rewrite decimal_thousand. auto. apply nat_ascii_bounded. Qed. Lemma read_show_quoted_string : forall (s : string), read_quoted_string (show_quoted_string s) = Some s. Proof. induction s. - auto. - unfold show_quoted_string. destruct (ascii_dec a "009") as [is_tab | isn_tab]. { fold show_quoted_string. simpl. rewrite IHs. rewrite is_tab; auto. } destruct (ascii_dec a "010") as [is_nl | isn_nl]. { fold show_quoted_string. simpl; rewrite IHs. rewrite is_nl; auto. } destruct (ascii_dec a "013") as [is_cr | isn_cr]. { fold show_quoted_string. simpl; rewrite IHs. rewrite is_cr; auto. } destruct (ascii_dec a """") as [is_dq | isn_dq]. { fold show_quoted_string. simpl; rewrite IHs. rewrite is_dq; auto. } destruct (ascii_dec a "\") as [is_bs | isn_bs]. { fold show_quoted_string. simpl; rewrite IHs. rewrite is_bs; auto. } destruct ((nat_of_ascii a nat -> nat ; numSuccessTests : nat ; numDiscardedTests : nat ; labels : Map.t nat ; expectedFailure : bool ; randomSeed : RandomSeed ; numSuccessShrinks : nat ; numTryShrinks : nat ; stDoAnalysis : bool }. Definition updTryShrinks (st : State) (f : nat -> nat) : State := match st with | MkState mst mdt ms cs nst ndt ls e r nss nts ana => MkState mst mdt ms cs nst ndt ls e r nss (f nts) ana end. Definition updSuccessShrinks (st : State) (f : nat -> nat) : State := match st with | MkState mst mdt ms cs nst ndt ls e r nss nts ana => MkState mst mdt ms cs nst ndt ls e r (f nss) nts ana end. Definition updSuccTests st f := match st with | MkState mst mdt ms cs nst ndt ls e r nss nts ana => MkState mst mdt ms cs (f nst) ndt ls e r nss nts ana end. Definition updDiscTests st f := match st with | MkState mst mdt ms cs nst ndt ls e r nss nts ana => MkState mst mdt ms cs nst (f ndt) ls e r nss nts ana end. QuickChick-2.1.0/src/StringOT.v000066400000000000000000000126541476030541200162310ustar00rootroot00000000000000(* Ordering code by Antal :) *) (* CH: We already have a similar class in RandomQC.v, why not use that one instead (maybe after moving it to separate file)? *) Require Import OrderedType. Require Import Bool. Module BoolOT <: OrderedType. Definition t := bool. Definition eq := @Logic.eq bool. Definition eq_refl := @Logic.eq_refl bool. Definition eq_sym := @Logic.eq_sym bool. Definition eq_trans := @Logic.eq_trans bool. Definition eq_dec := bool_dec. Definition lt (b1 b2 : bool) : Prop := b1 = false /\ b2 = true. Theorem lt_trans : forall x y z : bool, lt x y -> lt y z -> lt x z. Proof. unfold lt; tauto. Qed. Theorem lt_not_eq : forall x y : bool, lt x y -> ~ eq x y. Proof. unfold lt, eq; intuition; congruence. Qed. Definition compare : forall x y : bool, Compare lt eq x y. Proof. unfold lt, eq; repeat (let b := fresh in intros b; destruct b); [apply EQ | apply GT | apply LT | apply EQ]; auto. Defined. End BoolOT. Require Import Ascii NArith. Module AsciiOT <: OrderedType. Definition t := ascii. Definition eq := @Logic.eq ascii. Definition eq_refl := @Logic.eq_refl ascii. Definition eq_sym := @Logic.eq_sym ascii. Definition eq_trans := @Logic.eq_trans ascii. Definition eq_dec := ascii_dec. Definition lt (c d : ascii) : Prop := (N_of_ascii c < N_of_ascii d)%N. Theorem lt_trans : forall c d e : ascii, lt c d -> lt d e -> lt c e. Proof. intros *; unfold lt; apply N.lt_trans. Qed. Theorem lt_not_eq : forall c d : ascii, lt c d -> ~ eq c d. Proof. unfold lt, eq; red; intros; assert (N_of_ascii c = N_of_ascii d) as eq' by (f_equal; assumption); generalize dependent eq'; apply N.lt_neq; assumption. Qed. Definition compare : forall c d : t, Compare lt eq c d. Proof. unfold lt, eq; intros; remember (N_of_ascii c ?= N_of_ascii d)%N as C; symmetry in HeqC; destruct C; [ apply EQ; replace c with (ascii_of_N (N_of_ascii c)) by apply ascii_N_embedding; replace d with (ascii_of_N (N_of_ascii d)) by apply ascii_N_embedding; f_equal; apply N.compare_eq | apply LT | apply GT; apply N.gt_lt]; assumption. Defined. End AsciiOT. Require Import Coq.Strings.String. Module StringOT <: OrderedType. Definition t := string. Definition eq := @Logic.eq string. Definition eq_refl := @Logic.eq_refl string. Definition eq_sym := @Logic.eq_sym string. Definition eq_trans := @Logic.eq_trans string. Definition eq_dec := string_dec. Inductive SOrdering := SLT | SEQ | SGT. Fixpoint strcmp (s1 s2 : string) : SOrdering := match s1, s2 with | EmptyString, EmptyString => SEQ | EmptyString, String _ _ => SLT | String _ _, EmptyString => SGT | String ch1 s1', String ch2 s2' => match AsciiOT.compare ch1 ch2 with | LT _ => SLT | EQ _ => strcmp s1' s2' | GT _ => SGT end end. Definition lt (s1 s2 : string) := strcmp s1 s2 = SLT. Local Ltac do_ascii_lt_trans := match goal with | [ _ : AsciiOT.lt ?c1 ?c2 , _ : AsciiOT.lt ?c2 ?c3 |- _ ] => assert (AsciiOT.lt c1 c3) by (eapply AsciiOT.lt_trans; eauto) end. Local Ltac not_ascii_lt_refl := match goal with | [ _ : AsciiOT.lt ?c ?c |- _ ] => assert (c <> c) by (apply AsciiOT.lt_not_eq; assumption); congruence end. Theorem lt_trans : forall s1 s2 s3 : string, lt s1 s2 -> lt s2 s3 -> lt s1 s3. Proof. unfold lt; intros s1 s2; generalize dependent s1; induction s2 as [| c2 s2']. (* s2 = "" *) destruct s1; [trivial | simpl; congruence]. (* s2 <> "" *) destruct s1 as [| c1 s1']; simpl. (* s1 = "" *) destruct s3; [congruence | trivial]. (* s1 <> "" *) destruct s3 as [| c3 s3']; [congruence |]. (* s3 <> "" *) destruct (AsciiOT.compare c1 c2) as [? | ? | ?] eqn:?; destruct (AsciiOT.compare c2 c3) as [? | ? | ?] eqn:?; destruct (AsciiOT.compare c1 c3) as [? | ? | ?] eqn:?; unfold AsciiOT.eq in *; subst; solve [ apply IHs2' | congruence | repeat (try not_ascii_lt_refl; do_ascii_lt_trans) ]. Qed. Theorem lt_not_eq : forall s1 s2 : string, lt s1 s2 -> ~ eq s1 s2. Proof. unfold lt, eq; induction s1 as [| c1 s1']. (* s1 = "" *) destruct s2; simpl; congruence. (* s1 <> "" *) destruct s2 as [| c2 s2']; simpl. (* s2 = "" *) congruence. (* s2 <> "" *) destruct (AsciiOT.compare c1 c2) as [? | ? | ?] eqn:?; intros Hc Heq; inversion Heq. (* c1 < c2 *) subst; not_ascii_lt_refl. (* c1 = c2 *) apply IHs1' in Hc; apply Hc; assumption. (* c1 > c2 *) congruence. Qed. Theorem compare : forall s1 s2 : t, Compare lt eq s1 s2. Proof. unfold lt, eq; induction s1 as [| c1 s1']. (* s1 = "" *) destruct s2; [apply EQ | apply LT]; auto. (* s1 <> "" *) destruct s2 as [| c2 s2']; [apply GT; auto | ]. destruct (AsciiOT.compare c1 c2) as [? | ? | ?] eqn:Hcmp. (* c1 < c2 *) apply LT; simpl; rewrite Hcmp; auto. (* c1 = c2 *) unfold AsciiOT.eq in *; subst. destruct (IHs1' s2'); [apply LT | apply EQ | apply GT]; first [ simpl; rewrite Hcmp; assumption | subst; reflexivity ]. (* c1 > c2 *) apply GT; simpl. destruct (AsciiOT.compare c2 c1) as [? | ? | ?] eqn:Hcmp'. reflexivity. unfold AsciiOT.eq in *; subst; not_ascii_lt_refl. do_ascii_lt_trans; not_ascii_lt_refl. Defined. End StringOT. QuickChick-2.1.0/src/Tactics.v000066400000000000000000000023671476030541200161120ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". From Coq Require Import ZArith Lia ssreflect ssrfun ssrbool. From mathcomp Require Import ssrnat eqtype seq. Ltac inv H := inversion H; subst. (* lia for ssrnat, taken from https://github.com/pi8027/formalized-postscript/blob/master/stdlib_ext.v *) Ltac arith_hypo_ssrnat2coqnat := match goal with | H : context [andb _ _] |- _ => let H0 := fresh in case/andP: H => H H0 | H : context [orb _ _] |- _ => case/orP: H => H | H : context [?L <= ?R] |- _ => move/leP: H => H | H : context [?L < ?R] |- _ => move/ltP : H => H | H : context [?L == ?R] |- _ => move/eqP : H => H | H : context [addn ?L ?R] |- _ => rewrite -plusE in H | H : context [muln ?L ?R] |- _ => rewrite -multE in H | H : context [subn ?L ?R] |- _ => rewrite -minusE in H end. Ltac arith_goal_ssrnat2coqnat := rewrite ?NatTrec.trecE -?plusE -?minusE -?multE -?leqNgt -?ltnNge; repeat match goal with | |- is_true (andb _ _) => apply/andP; split | |- is_true (orb _ _) => try apply/orP | |- is_true (_ <= _) => try apply/leP | |- is_true (_ < _) => try apply/ltP end. Ltac ssromega := repeat arith_hypo_ssrnat2coqnat; arith_goal_ssrnat2coqnat; simpl; lia. QuickChick-2.1.0/src/TacticsUtil.v.cppo000066400000000000000000000070261476030541200177050ustar00rootroot00000000000000Require Import String. Require Import List. Require Import RoseTrees. Require Import Show. Require Import State. Require Import Producer Generators. Require Import Classes. Require Import DependentClasses. Require Import Tactics. From Ltac2 Require Import Ltac2. From Ltac2 Require Import Message. From Ltac2 Require Import Constr. #if COQ_VERSION >= (8, 21, 0) Ltac2 ltac1_congruence () := Ltac1.run (Ltac1.ref [ident:(Stdlib); ident:(Init); ident:(Prelude); ident:(congruence)]). #else Ltac2 ltac1_congruence () := Ltac1.run (Ltac1.ref [ident:(Coq); ident:(Init); ident:(Prelude); ident:(congruence)]). #endif Ltac2 Notation "congruence" := ltac1_congruence (). (* From https://github.com/tchajed/coq-ltac2-experiments/blob/master/src/Ltac2Lib.v *) Local Ltac2 inv_tac (h: ident) := Std.inversion Std.FullInversion (Std.ElimOnIdent h) None None; subst; Std.clear [h]. Ltac2 Notation "inv" h(ident) := inv_tac h. Local Ltac2 exfalso_tac () := ltac1:(exfalso). Ltac2 Notation "exfalso" := exfalso_tac (). Local Ltac2 lia_ltac1 () := ltac1:(Lia.lia). Ltac2 Notation "lia" := lia_ltac1 (). Ltac2 inv := fun (h : ident) => inversion h; subst. Ltac2 eassumption_ltac2 () := ltac1:(eassumption). Ltac2 Notation "eassumption" := eassumption_ltac2 (). Ltac2 tci_ltac (_ : unit) := now eauto 20 with typeclass_instances. Ltac2 Notation "tci" := tci_ltac (). Ltac2 print_string (s : string) := Message.print (Message.of_string s). Ltac2 print_kind (p : constr) := match Constr.Unsafe.kind p with | Constr.Unsafe.Rel _ => print_string "Rel" | Constr.Unsafe.Var _ => print_string "Var" | Constr.Unsafe.Meta _ => print_string "Meta" | Constr.Unsafe.Evar _ _ => print_string "Evar" | Constr.Unsafe.Sort _ => print_string "Sort" | Constr.Unsafe.Cast _ _ _ => print_string "Case" | Constr.Unsafe.Prod _ _ => print_string "Prod" | Constr.Unsafe.Lambda _ _ => print_string "Lambda" | Constr.Unsafe.LetIn _ _ _ => print_string "Letin" | Constr.Unsafe.App _ _ => print_string "App" | Constr.Unsafe.Constant _ _ => print_string "Constant" | Constr.Unsafe.Ind _ _ => print_string "Ind" | Constr.Unsafe.Constructor _ _ => print_string "Constructor" | Constr.Unsafe.Case _ _ _ _ _ => print_string "Case" | Constr.Unsafe.Fix _ _ _ _ => print_string "fix" | Constr.Unsafe.CoFix _ _ _ => print_string "Cofix" #if COQ_VERSION >= (8, 19, 0) | Constr.Unsafe.Proj _ _ _ => print_string "Proj" #else | Constr.Unsafe.Proj _ _ => print_string "Proj" #endif | Constr.Unsafe.Uint63 _ => print_string "Uint63" | Constr.Unsafe.Float _ => print_string "Float" #if COQ_VERSION >= (8, 20, 0) | Constr.Unsafe.String _ => print_string "String" #endif | Constr.Unsafe.Array _ _ _ _ => print_string "Array" end. Ltac2 constr_to_ident (a : Init.constr) := match Constr.Unsafe.kind a with | Constr.Unsafe.Var i => i | _ => Control.throw (Tactic_failure (Some (Message.of_string ("constr is not a var")))) end. Ltac2 constrs_to_idents (a : Init.constr list) := List.map constr_to_ident a. Ltac simplstar := simpl in *. Ltac2 id_of_string (s : string) := match Ident.of_string s with | Some i => i | None => Control.throw (Tactic_failure (Some (Message.of_string ("Not a valid string for identifier")))) end. Ltac2 print_constr (c : constr) := Message.print (Message.of_constr c). Ltac2 print_str (c : string) := Message.print (Message.of_string c). Local Ltac2 ssromega_tac () := ltac1:(ssromega). Ltac2 Notation "ssromega" := ssromega_tac (). Ltac2 clear_dependent (x : ident) := let x := Control.hyp x in ltac1:(x |- clear dependent x) (Ltac1.of_constr x). QuickChick-2.1.0/src/Test.v000066400000000000000000000533651476030541200154430ustar00rootroot00000000000000From Coq Require Import Bool ZArith Ascii String List. Import ListNotations. From ExtLib Require Import Structures.Monad. Import MonadNotation. Local Open Scope monad_scope. From SimpleIO Require Import SimpleIO. From QuickChick Require Import RoseTrees RandomQC Generators Producer SemChecker. From QuickChick Require Import Show Checker State Classes. Definition gte n m := Nat.leb m n. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Set Bullet Behavior "Strict Subproofs". Record Args := MkArgs { replay : option (RandomSeed * nat); maxSuccess : nat; maxDiscard : nat; maxShrinks : nat; maxSize : nat; chatty : bool; analysis : bool }. Definition updMaxSize (a : Args) (x : nat) : Args := let '(MkArgs r msc md msh msz c an) := a in MkArgs r msc md msh x c an. Definition updMaxSuccess (a : Args) (x : nat) : Args := let '(MkArgs r msc md msh msz c an) := a in MkArgs r x md msh msz c an. Definition updAnalysis (a : Args) (b : bool) : Args := let '(MkArgs r msc md msh msz c an) := a in MkArgs r msc md msh msz c b. Inductive Result := | Success : nat -> nat -> list (string * nat) -> string -> Result | GaveUp : nat -> list (string * nat) -> string -> Result | Failure : nat -> nat -> nat -> RandomSeed -> nat -> string -> list (string * nat) -> string -> Result | NoExpectedFailure : nat -> list (string * nat) -> string -> Result. Definition isSuccess (r : Result) : bool := match r with | Success _ _ _ _ => true | _ => false end. (* Representing large constants in Coq is not a good idea... :) *) Axiom defNumTests : nat. Extract Constant defNumTests => "10000". Axiom defNumDiscards : nat. Extract Constant defNumDiscards => "(2 * defNumTests)". Axiom defNumShrinks : nat. Extract Constant defNumShrinks => "1000". Axiom defSize : nat. Extract Constant defSize => "7". Definition doAnalysis := false. Definition stdArgs := MkArgs None defNumTests defNumDiscards defNumShrinks defSize true doAnalysis. Definition roundTo n m := (n / m) * m. (* This matches the formula in Haskell QuickCheck *) Definition computeSize'' (maxSize_ maxSuccess_ n d : nat) : nat := if (roundTo n maxSize_ + maxSize_ <=? maxSuccess_) || (maxSuccess_ <=? n) || (maxSuccess_ mod maxSize_ =? 0) then min (n mod maxSize_ + d / 10) maxSize_ else min ((n mod maxSize_) * maxSize_ / (maxSuccess_ mod maxSize_ + d / 10)) maxSize_. Definition computeSize' (a : Args) (n : nat) (d : nat) : nat := computeSize'' (maxSize a) (maxSuccess a) n d. Definition at0 (f : nat -> nat -> nat) (s : nat) (n d : nat) := if andb (Nat.eqb n 0) (Nat.eqb d 0) then s else f n d. Fixpoint prependToAll {A : Type} (sep : A) (ls : list A) : list A := match ls with | nil => nil | h :: t => sep :: h :: prependToAll sep t end. Definition intersperse {A : Type} (sep : A) (ls : list A) : list A := match ls with | nil => nil | h :: t => h :: prependToAll sep t end. Definition notNull (ls : list string) : bool := match ls with | nil => false | _ => true end. Fixpoint insertBy A (compare : A -> A -> bool) (x : A) (l : list A) : list A := match l with | nil => x :: nil | h :: t => if compare x h then x :: l else h :: insertBy compare x t end. Fixpoint insSortBy A (compare : A -> A -> bool) (l : list A) : list A := match l with | nil => nil | h :: t => insertBy compare h (insSortBy compare t) end. Fixpoint concatStr (l : list string) : string := match l with | nil => "" | (h :: t) => h ++ concatStr t end%string. Definition summary (st : State) : list (string * nat) := let res := Map.fold (fun key elem acc => (key,elem) :: acc) (labels st) nil in insSortBy (fun x y => snd y <=? snd x) res. Definition doneTesting (st : State) : Result := if expectedFailure st then Success (numSuccessTests st + 1) (numDiscardedTests st) (summary st) ( if (stDoAnalysis st) then ("""result"": ""success"", ""tests"": " ++ (show (numSuccessTests st)) ++ ", ""discards"": " ++ (show (numDiscardedTests st))) else ("+++ Passed " ++ (show (numSuccessTests st)) ++ " tests (" ++ (show (numDiscardedTests st)) ++ " discards)" ++ newline) ) else NoExpectedFailure (numSuccessTests st) (summary st) ( if (stDoAnalysis st) then ("""result"": ""expected_failure"", ""tests"": " ++ (show (numSuccessTests st))) else ("*** Failed! Passed " ++ (show (numSuccessTests st))++ " tests (expected Failure)" ++ newline) ). (* TODO: success st - labels *) Definition giveUp (st : State) : Result := GaveUp (numSuccessTests st) (summary st) ( if (stDoAnalysis st) then ("""result"": ""gave_up"", ""tests"":" ++ (show (numSuccessTests st)) ++ ", ""discards"": " ++ (show (numDiscardedTests st))) else ("*** Gave up! Passed only " ++ (show (numSuccessTests st)) ++ " tests" ++ newline ++ "Discarded: " ++ (show (numDiscardedTests st)) ++ newline) ). Definition callbackPostTest (st : State) (res : Checker.Result) : nat := match res with | MkResult o e r i s c t => fold_left (fun acc callback => match callback with | PostTest _ call => (call st (MkSmallResult o e r i s t)) + acc | _ => acc end) c 0 end. Definition callbackPostFinalFailure (st : State) (res : Checker.Result) : nat := match res with | MkResult o e r i s c t => fold_left (fun acc callback => match callback with | PostFinalFailure _ call => (call st (MkSmallResult o e r i s t)) + acc | _ => acc end) c 0 end. Fixpoint localMin (st : State) (r : Rose Checker.Result) {struct r} : (nat * Checker.Result) := match r with | MkRose res ts => let fix localMin' st ts {struct ts} := match ts return (nat * Checker.Result) with | nil => let zero := callbackPostFinalFailure st res in (numSuccessShrinks st + zero, res) | cons ((MkRose res' _) as r') ts' => let zero := callbackPostTest st res in match ok res' with | Some x => let consistent_tags := match result_tag res, result_tag res' with | Some t1, Some t2 => if string_dec t1 t2 then true else false | None, None => true | _, _ => false end in if andb (negb x) consistent_tags then localMin (updSuccessShrinks st (fun x => x + 1 + zero)) r' else localMin' (updTryShrinks st (fun x => x + 1)) ts' | None => localMin' (updTryShrinks st (fun x => x + 1)) ts' end end in localMin' st (force ts) end. Fixpoint runATest (st : State) (f : nat -> RandomSeed -> QProp) (maxSteps : nat) := match maxSteps with | S maxSteps' => let size := (computeSize st) (numSuccessTests st) (numDiscardedTests st) in let (rnd1, rnd2) := randomSplit (randomSeed st) in let test (st : State) := if (gte (numSuccessTests st) (maxSuccessTests st)) then doneTesting st else if (gte (numDiscardedTests st) (maxDiscardedTests st)) then giveUp st else runATest st f maxSteps' in match st with | MkState mst mdt ms cs nst ndt ls e r nss nts ana => match f size rnd1 with | MkProp (MkRose res ts) => (* TODO: CallbackPostTest *) let res_cb := callbackPostTest st res in match res with | MkResult (Some x) e reas _ s _ t => if x then (* Success *) let ls' := match s with | nil => ls | _ => let s_to_add := ShowFunctions.string_concat (ShowFunctions.intersperse " , "%string s) in match Map.find s_to_add ls with | None => Map.add s_to_add (res_cb + 1) ls | Some k => Map.add s_to_add (k+1) ls end end in (* let ls' := fold_left (fun stamps stamp => let oldBind := Map.find stamp stamps in match oldBind with | None => Map.add stamp 1 stamps | Some k => Map.add stamp (k+1) stamps end ) s ls in*) test (MkState mst mdt ms cs (nst + 1) ndt ls' e rnd2 nss nts ana) else (* Failure *) let tag_text := match t with | Some s => "Tag: " ++ s ++ nl | _ => "" end in let pre : string := ( if ana then ( if expect res then """result"": ""failed"", " else """result"": ""expected_failure"" " ) else ( if expect res then "*** Failed " else "+++ Failed (as expected) " ) )%string in let (numShrinks, res') := localMin st (MkRose res ts) in let suf := ( if ana then ( """tests"": " ++ (show (S nst)) ++ ", ""shrinks"": " ++ (show numShrinks) ++ ", ""discards"": " ++ (show ndt) ) else ( "after " ++ (show (S nst)) ++ " tests and " ++ (show numShrinks) ++ " shrinks. (" ++ (show ndt) ++ " discards)" ) )%string in (* TODO: Output *) if (negb (expect res)) then Success (nst + 1) ndt (summary st) (tag_text ++ pre ++ suf) else Failure (nst + 1) numShrinks ndt r size (tag_text ++ pre ++ suf) (summary st) reas | MkResult None e reas _ s _ t => (* Ignore labels of discarded tests? *) let ls' := match s with | nil => ls | _ => let s_to_add := "(Discarded) " ++ ShowFunctions.string_concat (ShowFunctions.intersperse " , "%string s) in match Map.find s_to_add ls with | None => Map.add s_to_add (res_cb + 1) ls | Some k => Map.add s_to_add (k+1) ls end end in test (MkState mst mdt ms cs nst (S ndt) ls' e rnd2 nss nts ana) end end end | 0 => giveUp st end%string. Definition test (st : State) (f : nat -> RandomSeed -> QProp) : Result := if (gte (numSuccessTests st) (maxSuccessTests st)) then doneTesting st else if (gte (numDiscardedTests st) (maxDiscardedTests st)) then giveUp st else let maxSteps := maxSuccessTests st + maxDiscardedTests st in runATest st f maxSteps. (* ZP: This was quickCheckResult before but since we always return result return result there is no reason for such distinction *) Definition quickCheckWith {prop : Type} {_ : Checkable prop} (a : Args) (p : prop) : Result := (* ignore terminal - always use trace :D *) let (rnd, computeFun) := match replay a with | Some (rnd, s) => (rnd, at0 (computeSize' a) s) | None => (newRandomSeed, computeSize' a) (* make it more random...? need IO action *) end in test (MkState (maxSuccess a) (* maxSuccessTests *) (maxDiscard a) (* maxDiscardTests *) (maxShrinks a) (* maxShrinks *) computeFun (* computeSize *) 0 (* numSuccessTests *) 0 (* numDiscardTests *) (Map.empty nat) (* labels *) false (* expectedFailure *) rnd (* randomSeed *) 0 (* numSuccessShrinks *) 0 (* numTryShrinks *) (analysis a) (* analysisFlag *) ) (run (checker p)). Fixpoint showCollectStatistics (l : list (string * nat)) : string := match l with | nil => "" | cons (s,n) l' => show n ++ " : " ++ s ++ newline ++ showCollectStatistics l' end. #[global] Instance showResult : Show Result := Build_Show _ (fun r => match r with | Success _ _ l s => showCollectStatistics l ++ s | GaveUp _ l s => showCollectStatistics l ++ s | Failure _ _ _ _ _ s l _ => showCollectStatistics l ++ s | NoExpectedFailure _ l s => showCollectStatistics l ++ s end)%string. Definition quickCheck {prop : Type} {_ : Checkable prop} (p : prop) : Result := quickCheckWith stdArgs p. (* A named test property with parameters. *) Inductive Test : Type := | QuickChickTest : string -> Args -> Checker -> Test. (* Make a named test property with explicit parameters. *) Definition qc_ {prop : Type} {_ : Checkable prop} (name : string) (a : Args) (p : prop) : Test := QuickChickTest name a (checker p). (* Make a named test property with implicit default parameters. *) Definition qc {prop : Type} {_ : Checkable prop} (name : string) (p : prop) : Test := qc_ name stdArgs (checker p). (* IO action that runs the tests. *) Fixpoint testRunner (tests : list Test) : IO unit := match tests with | [] => ret tt | QuickChickTest name args test :: tests => print_endline ("Checking " ++ name ++ "...");; print_endline (show (quickCheckWith args test));; testRunner tests end%string. (* Actually run the tests. (Only meant for extraction.) *) Definition runTests (tests : list Test) : io_unit := IO.unsafe_run (testRunner tests). (* Fuzzing parts *) Definition fuzzCheck {prop : Type} {_ : Checkable prop} (p : prop) : Result := quickCheckWith (MkArgs None 1 1 0 defSize true false) p. (* HACK! This will be implemented by appending it to the beginning of the file...*) Axiom withInstrumentation : (unit -> option bool) -> (option bool * (bool * nat)). Extract Constant withInstrumentation => "withInstrumentation". (* After this many random consecutive tests, control flow returns to saved seeds. *) Axiom random_fuel : nat. Extract Constant random_fuel => "1000". Fixpoint pick_next_aux pick_fuel {A} (gen : G A) (fuzz : A -> G A) fs ds fsq dsq randoms saved := match pick_fuel with | O => (gen, fs, ds, fsq, dsq, randoms, saved) | S pick_fuel => match fs with (* First pick: something from the favorite queue. If its weight is 0, try the next one. *) | ((O, fav)::fs') => pick_next_aux pick_fuel gen fuzz fs' ds fsq dsq randoms saved | ((S n, fav)::fs') => (fuzz fav, (n, fav)::fs', ds, fsq, dsq, randoms, saved) | [] => (* Then: If no favorites exist, check if there are still favorites in the queue. *) match fsq with (* If not, go to the discards. *) | [] => match ds with (* If we have fuzzed this (discarded) seed to completion, randomly generate a new test. *) | ((O, _)::ds') => (gen, fs, ds', fsq, dsq, randoms, saved) | ((S n, dis)::ds') => (fuzz dis, fs, ((n, dis):: ds'), fsq, dsq, randoms, saved) | [] => (* If no discards, look at the queue. *) match dsq with (* No queue -> Random generation *) | [] => (* Check if we've exhausted the random fuel *) match randoms with (* If we run out of random fuel, try restoring the saved queue *) | O => pick_next_aux pick_fuel gen fuzz saved [] [] [] random_fuel saved | S randoms' => (gen, [], [], [], [], randoms', saved) end (* Discarded in queue: update queue. *) | _ => pick_next_aux pick_fuel gen fuzz [] dsq [] [] randoms saved end end (* If yes, updated the favored list. *) | _ => pick_next_aux pick_fuel gen fuzz fsq ds [] dsq randoms saved end end end. Definition pick_next := @pick_next_aux 7. Axiom printnvb : unit -> nat. Extract Constant printnvb => "(fun u -> Printf.printf ""%d\n"" (count_non_virgin_bytes u); 42)". Definition doneTestingFuzz (x : nat) st := doneTesting st. Axiom clear_queues : nat -> bool. Extract Constant clear_queues => "(fun n -> n land 1023 == 0)". (* Keep two lists for seeds: favored : contains _successful_ runs and their energy. discards : contains _discarded_ runs and their energy (lower priority) Always fuzz a favored one if it exists. If not, interleave fuzzing a discard or generating randomly. *) Fixpoint fuzzLoopAux {A} (fuel : nat) (st : State) (favored : list (nat * A)) (discards : list (nat * A)) (favored_queue : list (nat * A)) (discard_queue : list (nat * A)) (randoms : nat) (saved : list (nat * A)) (gen : G A) (fuzz : A -> G A) (print : A -> string) (prop : A -> option bool) : Result := match fuel with | O => giveUp st | S fuel' => if (gte (numSuccessTests st) (maxSuccessTests st)) then let x : nat := printnvb tt in doneTestingFuzz (trace (show x) x) st else if (gte (numDiscardedTests st) (maxDiscardedTests st)) then giveUp st else let size := (computeSize st) (numSuccessTests st) (numDiscardedTests st) in let (rnd1, rnd2) := randomSplit (randomSeed st) in (* How to decide between generation and fuzzing? *) (* For now, if there is a succesful seed, use it. If there is not, pick the first discarded one, fuzz it until you run out of energy, and then generate a random test again. *) let '(g,favored',discards',favored_queue', discard_queue', randoms', saved') := pick_next gen fuzz favored discards favored_queue discard_queue randoms saved in let a := run g size rnd1 in (* TODO: These recursive calls are a place to hold depth/handicap information as well.*) let '(res, (is_interesting, energy)) := withInstrumentation (fun _ : unit => prop a) in let zero_0 := 0 in (* trace (show res ++ nl) 0 in*) match res with | Some true => match clear_queues fuel with | true => fuzzLoopAux fuel' (updSuccTests st S) nil nil nil nil randoms' nil gen fuzz print prop | _ => if is_interesting then (* Successful and interesting, keep in favored queue and save! *) fuzzLoopAux fuel' (updSuccTests st S) favored' discards' ((energy, a)::favored_queue') discard_queue' randoms' ((energy,a) :: saved') gen fuzz print prop else (* Successful but no new paths, don't keep. *) fuzzLoopAux fuel' (updSuccTests st S) favored' discards' favored_queue' discard_queue' randoms' saved' gen fuzz print prop end | Some false => let '(MkState mst mdt ms cs nst ndt ls e r nss nts ana) := st in let zero := trace (print a ++ nl) zero_0 in let pre : string := "*** Failed " in (* TODO: shrinking *) (* let (numShrinks, res') := localMin rnd1_copy st (MkRose res ts) in *) let numShrinks := 0 in let suf := ("after " ++ (show (S nst)) ++ " tests and " ++ (show numShrinks) ++ " shrinks. (" ++ (show ndt) ++ " discards)")%string in Failure (nst + 1 + zero) numShrinks ndt r size (pre ++ suf) (summary st) "Falsified!" | None => match clear_queues fuel with | true => fuzzLoopAux fuel' (updDiscTests st S) nil nil nil nil randoms' nil gen fuzz print prop | _ => if is_interesting then (* Interesting (new path), but discard. Put in discard queue *) fuzzLoopAux fuel' (updDiscTests st S) favored' discards' favored_queue' ((energy, a)::discard_queue') randoms' saved' gen fuzz print prop (* fuzzLoopAux fuel' (updDiscTests st S) favored' discards' favored_queue' discard_queue' gen fuzz print prop *) else (* Not interesting + discard. Throw away. *) fuzzLoopAux fuel' (updDiscTests st S) favored' discards' favored_queue' discard_queue' randoms' saved' gen fuzz print prop end end end%string. Definition fuzzLoopWith {A} (a : Args) (gen : G A) (fuzz : A -> G A) (print : A -> string) (prop : A -> option bool) := let compFun maxSuccess maxSize n d := maxSize in let (rnd, computeFun) := (newRandomSeed, compFun (maxSize a) (maxSuccess a)) in let st := MkState (maxSuccess a) (* maxSuccessTests *) (maxDiscard a) (* maxDiscardTests *) (maxShrinks a) (* maxShrinks *) computeFun (* computeSize *) 0 (* numSuccessTests *) 0 (* numDiscardTests *) (Map.empty nat) (* labels *) true (* expectedFailure *) rnd (* randomSeed *) 0 (* numSuccessShrinks *) 0 (* numTryShrinks *) false (* analysis *) in fuzzLoopAux (maxSuccess a + maxDiscard a) st [] [] [] [] random_fuel [] gen fuzz print prop. Definition fuzzLoop {A} := @fuzzLoopWith A stdArgs. QuickChick-2.1.0/src/Typeclasses.v000066400000000000000000000164361476030541200170210ustar00rootroot00000000000000Set Warnings "-notation-overridden,-parsing". From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq. From QuickChick Require Import Classes DependentClasses Checker Show Producer Generators Sets. Local Open Scope set_scope. (* TODO: Derive these *) #[global] Instance arbST_eq {A} (a : A) : GenSuchThat A (fun x => x = a) := {| arbitraryST := returnGen (Some a) |}. #[global] Instance arbST_Correct {A} (a : A) : CorrectST (fun x => x = a) (genST (fun x => x = a)). Proof. constructor. simpl; rewrite semReturnOpt. split; intros H. now firstorder. subst. reflexivity. Defined. #[global] Instance arbST_eq' {A} (a : A) : GenSuchThat A (fun x => a = x) := {| arbitraryST := returnGen (Some a) |}. #[global] Instance arbST_Correct' {A} (a : A) : CorrectST (fun x => a = x ) (genST (fun x => a = x)). Proof. constructor. simpl; rewrite semReturnOpt. split; intros H. now firstorder. now firstorder. Defined. (* Typeclass instances that derive checkable from dependent generators *) (* Obvious TODO: Shrink *) (* Is there another way of getting around the typeclass system? *) Axiom ignore_generator_proofs : False. Ltac ignore_gen_proofs := exfalso; apply ignore_generator_proofs. #[global] Instance testSuchThat {A : Type} {pre : A -> Prop} {prop : A -> Type} `{Show A} `{GenSuchThat A (fun x => pre x)} `{forall (x : A), Checkable (prop x)} : Checkable (forall x, pre x -> prop x). Proof. refine {| checker f := forAllMaybe (genST (fun x => pre x)) (fun x => checker (f x _)) |}. ignore_gen_proofs. Defined. #[global] Instance testSuchThat2 {A B : Type} {pre : A -> B -> Prop} {prop : A -> B -> Type} `{Show A} `{Show B} `{GenSuchThat (A * B) (fun x => let (a,b) := x in pre a b)} `{forall (a : A) (b : B), Checkable (prop a b)} : Checkable (forall a b , pre a b -> prop a b). Proof. refine {| checker f := forAllMaybe (genST (fun x : A * B => let (a,b) := x in pre a b)) (fun x => let (a,b) := x in checker (f a b _)) |}. ignore_gen_proofs. Defined. (* Definition t := forall x, x = 17 -> x = 17. #[global] Instance ct : Checkable t. eapply testSuchThat; eauto. Unshelve. QuickChck t. (fun mx => match mx with | (fun mx H => (* Leo: Is there a better way to do this? *) let mx' := mx in let Heq := erefl mx' : mx' = mx in match mx as mx'' return (mx' = mx'' -> Checker) with | Some x => fun _ => checker (f x _) | None => fun _ => checker tt end Heq) |}. Proof. (* Annoying *) assert (Eq : mx = mx') by auto. rewrite -Eq in e. clear Heq Eq mx'. (* End annoying *) destruct H1. subst. (* Very annoying *) assert (Ha : (isSome :&: (semGen (genST [eta pre]))) (Some x)). { split; eauto. } apply STCorrect in Ha. destruct Ha as [y [Hin Heq]]. inversion Heq. subst. eassumption. Defined. #[global] Instance testSuchThat2_1 {A B : Type} {pre : A -> B -> Prop} {prop : A -> B -> Type} `{Show A} `{Show B} `{Arbitrary B} `{forall (b : B), GenSuchThat A (fun x => pre x b)} `{forall (b : B), SuchThatCorrect (fun x => pre x b) (genST (fun x => pre x b))} `{forall (a : A) (b : B), Checkable (prop a b)} : Checkable (forall a b , pre a b -> prop a b) := {| checker f := forAllShrink arbitrary shrink (fun b => forAllProof (genST (fun x => pre x b)) (fun mx H => (* Leo: Is there a better way to do this? *) let mx' := mx in let Heq := erefl mx' : mx' = mx in match mx as mx'' return (mx' = mx'' -> Checker) with | Some x => fun _ => checker (f x b _) | None => fun _ => checker tt end Heq) ) |}. Proof. (* Annoying *) assert (Eq : mx = mx') by auto. rewrite -Eq in e. clear Heq Eq mx'. (* End annoying *) destruct (H5 b). (* Very annoying *) subst. assert (Ha : (isSome :&: semGen (genST pre^~ b)) (Some x)). { split; eauto. } apply STCorrect in Ha. destruct Ha as [y [Hin Heq]]. inversion Heq. subst. eassumption. Defined. #[global] Instance testSuchThat2_2 {A B : Type} {pre : A -> B -> Prop} {prop : A -> B -> Type} `{Show A} `{Show B} `{Arbitrary A} `{forall (a : A), GenSuchThat B (fun x => pre a x)} `{forall (a : A), SuchThatCorrect (fun x => pre a x) (genST (fun x => pre a x))} `{forall (a : A) (b : B), Checkable (prop a b)} : Checkable (forall a b , pre a b -> prop a b) := {| checker f := forAllShrink arbitrary shrink (fun a => forAllProof (genST (fun x => pre a x)) (fun mx H => (* Leo: Is there a better way to do this? *) let mx' := mx in let Heq := erefl mx' : mx' = mx in match mx as mx'' return (mx' = mx'' -> Checker) with | Datatypes.Some x => fun _ => checker (f a x _) | Datatypes.None => fun _ => checker tt end Heq) ) |}. Proof. (* Annoying *) assert (Eq : mx = mx') by auto. rewrite -Eq in e. clear Heq Eq mx'. (* End annoying *) destruct (H5 a). (* Very annoying *) subst. assert (Ha : (isSome :&: semGen (genST [eta pre a])) (Some x)). { split; eauto. } apply STCorrect in Ha. destruct Ha as [y [Hin Heq]]. inversion Heq. subst. eassumption. Defined. #[global] Instance testSuchThat_swap {A B C : Type} {pre : A -> B -> Prop} {prop : A -> B -> C -> Type} `{Checkable (forall a b, pre a b -> forall c, prop a b c)} : Checkable (forall a b c, pre a b -> prop a b c) := {| checker f := @checker (forall a b, pre a b -> forall c, prop a b c) _ _ |}. Proof. intros; eauto. Defined. #[global] Instance GenSuchThatConj {A B : Type} (P : A -> Prop) (Q : B -> Prop) `{GenSuchThat A (fun x => P x)} `{GenSuchThat B (fun x => Q x)} : GenSuchThat (A * B) (fun xy => let (x,y) := xy in P x /\ Q y) := {| arbitraryST := bindGen (genST (fun x => P x)) (fun ma => bindGen (genST (fun x => Q x)) (fun mb => match ma, mb with | Some a, Some b => returnGen (Some (a,b)) | _, _ => returnGen None end)) |}. (* #[global] Instance GenSuchThatConjCorrect {A B : Type} (P : A -> Prop) (Q : B -> Prop) `{GA: GenSizedSuchThat A (fun x => P x)} `{GB: GenSizedSuchThat B (fun x => Q x)} `{SizedSuchThatCorrectSuchThatSizedCorrect A (fun x => P x) (@arbitraryST _ _ GA)} `{SuchThatSizeCorrect B (fun x => Q x) (@arbitraryST _ _ GB)} : SuchThatCorrect (fun xy : A * B => let (x,y) := xy in P x /\ Q y) (@arbitraryST _ (fun xy => let (x,y) := xy : A * B in P x /\ Q y) (@GenSuchThatConj A B P Q GA GB)) := {| STComplete := _ ; STSound := _ |}. Proof. - simpl. rewrite semBind *) *) QuickChick-2.1.0/src/dune000066400000000000000000000011351476030541200151770ustar00rootroot00000000000000(coq.theory (name QuickChick) (package coq-quickchick) (plugins coq-quickchick.plugin)) (rule (alias compat) (target Compat.v) (action (run sh %{dep:../scripts/mycppo} %{dep:Compat.v.cppo} %{target}))) (rule (alias compat) (target ExtractionQC.v) (action (run sh %{dep:../scripts/mycppo} %{dep:ExtractionQC.v.cppo} %{target}))) (rule (alias compat) (target QuickChick.v) (action (run sh %{dep:../scripts/mycppo} %{dep:QuickChick.v.cppo} %{target}))) (rule (alias compat) (target TacticsUtil.v) (action (run sh %{dep:../scripts/mycppo} %{dep:TacticsUtil.v.cppo} %{target}))) QuickChick-2.1.0/test/000077500000000000000000000000001476030541200145115ustar00rootroot00000000000000QuickChick-2.1.0/test/.gitignore000066400000000000000000000000461476030541200165010ustar00rootroot00000000000000*.ml *.mli *.native qc-mutants qc-out QuickChick-2.1.0/test/derive.v000066400000000000000000000003641476030541200161610ustar00rootroot00000000000000From QuickChick Require Import QuickChick Classes. Inductive a := | A1 : a | A2 : b -> a with b := | B1 : b | B2 : a -> b. Derive GenSized for a. Derive EnumSized for a. Derive Shrink for a. Derive Arbitrary for a. Derive Show for a. QuickChick-2.1.0/test/dune000066400000000000000000000005161476030541200153710ustar00rootroot00000000000000(alias (name runtest) (deps (alias_rec all))) (coq.theory (name QuickChick.Testing) (theories QuickChick) (modules plugin derive)) (coq.extraction (prelude mutation) (extracted_modules mutation) (theories QuickChick)) (test (name mutation) (modules mutation) (flags :standard -w -39-67) (libraries zarith)) QuickChick-2.1.0/test/mutation.v000066400000000000000000000007331476030541200165430ustar00rootroot00000000000000From QuickChick Require Import QuickChick. From Coq Require Import List String ExtrOcamlNatInt. Import ListNotations. Local Instance this_section : Mutant.section := "test"%string. Definition prop_example := let x := 10 mutant! 20 in let y := 1 mutant: "foo" 2 mutant! 3 mutant: "bar" 4 in whenFail (show x ++ " + " ++ show y ++ " <> 11")%string (x + y = 11 ?). Definition main := runTests [ qc "example" prop_example ]. Extraction "mutation.ml" main. QuickChick-2.1.0/test/plugin.v000066400000000000000000000022001476030541200161700ustar00rootroot00000000000000From QuickChick Require Import QuickChick. (* TODO: better naming *) Inductive foo {A : Type} := | bar : A -> foo -> foo | baz : foo . Derive (Arbitrary, Show) for foo. Sample (arbitrary : G foo). Section Sanity. Inductive qux : Type := | Qux: forall {A: Type}, A -> qux. Definition quux: qux -> bool := fun a => match a with | Qux a => true end. End Sanity. Section Failures. Set Asymmetric Patterns. Fail Definition quux': qux -> bool := fun a => match a with | Qux a => true end. End Failures. Import MonadNotation. Definition a : G nat := ret 1. Definition b : G nat := v <- a ;; ret v. Import BindOptNotation. Definition c : G (option nat) := ret (Some 42). Definition d : G (option nat) := v <-- c;; ret (Some v). Sample a. Sample b. Sample (liftM Some a). Sample c. Sample d. Set Warnings "-notation-overridden". From mathcomp Require Import ssreflect ssrnat div. QuickChick (fun (s : nat) (t : nat) => eqn (gcdn s t) (gcdn t s)). (* Test extraction hack (substitute type int = int) *) Definition int := nat. Definition teh := fun x : int => Nat.eqb x x. QuickChick teh. QuickChick-2.1.0/tutorials/000077500000000000000000000000001476030541200155605ustar00rootroot00000000000000QuickChick-2.1.0/tutorials/Automation.v000066400000000000000000000266161476030541200201020ustar00rootroot00000000000000(** * Automation Tutorial for QuickChick *) (** This tutorial explores the automation capabilities of QuickChick, leveraging typeclasses and plugin magic. *) From QuickChick Require Import QuickChick. (* Let's revisit our favorite datatype, binary trees: *) Inductive Tree A := | Leaf : Tree A | Node : A -> Tree A -> Tree A -> Tree A. Arguments Leaf {A}. Arguments Node {A} _ _ _. (* Instead of writing a generator, shrinker, and printer for trees, we could simply derive them using the `Derive` command. This command takes two parameters: - the name (or names) of the typeclass to be derived - the datatype to derive it for *) Derive (Arbitrary, Show) for Tree. (* ==> GenSizedTree is defined ShrinkTree is defined ShowTree is defined *) (* To decide propositions, QuickChick provides the convenient `Dec` typeclass. This is a thin wrapper around ssreflects decidable definition, which in itself is just a proof that P holds or does not hold. *) (* Importing ssreflect yields a bunch of "notation overridden" warnings, which we can suppress with the following line. *) Set Warnings "-notation-overridden,-parsing". From mathcomp Require Import ssrbool. Check decidable. (* ==> fun P : Prop => {P} + {~ P} *) Module DecPlayground. (* The Dec class provides the dec method which gives a decidability witness for P *) Class Dec (P : Prop) : Type := { dec : decidable P }. (* The DecOpt class encodes partial decidability: - It takes a nat argument as fuel - It returns None, if it can't decide. - It returns Some true/Some false if it can. - These are supposed to be monotonic, in the sense that if they ever return Some b for some fuel, they will also do so for higher fuel values. *) Class DecOpt (P : Prop) := { decOpt : nat -> option bool }. (* Every Dec instance naturally gives rise to an instance of DecOpt *) (* QuickChick also provides convenient notation for accessing these instances: *) Notation "P '?'" := (match (@dec P _) with | left _ => true | right _ => false end) (at level 100). Notation "P '??' n" := (@decOpt P _ n) (at level 100). (* The most common use of the Dec class is boolean equality testing. That is the purpose of the Dec_Eq typeclass. *) Class Dec_Eq (A : Type) := { dec_eq : forall (x y : A), decidable (x = y) }. End DecPlayground. (* For the Dec_Eq class in particular, QuickChick provides a useful tactic for using the Coq-provided `decide equality` tactic in conjunction with existing Dec_Eq instances, to automate its construction. For example, for our Tree example we can invoke `dec_eq`, assuming our type A is also testable for equality --- note the "Defined" to close the proof. *) #[global] Instance Dec_Eq_Tree {A} `{Dec_Eq A} : Dec_Eq (Tree A). Proof. dec_eq. Defined. (* Armed with all these instances, we can now automatically test properties of trees. For example, in the BasicUsage tutorial we saw a `mirror` function: *) Fixpoint mirror {A : Type} (t : Tree A) : Tree A := match t with | Leaf => Leaf | Node x l r => Node x (mirror r) (mirror l) end. (* Along with a faulty mirror property, specialized to nat for simpler testing: *) Definition faulty_mirrorP (t : Tree nat) := mirror t = t?. QuickChick faulty_mirrorP. (* Preconditions + Automation *) (* ========================== *) (* Another very common occurrence in Coq is to have complex inductive definitions that both constrain the inputs of theorems, and are used in the conclusion. For a complete example, we refer the user to the stlc tutorial. For here, let's consider the simpler case of balanced trees of height `n`, where every path through the tree has length either `n` or `n-1`. *) Inductive balanced {A} : nat -> Tree A -> Prop := | B0 : balanced 0 Leaf | B1 : balanced 1 Leaf | BS : forall n x l r, balanced n l -> balanced n r -> balanced (S n) (Node x l r). (* When implementing a data structure such as AVL trees, we would ensure that a balanced tree remains balanced after inserting an element with intricate rebalancing operations. Here, let's encode a very naive insertion function that always inserts elements on the leftmost path, and see how QuickChick can figure out when things go wrong: *) Fixpoint insert {A} (x : A) (t : Tree A) : Tree A := match t with | Leaf => Node x Leaf Leaf | Node y l r => Node y (insert x l) r end. (* To check if a tree t is balanced, we need a _computable_ way of deciding whether there exists a height n for which `balanced n t` holds. Inductives in Coq don't provide that capability, and most often users resort to writing a separate piece of code that performs this computation, usually along with a proof that it does so correctly. However, QuickChick provides a derivation mechanism that allows for extracting such computational content from an inductive relation over simply-typed first-order data, levering the typeclass infrastructure we've seen! *) Derive Checker for (balanced n t). (* ==> DecOptbalanced is defined *) (* This Derive command produces an instance of the DecOpt typeclass for the proposition `Balanced n t` for arbitrary parameters n and t. *) Check DecOptbalanced. (* ==> DecOptbalanced : forall (n_ : nat) (t_ : Tree ?A), DecOpt (balanced n_ t_) *) (* We can use this to check whether a given tree is balanced at a given height *) Eval compute in (balanced 1 (Node 42 Leaf Leaf) ?? 10). (* ==> Some true *) Eval compute in (balanced 2 Leaf ?? 10). (* ==> Some false *) Eval compute in (balanced 3 (Node 42 (Node 10 Leaf Leaf) (Node 10 Leaf Leaf)) ?? 1). (* ==> None *) (* For QuickChick-derived instances of DecOpt, you can assume that `decOpt` functions are: - Monotonic: If they return a `Some` for some fuel value, they will also return the same result for all larger fuel values. - Sound: If they return `Some true`, then the inductive relation holds. If they return `Some false`, then the inductive relation doesn't hold. - Partially complete: If the inductive relation holds, then there exists a fuel value for which they return `Some true`. Unfortunately, the decision procedures are incomplete in the case where the inductive relation doesn't hold, as it might encode nonterminating computations. Proofs of these laws can also be obtained automatically for derived instances! For more information, check out the PLDI paper: "Computing Correctly with Inductive Relations". *) (* In the first case, a single node tree is balanced at height 1. In the second, a Leaf is balanced but not at height 2. In the third case, we didn't provide enough fuel for the checker to decide conclusively one way or another. *) (* So let's try to check our first (obviously false) property using derived checkers: all trees (of natural numbers) are balanced. *) Definition all_trees_are_balanced (n : nat) (t : Tree nat) := balanced n t ?? 10. QuickChick all_trees_are_balanced. (* ==> 0 (Node 0 Leaf Leaf) Failed after 5 tests and 11 shrinks. *) (* Sure enough, not all trees are balanced. But how would we go about generating balanced trees for testing purposes? Another `Derive` command to the rescue! *) Derive Generator for (fun t => balanced n t). (* ==> GenSizedSuchThatbalanced is defined *) (* This Derive command produces an instance of the GenSizedSuchThat typeclass, which produces trees t such that t is balanced---for a given input argument n. That is, the anonymous function arguments set what the argument to generate for is, and the rest of the names are assumed to be universally quantified. *) Check GenSizedSuchThatbalanced. (* ==> GenSizedSuchThatbalanced : forall n_ : nat, GenSizedSuchThat (Tree ?A) (fun t_ : Tree ?A => balanced n_ t_) *) (* But what is GenSizedSuchThat? *) Print GenSizedSuchThat. (* ==> Record GenSizedSuchThat (A : Type) (P : A -> Prop) : Type := Build_GenSizedSuchThat { arbitrarySizeST : nat -> G (option A) }. *) (* It's a typeclass with a single method, given an (inductive) predicate P over some type A, it (maybe) produces instances of A given some fuel. For the QuickChick-derived instances you can once again assume: - Monotonicity on fuel - Soundness (will only produce As satisfying P) - Completeness (all As satisfying P can be produced) Proofs of these can again be obtained automatically. Finally, QuickChick provides a convenient notation, `genSizedST` to invoke arbitrarySizeST, and `genST` to invoke it with the QuickChick-managed size parameter. *) Sample (genST (fun t => balanced 1 t)). (*==> QuickChecking (genST (fun t => balanced 1 t)) [ Some Leaf ; Some Leaf ; Some Node 5 Leaf Leaf ; Some Node 4 Leaf Leaf ; Some Node 1 Leaf Leaf ; Some Node 5 Leaf Leaf ; Some Node 2 Leaf Leaf ; Some Leaf ; Some Node 0 Leaf Leaf ; Some Node 0 Leaf Leaf ; Some Leaf] You'll note that the generator produced both Leafs and single-Node trees, as both are balanced at height 1 according to our inductive definition. *) (* Now we can use this generator and the checker above, to sanity check that QuickChick has done the right thing: *) Definition prop_gen_balanced_is_balanced := let fuel := 10 in (* Generate an arbitrary n *) forAll (choose (0,5)) (fun (n : nat) => (* Generate an arbitrary balanced tree of height n *) forAllMaybe (genSizedST (fun t => balanced n t) fuel) (fun (t : Tree nat) => (* Check the resulting tree is balanced. *) balanced n t ?? fuel)). QuickChick prop_gen_balanced_is_balanced. (* ==> QuickChecking gen_balanced_is_balanced +++ Passed 10000 tests (0 discards) *) (* Perfect! Now let's try to write - and test - the property that insertion preserves balanced. We will use the '==>?' combinator which combines two option bools, treating failures in the precondition as a `None` - a discarded test. *) Definition balanced_preserves_balanced (fuel n x : nat) (t : Tree nat) := (balanced n t ?? fuel) ==>? (balanced n (insert x t) ?? fuel). (* We could try to test this property with the type based generators, for some height e.g. 5: *) QuickChick (balanced_preserves_balanced 10 5). (* ==> QuickChecking (balanced_preserves_balanced 10 5) *** Gave up! Passed only 0 tests Discarded: 20000 *) (* Naturally, no balanced trees of height 5 could even be generated! However, we could use the derived constrained generators instead: *) Definition prop_balanced_preserves_balanced (n : nat) := let fuel := 10 in (* Generate an arbitrary balanced tree of height n *) forAllMaybe (genSizedST (fun t => balanced n t) fuel) (fun (t : Tree nat) => (* Generate an arbitrary integer x to insert *) forAll (choose (0,10)) (fun x => balanced_preserves_balanced fuel n x t)). QuickChick (prop_balanced_preserves_balanced 5). (* ==> QuickChecking prop_balanced_preserves_balanced Node 4 (Node 0 (Node 5 (Node 3 (Node 4 Leaf Leaf) (Node 0 Leaf Leaf)) (Node 1 Leaf Leaf)) (Node 0 (Node 5 (Node 5 Leaf Leaf) Leaf) (Node 2 Leaf Leaf))) (Node 0 (Node 2 (Node 1 Leaf Leaf) (Node 0 Leaf (Node 0 Leaf Leaf))) (Node 0 (Node 3 Leaf (Node 5 Leaf Leaf)) (Node 1 (Node 4 Leaf Leaf) (Node 2 Leaf Leaf)))) 7 *** Failed after 6 tests and 0 shrinks. (0 discards) *) (* We immediately get a balanced tree of height 5 that invalidates the property! *) QuickChick-2.1.0/tutorials/BasicUsage.v000066400000000000000000000625561476030541200177730ustar00rootroot00000000000000(** * Tutorial for QuickChick *) (** QuickChick is a clone of Haskell's QuickCheck, slightly on steroids. This tutorial explores basic aspects of random property-based testing and details the majority of features of QuickChick. *) From QuickChick Require Import QuickChick. Import QcDefaultNotation. Open Scope qc_scope. Require Import List ZArith. Import ListNotations. (** ** Introduction *) (** It is not uncommon during a verification effort to spend many hours attempting to prove a slightly false theorem, only to result in frustration when the mistake is realized and one needs to start over. Other theorem provers have testing tools to quickly raise one's confidence before embarking on the body of the proof; Isabelle has its own QuickCheck clone, as well as Nitpick, Sledgehammer and a variety of other tools; ACL2 has gone a step further using random testing to facilitate its automation. QuickChick is meant to fill this void for Coq. Consider the following short function [remove] that takes a natural number [x] and a list of nats [l] and proceeds to remove [x] from the list. While one might be tempted to pose the question "Is there a bug in this definition?", such a question has little meaning without an explicit specification. Here, [removeP] requires that after removing [x] from [l], the resulting list does not contain any occurences of [x]. *) Fixpoint remove (x : nat) (l : list nat) : list nat := match l with | [] => [] | h::t => if Nat.eqb h x then t else h :: remove x t end. Definition removeP (x : nat) (l : list nat) : bool := negb (existsb (fun y => x =? y) (remove x l)). (** For this simple example, it is not hard to "spot" the bug by inspection. We will use QuickChick to find out what is wrong. QuickChick provides a toplevel command [QuickChick] that receives as input an executable property and attempts to falsify it. *) QuickChick removeP. (** Internally, the code is extracted to OCaml, compiled, and run. The following output is presented in your terminal, CoqIDE [Messages] pane, or Visual Studio Code [Info] pulldown menu tab: << 0 [0; 0] Failed! After 17 tests and 12 shrinks >> The output signifies that if we use an input where [x] is [0] and [l] is the two element list containing two zeros, then our property fails. Indeed, we can now identify that the [then] branch of [remove] fails to make a recursive call, which means that only one occurence of each element will be deleted. The last line of the output states that it took 17 tests to identify some fault inducing input and 12 shrinks to reduce it to a minimal counterexample. Before we begin to explain exactly how QuickChick magically comes up with this result, it is important to point out the first (and arguably most important) limitation of this tool: it requires an *executable* specification. QuickChick needs to be able to "run" a property and decide whether it is true or not; a definition like [remove_spec] can't be QuickChecked! *) Definition remove_spec := forall x l, ~ In x (remove x l). (** QuickChick requires either a functional spec (like [removeP]) or a decidability procedure for an inductive spec. *) (** ** Property Based Random Testing Ingredients There are four basic ingredients in property based random testing: - An executable property, as discussed above - A printer, to report counterexamples found - A generator, to produce random inputs - A shrinker, to reduce counterexamples. We will now review the latter three in order. *) (** *** Printing For printing, QuickChick uses a [Show] typeclass, like Haskell. *) Print Show. (** ==> Record Show (A : Type) : Type := Build_Show { show : A -> String.string } *) (** The [Show] typeclass contains a single function [show] from some type [A] to Coq's [string]. QuickChick provides default instances for [string]s (the identity function), [nat], [bool], [Z], etc. (via extraction to appropriate OCaml functions for efficiency), as well as some common compound datatypes: lists, pairs and options. Writing your own show instance is easy! Let's define a simple [Color] datatype. *) Inductive Color := Red | Green | Blue | Yellow. (** After ensuring we have opened the [string] scope, we can declare an instance of [Show Color] by encoding [show] as a simple pattern matching on colors. *) Require Import String. Open Scope string. #[global] Instance show_color : Show Color := {| show c := match c with | Red => "Red" | Green => "Green" | Blue => "Blue" | Yellow => "Yellow" end |}. (* You can safely ignore the "#[export]" annotation for now, it signifies that this instance should be exported along with this module. *) Eval compute in (show Green). (** ==> "Green" : string *) (** While writing show instances is relatively straightforward, it can get tedious. The QuickChick provides a lot of automation, which will be discussed at the end of this Tutorial. *) (** *** Generators *) (** **** The [G] Monad *) (** The heart of property based random testing is the random generation of inputs. In QuickChick, a generator for elements of some type [A] is a monadic object with type [G A]. The monad [G] serves as an abstraction over random seed plumbing. Consider writing a program that given a random seed generates many integers: one needs to use the given seed to produce an integer while at the same time obtain a new, altered seed to use for future draws. This [State]-monad like behavior is hidden behind [G]. Standard monadic functions have the [Gen] suffix. *) Check bindGen. (** ==> bindGen : G ?A -> (?A -> G ?B) -> G ?B *) Check returnGen. (** ==> returnGen : ?A -> G ?A *) (** For those familiar with Haskell's monadic interface, QuickChick also provides variants of [liftM] (as [liftGen]) with arities 1 to 5, [sequence] (as [sequenceGen]) and [foldM] (as [foldGen]). *) (** **** Primitive generators *) (** Primitive generators for booleans, natural numbers and integers are provided via extraction to OCaml. They can be accessed via the [choose] combinator. *) Check choose. (** ==> choose : N * N -> G N *) (** While here [choose] is monomorphised to [N], it actually takes an interval of any type [A] that satisfies a [ChoosableFromInterval] typeclass (with default standard numeric instances) and produces an object of type [A] within that interval. We can see that in action using [Sample]. This is another toplevel command by QuickChick that runs a generator a number of times and prints whatever was generated in the form of a list. *) Sample (choose(0, 10)). (** ==> [ 1, 2, 1, 9, 8, 1, 3, 6, 2, 1, 8, 0, 1, 1, 3, 5, 4, 10, 4, 6 ] *) (** **** Lists *) (** Due to being the most commonly used compound datatype, lists have special combinators in Haskell's QuickCheck. The same is true in QuickChick; there are two combinators, [listOf] and [vectorOf]. *) Check listOf. (** ==> listOf : G ?A -> G (list ?A) *) (** [listOf] takes as input a generator for elements of type [A] and returns a generator for lists of the same type. *) Sample (listOf (choose (0,4))). (** ==> [ [ 0, 3, 2, 0 ], [ 1, 3, 4, 1, 0, 3, 0, 2, 2, 3, 2, 2, 2, 0, 4, 2, 3, 0, 1 ], [ 3, 4, 3, 1, 2, 4, 4, 1, 0, 3, 4, 3, 2, 2, 4, 4, 1 ], [ 0 ], [ 4, 2, 3 ], [ 3, 3, 4, 0, 1, 4, 3, 2, 4, 1 ], [ 0, 4 ], [ ], [ 1, 0, 1, 3, 1 ], [ 0, 0 ], [ 1, 4 ], [ 4, 3, 2, 0, 2, 2, 4, 0 ], [ 1, 1, 0, 0, 1, 4 ], [ 2, 0, 2, 1, 3, 3 ], [ 4, 3, 3, 0, 1 ], [ 3, 3, 3 ], [ 3, 2, 4 ], [ 1, 2 ], [ ], [ ] ] *) (** The second combinator, [vectorOf], receives an additional numeric argument [n], the length of the list to be generated. *) Check vectorOf. (** ==> vectorOf : nat -> G ?A -> G (list ?A) *) (** This raises a question: how does [listOf] decide how big of a list to generate? The answer is hidden inside the [G] monad. In addition to handling random seed plumbing, the [G] monad also provides a [Reader]-like environment with size information: a natural number [n] that nominally serves as the upper bound on the depth of the generated objects. QuickChick progressively tries larger and larger values for [n], in order to explore larger and deeper part of the search space. Note that each generator can choose to interpret this input size however it wants and there is no guarantee that all generators comply to this standard - it is more of a "good practice" when writing one to respect this bound. *) (** **** Custom Datatypes *) (** Naturally, a lot of the time one needs to write generators involving user-defined datatypes. Let's revisit our color datatype; to generate a color, we only need to pick one of its four constructors, [Red], [Green], [Blue] and [Yellow]. This is done using [elements]. *) Check elems_. (** ==> elems_ : ?A -> list ?A -> G ?A *) (** This is the first place where the totality checker of Coq raises a design question. While Haskell's QuickCheck can simply fail raising an [error] whenever the input list is empty, Coq does not allow that behavior. Instead of increasing the burden to the user by requiring a proof that the list is not empty or by making the return type an option, QuickChick requires an additional element of type [A] as input to serve as a "default" object. If the list is not empty, [elems_] returns a generator that picks an element of that list; otherwise the generator always returns the default object. Moreover, QuickChick provides convenient notation to hide this default if it is apparent from the structure. *) (* Notation Scope " 'elems' [ x ] " := elems_ x (cons x nil) : qc_scope (default interpretation) " 'elems' [ x ; y ] " := elems_ x (cons x (cons y nil)) : qc_scope (default interpretation) " 'elems' [ x ; y ; .. ; z ] " := elems_ x (cons x (cons y .. (cons z nil) ..)) : qc_scope (default interpretation) " 'elems' ( x ;; l ) " := elems_ x (cons x l) : qc_scope (default interpretation) *) (** Armed with [elems], we can write the following simple [Color] generator. *) Definition genColor : G Color := elems [ Red ; Green ; Blue ; Yellow ]. Sample genColor. (** ==> [ Blue, Red, Yellow, Red, Blue, Yellow, Yellow, Blue, Green, Red, Green, Blue, Blue, Red, Yellow, Blue, Red, Blue, Blue, Red ] *) (** For more complicated ADTs, QuickChick provides more combinators. We will showcase them using everyone's favorite datatype: Trees! Our trees are standard binary trees; either [Leaf]s or [Node]s containing some payload of type [A] and two subtrees. *) Inductive Tree A := | Leaf : Tree A | Node : A -> Tree A -> Tree A -> Tree A. Arguments Leaf {A}. Arguments Node {A} _ _ _. (** Before getting to generators for trees, we give a simple [Show] instance. The rather inconvenient need for a local [let fix] declaration stems from the fact that Coq's typeclasses (unlike Haskell's) are not automatically recursive. *) #[global] Instance showTree {A} `{_ : Show A} : Show (Tree A) := {| show := let fix aux t := match t with | Leaf => "Leaf" | Node x l r => "Node (" ++ show x ++ ") (" ++ aux l ++ ") (" ++ aux r ++ ")" end in aux |}. (** The first combinator that actually combines different generators is [oneof]. *) Check oneOf_. (** ==> oneof : G ?A -> list (G ?A) -> G ?A *) (** [oneOf_] takes a default generator and a list of generators, and picks one of the generators from the list uniformly at random, as long as the list is not empty. Just like before, QuickChick introduces the notation [oneOf] to hide this default element. At this point, Coq's termination checker saves us from shooting ourselves in the foot. The "obvious" first generator that one might write is the following [genTree]: either generate a [Leaf] or a [Node] whose subtrees are generated recursively and whose payload is produced by a generator for elements of type [A].*) Fail Fixpoint genTree {A} (g : G A) : G (Tree A) := oneOf [ returnGen Leaf ; liftGen3 Node g (genTree g) (genTree g) ]. (** Of course, this fixpoint will not pass Coq's termination check. Attempting to justify this fixpoint to oneself, one might say that at some point the random generation will pick a [Leaf] so it will eventually terminate. Sadly, in this case the expected size of the generated Tree is infinite... The solution is the standard "fuel" solution Coq users are so familiar with: we add an additional natural number [sz] as a parameter; when that parameter is [O] we only generate non-recursive branches, while we decrease this size in each recursive call. Thus, [sz] serves as a bound on the depth of the tree. *) Fixpoint genTreeSized {A} (sz : nat) (g : G A) : G (Tree A) := match sz with | O => returnGen Leaf | S sz' => oneOf [ returnGen Leaf ; liftGen3 Node g (genTreeSized sz' g) (genTreeSized sz' g) ] end. Sample (genTreeSized 3 (choose(0,3))). (** ==> [ Leaf, Leaf, Node (3) (Node (0) (Leaf) (Leaf)) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))), Leaf, Leaf, Leaf, Node (1) (Leaf) (Node (1) (Leaf) (Node (0) (Leaf) (Leaf))), Leaf, Node (3) (Leaf) (Leaf), Node (1) (Leaf) (Leaf), Leaf, Leaf, Node (0) (Leaf) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))), Node (0) (Node (2) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf), Node (0) (Leaf) (Leaf), Leaf, Leaf, Leaf, Leaf, Leaf ] *) (** While this generator succesfully generated trees, just by observing [Sample] above there is a problem: [genTreeSized] produces way too many [Leaf]s! That is to be expected, 50% of the time we generate a [Leaf]. The solution is to skew the distribution towards [Node]s, using the most expressive QuickChick combinator, [freq_] and its associated default-lifting notation [freq]. *) Check freq_. (** ==> freq_ : G ?A -> seq (nat * G ?A) -> G ?A *) (** [freq] takes a list of generators, each one tagged with a natural number that serves as the weight of that generator. In the following example, a [Leaf] will be generated 1 / (sz + 1) of the time, while a [Node] the remaining sz / (sz + 1) of the time.*) Fixpoint genTreeSized' {A} (sz : nat) (g : G A) : G (Tree A) := match sz with | O => returnGen Leaf | S sz' => freq [ (1, returnGen Leaf) ; (sz, liftGen3 Node g (genTreeSized' sz' g) (genTreeSized' sz' g)) ] end. Sample (genTreeSized' 3 (choose(0,3))). (** ==> [ Node (3) (Node (1) (Node (3) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))), Leaf, Node (2) (Node (1) (Leaf) (Leaf)) (Leaf), Node (0) (Leaf) (Node (0) (Node (2) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))), Node (1) (Node (2) (Leaf) (Node (0) (Leaf) (Leaf))) (Leaf), Node (0) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (2) (Leaf) (Leaf)), Node (1) (Node (3) (Node (2) (Leaf) (Leaf)) (Node (3) (Leaf) (Leaf))) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))), Node (0) (Node (0) (Node (0) (Leaf) (Leaf)) (Node (1) (Leaf) (Leaf))) (Node (2) (Node (3) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))), Node (2) (Node (2) (Leaf) (Leaf)) (Node (1) (Node (2) (Leaf) (Leaf)) (Node (2) (Leaf) (Leaf))), Node (2) (Node (3) (Node (2) (Leaf) (Leaf)) (Leaf)) (Node (0) (Node (2) (Leaf) (Leaf)) (Leaf)), Leaf, Node (2) (Node (3) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf), Leaf, Node (1) (Leaf) (Leaf), Leaf, Node (1) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (0) (Leaf) (Node (1) (Leaf) (Leaf))), Leaf, Node (3) (Node (0) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))), Node (2) (Node (2) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))), Leaf ] *) (** To showcase this generator, we will use the notion of mirroring a tree: swapping its left and right subtrees recursively. *) Fixpoint mirror {A : Type} (t : Tree A) : Tree A := match t with | Leaf => Leaf | Node x l r => Node x (mirror r) (mirror l) end. (** We also need a simple structural equality on trees *) Fixpoint eq_tree (t1 t2 : Tree nat) : bool := match t1, t2 with | Leaf, Leaf => true | Node x1 l1 r1, Node x2 l2 r2 => Nat.eqb x1 x2 && eq_tree l1 l2 && eq_tree r1 r2 | _, _ => false end. (** One expects that [mirror] should be unipotent; mirroring a tree twice yields the original tree. *) Definition mirrorP (t : Tree nat) := eq_tree (mirror (mirror t)) t. (** To test this assumption, we can use the [forAll] property combinator that receives a generator [g] for elements of type [A] and an executable property with argument [A] and tests the property on random inputs of [g]. *) QuickChick (forAll (genTreeSized' 5 (choose (0,5))) mirrorP). (** QuickChick quickly responds that this property passed 10000 tests, so we gain some confidence in its truth. But what would happend if we had the *wrong* property? *) Definition faultyMirrorP (t : Tree nat) := eq_tree (mirror t) t. QuickChick (forAll (genTreeSized' 5 (choose (0,5))) faultyMirrorP). (** ==> Node (3) (Node (0) (Leaf) (Node (0) (Node (1) (Leaf) (Leaf)) (Leaf))) (Node (5) (Node (0) (Node (1) (Leaf) (Node (4) (Leaf) (Leaf))) (Node (4) (Leaf) (Node (0) (Leaf) (Leaf)))) (Node (5) (Node (4) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (3) (Leaf) (Leaf)))) *** Failed! After 1 tests and 0 shrinks *) (** The bug is found immediately and reported. However, is this counterexample really helpful? What is the important part of it? The reported bug is too big and noisy to identify the root cause of the problem. That is where shrinking comes in. *) (** **** Shrinking *) (** Shrinking, also known as delta debugging, is a greedy process by which we can find a smaller counterexample given a relatively large one. Given a shrinking function [s] of type [A -> list A] and a counterexample [x] of type [A] that is known to falsify some property [p], QuickChick (lazily) tries [p] on all members of [s x] until it finds another counterexample; then it repeats this process. This greedy algorithm can only work if all elements of [s x] are strictly "smaller" that [x] for all [x]. Most of the time, a shrinking function for some type only returns elements that are "one step" smaller. For example, consider the default shrinking function for lists provided by QuickChick. *) Print shrinkList. (** ==> shrinkList = fix shrinkList (A : Type) (shr : A -> seq A) (l : seq A) {struct l} : seq (seq A) := match l with | [::] => [::] | x :: xs => ((xs :: List.map (fun xs' : seq A => x :: xs') (shrinkList A shr xs))%SEQ ++ List.map (fun x' : A => (x' :: xs)%SEQ) (shr x))%list end : forall A : Type, (A -> seq A) -> seq A -> seq (seq A) *) (** An empty list can not be shrunk - there is no smaller list. A cons cell can be shrunk in three ways: by returning the tail of the list, by shrinking the tail of the list and consing the head, or by shrinking the head and consing its tail. By induction, this process can generate all smaller lists. Writing a shrinking instance for trees is equally straightforward: we don't shrink [Leaf]s while for [Node]s we can return the left or right subtrees, shrink the payload or one of the subtrees.*) Open Scope list. Fixpoint shrinkTree {A} (s : A -> list A) (t : Tree A) : list (Tree A) := match t with | Leaf => [] | Node x l r => [l] ++ [r] ++ map (fun x' => Node x' l r) (s x) ++ map (fun l' => Node x l' r) (shrinkTree s l) ++ map (fun r' => Node x l r') (shrinkTree s r) end. (** Armed with [shrinkTree], we use the [forAllShrink] property combinator that takes an additional argument, a shrinker *) QuickChick (forAllShrink (genTreeSized' 5 (choose (0,5))) (shrinkTree shrink) faultyMirrorP). (** ==> Node (0) (Leaf) (Node (0) (Leaf) (Leaf)) *** Failed! After 1 tests and 8 shrinks *) (** We now got a much simpler counterexample (in fact, this is one of the two minimal ones) and can tell that the real problem occurs when the subtrees of a [Node] are different. *) (** **** Putting it all Together *) (** QuickChick, just like QuickCheck, provides an [Arbitrary] typeclass parameterized over some type [A] with two objects: [arbitrary] and [shrink]. The [arbitrary] object is a generator for elements of type [A]. If we were to encode an [Arbitrary] instance for trees we would like to use [genTreeSized']; however that generator takes an additional size argument. The [G] monad will provide that argument through the combinator [sized].*) Check sized. (** ==> sized : (nat -> G ?A) -> G ?A *) (** [sized] receives a function that given a number produces a generator, just like [genTreeSized'], and returns a generator that uses the size information inside the [G] monad. The [shrink] function is simply a shrinker like [shrinkTree]. *) #[global] Instance genTree {A} `{Gen A} : GenSized (Tree A) := {| arbitrarySized n := genTreeSized n arbitrary |}. #[global] Instance shrTree {A} `{Shrink A} : Shrink (Tree A) := {| shrink x := shrinkTree shrink x |}. (** With this [Arbitrary] instance we can once again use the toplevel [QuickChick] command with just the property. *) QuickChick faultyMirrorP. (** [QuickChick] internally calls the function [quickCheck] with type [forall prop. Checkable prop => prop -> Result]. But what _is_ [Checkable]? It is easy to see how a boolean is [Checkable]; we can always tell if it is true or not and then return a [Result], [Success]/[Failure] as appropriate. To see how executable properties are [Checkable], consider a single argument function [p : A -> Bool] that returns a boolean. If we know that [A] has [Show] and [Arbitrary] instances, we can just call [forAllShrink] with [arbitrary] and [shrink]. Going a step further, the result type doesn't really need to be [Bool], it can be a [Checkable]! Thus, we can provide a [Checkable] instance for arbitrary functions.*) Print testFun. (** **** Collecting Statistics *) (** Earlier in this tutorial we claimed that [genTreeSized] produced "too many" [Leaf]s. But how can we justify that? Just looking at the result of [Sample] gives us an idea that something is going wrong but just observing a handful of samples cannot realistically provide statistical guarantees. That is where [collect], another property combinator, comes in. In Haskell notation, [collect] would have the type [collect : Show A, Checkable prop => A -> prop -> prop]; it takes some value of type [A] that can be shown and a property, and returns the property itself. Whenever the resulting property is exercised, the [A] object is captured and statistics are collected. For example, consider a [size] function on [Tree]s. *) Fixpoint size {A} (t : Tree A) : nat := match t with | Leaf => O | Node _ l r => 1 + size l + size r end. (** If we were to write a dummy property to check our generators and measure the size of generated trees, we could use [treeProp] below. *) Definition treeProp (g : nat -> G nat -> G (Tree nat)) n := forAll (g n (choose (0,n))) (fun t => collect (size t) true). QuickChick (treeProp genTreeSized 5). (** ==> 4947 : 0 1258 : 1 673 : 2 464 : 6 427 : 5 393 : 3 361 : 7 302 : 4 296 : 8 220 : 9 181 : 10 127 : 11 104 : 12 83 : 13 64 : 14 32 : 15 25 : 16 16 : 17 13 : 18 6 : 19 5 : 20 2 : 21 1 : 23 +++ OK, passed 10000 tests We see that 62.5% of the tests are either [Leaf]s or empty [Nodes], while too few tests have larger sizes. Compare that with [genTreeSized'] below. *) QuickChick (treeProp genTreeSized' 5). (** ==> 1624 : 0 571 : 10 564 : 12 562 : 11 559 : 9 545 : 8 539 : 14 534 : 13 487 : 7 487 : 15 437 : 16 413 : 6 390 : 17 337 : 5 334 : 1 332 : 18 286 : 19 185 : 4 179 : 20 179 : 2 138 : 21 132 : 3 87 : 22 62 : 23 19 : 24 10 : 25 6 : 26 2 : 27 +++ OK, passed 10000 tests A lot fewer terms have small sizes, allowing us to explore larger terms*) (** ** Avoiding Work :) *) (** While a lot of time putting a bit of time and effort in a generator and a shrinker, the examples shown here are fairly straightforward. After writing a couple of [Show] and [Arbitrary] instances, it can get tedious and boring. That is precisely why [QuickChick] provides some automation in deriving such instances for _plain_ datatypes automatically. *) Derive Arbitrary for Tree. (* GenSizedTree is defined *) (* ShrinkTree is defined *) Print GenSizedTree. Print ShrinkTree. Derive Show for Tree. (* ShowTree is defined *) Print ShowTree. QuickChick-2.1.0/tutorials/DerivingProofs.v000066400000000000000000000304121476030541200207070ustar00rootroot00000000000000From Coq Require Import Init.Nat List. Import ListNotations. From QuickChick Require Import QuickChick. Import QcNotation. Import QcDefaultNotation. Require Import Coq.Strings.Ascii. Open Scope qc_scope. Open Scope nat_scope. (* First of all, we need to import the proof-related modules, as they are not exported by default. *) From QuickChick Require Import EnumProofs CheckerProofs. (** Regexp Matching *) (* This example is taken from the Logical Foundations Volume of Software Foundations textbook *) Definition string := list ascii. (* We start with an inductive definion of the regular expression data type *) Inductive reg_exp (T : Type) : Type := | EmptySet | EmptyStr | Char (t : T) | App (r1 r2 : reg_exp T) | Union (r1 r2 : reg_exp T) | Star (r : reg_exp T). (* We can then derive an enumerator for inhabitants of this data type *) Derive EnumSized for reg_exp. (* Prints: EnumSizedreg_exp is defined *) About EnumSizedreg_exp. (* EnumSizedreg_exp : forall {T : Type}, Enum T -> EnumSized (reg_exp T) *) (* The [EnumSizedreg_exp] definition is a function that for each type T that can be enumerated (reflected in the typeclass constrain [Enum T]), returns an Instance of the typeclass [EnumSized]. *) (* Let's look more closely at these two typeclasses. First, what is an enumerator? The enumerator monad -------------------- Inductive EnumType (A : Type) : Type := MkEnum : (nat -> LazyList A) -> EnumType A The type of enumerators is [EnumType] (or for short, just [E]). This type encapsulates a function of type [nat -> LazyList A]. The [nat] parameter is an upper bound for the enumeration process. The return type is a lazy list that contains all inhabitants of type A up to the given size. The Enum typeclass ------------------ Class Enum (A : Type) : Type := { enum : E A } The [Enum] typeclass then is the class of all types that have an enumerator. The EnumSized typeclass ----------------------- The [EnumSized] typeclass is similar. Class EnumSized (A : Type) := { enumSized : nat -> E A }. The difference is that the enumerators of the EnumSized class have an additional [nat] parameter that is commonly used to bound the recursion depth. From EnumSized to Enum ---------------------- We can go from [EnumSized] to [Enum] using the [sized] combinator that internalizes the size parameter of [EnumSized]. Given an [EnumSized] instance, we can automatically derive an [Enum] instance with typeclass resolution. *) (* After automatically generating the [EnumSized] instance, we can generate correctness proofs. To do this proof we first define a "set-of-outcomes" semantics for our enumerator. In particular, the combinator [semEnumSize], with signature: semEnumSize : forall {A : Type}, E A -> nat -> set A maps an enumerator of type A to set indexed by a size. This is the set of element that can be generated for each value of the internal size parameter. We will use this to state properties of enumerators. Before generating correctness we need some crucial monotonicity properties. Monotonicity in the external size parameter -------------------------------------- First, we prove that the enumerator is monotonic in the external size parameter. That is, forall s s1 s2 : nat, s1 <= s2 -> semProdSize (enumSized s) s1 \subset (enumSized s) s2 This property is captured by the [SizeMonotonic] typeclass. Again. we automatically instances of these typeclass. *) #[local] Instance EnumSizedreg_exp_SizedMonotonic T {_ : Enum T} : SizedMonotonic (@enumSized _ (@EnumSizedreg_exp T _)). Proof. derive_enum_SizedMonotonic. Qed. (* Monotonicity in the internal size parameter -------------------------------------- We also prove that the enumerator is monotonic in the internal size parameter. That is, forall s s1 s2 : nat, s1 <= s2 -> semEnumSize (enumSized s1) s \subset semEnumSize (enumSized s2) s This property is captured by the [SizeMonotonic] typeclass. We automatically derive instances of this typeclass using our Ltac2 proofscript [derive_enum_SizedMonotonic]. *) #[local] Instance EnumSizedreg_exp_SizeMonotonic T `{EnumMonotonic T}: forall s, SizeMonotonic (@enumSized _ (@EnumSizedreg_exp T _) s). Proof. derive_enum_SizeMonotonic. Qed. (* Correctness ----------- We use the two monotonicity properties to prove correctness. For simple enumerators like this one, correctness states: { x | exists s s', x \in semEnumSize (enumSized s) s' } <--> [set: A] That is, the set of elements that belongs to [semEnumSize (enumSized s) s'] for some size parameters s (external) and s' (internal), is exactly the set of elements of type A (denoted [set: A]). The notation <--> denotes set equality. *) #[local] Instance EnumSizedreg_expCorrect T `{EnumMonotonicCorrect T}: CorrectSized (@enumSized _ EnumSizedreg_exp). Proof. derive_enum_Correct. Qed. (* Now that we have seen how enumeration of simple data types works, we can move on to enumeration and checking of inductive relations. We focus on regular expression matching. *) Reserved Notation "s =~ re" (at level 80). Definition app := @app. Arguments EmptySet {T}. Arguments EmptyStr {T}. Arguments Char {T} _. Arguments App {T} _ _. Arguments Union {T} _ _. Arguments Star {T} _. (* The following inductive relation holds whenever a string of characters drawn from a set [T] matches a regular expression. *) Inductive exp_match {T: Type} : list T -> reg_exp T -> Prop := | MEmpty : [] =~ EmptyStr | MChar x : [x] =~ (Char x) | MApp s1 re1 s2 re2 : s1 =~ re1 -> s2 =~ re2 -> s1 ++ s2 =~ (App re1 re2) | MUnionL s1 re1 re2 : s1 =~ re1 -> s1 =~ (Union re1 re2) | MUnionR re1 s2 re2 : s2 =~ re2 -> s2 =~ (Union re1 re2) | MStar0 re : [] =~ (Star re) | MStarApp s1 s2 re : s1 =~ re -> s2 =~ (Star re) -> s1 ++ s2 =~ (Star re) where "s =~ re" := (exp_match s re). (** Checkers *) (* First, we can generate a checker for [exp_match]. *) (* Instance EnumTest (y : nat) : EnumSizedSuchThat _ (fun x => eq x y). Admitted. Instance Dec (x y : nat) : DecOpt (x = y). Admitted. *) Derive DecOpt for (exp_match l e). (* DecOptexp_match is defined *) Derive EnumSizedSuchThat for (fun l => exp_match l e). About DecOptexp_match. (* DecOptexp_match : forall {T : Type}, Dec_Eq T -> Enum T -> forall (l : list T) (e : reg_exp T), DecOpt (l =~ e) *) (* That is, for all types [T] that have decidable equality and are enumerable (this constraint is always present even though the checker does now always use it), for all inputs [l] and [e], we can decide weather the string [l] matches the regular expression [e]. Checkers are described with the DecOpt typeclass. The DecOpt typeclass -------------------- Class DecOpt (P : Prop) := { decOpt : nat -> option bool }. This typeclass describes [Prop]'s that have a semi-decision procedures of type [nat -> option bool]. The natural number is the fuel that bounds the recursion depth of the generated procedure. Conceptually, the procedure can decide the validity of [Prop]'s whose proof derivation have depth less or equal to this number. *) (* We can now prove correctness of the derived checker. Monotonicity ------------ As before, we need to show monotonicity. In particular, we show that if the validity of a proposition has been decided, then the decision will not change by providing more fuel. In particular: forall (s1 s2 : nat) (b : bool), s1 <= s2 -> decOpt s1 = Some b -> decOpt s2 = Some b This is capture by the [DecOptSizeMonotonic] typeclass. As before, an instance is derived automatically. *) #[local] Instance DecOptexp_match_monotonic {T} `{_ : Dec_Eq T} `{_ : EnumMonotonic T} (m : list T) n : DecOptSizeMonotonic (exp_match m n). Proof. derive_mon. Qed. (* Soundness and Completeness -------------------------- Using monotonicity we can prove soundness and completeness. Soundness states: forall (P : Prop) (H : DecOpt P) (s : nat), decOpt s = Some true -> P That is, is [decOpt s] is [true] for some [s], then [P] holds. It is captured by the [DecOptSoundPos] typeclass. Completeness states: forall (P : Prop) (H : DecOpt P), P -> exists s : nat, decOpt s = Some true That is, if P holds then there exists some fuel [s] such that [decOpt s] is true. Again, we derive these instances automatically. *) #[local] Instance DecOptexp_match_sound {T} `{_ : Dec_Eq T} `{_ : EnumMonotonicCorrect T} (m : list T) n : DecOptSoundPos (exp_match m n). Proof. derive_sound. Qed. #[local] Instance DecOptexp_match_complete {T} `{_ : Dec_Eq T} `{_ : EnumMonotonicCorrect T} (m : list T) n : DecOptCompletePos (exp_match m n). Proof. derive_complete. Qed. (* Enumeration for the Eq predicate (TODO move) (required by [exp_match]) *) Derive EnumSizedSuchThat for (fun n => eq x n). #[local] Instance EnumSizedSuchThateq_SizedMonotonic X {_ : Enum X} {_ : Dec_Eq X} (n : X) : SizedMonotonicOptFP (@enumSizeST _ _ (EnumSizedSuchThateq n)). Proof. derive_enumST_SizedMonotonicFP. Qed. #[local] Instance EnumSizedSuchThateq_SizeMonotonic X `{_ : EnumMonotonic X} {_ : Dec_Eq X} (n : X) : forall s, SizeMonotonicOptFP (@enumSizeST _ _ (EnumSizedSuchThateq n) s). Proof. derive_enumST_SizeMonotonicFP. Qed. (* TODO: FIX: #[local] Instance EnumSizedSuchThateq_Correct X `{_ : EnumMonotonicCorrect X} `{_ : Dec_Eq X} (n : X) : CorrectSizedST (fun m => eq n m) (@enumSizeST _ _ (EnumSizedSuchThateq n)). Proof. derive_enumST_Correct. Qed. *) (* We can also derive an enumerator that given a regular expression, enumerates all strings that match the regular expression. *) Derive EnumSizedSuchThat for (fun l => exp_match l e). (* EnumSizedSuchThatexp_match is defined. *) About EnumSizedSuchThatexp_match. (* EnumSizedSuchThatexp_match : forall {T : Type}, Dec_Eq T -> Enum T -> forall e : reg_exp T, EnumSizedSuchThat (list T) (fun l : list T => l =~ e) *) (* For all types [T] that have decidable equality and are enumerable, and for all input regular expressions [e], we derive an enumerator. The [EnumSizedSuchThat] typeclass --------------------------------- [EnumSizedSuchThat] is similar to [EnumSized] but it is also parameterized by a predicate that the enumerated elements must satisfy. Class EnumSizedSuchThat (A : Type) (P : A -> Prop) := { enumSizeST : nat -> E (option A) } The type of the enumerator is [nat -> E (option A)]. Again, it has a [nat] parameter that bounds the recursion depth. The type of the enumerator is [E (option A)]. The semantics of [None] in the output of enumerator is that enumeration is not complete and there might be more elements that satisfy the predicate. *) (* As with the simple enumeration, before deriving correctness, we need to derive monotonicity. *) #[local] Instance EnumSizedSuchThatexp_match_SizedMonotonic {T} `{_ : Dec_Eq T} `{_ : EnumMonotonic T} e: SizedMonotonicOptFP (@enumSizeST _ _ (EnumSizedSuchThatexp_match e)). Proof. derive_enumST_SizedMonotonicFP. Qed. #[local] Instance EnumSizedSuchThatexp_match_SizeMonotonic {T} `{_ : Dec_Eq T} `{_ : EnumMonotonic T} e : forall s, SizeMonotonicOptFP (@enumSizeST _ _ (EnumSizedSuchThatexp_match e) s). Proof. derive_enumST_SizeMonotonicFP. Qed. (* Correctness ----------- Correctness of enumerators states that all elements that are generated satisfy the predicate (soundness) and that all elements that satisfy the predicate can be enumerated. Using the set of outcomes semantics, this can be states as: { x | exists s s', Some x \in semEnumSize (enumSizeST s) s' } <--> { x | P x } This is captured by the [CorrectSizedST] typeclass. We derive this instance automatically. *) (* TODO: Fix: #[local] Instance EnumSizedSuchThatexp_match_Correct {T} `{_ : Dec_Eq T} `{_ : EnumMonotonicCorrect T} e : CorrectSizedST (fun l => exp_match l e) (@enumSizeST _ _ (EnumSizedSuchThatexp_match e)). Proof. derive_enumST_Correct. Qed. *) (* Νote that we can also generate a enumerator for all the regular expressions that can match a string (i.e., the input is the string and the output is the regular expression) *) Derive EnumSizedSuchThat for (fun e => exp_match l e). QuickChick-2.1.0/tutorials/dune000066400000000000000000000002661476030541200164420ustar00rootroot00000000000000(alias (name runtest) (deps (alias_rec all))) (coq.theory (name QuickChick.Tutorials) (theories QuickChick) (modules BasicUsage Automation DerivingProofs ))