diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -21,15 +21,20 @@ **/TAGS **/tags -doc +doc/**/*.html +doc/**/*.css +doc/**/*.js +doc/**/*.png +doc/**/*.gif +doc/**/*.json README.html mk/toplibs -tests/test-extrapolate -tests/test-utils -tests/test-derive -tests/test-step-by-step -tests/test-new +test/extrapolate +test/utils +test/derive +test/step-by-step +test/new eg/sorting eg/list eg/int diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -37,7 +37,7 @@ - make && make test - make haddock HADDOCKFLAGS= #- travis_wait 30 cabal test -- stack $STACKR --no-terminal --skip-ghc-check test +- stack $STACKR --no-terminal --skip-ghc-check test --ghc-options=-O0 matrix: allow_failures: @@ -46,9 +46,12 @@ - ghc: 'head' env: GHCVER=head CABALVER=head addons: {apt: {packages: [ghc-head, cabal-install-head], sources: hvr-ghc}} + - ghc: '8.6' + env: GHCVER=8.6.3 CABALVER=2.4 + addons: {apt: {packages: [ghc-8.6.3, cabal-install-2.4], sources: hvr-ghc}} - ghc: '8.4' - env: GHCVER=8.4.2 CABALVER=2.2 - addons: {apt: {packages: [ghc-8.4.2, cabal-install-2.2], sources: hvr-ghc}} + env: GHCVER=8.4.4 CABALVER=2.2 + addons: {apt: {packages: [ghc-8.4.4, cabal-install-2.2], sources: hvr-ghc}} - ghc: '8.2' env: GHCVER=8.2.2 CABALVER=2.0 addons: {apt: {packages: [ghc-8.2.2, cabal-install-2.0], sources: hvr-ghc}} @@ -56,7 +59,7 @@ env: GHCVER=8.0.2 CABALVER=1.24 addons: {apt: {packages: [ghc-8.0.2, cabal-install-1.24], sources: hvr-ghc}} - ghc: '7.10' - env: GHCVER=7.10.3 CABALVER=1.22 STACKR=--resolver=lts-11.11 + env: GHCVER=7.10.3 CABALVER=1.22 STACK_YAML=stack-lts-11.yaml addons: {apt: {packages: [ghc-7.10.3, cabal-install-1.22], sources: hvr-ghc}} # we only support stack with GHC >= 7.10 - ghc: '7.8' diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,15 +1,15 @@ # Makefile for Extrapolate # -# Copyright: (c) 2015-2018 Rudy Matela +# Copyright: (c) 2015-2019 Rudy Matela # License: 3-Clause BSD (see the file LICENSE) # Maintainer: Rudy Matela TESTS = \ - tests/test-derive \ - tests/test-utils \ - tests/test-new \ - tests/test-step-by-step \ - tests/test-extrapolate + test/derive \ + test/utils \ + test/step-by-step \ + test/extrapolate QUICKEG = \ + eg/sorting \ eg/int \ eg/list \ eg/calculator \ @@ -17,8 +17,7 @@ eg/parser \ eg/heap \ eg/redblack \ - eg/word-refinements \ - eg/sorting + eg/word-refinements EG = \ bench/true \ bench/false \ @@ -28,24 +27,29 @@ eg/overflow \ eg/overflow8 \ $(QUICKEG) -GHCIMPORTDIRS = src:tests:eg +GHCIMPORTDIRS = src:test:eg GHCEXTRAFLAGS = #-prof -fprof-auto #-caf-all # When profiling is enabled, to get the cost centres with more than 6% time: # $ ./eg/sorting +RTS -p -RTS # $ cat sorting.prof | grep -v ' [0-5].[0-9] ......$' -GHCFLAGS = -O2 $(GHCEXTRAFLAGS) \ +GHCFLAGS = -O2 \ + $(GHCEXTRAFLAGS) \ $(shell grep -q "Arch Linux" /etc/lsb-release && echo -dynamic) -HADDOCKFLAGS = --no-print-missing-docs +# -Wall -Wno-name-shadowing -Wno-orphans -Wno-unused-matches +HADDOCKFLAGS = --no-print-missing-docs \ + $(shell grep -q "Arch Linux" /etc/lsb-release && echo --optghc=-dynamic) +LIST_ALL_HSS = find src test mk eg/*.hs bench/*.hs -name "*.hs" +LIB_DEPS = base template-haskell leancheck express speculate all: mk/toplibs all-all: mk/All.hs -test: $(patsubst %,%.test,$(TESTS)) diff-test +test: $(patsubst %,%.run,$(TESTS)) diff-test test-sdist diff-test: $(patsubst %,%.diff-test,$(EG)) -quick-test: $(patsubst %,%.test,$(TESTS)) quick-diff-test +quick-test: $(patsubst %,%.run,$(TESTS)) quick-diff-test test-sdist quick-diff-test: $(patsubst %,%.diff-test,$(QUICKEG)) @@ -53,22 +57,22 @@ egs: $(EG) -%.test: tests/test-% - ./$< - -%.test: % +%.run: % ./$< %.diff-test: % - ./$< | diff -rud tests/model/$<.out - + ./$< | diff -rud test/model/$<.out - %.update-diff-test: % - ./$< > tests/model/$<.out + ./$< > test/model/$<.out test-sdist: - ./tests/test-sdist + ./test/sdist +.PHONY: bench bench: $(patsubst %,%.bench,$(EG)) + @mkdir -p bench/runtime/$$HOSTNAME + ./bench/versions | tee bench/runtime/$$HOSTNAME/versions .PHONY: %.bench %.bench: % @@ -82,7 +86,7 @@ ghci: mk/All.ghci -ghci-test: tests/Test.ghci +ghci-test: test/Test.ghci ghci-7.10: GHC=ghc-7.10 ghci-7.10: mk/All.ghci @@ -135,8 +139,8 @@ pandoc README.md -o README.html # NOTE: (very hacky!) the following target allows parallel compilation (-jN) of -# eg and tests programs so long as they don't share dependencies _not_ stored -# in src/ and tests/. Runnable binaries should depend on mk/toplibs instead of +# eg and test programs so long as they don't share dependencies _not_ stored +# in src/ and test/. Runnable binaries should depend on mk/toplibs instead of # actual Haskell source files mk/toplibs: mk/Toplibs.o touch mk/toplibs diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,6 +6,8 @@ [![Extrapolate on Stackage LTS][stackage-lts-badge]][extrapolate-on-stackage-lts] [![Extrapolate on Stackage Nightly][stackage-nightly-badge]][extrapolate-on-stackage-nightly] +![Extrapolate logo][extrapolate-logo] + Extrapolate is a [property-based testing] library for [Haskell] capable of reporting generalized counter-examples. @@ -123,9 +125,8 @@ There are two other tools for [Haskell] capable of producing generalized counter-examples: [SmartCheck] and [Lazy SmallCheck 2012]. -Extrapolate was accepted for presentation at [IFL 2017], -see the pre-symposium proceedings -[paper about Extrapolate](https://matela.com.br/paper/extrapolate.pdf). +Extrapolate was accepted for presentation at [IFL 2017], see the +[IFL paper about Extrapolate](https://matela.com.br/paper/extrapolate.pdf). Extrapolate is also subject to a chapter in a [PhD Thesis (2017)]. [extrapolate-on-hackage]: https://hackage.haskell.org/package/extrapolate @@ -147,11 +148,13 @@ [Lazy SmallCheck 2012]: https://github.com/UoYCS-plasma/lazysmallcheck2012 [PhD Thesis (2017)]: https://matela.com.br/paper/rudy-phd-thesis-2017.pdf +[extrapolate-logo]: https://github.com/rudymatela/extrapolate/raw/master/doc/extrapolate.svg?sanitize=true + [build-status]: https://travis-ci.org/rudymatela/extrapolate.svg?branch=master [build-log]: https://travis-ci.org/rudymatela/extrapolate [hackage-version]: https://img.shields.io/hackage/v/extrapolate.svg -[stackage-lts-badge]: http://stackage.org/package/extrapolate/badge/lts -[stackage-nightly-badge]: http://stackage.org/package/extrapolate/badge/nightly -[extrapolate-on-stackage]: http://stackage.org/package/extrapolate -[extrapolate-on-stackage-lts]: http://stackage.org/lts/package/extrapolate -[extrapolate-on-stackage-nightly]: http://stackage.org/nightly/package/extrapolate +[stackage-lts-badge]: https://stackage.org/package/extrapolate/badge/lts +[stackage-nightly-badge]: https://stackage.org/package/extrapolate/badge/nightly +[extrapolate-on-stackage]: https://stackage.org/package/extrapolate +[extrapolate-on-stackage-lts]: https://stackage.org/lts/package/extrapolate +[extrapolate-on-stackage-nightly]: https://stackage.org/nightly/package/extrapolate diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -3,79 +3,15 @@ A non-exhaustive list of things TO DO for Extrapolate. -WARNING: This TO DO list is outdated. - -* `deriveGeneralizable` should `deriveListableIfNeeded`. - -examples --------- - - -* `ideal-generalizations`: - Add examples of ideal generalizations as described in past paper by human - experts. The counter example is `blah` because the property fails for every - `bleh` and `blih`. I found: - - - one on Duregard's licentiate Thesis: `prop_cycle` from `BNFC-meta`. - - one on Duregard's doctorate Thesis. - - one on SmallCheck's paper: `prop_insertRB` from RedBlack - - there are none on: - - - QuickCheck - - Testing and Tracing with Quickcheck and Hat - - SmartCheck - - Feat - - Real World Haskell - - Learn-you-a-haskell - - Growing and shrinking polygons - - QuickFuzz - -* `add-th-eg`: - add the parser example from the Feat paper; - -* `apply-lazysmallcheck`: - apply Lazy SmallCheck to calculator and parse and record the results. - -feature -------- - -* `deriveGeneralizableAtomic`: derive a generalizable value treating it as - atomic, as I did with the Map on the XMonad example. To be used on datatypes - with data invariants. +* improve performance by improving performance of Speculate * `deriveGeneralizableFromTo`: derive a generalizable value using a bijection passed as parameter so that a data invariant is not broken. Example: deriveGeneralizable ''Map fromList toList. - -* `background-exclusion`: - add a mechanism to exclude functions from the background. - -* `report-multiple-generalizations`: - when there is more than one generalization and they don't encompass - one-another, report both. - -* `detect-silly-conditionals`: - eg: - - xs when 0 /= length xs - - that's just: - - _:_ - - the above is for the last property of the list example - -* `renaming`: - possibly print `(Div (C 0) (Add (C x) (C (negate x))))` - which is equivalent to `(Div (C 0) (Add (C x) (C y))) when y == negate x` - instead of `(Div (C 0) (Add (C 0) (C 0)))`; - - I got it to print the middle one, by just: `-- not (isAssignment wc)` and - `constant "negate" (negate -:> x) in the background`. - +* `add-th-eg`: + add the parser example from the Feat paper; * `improve-record-printing`: Improve the record printing by explictly printing records and _not_ showing @@ -83,7 +19,7 @@ StackSet (Screen (Workspace x y (Just s)) z x’) ss ws crs - but we could get instead, with the actual following indentation: + but we could get the following instead (with indent): > check prop_delete StackSet { current = Screen @@ -103,90 +39,3 @@ which could be further summarized to: stackset {current = scr {workspace = ws {stack = Just s}}} - - -performance and improvements in the algorithm (only later) ----------------------------------------------------------- - -* `type-after-type`: - to improve performance, instead of working with all types at once, perform - the algorithm type after type - -* `single-then-multi`: - only do vassignments *after* finding a failing single variable instance. - I'll have to re-test, but the time I save may pay off. - -* `new-lgg-algorithm`: - - This is just a sketch: - - 1. test and keep all tests that pass and fail - - 2. pick first counter-example, note that it does not match any of the passing - tests - - 3. first counter-example is current generalization - - 4. compute lgg of current generalization with the next counter-example - - 5. if it does not matches any of the passing tests, update current generalization - - 6. go to 4 - - 7. generalize to several variables - - Variation of steps 4 and 5 with conditions: - - 4. compute lgg of current generaliation with the next counter-example, - find weakest condition for it to hold - - 5. if lgg matches 10% of failing tests, update current generalization. - - The variation may have trouble when dealing with multiple variables, - maybe there should be a multi-lgg, or start with all vars different - - After some tests, I see that this does not quite work as expected. c.f. - `union xs ys == union ys xs`. When incorporating a counterExample, sometimes - the generalization will temporarily match some passing tests, only to be - later weeded out by some other counter-example. There are many many more - combinations of counterexamples 2^#nce then there are candidate - generalizations of the smallest counter-example (at least in the worst case, - maybe there is a property here that I am not seeing). - - - -won't fix ---------- - -* `nlp-example`: - add the NLP example from the SmartCheck paper. I don't think I'll use this - because of a few issues. - - GenI has the bit-rot: - - - GenI 0.24.3 refuses to build on GHC 8.0.1; - - - GenI 0.24.3 builds on GHC 7.8 but test files are missing; - - - The version on git is the most up-to-date contradicting the fact that it is - supposed to be a mirror from Darcs. It does not seem to be building on - Travis. It has tests, but I have not tried compiling it. - - Lee Pike's paper does not list the exact property and fault for which - SmartCheck recuces its counterexample. I also looked at the TeX comments, - and the info is also not there. The mentioned stackoverflow question does - not help with that either. I could certainly ask of course if I choose to - carry on with this. - - Thinking again, maybe it is a good idea to use this. It is a real library - with real bugs in the git history. - -* `enlarge-default-background`: - I tried enlarging the default background by including (&&) and (||). Not - only there is no effect in the output of the build-in examples, runtime - increases for up to 33%. - - I also tried enlarging the default background by including functions over - lists from the prelude, such as: (:), last, reverse, init. Runtime increases - by 10x, with no interesting effect on output (most changes are just - rewritings of the unconditional generalization. diff --git a/bench/diff.hs b/bench/diff.hs --- a/bench/diff.hs +++ b/bench/diff.hs @@ -1,5 +1,4 @@ import Test.Extrapolate -import Data.List import Data.Typeable (typeOf) main :: IO () diff --git a/bench/eq.hs b/bench/eq.hs --- a/bench/eq.hs +++ b/bench/eq.hs @@ -1,5 +1,4 @@ import Test.Extrapolate -import Data.List import Data.Typeable (typeOf) main :: IO () diff --git a/bench/false.hs b/bench/false.hs --- a/bench/false.hs +++ b/bench/false.hs @@ -1,5 +1,4 @@ import Test.Extrapolate -import Data.List import Data.Typeable (typeOf) main :: IO () diff --git a/bench/ord.hs b/bench/ord.hs --- a/bench/ord.hs +++ b/bench/ord.hs @@ -1,5 +1,4 @@ import Test.Extrapolate -import Data.List import Data.Typeable (typeOf) main :: IO () @@ -49,6 +48,7 @@ check `withConditionSize` 3 $ (>=) -:> x putStrLn "" +{- chint :: IO () chint = do -- TODO: make the following work on GHC >= 8.2 @@ -64,3 +64,4 @@ check `withConditionSize` 3 $ (>) -:> [int] check `withConditionSize` 3 $ (>=) -:> [int] putStrLn "" +-} diff --git a/bench/runtime/zero/bench/diff.runtime b/bench/runtime/zero/bench/diff.runtime --- a/bench/runtime/zero/bench/diff.runtime +++ b/bench/runtime/zero/bench/diff.runtime @@ -1,1 +1,1 @@ -7.05 +4.95 diff --git a/bench/runtime/zero/bench/eq.runtime b/bench/runtime/zero/bench/eq.runtime --- a/bench/runtime/zero/bench/eq.runtime +++ b/bench/runtime/zero/bench/eq.runtime @@ -1,1 +1,1 @@ -27.25 +18.07 diff --git a/bench/runtime/zero/bench/false.runtime b/bench/runtime/zero/bench/false.runtime --- a/bench/runtime/zero/bench/false.runtime +++ b/bench/runtime/zero/bench/false.runtime @@ -1,1 +1,1 @@ -6.47 +5.64 diff --git a/bench/runtime/zero/bench/ord.runtime b/bench/runtime/zero/bench/ord.runtime --- a/bench/runtime/zero/bench/ord.runtime +++ b/bench/runtime/zero/bench/ord.runtime @@ -1,1 +1,1 @@ -13.25 +8.98 diff --git a/bench/runtime/zero/bench/true.runtime b/bench/runtime/zero/bench/true.runtime --- a/bench/runtime/zero/bench/true.runtime +++ b/bench/runtime/zero/bench/true.runtime @@ -1,1 +1,1 @@ -0.08 +0.07 diff --git a/bench/runtime/zero/eg/calculator.runtime b/bench/runtime/zero/eg/calculator.runtime --- a/bench/runtime/zero/eg/calculator.runtime +++ b/bench/runtime/zero/eg/calculator.runtime @@ -1,1 +1,1 @@ -0.79 +0.40 diff --git a/bench/runtime/zero/eg/gencalc.runtime b/bench/runtime/zero/eg/gencalc.runtime --- a/bench/runtime/zero/eg/gencalc.runtime +++ b/bench/runtime/zero/eg/gencalc.runtime @@ -1,1 +1,1 @@ -0.71 +0.39 diff --git a/bench/runtime/zero/eg/heap.runtime b/bench/runtime/zero/eg/heap.runtime --- a/bench/runtime/zero/eg/heap.runtime +++ b/bench/runtime/zero/eg/heap.runtime @@ -1,1 +1,1 @@ -4.29 +2.70 diff --git a/bench/runtime/zero/eg/int.runtime b/bench/runtime/zero/eg/int.runtime --- a/bench/runtime/zero/eg/int.runtime +++ b/bench/runtime/zero/eg/int.runtime @@ -1,1 +1,1 @@ -4.18 +2.85 diff --git a/bench/runtime/zero/eg/list.runtime b/bench/runtime/zero/eg/list.runtime --- a/bench/runtime/zero/eg/list.runtime +++ b/bench/runtime/zero/eg/list.runtime @@ -1,1 +1,1 @@ -10.17 +6.82 diff --git a/bench/runtime/zero/eg/overflow.runtime b/bench/runtime/zero/eg/overflow.runtime --- a/bench/runtime/zero/eg/overflow.runtime +++ b/bench/runtime/zero/eg/overflow.runtime @@ -1,1 +1,1 @@ -0.21 +0.18 diff --git a/bench/runtime/zero/eg/overflow8.runtime b/bench/runtime/zero/eg/overflow8.runtime --- a/bench/runtime/zero/eg/overflow8.runtime +++ b/bench/runtime/zero/eg/overflow8.runtime @@ -1,1 +1,1 @@ -7.16 +5.02 diff --git a/bench/runtime/zero/eg/parser.runtime b/bench/runtime/zero/eg/parser.runtime --- a/bench/runtime/zero/eg/parser.runtime +++ b/bench/runtime/zero/eg/parser.runtime @@ -1,1 +1,1 @@ -8.91 +6.37 diff --git a/bench/runtime/zero/eg/redblack.runtime b/bench/runtime/zero/eg/redblack.runtime --- a/bench/runtime/zero/eg/redblack.runtime +++ b/bench/runtime/zero/eg/redblack.runtime @@ -1,1 +1,1 @@ -0.02 +0.03 diff --git a/bench/runtime/zero/eg/sorting.runtime b/bench/runtime/zero/eg/sorting.runtime --- a/bench/runtime/zero/eg/sorting.runtime +++ b/bench/runtime/zero/eg/sorting.runtime @@ -1,1 +1,1 @@ -12.02 +24.21 diff --git a/bench/runtime/zero/eg/word-refinements.runtime b/bench/runtime/zero/eg/word-refinements.runtime --- a/bench/runtime/zero/eg/word-refinements.runtime +++ b/bench/runtime/zero/eg/word-refinements.runtime @@ -1,1 +1,1 @@ -11.42 +7.84 diff --git a/bench/runtime/zero/versions b/bench/runtime/zero/versions new file mode 100644 --- /dev/null +++ b/bench/runtime/zero/versions @@ -0,0 +1,4 @@ +GHC 8.6.5 +leancheck-0.9.1 +express-0.0.4 +speculate-0.3.5 diff --git a/bench/true.hs b/bench/true.hs --- a/bench/true.hs +++ b/bench/true.hs @@ -1,5 +1,4 @@ import Test.Extrapolate -import Data.List import Data.Typeable (typeOf) main :: IO () diff --git a/bench/versions b/bench/versions new file mode 100644 --- /dev/null +++ b/bench/versions @@ -0,0 +1,14 @@ +#!/bin/bash +get-ghc-v() { + ghc --version | sed -e "s/.* version/GHC/" +} +get-pkg-v() { + ghc-pkg list $1 2>/dev/null | + grep " $1-" | + sed -e "s/^ *//" | + tail -1 +} +get-ghc-v +get-pkg-v leancheck +get-pkg-v express +get-pkg-v speculate diff --git a/doc/extrapolate.svg b/doc/extrapolate.svg new file mode 100644 --- /dev/null +++ b/doc/extrapolate.svg @@ -0,0 +1,127 @@ + + + + + Extrapolate + + + + + + + + + + image/svg+xml + + Extrapolate + + 2018-11-24 + + + Rudy Matela + + + https://github.com/rudymatela/extrapolate + + + Extrapolate + Haskell + logo + LeanCheck + + + Extrapolate's logo. An X is seen in red intersected with a lambda sign. An equals sign follows. + +The proportions are based on the beautiful proportions of the Thompson-Wheeler Haskell logo (2009). + + + + + + + + + + + + + + + + + + diff --git a/eg/calculator.hs b/eg/calculator.hs --- a/eg/calculator.hs +++ b/eg/calculator.hs @@ -5,9 +5,8 @@ -- The version here is the one from the paper (similar to the one in the README -- file). I chose the one in the paper as it is clearer. import Control.Monad -import Test.Extrapolate hiding (eval) +import Test.Extrapolate import Data.Maybe -import qualified Test.LeanCheck as Lean #if __GLASGOW_HASKELL__ < 710 import Data.Typeable (Typeable) @@ -45,14 +44,17 @@ -- deriveGeneralizable ''Exp -- {- +instance Name Exp where name _ = "e1" + +instance Express Exp where + expr (C i) = value "C" C :$ expr i + expr (Add e1 e2) = value "Add" Add :$ expr e1 :$ expr e2 + expr (Div e1 e2) = value "Div" Div :$ expr e1 :$ expr e2 + instance Generalizable Exp where - name _ = "e1" - expr (C i) = constant "C" C :$ expr i - expr (Add e1 e2) = constant "Add" Add :$ expr e1 :$ expr e2 - expr (Div e1 e2) = constant "Div" Div :$ expr e1 :$ expr e2 - background e = [ constant "eval" eval - , constant "noDiv0" noDiv0 ] - instances e = this e $ instances (undefined :: Int) + background e = [ value "eval" eval + , value "noDiv0" noDiv0 ] + subInstances _ = instances (undefined :: Int) -- -} diff --git a/eg/gencalc.hs b/eg/gencalc.hs --- a/eg/gencalc.hs +++ b/eg/gencalc.hs @@ -46,12 +46,16 @@ -- deriveGeneralizable ''Exp -- {- +instance Name a => Name (Exp a) where name _ = "e1" + +instance Express a => Express (Exp a) where + expr e@(C i) = value "C" (C ->: e) :$ expr i + expr e@(Add e1 e2) = value "Add" (Add ->>: e) :$ expr e1 :$ expr e2 + expr e@(Div e1 e2) = value "Div" (Div ->>: e) :$ expr e1 :$ expr e2 + instance Generalizable a => Generalizable (Exp a) where - name _ = "e1" - expr e@(C i) = constant "C" (C ->: e) :$ expr i - expr e@(Add e1 e2) = constant "Add" (Add ->>: e) :$ expr e1 :$ expr e2 - expr e@(Div e1 e2) = constant "Div" (Div ->>: e) :$ expr e1 :$ expr e2 - instances e = this e $ (let C i = C undefined `asTypeOf` e in instances i) + subInstances e = instances i + where C i = e -- -} argTypeOf :: (a -> b) -> a -> (a -> b) diff --git a/eg/heap.hs b/eg/heap.hs --- a/eg/heap.hs +++ b/eg/heap.hs @@ -5,12 +5,10 @@ -- Which in turn was, -- Copied from QuickCheck2's examples. -import System.Environment import Data.List (sort) import Data.Typeable import Test.Extrapolate import qualified Test.LeanCheck as Lean -import Test.LeanCheck.Utils #if __GLASGOW_HASKELL__ < 710 import Data.Typeable (Typeable) @@ -23,13 +21,17 @@ instance (Ord a, Listable a) => Listable (Heap a) where tiers = cons1 heap -instance (Ord a, Generalizable a) => Generalizable (Heap a) where +instance Name (Heap a) where name _ = "h" - expr h = constant "fromList" (fromList ->: h) :$ expr (toList h) - background h = [ constant "size" $ size -:> h ] - instances h = this h $ instances (toList h) +instance (Ord a, Express a) => Express (Heap a) where + expr h = value "fromList" (fromList ->: h) :$ expr (toList h) +instance (Ord a, Generalizable a) => Generalizable (Heap a) where + background h = [ value "size" $ size -:> h ] + subInstances h = instances (toList h) + + data Heap a = Node a (Heap a) (Heap a) | Nil @@ -114,20 +116,22 @@ \/ cons2 Merge \/ cons1 FromList -instance (Generalizable a, Typeable a) => Generalizable (HeapP a) where +instance Name (HeapP a) where name _ = "p" - expr p'@Empty = constant "Empty" (Empty -: p') - expr p'@(Unit x) = constant "Unit" (Unit ->: p') :$ expr x - expr p'@(Insert x p) = constant "Insert" (Insert ->>: p') :$ expr x :$ expr p - expr p'@(SafeRemoveMin x) = constant "SafeRemoveMin" (SafeRemoveMin ->: p') :$ expr x - expr p'@(Merge p q) = constant "Merge" (Merge ->>: p') :$ expr p :$ expr q - expr p'@(FromList xs) = constant "FromList" (FromList ->: p') :$ expr xs - instances p = this p - $ let Unit x = Unit undefined `asTypeOf` p - in instances x +instance Express a => Express (HeapP a) where + expr p'@Empty = value "Empty" (Empty -: p') + expr p'@(Unit x) = value "Unit" (Unit ->: p') :$ expr x + expr p'@(Insert x p) = value "Insert" (Insert ->>: p') :$ expr x :$ expr p + expr p'@(SafeRemoveMin x) = value "SafeRemoveMin" (SafeRemoveMin ->: p') :$ expr x + expr p'@(Merge p q) = value "Merge" (Merge ->>: p') :$ expr p :$ expr q + expr p'@(FromList xs) = value "FromList" (FromList ->: p') :$ expr xs +instance (Generalizable a, Typeable a) => Generalizable (HeapP a) where + subInstances p = instances x where Unit x = p + + data HeapPP a = HeapPP { program :: (HeapP a) , theHeap :: (Heap a) } deriving (Show, Read) @@ -138,15 +142,17 @@ heappp :: Ord a => HeapP a -> HeapPP a heappp p = HeapPP p (heap p) -instance (Ord a, Generalizable a) => Generalizable (HeapPP a) where +instance Name (HeapPP a) where name _ = "hpp" - expr (HeapPP p _) = constant "heappp" (heappp -:> p) :$ expr p - background hpp = [ constant "program" $ program -:> hpp - , constant "theHeap" $ theHeap -:> hpp + +instance (Ord a, Express a) => Express (HeapPP a) where + expr (HeapPP p _) = value "heappp" (heappp -:> p) :$ expr p + +instance (Ord a, Generalizable a) => Generalizable (HeapPP a) where + background hpp = [ value "program" $ program -:> hpp + , value "theHeap" $ theHeap -:> hpp ] - instances hpp = this hpp - $ let HeapPP p h = HeapPP undefined undefined `asTypeOf` hpp - in instances p . instances h + subInstances hpp = instances p . instances h where HeapPP p h = hpp (==?) :: Ord a => Heap a -> [a] -> Bool diff --git a/eg/overflow.hs b/eg/overflow.hs --- a/eg/overflow.hs +++ b/eg/overflow.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} -- for GHC <= 7.8 import Test.Extrapolate import Test.LeanCheck.Utils -import qualified Test.LeanCheck as Lean import Data.Int #if __GLASGOW_HASKELL__ < 710 @@ -26,23 +25,16 @@ prop :: T -> Bool prop t = pre t ==> post t -instance Listable Int16 where - list = map unX list - +instance Name Int16 +instance Express Int16 where expr = val instance Generalizable Int16 where - name _ = "x" - expr = showConstant - instances x = this x id - background x = bgOrd x + background x = reifyEqOrd x -{- instance Listable T where tiers = cons5 makeT where makeT (Xs i) (Xs j) (Xs k) (Xs l) (Xs m) = T i j k l m --} -deriveListable ''T deriveGeneralizable ''T main :: IO () @@ -50,6 +42,6 @@ check `for` 10000 `withConditionSize` 2 -- NOTE: it takes 25m to run with the following two lines uncommented --- `withBackground` [constant "sum" (sum :: [Int16] -> Int16)] +-- `withBackground` [value "sum" (sum :: [Int16] -> Int16)] -- `withConditionSize` 4 $ prop diff --git a/eg/overflow8.hs b/eg/overflow8.hs --- a/eg/overflow8.hs +++ b/eg/overflow8.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} -- for GHC <= 7.8 import Test.Extrapolate import Test.LeanCheck.Utils -import qualified Test.LeanCheck as Lean import Data.Int #if __GLASGOW_HASKELL__ < 710 @@ -26,22 +25,22 @@ prop :: T -> Bool prop t = pre t ==> post t -instance Listable Int8 where - list = map unX list - +instance Name Int8 +instance Express Int8 where expr = val instance Generalizable Int8 where - name _ = "x" - expr = showConstant - instances x = this x id - background x = bgOrd x + background x = reifyEqOrd x -deriveListable ''T +instance Listable T where + tiers = cons2 makeT + where + makeT (Xs i) (Xs j) = T i j + deriveGeneralizable ''T main :: IO () main = do check `for` 1080 -- 2160 - `withBackground` [constant "sum" (sum :: [Int8] -> Int8)] + `withBackground` [value "sum" (sum :: [Int8] -> Int8)] `withConditionSize` 4 $ prop -- NOTE: with T defined as a triple, this takes 25s to run diff --git a/eg/parser.hs b/eg/parser.hs --- a/eg/parser.hs +++ b/eg/parser.hs @@ -13,12 +13,10 @@ import Prelude hiding (showList, mod) --import Test.LeanCheck -import Test.Extrapolate hiding (Var) +import Test.Extrapolate import qualified Test.LeanCheck as Lean import Test.LeanCheck.Utils ((-:>)) -import System.Environment - import Data.List import GHC.Generics @@ -110,54 +108,66 @@ deriveGeneralizable ''Stmt -} -- {- +instance Name Var where name _ = "v" +instance Name Lang where name _ = "l" +instance Name Mod where name _ = "m" +instance Name Func where name _ = "f" +instance Name Exp where name _ = "e" +instance Name Stmt where name _ = "stmt" + +instance Express Var where + expr (Var v) = value "Var" Var :$ expr v + +instance Express Lang where + expr (Lang ms fs) = value "Lang" Lang :$ expr ms :$ expr fs + +instance Express Mod where + expr (Mod is es) = value "Mod" Mod :$ expr is :$ expr es + +instance Express Func where + expr (Func n as ss) = value "Func" Func :$ expr n :$ expr as :$ expr ss + +instance Express Exp where + expr (Int i) = value "Int" Int :$ expr i + expr (Bool p) = value "Bool" Bool :$ expr p + expr (Add e1 e2) = value "Add" Add :$ expr e1 :$ expr e2 + expr (Sub e1 e2) = value "Sub" Sub :$ expr e1 :$ expr e2 + expr (Mul e1 e2) = value "Mul" Mul :$ expr e1 :$ expr e2 + expr (Div e1 e2) = value "Div" Div :$ expr e1 :$ expr e2 + expr (Not e) = value "Not" Not :$ expr e + expr (And e1 e2) = value "And" And :$ expr e1 :$ expr e2 + expr (Or e1 e2) = value "Or " Or :$ expr e1 :$ expr e2 + +instance Express Stmt where + expr (Assign v e) = value "Assign" Assign :$ expr v :$ expr e + expr (Alloc v e) = value "Alloc" Alloc :$ expr v :$ expr e + expr (Return e) = value "Return" Return :$ expr e + instance Generalizable Var where - name _ = "v" - expr (Var v) = constant "Var" Var :$ expr v - instances v = this v $ instances (undefined :: [String]) + subInstances v = instances (undefined :: [String]) instance Generalizable Lang where - name _ = "l" - expr (Lang ms fs) = constant "Lang" Lang :$ expr ms :$ expr fs - instances l = this l $ instances (undefined :: [Mod]) - . instances (undefined :: [Func]) + subInstances l = instances (undefined :: [Mod]) + . instances (undefined :: [Func]) instance Generalizable Mod where - name _ = "m" - expr (Mod is es) = constant "Mod" Mod :$ expr is :$ expr es - instances m = this m $ instances (undefined :: Var) + subInstances m = instances (undefined :: Var) instance Generalizable Func where - name _ = "f" - expr (Func n as ss) = constant "Func" Func :$ expr n :$ expr as :$ expr ss - instances f = this f $ instances (undefined :: Var) - . instances (undefined :: [Exp]) - . instances (undefined :: [Stmt]) + subInstances f = instances (undefined :: Var) + . instances (undefined :: [Exp]) + . instances (undefined :: [Stmt]) instance Generalizable Exp where - name _ = "e" - expr (Int i) = constant "Int" Int :$ expr i - expr (Bool p) = constant "Bool" Bool :$ expr p - expr (Add e1 e2) = constant "Add" Add :$ expr e1 :$ expr e2 - expr (Sub e1 e2) = constant "Sub" Sub :$ expr e1 :$ expr e2 - expr (Mul e1 e2) = constant "Mul" Mul :$ expr e1 :$ expr e2 - expr (Div e1 e2) = constant "Div" Div :$ expr e1 :$ expr e2 - expr (Not e) = constant "Not" Not :$ expr e - expr (And e1 e2) = constant "And" And :$ expr e1 :$ expr e2 - expr (Or e1 e2) = constant "Or " Or :$ expr e1 :$ expr e2 - background e = [ constant "==" ((==) -:> e) - , constant "/=" ((/=) -:> e) ] - instances e = this e - $ instances (undefined :: Var) - . instances (undefined :: Int) - . instances (undefined :: Bool) + background e = [ value "==" ((==) -:> e) + , value "/=" ((/=) -:> e) ] + subInstances e = instances (undefined :: Var) + . instances (undefined :: Int) + . instances (undefined :: Bool) instance Generalizable Stmt where - name _ = "stmt" - expr (Assign v e) = constant "Assign" Assign :$ expr v :$ expr e - expr (Alloc v e) = constant "Alloc" Alloc :$ expr v :$ expr e - expr (Return e) = constant "Return" Return :$ expr e - instances s = this s $ instances (undefined :: Var) - . instances (undefined :: Exp) + subInstances s = instances (undefined :: Var) + . instances (undefined :: Exp) -- -} diff --git a/eg/redblack.hs b/eg/redblack.hs --- a/eg/redblack.hs +++ b/eg/redblack.hs @@ -14,10 +14,8 @@ -- http://www.seas.upenn.edu/~cis552/12fa/lectures/stub/BST.html import RedBlackSet -import Control.Monad import Test.Extrapolate -import Data.Typeable instance (Ord a, Listable a) => Listable (RBSet a) where @@ -36,6 +34,7 @@ blackDepth (T B l _ r) = case (blackDepth(l),blackDepth(r)) of (Just(n),Just(m)) -> if n == m then Just(1+n) else Nothing (_,_) -> Nothing +blackDepth _ = error "unhandled pattern" -- Check for red-red violations: prop_NoRedRed :: RBSet Int -> Bool @@ -43,6 +42,7 @@ prop_NoRedRed (T R (T R _ _ _) _ _) = False prop_NoRedRed (T R _ _ (T R _ _ _)) = False prop_NoRedRed (T _ l x r) = (prop_NoRedRed l) && (prop_NoRedRed r) +prop_NoRedRed _ = error "unhandled pattern" -- Check for black-balanced violations: @@ -124,11 +124,14 @@ instance Listable Color where tiers = [[R, B], [BB, NB]] -instance (Ord a, Generalizable a) => Generalizable (RBSet a) where +instance Name (RBSet a) where name _ = "h" - expr t = constant "fromList" (fromList ->: t) :$ expr (toAscList t) - instances h = this h - $ instances (toAscList h) + +instance (Ord a, Express a) => Express (RBSet a) where + expr t = value "fromList" (fromList ->: t) :$ expr (toAscList t) + +instance (Ord a, Generalizable a) => Generalizable (RBSet a) where + subInstances h = instances (toAscList h) -- TODO: make LeanCheck find a counter-example to prop_BlackBalanced -- when -DBALANCE_BUG is active or find out why it cannot find it. diff --git a/eg/sorting.hs b/eg/sorting.hs --- a/eg/sorting.hs +++ b/eg/sorting.hs @@ -1,6 +1,4 @@ import Test.Extrapolate -import Test.LeanCheck.Utils -import qualified Test.LeanCheck as Lean sort :: Ord a => [a] -> [a] sort [] = [] @@ -29,5 +27,5 @@ chk `for` 99 $ prop_sortCount -:> bool where chk :: Testable a => a -> IO () - chk = check `withBackground` [ constant "count" $ count -:> int ] + chk = check `withBackground` [ value "count" $ count -:> int ] `withConditionSize` 6 diff --git a/eg/word-refinements.hs b/eg/word-refinements.hs --- a/eg/word-refinements.hs +++ b/eg/word-refinements.hs @@ -25,10 +25,10 @@ main :: IO () main = do check prop_lengthWords0 - let check1 = check `withBackground` [constant "isSpace" isSpace] + let check1 = check `withBackground` [value "isSpace" isSpace] check1 prop_lengthWords0 check1 prop_lengthWords1 - let check2 = check `withBackground` [ constant "`isInfixOf`" $ isInfixOf -:> string - , showConstant " " ] + let check2 = check `withBackground` [ value "`isInfixOf`" $ isInfixOf -:> string + , val " " ] check2 prop_lengthWords0 -- a step back, note the *zero* check prop_lengthWords2 diff --git a/eg/xmonad/extrapolate.hs b/eg/xmonad/extrapolate.hs --- a/eg/xmonad/extrapolate.hs +++ b/eg/xmonad/extrapolate.hs @@ -7,10 +7,7 @@ deriveListableCascading ''StackSet -instance (Generalizable a, Generalizable b) => Generalizable (Map a b) where - expr = showConstant - name xys = name (argTy1of2 xys) ++ name (argTy2of2 xys) ++ "s" - instances xys = this xys id +instance (Generalizable a, Generalizable b) => Generalizable (Map a b) deriveGeneralizableCascading ''StackSet diff --git a/extrapolate.cabal b/extrapolate.cabal --- a/extrapolate.cabal +++ b/extrapolate.cabal @@ -1,5 +1,5 @@ name: extrapolate -version: 0.3.3 +version: 0.4.0 synopsis: generalize counter-examples of test properties description: Extrapolate is a tool able to provide generalized counter-examples of test @@ -22,9 +22,11 @@ extra-doc-files: README.md , TODO.md + , doc/extrapolate.svg extra-source-files: .gitignore , .travis.yml , Makefile + , bench/versions , bench/diff.hs , bench/eq.hs , bench/false.hs @@ -36,6 +38,7 @@ , bench/runtime/oubli/eg/*.runtime , bench/runtime/zero/bench/*.runtime , bench/runtime/zero/eg/*.runtime + , bench/runtime/zero/versions , bench/smartcheck/*.txt , bench/smartcheck/Makefile , bench/smartcheck/bin/count-cons @@ -61,10 +64,12 @@ , mk/haddock-i , mk/haskell.mk , stack.yaml - , tests/model/bench/*.out - , tests/model/eg/*.out - , tests/test-sdist -tested-with: GHC==8.4, GHC==8.2, GHC==8.0, GHC==7.10, GHC==7.8 + , stack-lts-11.yaml + , test/model/bench/*.out + , test/model/eg/*.out + , test/sdist +tested-with: GHC==8.6, GHC==8.4, GHC==8.2, GHC==8.0 + , GHC==7.10, GHC==7.8 source-repository head type: git @@ -73,62 +78,58 @@ source-repository this type: git location: https://github.com/rudymatela/extrapolate - tag: v0.3.3 + tag: v0.4.0 library exposed-modules: Test.Extrapolate , Test.Extrapolate.Core - , Test.Extrapolate.Basic - , Test.Extrapolate.Derive - , Test.Extrapolate.Exprs + , Test.Extrapolate.Expr + , Test.Extrapolate.Generalizable + , Test.Extrapolate.Generalizable.Derive + , Test.Extrapolate.Generalization + , Test.Extrapolate.ConditionalGeneralization + , Test.Extrapolate.Speculation + , Test.Extrapolate.Testable , Test.Extrapolate.IO , Test.Extrapolate.TypeBinding , Test.Extrapolate.Utils - , Test.Extrapolate.New other-extensions: TemplateHaskell, CPP build-depends: base >= 4 && < 5 - , leancheck >= 0.7.2 + , leancheck >= 0.9.1 , template-haskell - , speculate >= 0.3.4 + , speculate >= 0.4.0 + , express >= 0.1.0 hs-source-dirs: src default-language: Haskell2010 test-suite test type: exitcode-stdio-1.0 - main-is: test-extrapolate.hs + main-is: extrapolate.hs other-modules: Test - hs-source-dirs: tests - build-depends: base >= 4 && < 5, leancheck, speculate, extrapolate + hs-source-dirs: test + build-depends: base >= 4 && < 5, leancheck, express, speculate, extrapolate default-language: Haskell2010 test-suite derive type: exitcode-stdio-1.0 - main-is: test-derive.hs + main-is: derive.hs other-modules: Test - hs-source-dirs: tests - build-depends: base >= 4 && < 5, leancheck, speculate, extrapolate + hs-source-dirs: test + build-depends: base >= 4 && < 5, leancheck, express, speculate, extrapolate default-language: Haskell2010 test-suite utils type: exitcode-stdio-1.0 - main-is: test-utils.hs - other-modules: Test - hs-source-dirs: tests - build-depends: base >= 4 && < 5, leancheck, speculate, extrapolate - default-language: Haskell2010 - -test-suite new - type: exitcode-stdio-1.0 - main-is: test-new.hs + main-is: utils.hs other-modules: Test - hs-source-dirs: tests - build-depends: base >= 4 && < 5, leancheck, speculate, extrapolate + hs-source-dirs: test + build-depends: base >= 4 && < 5, leancheck, express, speculate, extrapolate default-language: Haskell2010 test-suite step-by-step type: exitcode-stdio-1.0 - main-is: test-step-by-step.hs + main-is: step-by-step.hs other-modules: Test - hs-source-dirs: tests - build-depends: base >= 4 && < 5, leancheck, speculate, extrapolate + hs-source-dirs: test + build-depends: base >= 4 && < 5, leancheck, express, speculate, extrapolate default-language: Haskell2010 diff --git a/mk/All.hs b/mk/All.hs --- a/mk/All.hs +++ b/mk/All.hs @@ -1,22 +1,16 @@ module All ( module Test.Extrapolate - , module Test.Extrapolate.Basic , module Test.Extrapolate.Core - , module Test.Extrapolate.Derive - , module Test.Extrapolate.Exprs + , module Test.Extrapolate.Expr , module Test.Extrapolate.IO , module Test.Extrapolate.TypeBinding , module Test.Extrapolate.Utils - , module Test.Extrapolate.New ) where import Test.Extrapolate -import Test.Extrapolate.Basic import Test.Extrapolate.Core -import Test.Extrapolate.Derive -import Test.Extrapolate.Exprs +import Test.Extrapolate.Expr import Test.Extrapolate.IO import Test.Extrapolate.TypeBinding import Test.Extrapolate.Utils -import Test.Extrapolate.New diff --git a/mk/Toplibs.hs b/mk/Toplibs.hs --- a/mk/Toplibs.hs +++ b/mk/Toplibs.hs @@ -1,4 +1,5 @@ -- Using ghc --make in this module trigger compilation of all modules module Toplibs () where -import Test.Extrapolate +import Test.Extrapolate() +import Test() diff --git a/mk/depend.mk b/mk/depend.mk --- a/mk/depend.mk +++ b/mk/depend.mk @@ -4,13 +4,16 @@ bench/diff.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ bench/diff.hs bench/eq: \ bench/eq.hs \ @@ -18,13 +21,16 @@ bench/eq.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ bench/eq.hs bench/false: \ bench/false.hs \ @@ -32,13 +38,16 @@ bench/false.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ bench/false.hs bench/ord: \ bench/ord.hs \ @@ -46,13 +55,16 @@ bench/ord.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ bench/ord.hs bench/true: \ bench/true.hs \ @@ -60,13 +72,16 @@ bench/true.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ bench/true.hs eg/calculator: \ eg/calculator.hs \ @@ -74,13 +89,16 @@ eg/calculator.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/calculator.hs eg/gencalc: \ eg/gencalc.hs \ @@ -88,13 +106,16 @@ eg/gencalc.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/gencalc.hs eg/heap: \ eg/heap.hs \ @@ -102,13 +123,16 @@ eg/heap.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/heap.hs eg/int: \ eg/int.hs \ @@ -116,13 +140,16 @@ eg/int.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/int.hs eg/list: \ eg/list.hs \ @@ -130,13 +157,16 @@ eg/list.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/list.hs eg/overflow8: \ eg/overflow8.hs \ @@ -144,13 +174,16 @@ eg/overflow8.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/overflow8.hs eg/overflow: \ eg/overflow.hs \ @@ -158,13 +191,16 @@ eg/overflow.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/overflow.hs eg/parser: \ eg/parser.hs \ @@ -172,13 +208,16 @@ eg/parser.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/parser.hs eg/redblack: \ eg/RedBlackSet.hs \ @@ -187,13 +226,16 @@ eg/redblack.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/RedBlackSet.hs \ eg/redblack.hs eg/RedBlackSet.o: \ @@ -204,13 +246,16 @@ eg/sorting.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/sorting.hs eg/word-refinements: \ eg/word-refinements.hs \ @@ -218,173 +263,209 @@ eg/word-refinements.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ eg/word-refinements.hs mk/All.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ mk/All.hs mk/Toplibs.o: \ + test/Test.hs \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs \ mk/Toplibs.hs -src/Test/Extrapolate/Basic.o: \ +src/Test/Extrapolate/ConditionalGeneralization.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ - src/Test/Extrapolate/New.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Expr.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs src/Test/Extrapolate/Core.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Core.hs -src/Test/Extrapolate/Derive.o: \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Expr.hs \ + src/Test/Extrapolate/Core.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs +src/Test/Extrapolate/Expr.o: \ + src/Test/Extrapolate/Expr.hs +src/Test/Extrapolate/Generalizable/Derive.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ - src/Test/Extrapolate/Core.hs -src/Test/Extrapolate/Exprs.o: \ - src/Test/Extrapolate/Exprs.hs -src/Test/Extrapolate/IO.o: \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs +src/Test/Extrapolate/Generalizable.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ - src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Core.hs -src/Test/Extrapolate/New.o: \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Expr.hs +src/Test/Extrapolate/Generalization.o: \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Expr.hs +src/Test/Extrapolate/IO.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ - src/Test/Extrapolate/New.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Core.hs + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ + src/Test/Extrapolate/IO.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Expr.hs \ + src/Test/Extrapolate/Core.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs src/Test/Extrapolate.o: \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs + src/Test/Extrapolate/ConditionalGeneralization.hs +src/Test/Extrapolate/Speculation.o: \ + src/Test/Extrapolate/Utils.hs \ + src/Test/Extrapolate/Speculation.hs \ + src/Test/Extrapolate/Expr.hs +src/Test/Extrapolate/Testable.o: \ + src/Test/Extrapolate/Utils.hs \ + src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Expr.hs src/Test/Extrapolate/TypeBinding.o: \ src/Test/Extrapolate/TypeBinding.hs src/Test/Extrapolate/Utils.o: \ src/Test/Extrapolate/Utils.hs -tests/test-derive.o: \ - tests/Test.hs \ - tests/test-derive.hs \ +test/derive.o: \ + test/Test.hs \ + test/derive.hs \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs -tests/test-derive: \ - tests/Test.hs \ - tests/test-derive.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs +test/derive: \ + test/Test.hs \ + test/derive.hs \ mk/toplibs -tests/test-extrapolate.o: \ - tests/Test.hs \ - tests/test-extrapolate.hs \ +test/extrapolate.o: \ + test/Test.hs \ + test/extrapolate.hs \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs -tests/test-extrapolate: \ - tests/Test.hs \ - tests/test-extrapolate.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs +test/extrapolate: \ + test/Test.hs \ + test/extrapolate.hs \ mk/toplibs -tests/test-new.o: \ - tests/Test.hs \ - tests/test-new.hs \ +test/step-by-step.o: \ + test/Test.hs \ + test/step-by-step.hs \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs -tests/test-new: \ - tests/Test.hs \ - tests/test-new.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs +test/step-by-step: \ + test/Test.hs \ + test/step-by-step.hs \ mk/toplibs -tests/Test.o: \ - tests/Test.hs \ +test/Test.o: \ + test/Test.hs \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ - src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs -tests/test-step-by-step.o: \ - tests/test-step-by-step.hs \ - tests/Test.hs \ - src/Test/Extrapolate/Utils.hs \ - src/Test/Extrapolate/TypeBinding.hs \ - src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ - src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs -tests/test-step-by-step: \ - tests/test-step-by-step.hs \ - tests/Test.hs \ - mk/toplibs -tests/Test: \ - tests/Test.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs +test/Test: \ + test/Test.hs \ mk/toplibs -tests/test-utils.o: \ - tests/test-utils.hs \ - tests/Test.hs \ +test/utils.o: \ + test/utils.hs \ + test/Test.hs \ src/Test/Extrapolate/Utils.hs \ src/Test/Extrapolate/TypeBinding.hs \ + src/Test/Extrapolate/Testable.hs \ + src/Test/Extrapolate/Speculation.hs \ src/Test/Extrapolate.hs \ - src/Test/Extrapolate/New.hs \ src/Test/Extrapolate/IO.hs \ - src/Test/Extrapolate/Exprs.hs \ - src/Test/Extrapolate/Derive.hs \ + src/Test/Extrapolate/Generalization.hs \ + src/Test/Extrapolate/Generalizable.hs \ + src/Test/Extrapolate/Generalizable/Derive.hs \ + src/Test/Extrapolate/Expr.hs \ src/Test/Extrapolate/Core.hs \ - src/Test/Extrapolate/Basic.hs -tests/test-utils: \ - tests/test-utils.hs \ - tests/Test.hs \ + src/Test/Extrapolate/ConditionalGeneralization.hs +test/utils: \ + test/utils.hs \ + test/Test.hs \ mk/toplibs diff --git a/mk/ghcdeps b/mk/ghcdeps --- a/mk/ghcdeps +++ b/mk/ghcdeps @@ -2,7 +2,7 @@ # # ghcdeps: generate Haskell make dependencies for compiling with GHC. # -# Copyright (c) 2015-2017 Rudy Matela. +# Copyright (c) 2015-2019 Rudy Matela. # Distributed under the 3-Clause BSD licence. # # From a list of files provided on standard input, diff --git a/mk/haddock-i b/mk/haddock-i --- a/mk/haddock-i +++ b/mk/haddock-i @@ -2,7 +2,7 @@ # # haddock-i: list haddock's -i parameters. # -# Copyright (c) 2015-2017 Rudy Matela. +# Copyright (c) 2015-2019 Rudy Matela. # Distributed under the 3-Clause BSD licence. # # $ haddock-i ... @@ -11,14 +11,26 @@ # documentation installed on your system, so you can: # # $ haddock-i base template-haskell | xargs haddock -errxit() { +err() { echo "$@" > /dev/stderr +} + +errxit() { + err "$@" exit 1 } -for pkg in "$@"; do - ghc-pkg field $pkg haddock-html,haddock-interfaces || - errxit "error: haddock-i: cannot find package $pkg (ghc-pkg)" -done | -sed "s/.*: //" | -sed "N;s/\n/,/;s/^/-i/" +iface-for() { + ghc-pkg field $1 haddock-interfaces | sort -rV | head -1 | sed "s/.*: //" +} + +html-for() { + ghc-pkg field $1 haddock-html | sort -rV | head -1 | sed "s/.*: //" +} + +for pkg in "$@" +do + iface=$(iface-for $pkg) + html=$(html-for $pkg) + [ -d "$html" -a -f "$iface" ] && echo "-i$html,$iface" || err "haddock-i: warning: could not find interface file for $pkg" +done diff --git a/mk/haskell.mk b/mk/haskell.mk --- a/mk/haskell.mk +++ b/mk/haskell.mk @@ -1,6 +1,6 @@ # Implicit rules for compiling Haskell code. # -# Copyright (c) 2015-2018 Rudy Matela. +# Copyright (c) 2015-2019 Rudy Matela. # Distributed under the 3-Clause BSD licence. # # You can optionally configure the "Configuration variables" below in your main @@ -20,6 +20,7 @@ GHCFLAGS ?= GHC ?= ghc GHCCMD = $(GHC) -i$(GHCIMPORTDIRS) $(GHCFLAGS) +HADDOCK ?= haddock # Hugs Parameters HUGSIMPORTDIRS ?= "/usr/lib/hugs/packages/*" @@ -43,7 +44,19 @@ LIB_HSS ?= $(shell $(LIST_LIB_HSS)) ALL_HSS ?= $(shell $(LIST_ALL_HSS)) +LIB_DEPS ?= base +ALL_DEPS ?= $(LIB_DEPS) + PKGNAME = $(shell cat *.cabal | grep "^name:" | sed -e "s/name: *//") +HADDOCK_VERSION = $(shell $(HADDOCK) --version | grep version | sed -e 's/.*version //;s/,.*//') +HADDOCK_MAJOR = $(shell echo $(HADDOCK_VERSION) | sed -e 's/\..*//') +HADDOCK_MINOR = $(shell echo $(HADDOCK_VERSION) | sed -e 's/[0-9]*\.\([0-9]*\).[0-9]*/\1/') +HADDOCK_PKG_NAME = $(shell [ $(HADDOCK_MAJOR) -gt 2 ] \ + || [ $(HADDOCK_MAJOR) -eq 2 -a $(HADDOCK_MINOR) -ge 20 ] \ + && echo "--package-name=$(PKGNAME)") +HADDOCK_HLNK_SRC = $(shell [ $(HADDOCK_MAJOR) -gt 2 ] \ + || [ $(HADDOCK_MAJOR) -eq 2 -a $(HADDOCK_MINOR) -ge 17 ] \ + && echo "--hyperlinked-source") # Implicit rules @@ -84,7 +97,7 @@ haddock: doc/index.html clean-haddock: - rm -f doc/*.{html,css,js,png,gif,json} README.html + rm -f doc/*.{html,css,js,png,gif,json} doc/src/*.{html,css,js} README.html upload-haddock: @echo "use \`cabal upload -d' instead" @@ -93,9 +106,14 @@ @echo "(on Arch Linux, use: cabal haddock --for-hackage --haddock-options=--optghc=-dynamic)" doc/index.html: $(LIB_HSS) - ./mk/haddock-i base template-haskell | xargs \ - haddock --html -odoc $(LIB_HSS) $(HADDOCKFLAGS) --title=$(PKGNAME) + ./mk/haddock-i $(LIB_DEPS) | xargs \ + $(HADDOCK) --html -odoc $(LIB_HSS) \ + --title=$(PKGNAME) \ + $(HADDOCK_PKG_NAME) \ + $(HADDOCK_HLNK_SRC) \ + $(HADDOCKFLAGS) + # lists all Haskell source files list-all-hss: @find $(ALL_HSS) @@ -103,6 +121,12 @@ # lists library Haskell source files list-lib-hss: @find $(LIB_HSS) + +bootstrap-haskell-mk: + @[ -d "$(DEST)" ] || (echo -e "error: no destination found\nusage: \`make bootstrap-haskell-mk DEST=path/to/prj'"; exit 1) + mkdir -p mk + cp mk/{haskell.mk,ghcdeps,haddock-i} $(DEST)/mk + touch $(DEST)/mk/depend.mk show-pkgname: @echo $(PKGNAME) diff --git a/src/Test/Extrapolate.hs b/src/Test/Extrapolate.hs --- a/src/Test/Extrapolate.hs +++ b/src/Test/Extrapolate.hs @@ -1,6 +1,6 @@ -- | -- Module : Test.Extrapolate --- Copyright : (c) 2017 Rudy Matela +-- Copyright : (c) 2017-2019 Rudy Matela -- License : 3-Clause BSD (see the file LICENSE) -- Maintainer : Rudy Matela -- @@ -19,19 +19,29 @@ -- library. See: -- -- > > check $ \xs -> sort (sort xs :: [Int]) == sort xs --- > +++ OK, passed 360 tests. +-- > +++ OK, passed 500 tests. -- -- When tests fail, Extrapolate reports a fully defined counter-example and a -- generalization of failing inputs. See: -- --- > > > check $ \xs -> length (sort xs :: [Int]) == length xs +-- > > check $ \xs -> length (sort xs :: [Int]) == length xs -- > *** Failed! Falsifiable (after 3 tests): -- > [0,0] -- > -- > Generalization: -- > x:x:_ +-- > +-- > Conditional Generalization: +-- > x:xs when elem x xs -- --- The property fails for any integer @x@ and for any list @_@ at the tail. +-- /Generalization:/ +-- the property fails for any integer @x@ and for any list @_@ at the tail. +-- +-- /Conditional Generalization:/ +-- the property fails for a list @x:xs@ whenever @x@ is an element of @xs@ +-- +-- This hints at the actual source of the fault: +-- our @sort@ above discards repeated elements! module Test.Extrapolate ( -- * Checking properties @@ -40,15 +50,15 @@ , for , withBackground , withConditionSize - , minFailures -- * Generalizable types , Generalizable (..) - , this + , instances , Expr (..) - , constant, showConstant - , bgEq - , bgOrd + , value, val + , reifyEq + , reifyOrd + , reifyEqOrd -- * Testable properties , Testable @@ -58,21 +68,23 @@ , deriveGeneralizableIfNeeded , deriveGeneralizableCascading +-- * Typeclasses required by Generalizable + , Name (..) + , Express (..) + -- * Other useful modules , module Test.Extrapolate.TypeBinding , module Test.LeanCheck - , module Test.LeanCheck.Utils.TypeBinding ) where import Test.Extrapolate.Core -import Test.Extrapolate.Basic -import Test.Extrapolate.Derive +import Test.Extrapolate.Generalizable.Derive import Test.Extrapolate.TypeBinding import Test.Extrapolate.IO import Test.LeanCheck hiding - ( Testable (..) + ( Testable , results , counterExamples , counterExample @@ -82,4 +94,3 @@ , checkResult , checkResultFor ) -import Test.LeanCheck.Utils.TypeBinding diff --git a/src/Test/Extrapolate/Basic.hs b/src/Test/Extrapolate/Basic.hs deleted file mode 100644 --- a/src/Test/Extrapolate/Basic.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE CPP #-} -- for GHC <= 7.8 --- | --- Module : Test.Extrapolate.Basic --- Copyright : (c) 2017 Rudy Matela --- License : 3-Clause BSD (see the file LICENSE) --- Maintainer : Rudy Matela --- --- This module is part of Extrapolate, --- a library for generalization of counter-examples. --- --- This provides the basic functionality of extrapolate. You will have better --- luck importing "Test.Extrapolate" directly. -module Test.Extrapolate.Basic - ( module Test.Extrapolate.Core - , module Test.Extrapolate.New - ) -where - -import Test.Extrapolate.Core -import Test.Extrapolate.New -import Data.Ratio - -instance (Integral a, Generalizable a) => Generalizable (Ratio a) where - expr = showConstant - name _ = "q" - instances q = this q id --- The following would allow zero denominators --- expr (n % d) = constant "%" ((%) -:> n) :$ expr n :$ expr d - -instance ( Generalizable a, Generalizable b, Generalizable c, Generalizable d - , Generalizable e ) - => Generalizable (a,b,c,d,e) where - name xyzwv = name x ++ name y ++ name z ++ name w ++ name v - where (x,y,z,w,v) = xyzwv - expr (x,y,z,w,v) = constant ",,,," ((,,,,) ->>>>>: (x,y,z,w,v)) - :$ expr x :$ expr y :$ expr z :$ expr w :$ expr v - instances xyzwv = this xyzwv $ instances x . instances y . instances z - . instances w . instances v - where (x,y,z,w,v) = xyzwv - -instance ( Generalizable a, Generalizable b, Generalizable c, Generalizable d - , Generalizable e, Generalizable f ) - => Generalizable (a,b,c,d,e,f) where - name xyzwvu = name x ++ name y ++ name z ++ name w ++ name v ++ name u - where (x,y,z,w,v,u) = xyzwvu - expr (x,y,z,w,v,u) = constant ",,,,," ((,,,,,) ->>>>>>: (x,y,z,w,v,u)) - :$ expr x :$ expr y :$ expr z :$ expr w :$ expr v :$ expr u - instances xyzwvu = this xyzwvu $ instances x . instances y . instances z - . instances w . instances v . instances u - where (x,y,z,w,v,u) = xyzwvu - -instance ( Generalizable a, Generalizable b, Generalizable c, Generalizable d - , Generalizable e, Generalizable f, Generalizable g ) - => Generalizable (a,b,c,d,e,f,g) where - name xyzwvut = name x ++ name y ++ name z ++ name w - ++ name v ++ name u ++ name t - where (x,y,z,w,v,u,t) = xyzwvut - expr (x,y,z,w,v,u,t) = constant ",,,,,," ((,,,,,,) ->>>>>>>: (x,y,z,w,v,u,t)) - :$ expr x :$ expr y :$ expr z :$ expr w - :$ expr v :$ expr u :$ expr t - instances xyzwvut = this xyzwvut - $ instances x . instances y . instances z . instances w - . instances v . instances u . instances t - where (x,y,z,w,v,u,t) = xyzwvut - -#if __GLASGOW_HASKELL__ < 710 --- No 8-tuples for you: --- On GHC 7.8, 8-tuples are not Typeable instances. We could add a standalone --- deriving clause, but that may cause trouble if some other library does the --- same. User should declare Generalizable 8-tuples manually when using GHC <= --- 7.8. -#else -instance ( Generalizable a, Generalizable b, Generalizable c, Generalizable d - , Generalizable e, Generalizable f, Generalizable g, Generalizable h ) - => Generalizable (a,b,c,d,e,f,g,h) where - name xyzwvuts = name x ++ name y ++ name z ++ name w - ++ name v ++ name u ++ name t ++ name s - where (x,y,z,w,v,u,t,s) = xyzwvuts - expr (x,y,z,w,v,u,t,s) = constant ",,,,,,," ((,,,,,,,) ->>>>>>>>: (x,y,z,w,v,u,t,s)) - :$ expr x :$ expr y :$ expr z :$ expr w - :$ expr v :$ expr u :$ expr t :$ expr s - instances xyzwvuts = this xyzwvuts - $ instances x . instances y . instances z . instances w - . instances v . instances u . instances t . instances s - where (x,y,z,w,v,u,t,s) = xyzwvuts -#endif diff --git a/src/Test/Extrapolate/ConditionalGeneralization.hs b/src/Test/Extrapolate/ConditionalGeneralization.hs new file mode 100644 --- /dev/null +++ b/src/Test/Extrapolate/ConditionalGeneralization.hs @@ -0,0 +1,78 @@ +-- | +-- Module : Test.Extrapolate.ConditionalGeneralization +-- Copyright : (c) 2017-2019 Rudy Matela +-- License : 3-Clause BSD (see the file LICENSE) +-- Maintainer : Rudy Matela +-- +-- This module is part of Extrapolate, +-- a library for generalization of counter-examples. +-- +-- This defines utilities for conditional generalization. +-- +-- You are probably better off importing "Test.Extrapolate". +module Test.Extrapolate.ConditionalGeneralization + ( conditionalCounterExampleGeneralizations + , validConditions + , candidateConditions + ) +where + +import Data.Ratio + +import Test.LeanCheck.Error (errorToFalse) + +import Test.Extrapolate.Speculation +import Test.Extrapolate.Generalization +import Test.Extrapolate.Utils + +conditionalCounterExampleGeneralizations + :: Int -> [[Expr]] -> (Expr -> [Expr]) -> (Expr -> Expr -> Expr) + -> Expr -> [Expr] +conditionalCounterExampleGeneralizations maxCondSize atoms grounds (-==-) e = + [ canonicalize $ g -&&- wc + | g <- fastCandidateGeneralizations isListable e + , let wc = weakestCondition' g + , wc /= value "False" False + , wc /= value "True" True + ] + where + isListable = not . null . grounds . holeAsTypeOf + weakestCondition' = weakestCondition + (theoryAndReprConds maxCondSize (===) atoms) + grounds + e1 === e2 = isTrue grounds $ e1 -==- e2 + +candidateConditions :: (Expr -> [Expr]) -> (Thy,[Expr]) -> Expr -> [Expr] +candidateConditions grounds (thy,cs) e = expr True : + [ c | (c,_) <- classesFromSchemasAndVariables thy (nubVars e) cs + , hasVar c + , not (isAssignment c) + , not (isAssignmentTest grounds c) + ] +-- 'expr True' is expected by the functions that call candidateConditions. It +-- is always useful to check if a generalization without any conditions still +-- passes (that means we should skip as there is an already reported +-- unconditional generalization). + +validConditions :: (Thy,[Expr]) -> (Expr -> [Expr]) -> Expr -> [Expr] +validConditions thyes grounds e = + [ c | c <- candidateConditions grounds thyes e + , isCounterExample $ e -&&- c ] ++ [expr False] + where + isCounterExample = all (not . errorToFalse . eval False) . grounds + +weakestCondition :: (Thy,[Expr]) -> (Expr -> [Expr]) -> Expr -> Expr +weakestCondition thyes grounds e = + maximumOn (ratioFailures grounds . (e -&&-)) $ validConditions thyes grounds e + +ratioFailures :: (Expr -> [Expr]) -> Expr -> Ratio Int +ratioFailures grounds e = length ps % length gs + where + gs = grounds e + ps = filter (errorToFalse . eval False . snd . unand) gs + +isAssignmentTest :: (Expr -> [Expr]) -> Expr -> Bool +isAssignmentTest grounds e | typ e /= typ false = False +isAssignmentTest grounds e = length rs > 1 && length (filter id rs) == 1 + where + rs = [errorToFalse $ eval False e' | e' <- grounds e] diff --git a/src/Test/Extrapolate/Core.hs b/src/Test/Extrapolate/Core.hs --- a/src/Test/Extrapolate/Core.hs +++ b/src/Test/Extrapolate/Core.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} -- for GHC <= 7.8 -- | -- Module : Test.Extrapolate.Core --- Copyright : (c) 2017 Rudy Matela +-- Copyright : (c) 2017-2019 Rudy Matela -- License : 3-Clause BSD (see the file LICENSE) -- Maintainer : Rudy Matela -- @@ -11,66 +11,21 @@ -- This is the core of extrapolate. module Test.Extrapolate.Core ( module Test.LeanCheck - , module Test.LeanCheck.Utils.TypeBinding - , module Test.Extrapolate.Exprs - - , Generalizable (..) - , this - , backgroundWith - , (+++) - , backgroundOf - , bgEq - , bgOrd - , bgEqWith1 - , bgEqWith2 - - , Option (..) - , WithOption (..) - , maxTests - , extraInstances - , maxConditionSize - , hasEq - , (*==*) - , (*/=*) - , (*<=*) - , (*<*) - , tBackground - - , counterExamples - , counterExampleGen - , counterExampleGens - - , generalizations - , generalizationsCE - , generalizationsCEC - , generalizationsCounts - - , atoms - , theoryAndReprExprs - , theoryAndReprConds - , candidateConditions - , validConditions - , weakestCondition - , getBackground - , fullInstances - - , matchList - , newMatches - - , Testable (..) - , results + , module Test.Extrapolate.Expr + , module Test.Extrapolate.Speculation + , module Test.Extrapolate.Generalizable + , module Test.Extrapolate.Generalization + , module Test.Extrapolate.ConditionalGeneralization + , module Test.Extrapolate.Testable - , areInstancesOf + , counterExampleWithGeneralizations ) where -import Test.Extrapolate.Utils -import Test.LeanCheck.Utils -import Test.LeanCheck.Utils.TypeBinding import Data.Typeable -import Data.Dynamic + import Test.LeanCheck hiding - ( Testable (..) + ( Testable , results , counterExamples , counterExample @@ -80,614 +35,26 @@ , checkResult , checkResultFor ) -import Data.Maybe -import Data.Either (isRight) -import Data.List (insert, nub, sort) -import Data.Functor ((<$>)) -- for GHC <= 7.8 -import Test.Extrapolate.Exprs -import Test.LeanCheck.Error (errorToFalse) -import Data.Ratio (Ratio, numerator, denominator) -import Test.Extrapolate.TypeBinding -- for Haddock -import Test.Speculate.Reason (Thy) -import Test.Speculate.Engine (theoryAndRepresentativesFromAtoms, classesFromSchemasAndVariables) -import Data.Monoid ((<>)) --- | Extrapolate can generalize counter-examples of any types that are --- 'Generalizable'. --- --- The core (and only required functions) of the generalizable typeclass are --- the 'expr' and 'instances' functions. --- --- The following example shows a datatype and its instance: --- --- > data Stack a = Stack a (Stack a) | Empty --- --- > instance Generalizable a => Generalizable (Stack a) where --- > name _ = "s" --- > expr s@(Stack x y) = constant "Stack" (Stack ->>: s) :$ expr x :$ expr y --- > expr s@Empty = constant "Empty" (Empty -: s) --- > instances s = this s $ instances (argTy1of1 s) --- --- To declare 'instances' and 'expr' it may be useful to use: --- --- * LeanCheck's "Test.LeanCheck.Utils.TypeBinding" operators: --- '-:', '->:', '->>:', ...; --- * Extrapolate's "Test.Extrapolate.TypeBinding" operators: --- 'argTy1of1', 'argTy1of2', 'argTy2of2', .... -class (Listable a, Typeable a, Show a) => Generalizable a where - -- | Transforms a value into an manipulable expression tree. - -- See 'constant' and ':$'. - expr :: a -> Expr - - -- | Common name for a variable, defaults to @"x"@. - name :: a -> String - name _ = "x" - - -- | List of symbols allowed to appear in side-conditions. - -- Defaults to @[]@. See 'constant'. - background :: a -> [Expr] - background _ = [] - - -- | Computes a list of reified instances. See 'this'. - instances :: a -> Instances -> Instances - - -instance Generalizable () where - expr = showConstant - name _ = "u" - instances u = this u id - -instance Generalizable Bool where - expr = showConstant - name _ = "p" - background p = bgEq p - ++ [ constant "not" not ] - instances p = this p id - -instance Generalizable Int where - expr = showConstant - name _ = "x" - background x = bgOrd x - instances x = this x id - -instance Generalizable Integer where - expr = showConstant - name _ = "x" - background x = bgOrd x - instances x = this x id - -instance Generalizable Char where - expr = showConstant - name _ = "c" - background c = bgOrd c - instances c = this c id - -instance (Generalizable a) => Generalizable (Maybe a) where - expr mx@Nothing = constant "Nothing" (Nothing -: mx) - expr mx@(Just x) = constant "Just" (Just ->: mx) :$ expr x - name mx = "m" ++ name (fromJust mx) - background mx = bgEqWith1 (maybeEq ->:> mx) - ++ bgOrdWith1 (maybeOrd ->:> mx) - ++ [ constant "Just" (Just ->: mx) ] - instances mx = this mx $ instances (fromJust mx) - -instance (Generalizable a, Generalizable b) => Generalizable (Either a b) where - expr lx@(Left x) = constant "Left" (Left ->: lx) :$ expr x - expr ry@(Right y) = constant "Right" (Right ->: ry) :$ expr y - name exy = "e" ++ name (fromLeft exy) ++ name (fromRight exy) - background exy = bgEqWith2 (eitherEq ->>:> exy) - ++ bgOrdWith2 (eitherOrd ->>:> exy) - ++ [ constant "Left" (Left ->: exy) - , constant "Right" (Right ->: exy) ] - instances exy = this exy $ instances (fromLeft exy) - . instances (fromRight exy) - -instance (Generalizable a, Generalizable b) => Generalizable (a,b) where - name xy = name (fst xy) ++ name (snd xy) - expr (x,y) = constant "," ((,) ->>: (x,y)) - :$ expr x :$ expr y - background xy = bgEqWith2 (pairEq ->>:> xy) - ++ bgOrdWith2 (pairOrd ->>:> xy) - instances xy = this xy $ instances (fst xy) - . instances (snd xy) - -instance (Generalizable a, Generalizable b, Generalizable c) - => Generalizable (a,b,c) where - name xyz = name x ++ name y ++ name z - where (x,y,z) = xyz - expr (x,y,z) = constant ",," ((,,) ->>>: (x,y,z)) - :$ expr x :$ expr y :$ expr z - background xyz = bgEqWith3 (tripleEq ->>>:> xyz) - ++ bgOrdWith3 (tripleOrd ->>>:> xyz) - instances xyz = this xyz $ instances x . instances y . instances z - where (x,y,z) = xyz - -instance (Generalizable a, Generalizable b, Generalizable c, Generalizable d) - => Generalizable (a,b,c,d) where - name xyzw = name x ++ name y ++ name z ++ name w - where (x,y,z,w) = xyzw - expr (x,y,z,w) = constant ",,," ((,,,) ->>>>: (x,y,z,w)) - :$ expr x :$ expr y :$ expr z :$ expr w - background xyzw = bgEqWith4 (quadrupleEq ->>>>:> xyzw) - ++ bgOrdWith4 (quadrupleOrd ->>>>:> xyzw) - instances xyzw = this xyzw $ instances x - . instances y - . instances z - . instances w - where (x,y,z,w) = xyzw - -instance Generalizable a => Generalizable [a] where - name xs = name (head xs) ++ "s" - expr (xs@[]) = showConstant ([] -: xs) - expr (xs@(y:ys)) = constant ":" ((:) ->>: xs) :$ expr y :$ expr ys - background xs = bgEqWith1 (listEq ->:> xs) - ++ bgOrdWith1 (listOrd ->:> xs) - ++ [ constant "length" (length -:> xs) ] - ++ [ constant "elem" (elemBy (*==*) ->:> xs) | hasEq $ head xs ] - instances xs = this xs $ instances (head xs) - -instance Generalizable Ordering where - name o = "o" - expr o = showConstant o - background o = bgOrd o - instances o = this o id - -bgEq :: (Eq a, Generalizable a) => a -> [Expr] -bgEq x = [ constant "==" ((==) -:> x) - , constant "/=" ((/=) -:> x) ] - -bgOrd :: (Ord a, Generalizable a) => a -> [Expr] -bgOrd x = [ constant "==" ((==) -:> x) - , constant "/=" ((/=) -:> x) - , constant "<" ((<) -:> x) - , constant "<=" ((<=) -:> x) ] - -bgEqWith1 :: (Generalizable a, Generalizable b) - => ((b -> b -> Bool) -> a -> a -> Bool) -> [Expr] -bgEqWith1 makeEq = takeWhile (\_ -> hasEq x) - [ constant "==" ( makeEq (*==*)) - , constant "/=" (not .: makeEq (*==*)) ] - where - x = argTy1of2 $ argTy1of2 makeEq - -bgEqWith2 :: (Generalizable a, Generalizable b, Generalizable c) - => ((b -> b -> Bool) -> (c -> c -> Bool) -> a -> a -> Bool) -> [Expr] -bgEqWith2 makeEq = takeWhile (\_ -> hasEq x && hasEq y) - [ constant "==" ( makeEq (*==*) (*==*)) - , constant "/=" (not .: makeEq (*==*) (*==*)) ] - where - x = argTy1of2 $ argTy1of2 makeEq - y = argTy1of2 . argTy1of2 $ argTy2of2 makeEq - -bgEqWith3 :: (Generalizable a, Generalizable b, Generalizable c, Generalizable d) - => ((b->b->Bool) -> (c->c->Bool) -> (d->d->Bool) -> a -> a -> Bool) - -> [Expr] -bgEqWith3 makeEq = takeWhile (\_ -> hasEq x && hasEq y && hasEq z) - [ constant "==" (makeEq (*==*) (*==*) (*==*)) - , constant "/=" (not .: makeEq (*==*) (*==*) (*==*)) ] - where - x = argTy1of2 $ argTy1of2 makeEq - y = argTy1of2 . argTy1of2 $ argTy2of2 makeEq - z = argTy1of2 . argTy1of2 . argTy2of2 $ argTy2of2 makeEq - -bgEqWith4 :: (Generalizable a, Generalizable b, Generalizable c, Generalizable d, Generalizable e) - => ((b->b->Bool) -> (c->c->Bool) -> (d->d->Bool) -> (e->e->Bool) -> a -> a -> Bool) - -> [Expr] -bgEqWith4 makeEq = takeWhile (\_ -> hasEq x && hasEq y && hasEq z && hasEq w) - [ constant "==" (makeEq (*==*) (*==*) (*==*) (*==*)) - , constant "/=" (not .: makeEq (*==*) (*==*) (*==*) (*==*)) ] - where - x = argTy1of2 $ argTy1of2 makeEq - y = argTy1of2 . argTy1of2 $ argTy2of2 makeEq - z = argTy1of2 . argTy1of2 . argTy2of2 $ argTy2of2 makeEq - w = argTy1of2 . argTy1of2 . argTy2of2 . argTy2of2 $ argTy2of2 makeEq - -bgOrdWith1 :: (Generalizable a, Generalizable b) - => ((b -> b -> Bool) -> a -> a -> Bool) -> [Expr] -bgOrdWith1 makeOrd = takeWhile (\_ -> hasOrd x) - [ constant "<=" ( makeOrd (*<=*)) - , constant "<" (not .: flip (makeOrd (*<=*))) ] - where - x = argTy1of2 $ argTy1of2 makeOrd - -bgOrdWith2 :: (Generalizable a, Generalizable b, Generalizable c) - => ((b -> b -> Bool) -> (c -> c -> Bool) -> a -> a -> Bool) -> [Expr] -bgOrdWith2 makeOrd = takeWhile (\_ -> hasOrd x && hasOrd y) - [ constant "<=" ( makeOrd (*<=*) (*<=*)) - , constant "<" (not .: flip (makeOrd (*<=*) (*<=*))) ] - where - x = argTy1of2 $ argTy1of2 makeOrd - y = argTy1of2 . argTy1of2 $ argTy2of2 makeOrd - -bgOrdWith3 :: (Generalizable a, Generalizable b, Generalizable c, Generalizable d) - => ((b->b->Bool) -> (c->c->Bool) -> (d->d->Bool) -> a -> a -> Bool) - -> [Expr] -bgOrdWith3 makeOrd = takeWhile (\_ -> hasOrd x && hasOrd y && hasOrd z) - [ constant "<=" (makeOrd (*<=*) (*<=*) (*<=*)) - , constant "<" (not .: flip (makeOrd (*<=*) (*<=*) (*<=*))) ] - where - x = argTy1of2 $ argTy1of2 makeOrd - y = argTy1of2 . argTy1of2 $ argTy2of2 makeOrd - z = argTy1of2 . argTy1of2 . argTy2of2 $ argTy2of2 makeOrd - -bgOrdWith4 :: (Generalizable a, Generalizable b, Generalizable c, Generalizable d, Generalizable e) - => ((b->b->Bool) -> (c->c->Bool) -> (d->d->Bool) -> (e->e->Bool) -> a -> a -> Bool) - -> [Expr] -bgOrdWith4 makeOrd = takeWhile (\_ -> hasOrd x && hasOrd y && hasOrd z && hasOrd w) - [ constant "<=" (makeOrd (*<=*) (*<=*) (*<=*) (*<=*)) - , constant "<" (not .: flip (makeOrd (*<=*) (*<=*) (*<=*) (*<=*))) ] - where - x = argTy1of2 $ argTy1of2 makeOrd - y = argTy1of2 . argTy1of2 $ argTy2of2 makeOrd - z = argTy1of2 . argTy1of2 . argTy2of2 $ argTy2of2 makeOrd - w = argTy1of2 . argTy1of2 . argTy2of2 . argTy2of2 $ argTy2of2 makeOrd - --- | Usage: @ins "x" (undefined :: Type)@ -ins :: Generalizable a => a -> Instances -ins x = listable x ++ nameWith (name x) x ++ backgroundWith (background x) x - -this :: Generalizable a - => a -> (Instances -> Instances) -> Instances -> Instances -this x f is = - if isListable is (typeOf x) - then is - else f (ins x ++ is) --- TODO: change type to a -> [Instances -> Instances] -> Instances -> Instances - -backgroundWith :: Typeable a => [Expr] -> a -> Instances -backgroundWith es x = [ Instance "Background" (typeOf x) es ] - -getBackground :: Instances -> [Expr] -getBackground is = concat [es | Instance "Background" _ es <- is] - -getEqInstancesFromBackground :: Instances -> Instances -getEqInstancesFromBackground is = - [Instance "Eq" (argumentTy $ typ eq) [eq, iq] | eq <- eqs, iq <- iqs, typ eq == typ iq] - where - eqs = [Constant "==" e | Constant "==" e <- bg] - iqs = [Constant "/=" e | Constant "/=" e <- bg] - bg = getBackground is - -backgroundOf :: Generalizable a => a -> [Expr] -backgroundOf x = getBackground $ instances x [] - -tBackground :: Testable a => a -> [Expr] -tBackground = getBackground . tinstances - --- | generalizes an expression by making it less defined, --- starting with smaller changes, then bigger changes: --- --- 1: change constant to variable --- 1.1: if a variable of the constant type exists, use it --- 1.2: if not, introduce new variable --- 2: change a variable to a new variable --- --- The above is the ideal, but let's start with a simpler algorithm: --- --- 1: change constant to hole -generalizations1 :: Instances -> Expr -> [Expr] -generalizations1 is (Var _ _) = [] -generalizations1 is (Constant _ dx) = - [holeOfTy t | let t = dynTypeRep dx, isListable is t] -generalizations1 is (e1 :$ e2) = - [holeOfTy t | isRight (etyp (e1 :$ e2)) - , let t = typ (e1 :$ e2) - , isListable is t] - ++ productWith (:$) (generalizations1 is e1) (generalizations1 is e2) - ++ map (:$ e2) (generalizations1 is e1) - ++ map (e1 :$) (generalizations1 is e2) --- note above, I should only generalize types that I know how to enumerate, --- i.e.: types that I have TypeInfo of! - -generalizations :: Instances -> [Expr] -> [ [Expr] ] -generalizations is = map unfold . generalizations1 is . fold - -productWith :: (a -> b -> c) -> [a] -> [b] -> [c] -productWith f xs ys = [f x y | x <- xs, y <- ys] - --- I don't love Option/WithOption. It is clever but it is not __clear__. --- Maybe remove from future versions of the tool? -data Option = MaxTests Int - | ExtraInstances Instances - | MaxConditionSize Int - | MinFailures (Ratio Int) - | MaxSpeculateSize (Maybe Int) - | ConditionBound (Maybe Int) - | ConstantBound (Maybe Int) - | DepthBound (Maybe Int) - deriving (Show, Typeable) -- Typeable needed for GHC <= 7.8 - -data WithOption a = With - { property :: a - , option :: Option } - -type Options = [Option] - -maxTests :: Testable a => a -> Int -maxTests p = head $ [m | MaxTests m <- options p] ++ [500] - -extraInstances :: Testable a => a -> Instances -extraInstances p = concat [is | ExtraInstances is <- options p] - -maxConditionSize :: Testable a => a -> Int -maxConditionSize p = head $ [m | MaxConditionSize m <- options p] ++ [4] - --- minimum number of failures for a conditional generalization -computeMinFailures :: Testable a => a -> Int -computeMinFailures p = max 2 $ m * numerator r `div` denominator r - where - r = head $ [r | MinFailures r <- options p] ++ [0] - m = maxTests p - -computeMaxSpeculateSize :: Testable a => a -> Maybe Int -computeMaxSpeculateSize p = head $ [b | MaxSpeculateSize b <- options p] ++ [Just 4] - -computeConditionBound :: Testable a => a -> Maybe Int -computeConditionBound p = head $ [b | ConditionBound b <- options p] ++ [Nothing] - -computeConstantBound :: Testable a => a -> Maybe Int -computeConstantBound p = head $ [b | ConstantBound b <- options p] ++ [Nothing] - -computeDepthBound :: Testable a => a -> Maybe Int -computeDepthBound p = head $ [b | DepthBound b <- options p] ++ [Nothing] - -class Testable a where - resultiers :: a -> [[([Expr],Bool)]] - ($-|) :: a -> [Expr] -> Bool - tinstances :: a -> Instances - options :: a -> Options - options _ = [] - -instance Testable a => Testable (WithOption a) where - resultiers (p `With` o) = resultiers p - (p `With` o) $-| es = p $-| es - tinstances (p `With` o) = tinstances p ++ extraInstances (p `With` o) - options (p `With` o) = o : options p - -instance Testable Bool where - resultiers p = [[([],p)]] - p $-| [] = p - p $-| _ = error "($-|): too many arguments" - tinstances _ = instances bool . instances int $ [] - -instance (Testable b, Generalizable a, Listable a) => Testable (a->b) where - resultiers p = concatMapT resultiersFor tiers - where resultiersFor x = mapFst (expr x:) `mapT` resultiers (p x) - mapFst f (x,y) = (f x, y) - p $-| [] = error "($-|): too few arguments" - p $-| (e:es) = p (eval (error "($-|): wrong type") e) $-| es - tinstances p = instances (undefarg p) $ tinstances (p undefined) - where - undefarg :: (a -> b) -> a - undefarg _ = undefined - -results :: Testable a => a -> [([Expr],Bool)] -results = concat . resultiers - -counterExamples :: Testable a => Int -> a -> [[Expr]] -counterExamples n p = [as | (as,False) <- take n (results p)] +import Test.Speculate.Reason (Thy) +import Test.Speculate.Engine (classesFromSchemasAndVariables) -counterExample :: Testable a => Int -> a -> Maybe [Expr] -counterExample n = listToMaybe . counterExamples n +import Test.Extrapolate.Expr +import Test.Extrapolate.Speculation +import Test.Extrapolate.Generalizable +import Test.Extrapolate.Generalization +import Test.Extrapolate.ConditionalGeneralization +import Test.Extrapolate.Testable -counterExampleGens :: Testable a => Int -> a -> Maybe ([Expr],[[Expr]]) -counterExampleGens n p = case counterExample n p of +counterExampleWithGeneralizations :: Testable a => a -> Maybe (Expr,[Expr]) +counterExampleWithGeneralizations p = case counterExample p of Nothing -> Nothing - Just es -> Just (es,generalizationsCE n p es) - -generalizationsCE :: Testable a => Int -> a -> [Expr] -> [[Expr]] -generalizationsCE n p es = - [ canonicalizeWith is gs' - | gs <- generalizations is es - , gs' <- vassignments gs - , isCounterExample n p gs' - ] - where - is = tinstances p - -generalizationsCEC :: Testable a => a -> [Expr] -> [(Expr,[Expr])] -generalizationsCEC p es | maxConditionSize p <= 0 = [] -generalizationsCEC p es = - [ (wc'', gs'') - | gs <- generalizations is es - , gs' <- vassignments gs - , let thycs = theoryAndReprConds p - , let wc = weakestCondition thycs p gs' - , wc /= constant "False" False - , wc /= constant "True" True - , let (wc'':gs'') = canonicalizeWith is (wc:gs') - ] - where - is = tinstances p - -isCounterExample :: Testable a => Int -> a -> [Expr] -> Bool -isCounterExample m p = all (not . errorToFalse . (p $-|)) - . take m - . grounds (tinstances p) - -generalizationsCounts :: Testable a => Int -> a -> [Expr] -> [([Expr],Int)] -generalizationsCounts n p es = - [ (canonicalizeWith is gs', countPasses n p gs') - | gs <- generalizations is es - , gs' <- vassignments gs - ] - where - is = tinstances p - -countPasses :: Testable a => Int -> a -> [Expr] -> Int -countPasses m p = length . filter (p $-|) . take m . grounds (tinstances p) - -counterExampleGen :: Testable a => Int -> a -> Maybe ([Expr],Maybe [Expr]) -counterExampleGen n p = case counterExampleGens n p of - Nothing -> Nothing - Just (es,[]) -> Just (es,Nothing) - Just (es,(gs:_)) -> Just (es,Just gs) - -areInstancesOf :: [Expr] -> [Expr] -> Bool -es1 `areInstancesOf` es2 = length es1 == length es2 - && and [e1 `isInstanceOf` e2 | (e1,e2) <- zip es1 es2] --- change the above to use fold --- maybe create a module that deals with lists of expressions, called Exprs - --- | List matches of lists of expressions if possible --- --- > [0,1] `matchList` [x,y] = Just [x=0, y=1] --- > [0,1+2] `matchList` [x,y+y] = Nothing -matchList :: [Expr] -> [Expr] -> Maybe Binds -matchList = m [] - where - m bs [] [] = Just bs - m bs (e1:es1) (e2:es2) = - case matchWith bs e1 e2 of - Nothing -> Nothing - Just bs -> m bs es1 es2 - --- list only the matches that introduce new variables (not variable-to-variable --- matches) -newMatches :: [Expr] -> [Expr] -> Maybe Binds -e1 `newMatches` e2 = filter (not . isVar . snd) <$> e1 `matchList` e2 - - --- | Given tiers of atomic expressions, generates tiers of expressions combined --- by function application. This is done blindly so redundant expressions --- are generated: like x + y and y + x. -expressionsTT :: [[Expr]] -> [[Expr]] -expressionsTT dss = dss \/ productMaybeWith ($$) ess ess `addWeight` 1 - where - ess = expressionsTT dss - --- Generates expression schemas and a theory -theoryAndReprsFromPropAndAtoms :: Testable a => a -> [[Expr]] -> (Thy,[[Expr]]) -theoryAndReprsFromPropAndAtoms p ess = - theoryAndRepresentativesFromAtoms - (maxConditionSize p) compareExpr (const True) (===) ess - where - -- the following uses of keep make Speculate run faster by defaulting to - -- "these things are not equal" even in cases that they are. Despite - -- failing to detect some equalities, Speculte will still be useful as a - -- generator of quasi-canonical expressions. - e1 === e2 = keep e1 && keep e2 && equal is m e1 e2 - keep e = maybe True (\b -> length (consts e) <= b) constBound - && maybe True (\b -> depthE e <= b) depthBound - && maybe True (\b -> lengthE e <= b) (computeMaxSpeculateSize p) --- NOTE: MaxSpeculateSize here should not be confused with the size --- considering sizes of atoms (as per tier enumeration), this regards only the --- size in number of symbols - constBound = computeConstantBound p - depthBound = computeDepthBound p - is = fullInstances p - m = maxTests p - compareExpr :: Expr -> Expr -> Ordering - compareExpr = compareComplexityThen (lexicompareBy cmp) - e1 `cmp` e2 | arity e1 == 0 && arity e2 /= 0 = LT - e1 `cmp` e2 | arity e1 /= 0 && arity e2 == 0 = GT - e1 `cmp` e2 = compareIndex (concat ess) e1 e2 <> e1 `compare` e2 --- NOTE: "concat $ atoms args" may be an infinite list. This function assumes --- that the symbols will appear on the list eventually for termination. If I --- am correct this ivariant is assured by the rest of the code. - --- tinstances including auto generated Eq instances (based on background) -fullInstances :: Testable a => a -> Instances -fullInstances p = is ++ getEqInstancesFromBackground is - where - is = tinstances p - --- Given a property, returns the atoms to be passed to Speculate -atoms :: Testable a => a -> [[Expr]] -atoms p = ([vs] \/) - . foldr (\/) [esU] - $ [ eval (error msg :: [[Expr]]) ess - | Instance "Listable" _ [ess] <- is ] - where - vs = sort . map holeOfTy . filter (isListable is) . nubMergeMap (typesIn . typ) $ esU - esU = getBackground is - msg = "canditateConditions: wrong type, not [[Expr]]" - is = tinstances p - -theoryAndReprExprs :: Testable a => a -> (Thy,[Expr]) -theoryAndReprExprs p = - (\(thy,ess) -> (thy, concat $ take (maxConditionSize p) ess)) - . theoryAndReprsFromPropAndAtoms p - $ atoms p - -theoryAndReprConds :: Testable a => a -> (Thy, [Expr]) -theoryAndReprConds p = (thy, filter (\c -> typ c == boolTy) es) - where - (thy,es) = theoryAndReprExprs p - -candidateConditions :: Testable a => (Thy,[Expr]) -> a -> [Expr] -> [Expr] -candidateConditions (thy,cs) p es = expr True : - [ c | (c,_) <- classesFromSchemasAndVariables thy (uncurry (flip Var) <$> vars es) cs - , hasVar c - , not (isAssignment c) - , not (isAssignmentTest is (maxTests p) c) - ] - where - is = tinstances p --- 'expr True' is expected by the functions that call candidateConditions. It --- is always useful to check if a generalization without any conditions still --- passes (that means we should skip as there is an already reported --- unconditional generalization). - -validConditions :: Testable a => (Thy,[Expr]) -> a -> [Expr] -> [(Expr,Int)] -validConditions thyes p es = - [ (c,n) | c <- candidateConditions thyes p es - , let (is,n) = isCounterExampleUnder p c es - , is - ] ++ [(expr False,0)] - -weakestCondition :: Testable a => (Thy,[Expr]) -> a -> [Expr] -> Expr -weakestCondition thyes p es = fst - . maximumOn snd - . takeBound (computeConditionBound p) - $ validConditions thyes p es - -isCounterExampleUnder :: Testable a => a -> Expr -> [Expr] -> (Bool, Int) -isCounterExampleUnder p c es = and' - [ not . errorToFalse $ p $-| es' - | (bs,es') <- take (maxTests p) $ groundsAndBinds (tinstances p) es - , errorToFalse $ eval False (c `assigning` bs) - ] - where - and' ps = let len = length ps - in (and ps && len > computeMinFailures p && len > 0, len) - -isVar :: Expr -> Bool -isVar (Var _ _) = True -isVar _ = False - -fromBackgroundOf :: (Generalizable a, Typeable b) => String -> a -> Maybe b -fromBackgroundOf nm = listToMaybe - . mapMaybe evaluate - . filter (`isConstantNamed` nm) - . background - -hasEq :: Generalizable a => a -> Bool -hasEq x = isJust $ "==" `fromBackgroundOf` x -: mayb (x >- x >- bool) - -hasOrd :: Generalizable a => a -> Bool -hasOrd x = isJust $ "<=" `fromBackgroundOf` x -: mayb (x >- x >- bool) - -(*==*) :: Generalizable a => a -> a -> Bool -x *==* y = x == y - where - (==) = fromMaybe (error "(*==*): no (==) operator in background") - $ "==" `fromBackgroundOf` x - -(*/=*) :: Generalizable a => a -> a -> Bool -x */=* y = x /= y - where - (/=) = fromMaybe (error "(*/=*): no (/=) operator in background") - $ "/=" `fromBackgroundOf` x - -(*<=*) :: Generalizable a => a -> a -> Bool -x *<=* y = x <= y - where - (<=) = fromMaybe (error "(*<=*): no (<=) operator in background") - $ "<=" `fromBackgroundOf` x - -(*<*) :: Generalizable a => a -> a -> Bool -x *<* y = x < y + Just e -> Just (e,gens e ++ take 1 (cgens e)) where - (<) = fromMaybe (error "(*<*): no (<) operator in background") - $ "<" `fromBackgroundOf` x + grounds = testableGrounds p + gens = counterExampleGeneralizations grounds + cgens = conditionalCounterExampleGeneralizations + (testableMaxConditionSize p) + (testableAtoms p) + grounds + (testableMkEquation p) diff --git a/src/Test/Extrapolate/Derive.hs b/src/Test/Extrapolate/Derive.hs deleted file mode 100644 --- a/src/Test/Extrapolate/Derive.hs +++ /dev/null @@ -1,391 +0,0 @@ -{-# LANGUAGE TemplateHaskell, CPP #-} --- | --- Module : Test.Extrapolate.Derive --- Copyright : (c) 2017 Rudy Matela --- License : 3-Clause BSD (see the file LICENSE) --- Maintainer : Rudy Matela --- --- This module is part of Extrapolate, --- a library for generalization of counter-examples. --- --- This is a module for deriving 'Generalizable' instances. --- --- Needs GHC and Template Haskell (tested on GHC 8.0). --- --- If Extrapolate does not compile under later GHCs, this module is the --- probable culprit. -module Test.Extrapolate.Derive - ( deriveGeneralizable - , deriveGeneralizableIfNeeded - , deriveGeneralizableCascading - ) -where - -import Test.Extrapolate.Core hiding (isInstanceOf) -import Test.Extrapolate.TypeBinding -import Language.Haskell.TH -import Test.LeanCheck.Basic -import Test.LeanCheck.Utils.TypeBinding -import Test.LeanCheck.Derive (deriveListableIfNeeded) -import Control.Monad (unless, liftM, liftM2, filterM) -import Data.List (delete,nub,sort) -import Data.Char (toLower) -import Data.Functor ((<$>)) -- for GHC <= 7.8 -import Data.Typeable -import Test.Extrapolate.Utils (foldr0) - --- | Derives a 'Generalizable' instance for a given type 'Name'. --- --- Consider the following @Stack@ datatype: --- --- > data Stack a = Stack a (Stack a) | Empty --- --- Writing --- --- > deriveGeneralizable ''Stack --- --- will automatically derive the following 'Generalizable' instance: --- --- > instance Generalizable a => Generalizable (Stack a) where --- > expr s@(Stack x y) = constant "Stack" (Stack ->>: s) :$ expr x :$ expr y --- > expr s@Empty = constant "Empty" (Empty -: s) --- > instances s = this "s" s --- > $ let Stack x y = Stack undefined undefined `asTypeOf` s --- > in instances x --- > . instances y --- --- This function needs the @TemplateHaskell@ extension. -deriveGeneralizable :: Name -> DecsQ -deriveGeneralizable = deriveGeneralizableX True False - --- | Same as 'deriveGeneralizable' but does not warn when instance already exists --- ('deriveGeneralizable' is preferable). -deriveGeneralizableIfNeeded :: Name -> DecsQ -deriveGeneralizableIfNeeded = deriveGeneralizableX False False - --- | Derives a 'Generalizable' instance for a given type 'Name' --- cascading derivation of type arguments as well. -deriveGeneralizableCascading :: Name -> DecsQ -deriveGeneralizableCascading = deriveGeneralizableX True True - -deriveGeneralizableX :: Bool -> Bool -> Name -> DecsQ -deriveGeneralizableX warnExisting cascade t = do - is <- t `isInstanceOf` ''Generalizable - if is - then do - unless (not warnExisting) - (reportWarning $ "Instance Generalizable " ++ show t - ++ " already exists, skipping derivation") - return [] - else - if cascade - then liftM2 (++) (deriveListableCascading t) (reallyDeriveGeneralizableCascading t) - else liftM2 (++) (deriveListableIfNeeded t) (reallyDeriveGeneralizable t) - -reallyDeriveGeneralizable :: Name -> DecsQ -reallyDeriveGeneralizable t = do - isEq <- t `isInstanceOf` ''Eq - isOrd <- t `isInstanceOf` ''Ord - (nt,vs) <- normalizeType t -#if __GLASGOW_HASKELL__ >= 710 - cxt <- sequence [ [t| $(conT c) $(return v) |] -#else - -- template-haskell <= 2.9.0.0: - cxt <- sequence [ classP c [return v] -#endif - | c <- ''Generalizable:([''Eq | isEq] ++ [''Ord | isOrd]) - , v <- vs] - cs <- typeConstructorsArgNames t - asName <- newName "x" - let generalizableExpr = mergeIFns $ foldr1 mergeI - [ do retTypeOf <- lookupValN $ "-" ++ replicate (length ns) '>' ++ ":" - let exprs = [[| expr $(varE n) |] | n <- ns] - let conex = [| $(varE retTypeOf) $(conE c) $(varE asName) |] - let root = [| constant $(stringE $ showJustName c) $(conex) |] - let rhs = foldl (\e1 e2 -> [| $e1 :$ $e2 |]) root exprs - [d| instance Generalizable $(return nt) where - expr $(asP asName $ conP c (map varP ns)) = $rhs |] - | (c,ns) <- cs - ] - let generalizableBackground = do - n <- newName "x" - case (isEq, isOrd) of - (True, True) -> - [d| instance Generalizable $(return nt) where - background $(varP n) = [ constant "==" ((==) -:> $(varE n)) - , constant "/=" ((/=) -:> $(varE n)) - , constant "<" ((<) -:> $(varE n)) - , constant "<=" ((<=) -:> $(varE n)) ] |] - (True, False) -> - [d| instance Generalizable $(return nt) where - background $(varP n) = [ constant "==" ((==) -:> $(varE n)) - , constant "/=" ((/=) -:> $(varE n)) ] |] - (False, False) -> - [d| instance Generalizable $(return nt) where - background $(varP n) = [] |] - _ -> error $ "reallyDeriveGeneralizable " ++ show t ++ ": the impossible happened" - let generalizableInstances = do - n <- newName "x" - let lets = [letin n c ns | (c,ns) <- cs, not (null ns)] - let rhs = foldr0 (\e1 e2 -> [| $e1 . $e2 |]) [|id|] lets - [d| instance Generalizable $(return nt) where - instances $(varP n) = this $(varE n) $ $rhs |] - let generalizableName = do - [d| instance Generalizable $(return nt) where - name _ = $(stringE vname) |] - cxt |=>| (generalizableName `mergeI` generalizableExpr - `mergeI` generalizableBackground - `mergeI` generalizableInstances) - where - showJustName = reverse . takeWhile (/= '.') . reverse . show - vname = map toLower . take 1 $ showJustName t - -letin :: Name -> Name -> [Name] -> ExpQ -letin x c ns = do - und <- VarE <$> lookupValN "undefined" - let lhs = conP c (map varP ns) - let rhs = return $ foldl AppE (ConE c) [und | _ <- ns] - let bot = foldl1 (\e1 e2 -> [| $e1 . $e2 |]) - [ [| instances $(varE n) |] | n <- ns ] - [| let $lhs = $rhs `asTypeOf` $(varE x) in $bot |] - -typeConstructorsArgNames :: Name -> Q [(Name,[Name])] -typeConstructorsArgNames t = do - cs <- typeConstructors t - sequence [ do ns <- sequence [newName "x" | _ <- ts] - return (c,ns) - | (c,ts) <- cs ] - -lookupValN :: String -> Q Name -lookupValN s = do - mn <- lookupValueName s - case mn of - Just n -> return n - Nothing -> fail $ "lookupValN: cannot find " ++ s - - -data Bla = Bla Int Int - | Ble Char - deriving (Eq, Ord, Show) - --- Not only really derive Generalizable instances, --- but cascade through argument types. -reallyDeriveGeneralizableCascading :: Name -> DecsQ -reallyDeriveGeneralizableCascading t = - return . concat - =<< mapM reallyDeriveGeneralizable - =<< filterM (liftM not . isTypeSynonym) - =<< return . (t:) . delete t - =<< t `typeConCascadingArgsThat` (`isntInstanceOf` ''Generalizable) - --- * Template haskell utilities - -typeConArgs :: Name -> Q [Name] -typeConArgs t = do - is <- isTypeSynonym t - if is - then liftM typeConTs $ typeSynonymType t - else liftM (nubMerges . map typeConTs . concat . map snd) $ typeConstructors t - where - typeConTs :: Type -> [Name] - typeConTs (AppT t1 t2) = typeConTs t1 `nubMerge` typeConTs t2 - typeConTs (SigT t _) = typeConTs t - typeConTs (VarT _) = [] - typeConTs (ConT n) = [n] -#if __GLASGOW_HASKELL__ >= 800 - -- typeConTs (PromotedT n) = [n] ? - typeConTs (InfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2 - typeConTs (UInfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2 - typeConTs (ParensT t) = typeConTs t -#endif - typeConTs _ = [] - -typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name] -typeConArgsThat t p = do - targs <- typeConArgs t - tbs <- mapM (\t' -> do is <- p t'; return (t',is)) targs - return [t' | (t',p) <- tbs, p] - -typeConCascadingArgsThat :: Name -> (Name -> Q Bool) -> Q [Name] -t `typeConCascadingArgsThat` p = do - ts <- t `typeConArgsThat` p - let p' t' = do is <- p t'; return $ t' `notElem` (t:ts) && is - tss <- mapM (`typeConCascadingArgsThat` p') ts - return $ nubMerges (ts:tss) - --- Normalizes a type by applying it to necessary type variables, making it --- accept "zero" parameters. The normalized type is tupled with a list of --- necessary type variables. --- --- Suppose: --- --- > data DT a b c ... = ... --- --- Then, in pseudo-TH: --- --- > normalizeType [t|DT|] == Q (DT a b c ..., [a, b, c, ...]) -normalizeType :: Name -> Q (Type, [Type]) -normalizeType t = do - ar <- typeArity t - vs <- newVarTs ar - return (foldl AppT (ConT t) vs, vs) - where - newNames :: [String] -> Q [Name] - newNames = mapM newName - newVarTs :: Int -> Q [Type] - newVarTs n = liftM (map VarT) - $ newNames (take n . map (:[]) $ cycle ['a'..'z']) - --- Normalizes a type by applying it to units (`()`) while possible. --- --- > normalizeTypeUnits ''Int === [t| Int |] --- > normalizeTypeUnits ''Maybe === [t| Maybe () |] --- > normalizeTypeUnits ''Either === [t| Either () () |] -normalizeTypeUnits :: Name -> Q Type -normalizeTypeUnits t = do - ar <- typeArity t - return (foldl AppT (ConT t) (replicate ar (TupleT 0))) - --- Given a type name and a class name, --- returns whether the type is an instance of that class. -isInstanceOf :: Name -> Name -> Q Bool -isInstanceOf tn cl = do - ty <- normalizeTypeUnits tn - isInstance cl [ty] - -isntInstanceOf :: Name -> Name -> Q Bool -isntInstanceOf tn cl = liftM not (isInstanceOf tn cl) - --- | Given a type name, return the number of arguments taken by that type. --- Examples in partially broken TH: --- --- > arity ''Int === Q 0 --- > arity ''Int->Int === Q 0 --- > arity ''Maybe === Q 1 --- > arity ''Either === Q 2 --- > arity ''Int-> === Q 1 --- --- This works for Data's and Newtype's and it is useful when generating --- typeclass instances. -typeArity :: Name -> Q Int -typeArity t = do - ti <- reify t - return . length $ case ti of -#if __GLASGOW_HASKELL__ < 800 - TyConI (DataD _ _ ks _ _) -> ks - TyConI (NewtypeD _ _ ks _ _) -> ks -#else - TyConI (DataD _ _ ks _ _ _) -> ks - TyConI (NewtypeD _ _ ks _ _ _) -> ks -#endif - TyConI (TySynD _ ks _) -> ks - _ -> error $ "error (typeArity): symbol " ++ show t - ++ " is not a newtype, data or type synonym" - --- Given a type name, returns a list of its type constructor names paired with --- the type arguments they take. --- --- > typeConstructors ''() === Q [('(),[])] --- --- > typeConstructors ''(,) === Q [('(,),[VarT a, VarT b])] --- --- > typeConstructors ''[] === Q [('[],[]),('(:),[VarT a,AppT ListT (VarT a)])] --- --- > data Pair a = P a a --- > typeConstructors ''Pair === Q [('P,[VarT a, VarT a])] --- --- > data Point = Pt Int Int --- > typeConstructors ''Point === Q [('Pt,[ConT Int, ConT Int])] -typeConstructors :: Name -> Q [(Name,[Type])] -typeConstructors t = do - ti <- reify t - return . map simplify $ case ti of -#if __GLASGOW_HASKELL__ < 800 - TyConI (DataD _ _ _ cs _) -> cs - TyConI (NewtypeD _ _ _ c _) -> [c] -#else - TyConI (DataD _ _ _ _ cs _) -> cs - TyConI (NewtypeD _ _ _ _ c _) -> [c] -#endif - _ -> error $ "error (typeConstructors): symbol " ++ show t - ++ " is neither newtype nor data" - where - simplify (NormalC n ts) = (n,map snd ts) - simplify (RecC n ts) = (n,map trd ts) - simplify (InfixC t1 n t2) = (n,[snd t1,snd t2]) - trd (x,y,z) = z - -isTypeSynonym :: Name -> Q Bool -isTypeSynonym t = do - ti <- reify t - return $ case ti of - TyConI (TySynD _ _ _) -> True - _ -> False - -typeSynonymType :: Name -> Q Type -typeSynonymType t = do - ti <- reify t - return $ case ti of - TyConI (TySynD _ _ t') -> t' - _ -> error $ "error (typeSynonymType): symbol " ++ show t - ++ " is not a type synonym" - --- Append to instance contexts in a declaration. --- --- > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|] --- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |] -(|=>|) :: Cxt -> DecsQ -> DecsQ -c |=>| qds = do ds <- qds - return $ map (`ac` c) ds -#if __GLASGOW_HASKELL__ < 800 - where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds - ac d _ = d -#else - where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds - ac d _ = d -#endif - -mergeIFns :: DecsQ -> DecsQ -mergeIFns qds = do ds <- qds - return $ map m' ds - where -#if __GLASGOW_HASKELL__ < 800 - m' (InstanceD c ts ds) = InstanceD c ts [foldr1 m ds] -#else - m' (InstanceD o c ts ds) = InstanceD o c ts [foldr1 m ds] -#endif - FunD n cs1 `m` FunD _ cs2 = FunD n (cs1 ++ cs2) - -mergeI :: DecsQ -> DecsQ -> DecsQ -qds1 `mergeI` qds2 = do ds1 <- qds1 - ds2 <- qds2 - return $ ds1 `m` ds2 - where -#if __GLASGOW_HASKELL__ < 800 - [InstanceD c ts ds1] `m` [InstanceD _ _ ds2] = [InstanceD c ts (ds1 ++ ds2)] -#else - [InstanceD o c ts ds1] `m` [InstanceD _ _ _ ds2] = [InstanceD o c ts (ds1 ++ ds2)] -#endif - -whereI :: DecsQ -> [Dec] -> DecsQ -qds `whereI` w = do ds <- qds - return $ map (`aw` w) ds -#if __GLASGOW_HASKELL__ < 800 - where aw (InstanceD c ts ds) w' = InstanceD c ts (ds++w') - aw d _ = d -#else - where aw (InstanceD o c ts ds) w' = InstanceD o c ts (ds++w') - aw d _ = d -#endif - --- > nubMerge xs ys == nub (merge xs ys) --- > nubMerge xs ys == nub (sort (xs ++ ys)) -nubMerge :: Ord a => [a] -> [a] -> [a] -nubMerge [] ys = ys -nubMerge xs [] = xs -nubMerge (x:xs) (y:ys) | x < y = x : xs `nubMerge` (y:ys) - | x > y = y : (x:xs) `nubMerge` ys - | otherwise = x : xs `nubMerge` ys - -nubMerges :: Ord a => [[a]] -> [a] -nubMerges = foldr nubMerge [] diff --git a/src/Test/Extrapolate/Expr.hs b/src/Test/Extrapolate/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Test/Extrapolate/Expr.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveDataTypeable #-} -- for GHC <= 7.8 +-- | +-- Module : Test.Extrapolate.Expr +-- Copyright : (c) 2017-2019 Rudy Matela +-- License : 3-Clause BSD (see the file LICENSE) +-- Maintainer : Rudy Matela +-- +-- This module is part of Extrapolate, +-- a library for generalization of counter-examples. +-- +-- This module re-exports functionality from +-- "Data.Express" and "Test.Speculate.Expr" +-- along with some extra utilities. +module Test.Extrapolate.Expr + ( module Data.Express + , module Test.Speculate.Expr + + , canonicalizeUsingHoles + , canonicalizeUsingHolesWith + , unand + , replaceFun + + -- * misc re-exports + , (-&&-) + , false + ) +where + +import Data.Express +import Data.Express.Fixtures +import Test.Speculate.Expr + +-- | +-- Like 'canonicalize' but uses holes for unrepeated variables. +canonicalizeUsingHoles :: Expr -> Expr +canonicalizeUsingHoles = canonicalizeUsingHolesWith (lookupNames preludeNameInstances) + +-- | +-- Like 'canonicalizeWith' but uses holes for unrepeated variables. +canonicalizeUsingHolesWith :: (Expr -> [String]) -> Expr -> Expr +canonicalizeUsingHolesWith namesFor = c1 . unrepeatedToHole1 + where + c1 e = e //- cn e + cn e = canonicalizationWith namesFor + $ fold [v | v <- vars e, not $ isHole v] + unrepeatedToHole1 e = e //- [(v, holeAsTypeOf v) | (v,1) <- countVars e] + countVars e = map (\e' -> (e',length . filter (== e') $ vars e)) $ nubVars e + +unand :: Expr -> (Expr,Expr) +unand ((op :$ e1) :$ e2) | op == andE = (e1,e2) +unand _ = error "unimply: not an implication" + +-- | /O(n)/. +-- Replaces the function in the given 'Expr'. +-- +-- > replaceFun timesE (plusE :$ one :$ two) = timesE :$ one :$ two +-- > replaceFun absE (idE :$ one) = absE :$ one +-- > replaceFun two (one) = two +replaceFun :: Expr -> Expr -> Expr +replaceFun ef e = foldApp (ef:tail es) + where + es = unfoldApp e diff --git a/src/Test/Extrapolate/Exprs.hs b/src/Test/Extrapolate/Exprs.hs deleted file mode 100644 --- a/src/Test/Extrapolate/Exprs.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -- for GHC <= 7.8 --- | --- Module : Test.Extrapolate.IO --- Copyright : (c) 2017 Rudy Matela --- License : 3-Clause BSD (see the file LICENSE) --- Maintainer : Rudy Matela --- --- This module is part of Extrapolate, --- a library for generalization of counter-examples. --- --- This module re-exports some functionality from Test.Speculate.Expr, but --- instead of working on single expressions it works in lists of expressions --- (the choosen representation for counter-examples). -module Test.Extrapolate.Exprs - ( Exprs - , canonicalizeWith - , grounds - , groundsAndBinds - , vassignments - , vars - , fold - , unfold - , isAssignmentTest - , nameWith - - , module Test.Speculate.Expr - ) -where - -import Test.Speculate.Expr hiding - ( ins - , name - , canonicalizeWith - , grounds - , vassignments - , vars - ) -import qualified Test.Speculate.Expr as E -import qualified Test.Speculate.Engine as E -import Test.LeanCheck.Error (errorToFalse) -import Data.Typeable (typeOf, TypeRep, Typeable) -import Data.List ((\\)) - -type Exprs = [Expr] - -nameWith :: Typeable a => String -> a -> Instances -nameWith = E.name - -canonicalizeWith :: Instances -> [Expr] -> [Expr] -canonicalizeWith is = unfold . canonicalizeWith1 is . unrepeatedToHole1 . fold - -canonicalizeWith1 :: Instances -> Expr -> Expr -canonicalizeWith1 ti e = e `assigning` ((\(t,n,n') -> (n,Var n' t)) `map` cr [] e) - where - cr :: [(TypeRep,String,String)] -> Expr -> [(TypeRep,String,String)] - cr bs (e1 :$ e2) = cr (cr bs e1) e2 - cr bs (Var n t) - | n == "" = bs - | any (\(t',n',_) -> t == t' && n == n') bs = bs - | otherwise = (t,n,head $ names ti t \\ map (\(_,_,n) -> n) bs):bs - cr bs _ = bs - -unrepeatedToHole1 :: Expr -> Expr -unrepeatedToHole1 e = e `assigning` [(n,Var "" t) | (t,n,1) <- countVars e] - -grounds :: Instances -> [Expr] -> [ [Expr] ] -grounds is = map unfold . E.grounds is . fold - -groundsAndBinds :: Instances -> [Expr] -> [(Binds,[Expr])] -groundsAndBinds is = map (mapSnd unfold) . E.groundAndBinds is . fold - where - mapSnd f (x,y) = (x,f y) - -vassignments :: [Expr] -> [[Expr]] -vassignments = map unfold . E.vassignments . fold - -vars :: [Expr] -> [(TypeRep,String)] -vars = E.vars . fold - -isAssignmentTest :: Instances -> Int -> Expr -> Bool -isAssignmentTest is m e | typ e /= boolTy = False -isAssignmentTest is m e = length rs > 1 && length (filter id rs) == 1 - where - rs = [errorToFalse $ eval False e' | [e'] <- take m $ grounds is [e]] - -data MarkerType = MarkerType - deriving Typeable -- for GHC <= 7.8 - -fold :: [Expr] -> Expr -fold [] = constant "[]" MarkerType -fold (e:es) = constant ":" MarkerType :$ e :$ fold es - -unfold :: Expr -> [Expr] -unfold e'@(Constant "[]" _) | typ e' == typeOf MarkerType = [] -unfold ((e'@(Constant ":" _) :$ e) :$ es) | typ e' == typeOf MarkerType = e : unfold es -unfold e = error $ "unfold: cannot unfold expression: " ++ showPrecExpr 0 e diff --git a/src/Test/Extrapolate/Generalizable.hs b/src/Test/Extrapolate/Generalizable.hs new file mode 100644 --- /dev/null +++ b/src/Test/Extrapolate/Generalizable.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE CPP #-} -- for GHC <= 7.8 +-- | +-- Module : Test.Extrapolate.Generalizable +-- Copyright : (c) 2017-2019 Rudy Matela +-- License : 3-Clause BSD (see the file LICENSE) +-- Maintainer : Rudy Matela +-- +-- This module is part of Extrapolate, +-- a library for generalization of counter-examples. +-- +-- This defines the 'Generalizable' typeclass +-- and utilities involving it. +-- +-- You are probably better off importing "Test.Extrapolate". +module Test.Extrapolate.Generalizable + ( Generalizable (..) + , instances + + , mkEq1 + , mkEq2 + , mkEq3 + , mkEq4 + , mkOrd1 + , mkOrd2 + , mkOrd3 + , mkOrd4 + + , (*==*) + , (*/=*) + , (*<=*) + , (*<*) + + , Listable (..) + , module Test.Extrapolate.Expr + ) +where + +import Data.Maybe +import Data.Ratio + +import Test.LeanCheck +import Test.LeanCheck.Utils + +import Test.Extrapolate.TypeBinding +import Test.Extrapolate.Utils +import Test.Extrapolate.Expr + +-- | +-- Extrapolate can generalize counter-examples of any types that are +-- 'Generalizable'. +-- +-- 'Generalizable' types must first be instances of +-- +-- * 'Listable', so Extrapolate knows how to enumerate values; +-- * 'Express', so Extrapolate can represent then manipulate values; +-- * 'Name', so Extrapolate knows how to name variables. +-- +-- There are no required functions, so we can define instances with: +-- +-- > instance Generalizable OurType +-- +-- However, it is desirable to define both 'background' and 'subInstances'. +-- +-- The following example shows a datatype and its instance: +-- +-- > data Stack a = Stack a (Stack a) | Empty +-- +-- > instance Generalizable a => Generalizable (Stack a) where +-- > subInstances s = instances (argTy1of1 s) +-- +-- To declare 'instances' it may be useful to use type binding +-- operators such as: 'argTy1of1', 'argTy1of2' and 'argTy2of2'. +-- +-- Instances can be automatically derived using +-- 'Test.Extrapolate.Derive.deriveGeneralizable' +-- which will also automatically derivate +-- 'Listable', 'Express' and 'Name' when needed. +class (Listable a, Express a, Name a, Show a) => Generalizable a where + -- | List of symbols allowed to appear in side-conditions. + -- Defaults to @[]@. See 'value'. + background :: a -> [Expr] + background _ = [] + + -- | Computes a list of reified subtype instances. + -- Defaults to 'id'. + -- See 'instances'. + subInstances :: a -> Instances -> Instances + subInstances _ = id + + +instance Generalizable () + +instance Generalizable Bool where + background p = reifyEq p + ++ [ value "not" not ] + +instance Generalizable Int where + background x = reifyEqOrd x + +instance Generalizable Integer where + background x = reifyEqOrd x + +instance Generalizable Char where + background c = reifyEqOrd c + +instance (Generalizable a) => Generalizable (Maybe a) where + background mx = mkEq1 (maybeEq ->:> mx) + ++ mkOrd1 (maybeOrd ->:> mx) + ++ [ value "Just" (Just ->: mx) ] + subInstances mx = instances (fromJust mx) + +-- TODO: move maybeEq and maybeOrd here, I'll have to change the tests + +instance (Generalizable a, Generalizable b) => Generalizable (Either a b) where + background exy = mkEq2 (eitherEq ->>:> exy) + ++ mkOrd2 (eitherOrd ->>:> exy) + ++ [ value "Left" (Left ->: exy) + , value "Right" (Right ->: exy) ] + subInstances exy = instances (fromLeft exy) + . instances (fromRight exy) + +-- TODO: move eitherEq and eitherOrd here, I'll have to change the tests + +instance (Generalizable a, Generalizable b) => Generalizable (a,b) where + background xy = mkEq2 (pairEq ->>:> xy) + ++ mkOrd2 (pairOrd ->>:> xy) + subInstances xy = instances (fst xy) + . instances (snd xy) + +instance (Generalizable a, Generalizable b, Generalizable c) + => Generalizable (a,b,c) where + background xyz = mkEq3 (tripleEq ->>>:> xyz) + ++ mkOrd3 (tripleOrd ->>>:> xyz) + subInstances xyz = instances x . instances y . instances z + where (x,y,z) = xyz + +instance (Generalizable a, Generalizable b, Generalizable c, Generalizable d) + => Generalizable (a,b,c,d) where + background xyzw = mkEq4 (quadrupleEq ->>>>:> xyzw) + ++ mkOrd4 (quadrupleOrd ->>>>:> xyzw) + subInstances xyzw = instances x + . instances y + . instances z + . instances w + where (x,y,z,w) = xyzw + +instance Generalizable a => Generalizable [a] where + background xs = mkEq1 (listEq ->:> xs) + ++ mkOrd1 (listOrd ->:> xs) + ++ [ value "length" (length -:> xs) ] + ++ [ value "elem" (elemBy (*==*) ->:> xs) | hasEq $ head xs ] + subInstances xs = instances (head xs) + +instance Generalizable Ordering where + background o = reifyEqOrd o + +mkEq1 :: (Generalizable a, Generalizable b) + => ((b -> b -> Bool) -> a -> a -> Bool) -> [Expr] +mkEq1 m = takeWhile (\_ -> hasEq x) . mkEq $ m (*==*) + where + x = arg1 ==: m + +mkEq2 :: (Generalizable a, Generalizable b, Generalizable c) + => ((b -> b -> Bool) -> (c -> c -> Bool) -> a -> a -> Bool) -> [Expr] +mkEq2 m = takeWhile (\_ -> hasEq x && hasEq y) . mkEq $ m (*==*) (*==*) + where + x = arg1 ==: m + y = arg2 ==: m + +mkEq3 :: (Generalizable a, Generalizable b, Generalizable c, Generalizable d) + => ((b->b->Bool) -> (c->c->Bool) -> (d->d->Bool) -> a -> a -> Bool) + -> [Expr] +mkEq3 m = takeWhile (\_ -> hasEq x && hasEq y && hasEq z) . mkEq + $ m (*==*) (*==*) (*==*) + where + x = arg1 ==: m + y = arg2 ==: m + z = arg3 ==: m + +mkEq4 :: (Generalizable a, Generalizable b, Generalizable c, Generalizable d, Generalizable e) + => ((b->b->Bool) -> (c->c->Bool) -> (d->d->Bool) -> (e->e->Bool) -> a -> a -> Bool) + -> [Expr] +mkEq4 m = takeWhile (\_ -> hasEq x && hasEq y && hasEq z && hasEq w) . mkEq + $ m (*==*) (*==*) (*==*) (*==*) + where + x = arg1 ==: m + y = arg2 ==: m + z = arg3 ==: m + w = arg4 ==: m + +mkOrd1 :: (Generalizable a, Generalizable b) + => ((b -> b -> Bool) -> a -> a -> Bool) -> [Expr] +mkOrd1 m = takeWhile (\_ -> hasOrd x) . mkOrdLessEqual + $ m (*<=*) + where + x = arg1 ==: m + +mkOrd2 :: (Generalizable a, Generalizable b, Generalizable c) + => ((b -> b -> Bool) -> (c -> c -> Bool) -> a -> a -> Bool) -> [Expr] +mkOrd2 m = takeWhile (\_ -> hasOrd x && hasOrd y) . mkOrdLessEqual + $ m (*<=*) (*<=*) + where + x = arg1 ==: m + y = arg2 ==: m + +mkOrd3 :: (Generalizable a, Generalizable b, Generalizable c, Generalizable d) + => ((b->b->Bool) -> (c->c->Bool) -> (d->d->Bool) -> a -> a -> Bool) + -> [Expr] +mkOrd3 m = takeWhile (\_ -> hasOrd x && hasOrd y && hasOrd z) . mkOrdLessEqual + $ m (*<=*) (*<=*) (*<=*) + where + x = arg1 ==: m + y = arg2 ==: m + z = arg3 ==: m + +mkOrd4 :: (Generalizable a, Generalizable b, Generalizable c, Generalizable d, Generalizable e) + => ((b->b->Bool) -> (c->c->Bool) -> (d->d->Bool) -> (e->e->Bool) -> a -> a -> Bool) + -> [Expr] +mkOrd4 m = takeWhile (\_ -> hasOrd x && hasOrd y && hasOrd z && hasOrd w) . mkOrdLessEqual + $ m (*<=*) (*<=*) (*<=*) (*<=*) + where + x = arg1 ==: m + y = arg2 ==: m + z = arg3 ==: m + w = arg4 ==: m + +-- | Usage: @ins "x" (undefined :: Type)@ +ins :: Generalizable a => a -> Instances +ins x = reifyListable x + ++ reifyName x + ++ reifyBackground x + +-- | Used in the definition of 'subInstances' +-- in 'Generalizable' typeclass instances. +instances :: Generalizable a => a -> Instances -> Instances +instances x = this x (subInstances x) + where + this :: Generalizable a + => a -> (Instances -> Instances) -> Instances -> Instances + this x f is = + if isListableT is (typeOf x) + then is + else f (ins x ++ is) + -- TODO: change type to a -> [Instances -> Instances] -> Instances -> Instances + +reifyBackground :: Generalizable a => a -> Instances +reifyBackground x = [value "background" (background x)] + +fromBackgroundOf :: (Generalizable a, Typeable b) => String -> a -> Maybe b +fromBackgroundOf nm = listToMaybe + . mapMaybe evaluate + . filter (`isConstantNamed` nm) + . background + +hasEq :: Generalizable a => a -> Bool +hasEq x = isJust $ "==" `fromBackgroundOf` x -: mayb (x >- x >- bool) + +hasOrd :: Generalizable a => a -> Bool +hasOrd x = isJust $ "<=" `fromBackgroundOf` x -: mayb (x >- x >- bool) + +(*==*) :: Generalizable a => a -> a -> Bool +x *==* y = x == y + where + (==) = fromMaybe (error "(*==*): no (==) operator in background") + $ "==" `fromBackgroundOf` x + +(*/=*) :: Generalizable a => a -> a -> Bool +x */=* y = x /= y + where + (/=) = fromMaybe (error "(*/=*): no (/=) operator in background") + $ "/=" `fromBackgroundOf` x + +(*<=*) :: Generalizable a => a -> a -> Bool +x *<=* y = x <= y + where + (<=) = fromMaybe (error "(*<=*): no (<=) operator in background") + $ "<=" `fromBackgroundOf` x + +(*<*) :: Generalizable a => a -> a -> Bool +x *<* y = x < y + where + (<) = fromMaybe (error "(*<*): no (<) operator in background") + $ "<" `fromBackgroundOf` x + +-- -- other Generalizable instances -- -- + +instance (Integral a, Generalizable a) => Generalizable (Ratio a) + +instance ( Generalizable a, Generalizable b, Generalizable c, Generalizable d + , Generalizable e ) + => Generalizable (a,b,c,d,e) where + subInstances xyzwv = instances x . instances y . instances z + . instances w . instances v + where (x,y,z,w,v) = xyzwv + +instance ( Generalizable a, Generalizable b, Generalizable c, Generalizable d + , Generalizable e, Generalizable f ) + => Generalizable (a,b,c,d,e,f) where + subInstances xyzwvu = instances x . instances y . instances z + . instances w . instances v . instances u + where (x,y,z,w,v,u) = xyzwvu + +instance ( Generalizable a, Generalizable b, Generalizable c, Generalizable d + , Generalizable e, Generalizable f, Generalizable g ) + => Generalizable (a,b,c,d,e,f,g) where + subInstances xyzwvut = instances x . instances y . instances z . instances w + . instances v . instances u . instances t + where (x,y,z,w,v,u,t) = xyzwvut + +#if __GLASGOW_HASKELL__ < 710 +-- No 8-tuples for you: +-- On GHC 7.8, 8-tuples are not Typeable instances. We could add a standalone +-- deriving clause, but that may cause trouble if some other library does the +-- same. User should declare Generalizable 8-tuples manually when using GHC <= +-- 7.8. +#else +instance ( Generalizable a, Generalizable b, Generalizable c, Generalizable d + , Generalizable e, Generalizable f, Generalizable g, Generalizable h ) + => Generalizable (a,b,c,d,e,f,g,h) where + subInstances xyzwvuts = instances x . instances y . instances z . instances w + . instances v . instances u . instances t . instances s + where (x,y,z,w,v,u,t,s) = xyzwvuts +#endif diff --git a/src/Test/Extrapolate/Generalizable/Derive.hs b/src/Test/Extrapolate/Generalizable/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Test/Extrapolate/Generalizable/Derive.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +-- | +-- Module : Test.Extrapolate.Generalizable.Derive +-- Copyright : (c) 2017-2019 Rudy Matela +-- License : 3-Clause BSD (see the file LICENSE) +-- Maintainer : Rudy Matela +-- +-- This module is part of Extrapolate, +-- a library for generalization of counter-examples. +-- +-- This is a module for deriving 'Generalizable' instances. +-- +-- Needs GHC and Template Haskell (tested on GHC 8.0). +-- +-- If Extrapolate does not compile under later GHCs, this module is the +-- probable culprit. +module Test.Extrapolate.Generalizable.Derive + ( deriveGeneralizable + , deriveGeneralizableIfNeeded + , deriveGeneralizableCascading + ) +where + +import Test.Extrapolate.Generalizable hiding (Name, isInstanceOf) +import Test.Extrapolate.Utils (foldr0) +import Test.LeanCheck.Derive (deriveListableIfNeeded, deriveListableCascading) +import Test.LeanCheck.Utils.TypeBinding ((-:>)) + +import Language.Haskell.TH +import Data.Express.Utils.TH + +import Control.Monad (liftM, filterM) +import Data.Functor ((<$>)) -- for GHC <= 7.8 +import Data.List (delete) + + +-- | Derives a 'Generalizable' instance for a given type 'Name'. +-- +-- If needed, this function also automatically derivates +-- 'Listable', 'Express' and 'Name' instances using respectively +-- 'deriveListable', 'deriveExpress' and 'deriveName'. +-- +-- Consider the following @Stack@ datatype: +-- +-- > data Stack a = Stack a (Stack a) | Empty +-- +-- Writing +-- +-- > deriveGeneralizable ''Stack +-- +-- will automatically derive the following 'Generalizable' instance: +-- +-- > instance Generalizable a => Generalizable (Stack a) where +-- > instances s = this "s" s +-- > $ let Stack x y = Stack undefined undefined `asTypeOf` s +-- > in instances x +-- > . instances y +-- +-- This function needs the @TemplateHaskell@ extension. +deriveGeneralizable :: Name -> DecsQ +deriveGeneralizable = deriveWhenNeededOrWarn ''Express reallyDerive + where + reallyDerive = reallyDeriveGeneralizableWithRequisites + +-- | Same as 'deriveGeneralizable' but does not warn when instance already exists +-- ('deriveGeneralizable' is preferable). +deriveGeneralizableIfNeeded :: Name -> DecsQ +deriveGeneralizableIfNeeded = deriveWhenNeeded ''Express reallyDerive + where + reallyDerive = reallyDeriveGeneralizableWithRequisites + +-- | Derives a 'Generalizable' instance for a given type 'Name' +-- cascading derivation of type arguments as well. +deriveGeneralizableCascading :: Name -> DecsQ +deriveGeneralizableCascading = deriveWhenNeeded ''Express reallyDerive + where + reallyDerive t = concat + <$> sequence [ deriveListableCascading t + , deriveNameCascading t + , deriveExpressCascading t + , reallyDeriveGeneralizableCascading t ] + +reallyDeriveGeneralizableWithRequisites :: Name -> DecsQ +reallyDeriveGeneralizableWithRequisites t = concat <$> + sequence [ deriveListableIfNeeded t + , deriveNameIfNeeded t + , deriveExpressIfNeeded t + , reallyDeriveGeneralizable t ] + +reallyDeriveGeneralizable :: Name -> DecsQ +reallyDeriveGeneralizable t = do + isEq <- t `isInstanceOf` ''Eq + isOrd <- t `isInstanceOf` ''Ord + (nt,vs) <- normalizeType t +#if __GLASGOW_HASKELL__ >= 710 + cxt <- sequence [ [t| $(conT c) $(return v) |] +#else + -- template-haskell <= 2.9.0.0: + cxt <- sequence [ classP c [return v] +#endif + | c <- ''Generalizable:([''Eq | isEq] ++ [''Ord | isOrd]) + , v <- vs] + cs <- typeConstructorsArgNames t + asName <- newName "x" + let generalizableBackground = do + n <- newName "x" + case (isEq, isOrd) of + (True, True) -> + [d| instance Generalizable $(return nt) where + background $(varP n) = [ value "==" ((==) -:> $(varE n)) + , value "/=" ((/=) -:> $(varE n)) + , value "<" ((<) -:> $(varE n)) + , value "<=" ((<=) -:> $(varE n)) ] |] + (True, False) -> + [d| instance Generalizable $(return nt) where + background $(varP n) = [ value "==" ((==) -:> $(varE n)) + , value "/=" ((/=) -:> $(varE n)) ] |] + (False, False) -> + [d| instance Generalizable $(return nt) where + background $(varP n) = [] |] + _ -> error $ "reallyDeriveGeneralizable " ++ show t ++ ": the impossible happened" + let generalizableInstances = do + n <- newName "x" + let lets = [letin n c ns | (c,ns) <- cs, not (null ns)] + let rhs = foldr0 (\e1 e2 -> [| $e1 . $e2 |]) [|id|] lets + [d| instance Generalizable $(return nt) where + subInstances $(varP n) = $rhs |] + cxt |=>| (generalizableBackground `mergeI` generalizableInstances) + +-- Not only really derive Generalizable instances, +-- but cascade through argument types. +reallyDeriveGeneralizableCascading :: Name -> DecsQ +reallyDeriveGeneralizableCascading t = + return . concat + =<< mapM reallyDeriveGeneralizable + =<< filterM (liftM not . isTypeSynonym) + =<< return . (t:) . delete t + =<< t `typeConCascadingArgsThat` (`isntInstanceOf` ''Generalizable) + +letin :: Name -> Name -> [Name] -> ExpQ +letin x c ns = do + und <- VarE <$> lookupValN "undefined" + let lhs = conP c (map varP ns) + let rhs = return $ foldl AppE (ConE c) [und | _ <- ns] + let bot = foldl1 (\e1 e2 -> [| $e1 . $e2 |]) + [ [| instances $(varE n) |] | n <- ns ] + [| let $lhs = $rhs `asTypeOf` $(varE x) in $bot |] diff --git a/src/Test/Extrapolate/Generalization.hs b/src/Test/Extrapolate/Generalization.hs new file mode 100644 --- /dev/null +++ b/src/Test/Extrapolate/Generalization.hs @@ -0,0 +1,144 @@ +-- | +-- Module : Test.Extrapolate.Generalization +-- Copyright : (c) 2017-2019 Rudy Matela +-- License : 3-Clause BSD (see the file LICENSE) +-- Maintainer : Rudy Matela +-- +-- This module is part of Extrapolate, +-- a library for generalization of counter-examples. +-- +-- This defines utilities for unconditional generalization. +-- +-- You are probably better off importing "Test.Extrapolate". +module Test.Extrapolate.Generalization + ( counterExampleGeneralizations + + , candidateGeneralizations + , fastCandidateGeneralizations + , candidateHoleGeneralizations + + , module Test.Extrapolate.Expr + ) +where + +import Test.LeanCheck.Error (errorToFalse) + +import Test.Extrapolate.Expr + +-- | +-- Given boolean expression representing a counter-example, +-- returns all possible unconditional generalizations. +-- +-- If more than one generalization is returned, +-- they are _not_ instances of one another. +-- (cf. 'isInstanceOf') +-- All according to a given function that lists ground expressions. +-- +-- > > counterExampleGeneralizations (groundsFor not) false +-- > [] +-- +-- > > counterExampleGeneralizations (groundsFor not) (false -&&- true) +-- > [False && p :: Bool] +-- +-- > > counterExampleGeneralizations (groundsFor not) (false -||- true) +-- > [] +-- +-- > > counterExampleGeneralizations (groundsFor not) (false -/=- false) +-- > [p /= p :: Bool] +-- +-- > > counterExampleGeneralizations (groundsFor not) (false -&&- true -&&- false) +-- > [ (False && _) && _ :: Bool +-- > , p && False :: Bool +-- > ] +counterExampleGeneralizations :: (Expr -> [Expr]) -> Expr -> [Expr] +counterExampleGeneralizations grounds = + map canonicalize . filterRelevant . fastCandidateGeneralizations isListable + where + isListable = not . null . grounds . holeAsTypeOf + isCounterExample = all (not . errorToFalse . eval False) . grounds + filterRelevant [] = [] + filterRelevant (g:gs) + | isCounterExample g = g : filterRelevant [g' | g' <- gs, not $ g' `isInstanceOf` g] + | otherwise = filterRelevant gs + +-- | +-- Returns candidate generalizations for an expression. +-- (cf. 'candidateHoleGeneralizations') +-- +-- This takes a function that returns whether to generalize a given +-- subexpression. +-- +-- > > import Data.Express.Fixtures +-- +-- > > candidateGeneralizations (\e -> typ e == typ one) (one -+- two) +-- > [ _ :: Int +-- > , _ + _ :: Int +-- > , x + x :: Int +-- > , _ + 2 :: Int +-- > , 1 + _ :: Int +-- > ] +-- +-- > > candidateGeneralizations (const True) (one -+- two) +-- > [ _ :: Int +-- > , _ _ :: Int +-- > , _ _ _ :: Int +-- > , _ x x :: Int +-- > , _ 1 _ :: Int +-- > , _ + _ :: Int +-- > , x + x :: Int +-- > , _ 2 :: Int +-- > , _ _ 2 :: Int +-- > , _ 1 2 :: Int +-- > , _ + 2 :: Int +-- > , 1 + _ :: Int +-- > ] +candidateGeneralizations :: (Expr -> Bool) -> Expr -> [Expr] +candidateGeneralizations should = map canonicalize + . fastCandidateGeneralizations should + +-- | +-- Like 'candidateGeneralizations' but faster because result is not +-- canonicalized. Variable names will be repeated across different types. +fastCandidateGeneralizations :: (Expr -> Bool) -> Expr -> [Expr] +fastCandidateGeneralizations should = concatMap fastCanonicalVariations + . candidateHoleGeneralizations should + +-- | +-- Returns candidate generalizations for an expression by replacing values with +-- holes. (cf. 'candidateGeneralizations') +-- +-- > > import Data.Express.Fixtures +-- +-- > > candidateHoleGeneralizations (\e -> typ e == typ one) (one -+- two) +-- > [ _ :: Int +-- > , _ + _ :: Int +-- > , _ + 2 :: Int +-- > , 1 + _ :: Int +-- > ] +-- +-- > > candidateHoleGeneralizations (const True) (one -+- two) +-- > [ _ :: Int +-- > , _ _ :: Int +-- > , _ _ _ :: Int +-- > , _ 1 _ :: Int +-- > , _ + _ :: Int +-- > , _ 2 :: Int +-- > , _ _ 2 :: Int +-- > , _ 1 2 :: Int +-- > , _ + 2 :: Int +-- > , 1 + _ :: Int +-- > ] +candidateHoleGeneralizations :: (Expr -> Bool) -> Expr -> [Expr] +candidateHoleGeneralizations shouldGeneralize = gen + where + gen e@(e1 :$ e2) = + [holeAsTypeOf e | shouldGeneralize e] + ++ productWith (:$) (gen e1) (gen e2) + ++ map (:$ e2) (gen e1) + ++ map (e1 :$) (gen e2) + gen e + | isVar e = [] + | otherwise = [holeAsTypeOf e | shouldGeneralize e] + +productWith :: (a -> b -> c) -> [a] -> [b] -> [c] +productWith f xs ys = [f x y | x <- xs, y <- ys] diff --git a/src/Test/Extrapolate/IO.hs b/src/Test/Extrapolate/IO.hs --- a/src/Test/Extrapolate/IO.hs +++ b/src/Test/Extrapolate/IO.hs @@ -1,6 +1,6 @@ -- | -- Module : Test.Extrapolate.IO --- Copyright : (c) 2017 Rudy Matela +-- Copyright : (c) 2017-2019 Rudy Matela -- License : 3-Clause BSD (see the file LICENSE) -- Maintainer : Rudy Matela -- @@ -17,11 +17,6 @@ , withInstances , withBackground , withConditionSize - , minFailures - , maxSpeculateSize - , conditionBound - , constantBound - , depthBound ) where @@ -30,9 +25,8 @@ #endif import Test.Extrapolate.Core -import Data.Maybe (listToMaybe, mapMaybe, fromMaybe) -import Data.List (find, intercalate) -import Data.Ratio (Ratio) +import Data.Maybe (mapMaybe, fromMaybe) +import Data.List (find) import Control.Monad import Control.Exception as E (SomeException, catch, evaluate) @@ -41,7 +35,7 @@ -- > > check `for` 10080 $ \xs -> sort (sort xs) == sort (xs :: [Int]) -- > +++ OK, passed 10080 tests. -- --- Don't forget the dollar (@$@)! +-- Don't forget the dollar ('$')! for :: Testable a => (WithOption a -> b) -> Int -> a -> b check `for` m = \p -> check $ p `With` MaxTests m @@ -52,7 +46,7 @@ -- | Use @`withBackground`@ to provide additional functions to appear in side-conditions. -- --- > check `withBackground` [constant "isSpace" isSpace] $ \xs -> unwords (words xs) == xs +-- > check `withBackground` [value "isSpace" isSpace] $ \xs -> unwords (words xs) == xs -- > *** Failed! Falsifiable (after 4 tests): -- > " " -- > @@ -62,43 +56,12 @@ -- > Conditional Generalization: -- > c:_ when isSpace c withBackground :: Testable a => (WithOption a -> b) -> [Expr] -> a -> b -check `withBackground` ufs = check `withInstances` backgroundWith ufs (undefined::Option) +check `withBackground` ufs = check `withInstances` [value "background" ufs] -- | Use @`withConditionSize`@ to configure the maximum condition size allowed. withConditionSize :: Testable a => (WithOption a -> b) -> Int -> a -> b check `withConditionSize` s = \p -> check $ p `With` MaxConditionSize s --- | Use @`minFailures`@ to configure the minimum number of failures for a --- conditional generalization in function of the maximum number of tests. --- --- To set that conditional generalizations should fail for 10% of cases: --- > check `minFailures` (`div` 10) $ prop --- --- To set that conditional generalizations should fail for 5% of cases: --- > check `minFailures` (`div` 20) $ prop -minFailures :: Testable a => (WithOption a -> b) -> Ratio Int -> a -> b -check `minFailures` s = \p -> check $ p `With` MinFailures s - -conditionBound :: Testable a => (WithOption a -> b) -> Maybe Int -> a -> b -check `conditionBound` mi = \p -> check $ p `With` ConditionBound mi - -maxSpeculateSize :: Testable a => (WithOption a -> b) -> Maybe Int -> a -> b -check `maxSpeculateSize` mi = \p -> check $ p `With` MaxSpeculateSize mi - --- | Configures a bound on the number of constants allowed in expressions that --- are considered when testing for equality in Speculate. --- --- Defaults to 2. -constantBound :: Testable a => (WithOption a -> b) -> Maybe Int -> a -> b -check `constantBound` mi = \p -> check $ p `With` ConstantBound mi - --- | Configures a bound on the depth of expressions that are considered --- when testing for equality in Speculate. --- --- Default to 3. -depthBound :: Testable a => (WithOption a -> b) -> Maybe Int -> a -> b -check `depthBound` mi = \p -> check $ p `With` DepthBound mi - -- | Checks a property printing results on 'stdout' -- -- > > check $ \xs -> sort (sort xs) == sort (xs::[Int]) @@ -121,21 +84,20 @@ -- for silence, you should use 'Test.LeanCheck.holds'. checkResult :: Testable a => a -> IO Bool checkResult p = do - (r,ces) <- resultIO m p - putStr . showResult m p ces $ r + (r,ces) <- resultIO p + putStr . showResult p ces $ r return (isOK r) where - m = maxTests p isOK (OK _) = True isOK _ = False data Result = OK Int - | Falsified Int [Expr] - | Exception Int [Expr] String + | Falsified Int Expr + | Exception Int Expr String deriving (Eq, Show) -resultsIO :: Testable a => Int -> a -> IO [Result] -resultsIO n = zipWithM torio [1..] . take n . results +resultsIO :: Testable a => a -> IO [Result] +resultsIO = zipWithM torio [1..] . limitedResults where tor i (_,True) = OK i tor i (as,False) = Falsified i as @@ -143,9 +105,9 @@ `catch` \e -> let _ = e :: SomeException in return (Exception i as (show e)) -resultIO :: Testable a => Int -> a -> IO (Result, [[Expr]]) -resultIO n p = do - rs <- resultsIO n p +resultIO :: Testable a => a -> IO (Result, [Expr]) +resultIO p = do + rs <- resultsIO p return ( fromMaybe (last rs) $ find isFailure rs , mapMaybe ce rs ) where @@ -155,35 +117,49 @@ ce (Falsified _ es) = Just es ce (Exception _ es _) = Just es -showResult :: Testable a => Int -> a -> [[Expr]] -> Result -> String -showResult m p ces (OK n) = "+++ OK, passed " ++ show n ++ " tests" - ++ takeWhile (\_ -> n < m) " (exhausted)" ++ ".\n\n" -showResult m p ces (Falsified i ce) = "*** Failed! Falsifiable (after " - ++ show i ++ " tests):\n" ++ showCEandGens m p ce -showResult m p ces (Exception i ce e) = "*** Failed! Exception '" ++ e ++ "' (after " - ++ show i ++ " tests):\n" ++ showCEandGens m p ce +showResult :: Testable a => a -> [Expr] -> Result -> String +showResult p ces (OK n) = "+++ OK, passed " ++ show n ++ " tests" + ++ takeWhile (\_ -> n < testableMaxTests p) " (exhausted)" ++ ".\n\n" +showResult p ces (Falsified i ce) = "*** Failed! Falsifiable (after " + ++ show i ++ " tests):\n" ++ showCEandGens p ce +showResult p ces (Exception i ce e) = "*** Failed! Exception '" ++ e ++ "' (after " + ++ show i ++ " tests):\n" ++ showCEandGens p ce -showCEandGens :: Testable a => Int -> a -> [Expr] -> String -showCEandGens m p es = showCE es ++ "\n\n" - ++ case generalizationsCE m p es of - [] -> "" - (es:_) -> "Generalization:\n" - ++ showCE es ++ "\n\n" - ++ case generalizationsCEC p es of +showCEandGens :: Testable a => a -> Expr -> String +showCEandGens p e = showCE e ++ "\n\n" + ++ concat [ "Generalization:\n" + ++ showCE (canonicalizeUsingHolesWith names e) + ++ "\n\n" + | e <- gens e] + ++ case cgens e of [] -> "" - (es:_) -> "Conditional Generalization:\n" - ++ showCCE es ++ "\n\n" + (e:_) -> "Conditional Generalization:\n" + ++ showCCE (canonicalizeUsingHolesWith names e) ++ "\n\n" + where + names = testableNames p + grounds = testableGrounds p + gens = counterExampleGeneralizations grounds + cgens = conditionalCounterExampleGeneralizations + (testableMaxConditionSize p) + (testableAtoms p) + (testableGrounds p) + (testableMkEquation p) -showCE :: [Expr] -> String -showCE [e] = showPrecExpr 0 e -showCE es = unwords [showPrecExpr 11 e | e <- es] +showCE :: Expr -> String +showCE = s . tail . unfoldApp + where + s [e] = showPrecExpr 0 e + s es = unwords [showPrecExpr 11 e | e <- es] -showCCE :: (Expr,[Expr]) -> String -showCCE (c,es) = showCE es ++ " when " ++ showPrecExpr 0 (prettify c) +showCCE :: Expr -> String +showCCE = s . unand + where + s (e,c) = showCE e ++ " when " ++ showPrecExpr 0 (prettify c) + -- WARNING: expressions are unevaluable after this, just good for printing prettify :: Expr -> Expr -prettify (((Constant "<=" _) :$ e1) :$ e2) | lengthE e1 < lengthE e2 = (((Constant ">=" undefined) :$ e2) :$ e1) -prettify (((Constant "<" _) :$ e1) :$ e2) | lengthE e1 < lengthE e2 = (((Constant ">" undefined) :$ e2) :$ e1) +prettify (((Value "<=" _) :$ e1) :$ e2) | size e1 < size e2 = (((Value ">=" undefined) :$ e2) :$ e1) +prettify (((Value "<" _) :$ e1) :$ e2) | size e1 < size e2 = (((Value ">" undefined) :$ e2) :$ e1) prettify (e1 :$ e2) = prettify e1 :$ prettify e2 prettify e = e diff --git a/src/Test/Extrapolate/New.hs b/src/Test/Extrapolate/New.hs deleted file mode 100644 --- a/src/Test/Extrapolate/New.hs +++ /dev/null @@ -1,55 +0,0 @@ --- | --- This module is otherwise unused in the code. --- --- This is a stub of a new algorithm that is smarter and generalizes from --- several initial counter-examples rather than just one. --- --- When this gets finished, it should be moved into "Test.Extrapolate.Core". -module Test.Extrapolate.New - ( generalizedCounterExamples - , lgg - , lgg1 - ) -where - -import Test.Extrapolate.Core - - --- This is not the actual function used to generate generalizedCounterExamples. --- It is otherwise unused elsewhere in the code. It is a sketch of a new --- version. Please see counterExampleGens and generalizationsCE to see how it --- works _now_. -generalizedCounterExamples :: Testable a => Int -> a -> [Exprs] -generalizedCounterExamples n p = gce $ counterExamples n p - where - passes = [as | (as,True) <- take n (results p)] - gce :: [Exprs] -> [Exprs] - gce [] = [] - gce (e:es) = foldr1 incorporate (e:es) - : gce es - incorporate :: Exprs -> Exprs -> Exprs - g `incorporate` e = let g' = lgg g e - in if not $ any (`areInstancesOf` g') passes - then g' - else g - - --- | Computes the least general generalization of two expressions --- --- > lgg1 (expr [0,0]) (expr [1,1]) --- [_,_] :: [Int] (holes: Int, Int) --- > lgg1 (expr [1,1::Int]) (expr [2,2,2::Int]) --- _:_:_ :: [Int] (holes: Int, Int, [Int]) -lgg1 :: Expr -> Expr -> Expr -lgg1 e1 e2 | typ e1 /= typ e2 = - error $ "lgg1: type mismatch: " ++ show e1 ++ ", " ++ show e2 -lgg1 (e1f :$ e1x) (e2f :$ e2x) | typ e1f == typ e2f - && typ e1x == typ e2x - = lgg1 e1f e2f :$ lgg1 e1x e2x -lgg1 e1@(Var _ _) _ = e1 -lgg1 _ e2@(Var _ _) = e2 -lgg1 e1 e2 | e1 == e2 = e1 - | otherwise = holeOfTy $ typ e1 - -lgg :: Exprs -> Exprs -> Exprs -lgg = zipWith lgg1 diff --git a/src/Test/Extrapolate/Speculation.hs b/src/Test/Extrapolate/Speculation.hs new file mode 100644 --- /dev/null +++ b/src/Test/Extrapolate/Speculation.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Test.Extrapolate.Speculation +-- Copyright : (c) 2017-2019 Rudy Matela +-- License : 3-Clause BSD (see the file LICENSE) +-- Maintainer : Rudy Matela +-- +-- This module is part of Extrapolate, +-- a library for generalization of counter-examples. +-- +-- This defines utilities for speculation about side conditions. +-- +-- You are probably better off importing "Test.Extrapolate". +module Test.Extrapolate.Speculation + ( theoryAndReprConds + + -- re-exports from Speculate + , Thy + , Expr + , classesFromSchemasAndVariables + ) +where + +import Data.Monoid ((<>)) -- for GHC <= 8.2 + +import Test.LeanCheck ((\/)) + +import Test.Speculate.Engine (theoryAndRepresentativesFromAtoms, classesFromSchemasAndVariables) +import Test.Speculate.Reason (Thy) +import Test.Speculate.Utils (boolTy, typesIn) + +import Test.Extrapolate.Utils +import Test.Extrapolate.Expr + +-- Generates expression schemas and a theory +theoryAndReprsFromPropAndAtoms :: Int -> (Expr -> Expr -> Bool) -> [[Expr]] -> (Thy,[[Expr]]) +theoryAndReprsFromPropAndAtoms maxConditionSize (===) ess = + theoryAndRepresentativesFromAtoms + maxConditionSize compareExpr (const True) (===) ess + where + compareExpr :: Expr -> Expr -> Ordering + compareExpr = compareComplexity <> lexicompareBy cmp + e1 `cmp` e2 | arity e1 == 0 && arity e2 /= 0 = LT + e1 `cmp` e2 | arity e1 /= 0 && arity e2 == 0 = GT + e1 `cmp` e2 = compareIndex (concat ess) e1 e2 <> e1 `compare` e2 +-- NOTE: "concat ess" may be an infinite list. This function assumes +-- that the symbols will appear on the list eventually for termination. If I +-- am correct this ivariant is assured by the rest of the code. + +theoryAndReprExprs :: Int -> (Expr -> Expr -> Bool) -> [[Expr]] -> (Thy,[Expr]) +theoryAndReprExprs maxConditionSize (===) = + (\(thy,ess) -> (thy, concat $ take maxConditionSize ess)) + . theoryAndReprsFromPropAndAtoms maxConditionSize (===) + +theoryAndReprConds :: Int -> (Expr -> Expr -> Bool) -> [[Expr]] -> (Thy, [Expr]) +theoryAndReprConds maxConditionSize (===) ess = (thy, filter (\c -> typ c == boolTy) es) + where + (thy,es) = theoryAndReprExprs maxConditionSize (===) ess diff --git a/src/Test/Extrapolate/Testable.hs b/src/Test/Extrapolate/Testable.hs new file mode 100644 --- /dev/null +++ b/src/Test/Extrapolate/Testable.hs @@ -0,0 +1,147 @@ +-- | +-- Module : Test.Extrapolate.Testable +-- Copyright : (c) 2017-2019 Rudy Matela +-- License : 3-Clause BSD (see the file LICENSE) +-- Maintainer : Rudy Matela +-- +-- This module is part of Extrapolate, +-- a library for generalization of counter-examples. +-- +-- This defines the 'Testable' typeclass +-- and utilities involving it. +-- +-- You are probably better off importing "Test.Extrapolate". +{-# LANGUAGE DeriveDataTypeable #-} -- for GHC <= 7.8 +module Test.Extrapolate.Testable + ( Testable (..) + , results + , limitedResults + , counterExample + , counterExamples + + , Option (..) + , WithOption (..) + + , testableMaxTests + , testableMaxConditionSize + , testableExtraInstances + + , testableGrounds + , testableNames + + , testableBackground + , testableMkEquation + , testableAtoms + ) +where + +import Data.List +import Data.Maybe +import Data.Ratio (Ratio) + +import Test.Extrapolate.Utils + +import Test.LeanCheck hiding (Testable, results, counterExample, counterExamples) +import Test.LeanCheck.Utils (bool, int) + +import Test.Extrapolate.Generalizable + + +class Typeable a => Testable a where + resultiers :: a -> [[(Expr,Bool)]] + tinstances :: a -> Instances + options :: a -> Options + options _ = [] + +instance Testable a => Testable (WithOption a) where + resultiers (p `With` o) = resultiers p + tinstances (p `With` o) = tinstances p ++ testableExtraInstances (p `With` o) + options (p `With` o) = o : options p + +instance Testable Bool where + resultiers p = [[(value "prop" p, p)]] + tinstances _ = instances bool . instances int $ [] + +instance (Testable b, Generalizable a, Listable a) => Testable (a->b) where + resultiers p = concatMapT resultiersFor tiers + where resultiersFor x = mapFst (replaceFun (value "prop" p :$ expr x)) `mapT` resultiers (p x) + mapFst f (x,y) = (f x, y) + tinstances p = instances (undefarg p) $ tinstances (p undefined) + where + undefarg :: (a -> b) -> a + undefarg _ = undefined + + +results :: Testable a => a -> [(Expr,Bool)] +results = concat . resultiers + +limitedResults :: Testable a => a -> [(Expr,Bool)] +limitedResults p = take (testableMaxTests p) (results p) + + +counterExample :: Testable a => a -> Maybe Expr +counterExample = listToMaybe . counterExamples + +counterExamples :: Testable a => a -> [Expr] +counterExamples p = [as | (as,False) <- limitedResults p] + + +-- I don't love Option/WithOption. It is clever but it is not __clear__. +-- Maybe remove from future versions of the tool? +data Option = MaxTests Int + | ExtraInstances Instances + | MaxConditionSize Int + deriving Typeable -- for GHC <= 7.8 + +data WithOption a = With + { property :: a + , option :: Option } + deriving Typeable -- for GHC <= 7.8 + +type Options = [Option] + + +testableMaxTests :: Testable a => a -> Int +testableMaxTests p = head $ [m | MaxTests m <- options p] ++ [500] + +testableMaxConditionSize :: Testable a => a -> Int +testableMaxConditionSize p = head $ [m | MaxConditionSize m <- options p] ++ [4] + +testableExtraInstances :: Testable a => a -> Instances +testableExtraInstances p = concat [is | ExtraInstances is <- options p] + + +testableGrounds :: Testable a => a -> Expr -> [Expr] +testableGrounds p = take (testableMaxTests p) . grounds (lookupTiers $ tinstances p) + +testableMkEquation :: Testable a => a -> Expr -> Expr -> Expr +testableMkEquation p = mkEquation (getEqInstancesFromBackground is) + where + is = tinstances p + getEqInstancesFromBackground is = eqs ++ iqs + where + eqs = [e | e@(Value "==" _) <- bg] + iqs = [e | e@(Value "/=" _) <- bg] + bg = concat [evl e | e@(Value "background" _) <- is] + +testableNames :: Testable a => a -> Expr -> [String] +testableNames = lookupNames . tinstances + +testableBackground :: Testable a => a -> [Expr] +testableBackground p = concat [eval err e | e@(Value "background" _) <- tinstances p] + where + err = error "Cannot evaluate background" + +-- Given a property, returns the atoms to be passed to Speculate +testableAtoms :: Testable a => a -> [[Expr]] +testableAtoms = atoms . tinstances + where + atoms :: Instances -> [[Expr]] + atoms is = ([vs] \/) + . foldr (\/) [esU] + $ [ eval (error msg :: [[Expr]]) tiersE + | tiersE@(Value "tiers" _) <- is ] + where + vs = sort . mapMaybe (maybeHoleOfTy is) . nubMergeMap (typesIn . typ) $ esU + esU = concat [evl e | e@(Value "background" _) <- is] + msg = "canditateConditions: wrong type, not [[Expr]]" diff --git a/src/Test/Extrapolate/TypeBinding.hs b/src/Test/Extrapolate/TypeBinding.hs --- a/src/Test/Extrapolate/TypeBinding.hs +++ b/src/Test/Extrapolate/TypeBinding.hs @@ -1,6 +1,6 @@ -- | -- Module : Test.Extrapolate.TypeBinding --- Copyright : (c) 2017 Rudy Matela +-- Copyright : (c) 2017-2019 Rudy Matela -- License : 3-Clause BSD (see the file LICENSE) -- Maintainer : Rudy Matela -- @@ -10,77 +10,48 @@ -- Some type binding operators that are useful when defining Generalizable -- instances. module Test.Extrapolate.TypeBinding - ( argTy1of1 + ( arg1 + , arg2 + , arg3 + , arg4 + , arg5 + , arg6 + , (==:) + , argTy1of1 , argTy1of2, argTy2of2 , argTy1of3, argTy2of3, argTy3of3 , argTy1of4, argTy2of4, argTy3of4, argTy4of4 , argTy1of5, argTy2of5, argTy3of5, argTy4of5, argTy5of5 , argTy1of6, argTy2of6, argTy3of6, argTy4of6, argTy5of6, argTy6of6 + , module Test.LeanCheck.Utils.TypeBinding ) where --- TODO: reexport LeanCheck's typebinding operators - -argTypes0 :: a -> a -argTypes0 f = f - -argTypes1 :: (a -> b) -> a -> (a -> b) -argTypes1 f _ = f - -argTypes2 :: (a -> b -> c) - -> a -> b - -> (a -> b -> c) -argTypes2 f _ _ = f - -argTypes3 :: (a -> b -> c -> d) - -> a -> b -> c - -> (a -> b -> c -> d) -argTypes3 f _ _ _ = f - -argTypes4 :: (a -> b -> c -> d -> e) - -> a -> b -> c -> d - -> (a -> b -> c -> d -> e) -argTypes4 f _ _ _ _ = f +import Test.LeanCheck.Utils.TypeBinding -argTypes5 :: (a -> b -> c -> d -> e -> f) - -> a -> b -> c -> d -> e - -> (a -> b -> c -> d -> e -> f) -argTypes5 f _ _ _ _ _ = f +-- TODO: reexport LeanCheck's typebinding operators +-- TODO: or maybe re-export Express's typebinding operators? -argTypes6 :: (a -> b -> c -> d -> e -> f -> g) - -> a -> b -> c -> d -> e -> f - -> (a -> b -> c -> d -> e -> f -> g) -argTypes6 f _ _ _ _ _ _ = f +arg1 :: (a -> b) -> a +arg1 _ = undefined -argTypes7 :: (a -> b -> c -> d -> e -> f -> g -> h) - -> a -> b -> c -> d -> e -> f -> g - -> (a -> b -> c -> d -> e -> f -> g -> h) -argTypes7 f _ _ _ _ _ _ _ = f +arg2 :: (a -> b -> c) -> b +arg2 _ = undefined -argTypes8 :: (a -> b -> c -> d -> e -> f -> g -> h -> i) - -> a -> b -> c -> d -> e -> f -> g -> h - -> (a -> b -> c -> d -> e -> f -> g -> h -> i) -argTypes8 f _ _ _ _ _ _ _ _ = f +arg3 :: (a -> b -> c -> d) -> c +arg3 _ = undefined -argTypes9 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) - -> a -> b -> c -> d -> e -> f -> g -> h -> i - -> (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -argTypes9 f _ _ _ _ _ _ _ _ _ = f +arg4 :: (a -> b -> c -> d -> e) -> d +arg4 _ = undefined -argTypes10 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) - -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j - -> (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -argTypes10 f _ _ _ _ _ _ _ _ _ _ = f +arg5 :: (a -> b -> c -> d -> e -> f) -> e +arg5 _ = undefined -argTypes11 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l) - -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k - -> (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l) -argTypes11 f _ _ _ _ _ _ _ _ _ _ _ = f +arg6 :: (a -> b -> c -> d -> e -> f -> g) -> f +arg6 _ = undefined -argTypes12 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m) - -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l - -> (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m) -argTypes12 f _ _ _ _ _ _ _ _ _ _ _ _ = f +(==:) :: (a -> (b -> c -> d)) -> a -> b +x ==: y = undefined argTy1of1 :: con a -> a diff --git a/src/Test/Extrapolate/Utils.hs b/src/Test/Extrapolate/Utils.hs --- a/src/Test/Extrapolate/Utils.hs +++ b/src/Test/Extrapolate/Utils.hs @@ -1,6 +1,6 @@ -- | -- Module : Test.Extrapolate.Utils --- Copyright : (c) 2017 Rudy Matela +-- Copyright : (c) 2017-2019 Rudy Matela -- License : 3-Clause BSD (see the file LICENSE) -- Maintainer : Rudy Matela -- @@ -31,18 +31,12 @@ , maximumOn , takeBound , nubMergeMap - , typesIn - , argumentTy - , resultTy - , discard , compareIndex - , (.:) ) where import Data.Function (on) -import Data.List (minimumBy, maximumBy, nub, elemIndex) -import Data.Typeable +import Data.List (minimumBy, elemIndex) nubMergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] nubMergeBy cmp (x:xs) (y:ys) = case x `cmp` y of @@ -183,43 +177,6 @@ nubMergeMap :: Ord b => (a -> [b]) -> [a] -> [b] nubMergeMap f = nubMerges . map f - -funTyCon :: TyCon -funTyCon = typeRepTyCon $ typeOf (undefined :: () -> ()) - -isFunTy :: TypeRep -> Bool -isFunTy t = - case splitTyConApp t of - (con,[_,_]) | con == funTyCon -> True - _ -> False - --- | For a given type, return all *-kinded types. --- (all non-function types) --- --- > typesIn (typeOf (undefined :: (Int -> Int) -> Int -> Bool)) --- > == [Bool,Int] -typesIn :: TypeRep -> [TypeRep] -typesIn t - | isFunTy t = typesIn (argumentTy t) - +++ typesIn (resultTy t) - | otherwise = [t] - -unFunTy :: TypeRep -> (TypeRep,TypeRep) -unFunTy t - | isFunTy t = let (f,[a,b]) = splitTyConApp t in (a,b) - | otherwise = error $ "error (unFunTy): `" ++ show t ++ "` is not a function type" - -argumentTy :: TypeRep -> TypeRep -argumentTy = fst . unFunTy - -resultTy :: TypeRep -> TypeRep -resultTy = snd . unFunTy - -discard :: (a -> Bool) -> [a] -> [a] -discard p = filter (not . p) - -(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) -(.:) = (.) . (.) compareIndex :: Eq a => [a] -> a -> a -> Ordering compareIndex xs x y = diff --git a/stack-lts-11.yaml b/stack-lts-11.yaml new file mode 100644 --- /dev/null +++ b/stack-lts-11.yaml @@ -0,0 +1,13 @@ +resolver: lts-11.22 + +packages: +- . + +extra-deps: +- leancheck-0.9.1 +- speculate-0.4.0 +- express-0.1.0 + +flags: {} + +extra-package-dbs: [] diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,16 +1,12 @@ -# stack.yaml docs: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -resolver: lts-12.7 +resolver: lts-13.30 packages: - . extra-deps: -- leancheck-0.7.3 -- speculate-0.3.5 +- leancheck-0.9.1 +- speculate-0.4.0 +- express-0.1.0 flags: {} diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,196 @@ +-- Copyright (c) 2017-2019 Rudy Matela. +-- Distributed under the 3-Clause BSD licence (see the file LICENSE). +module Test + ( module Test.Extrapolate + , module Test.Extrapolate.Core + , module Test.Extrapolate.Utils + , module Test.LeanCheck.Utils.Operators + + , reportTests + , getMaxTestsFromArgs + , mainTest + , printLines + + , operatorE + + -- * Properties and Tests + , generalizableOK + , exprOK + , idExprEval, showOK + , instancesOK + , namesOK, sameNamesIn, namesIn + , tiersOK, sameTiersIn, tiersIn + , bgEqOK, bgEqOrdOK + + , subset, bgSubset + , backgroundOf + + , instancesSubset + + , module Data.Express.Fixtures + ) +where + +import System.Exit (exitFailure) +import Data.List (elemIndices) +import System.Environment (getArgs) +import Data.Typeable (typeOf) +import Data.List (isPrefixOf, sort) +import Test.Speculate.Reason + +import Test.Extrapolate +import Test.Extrapolate.Core +import Test.Extrapolate.Utils +import Data.Express.Fixtures +import Test.LeanCheck.Utils.Operators + +reportTests :: [Bool] -> IO () +reportTests tests = + case elemIndices False tests of + [] -> putStrLn "Tests passed!" + is -> do putStrLn ("Failed tests:" ++ show is) + exitFailure + +getMaxTestsFromArgs :: Int -> IO Int +getMaxTestsFromArgs n = do + as <- getArgs + return $ case as of + (s:_) -> read s + _ -> n + +mainTest :: (Int -> [Bool]) -> Int -> IO () +mainTest tests n' = do + n <- getMaxTestsFromArgs n' + reportTests (tests n) + +printLines :: Show a => [a] -> IO () +printLines = putStrLn . unlines . map show + +operatorE :: Expr -> Expr +operatorE ((opE :$ _) :$ _) = opE +operatorE _ = error "operatorE: not a binary operator" + + + +-- Properties and tests -- + +generalizableOK :: (Eq a, Show a, Generalizable a) => Int -> a -> Bool +generalizableOK n x = holds n (exprOK -:> x) + && instancesOK (und -: x) + where + und = error "generalizableOK: this should not get evaluated" + +exprOK :: (Eq a, Show a, Generalizable a) => a -> Bool +exprOK = idExprEval &&& showOK + +idExprEval :: (Eq a, Generalizable a) => a -> Bool +idExprEval x = eval (error "idExprEval: could not eval") (expr x) == x + +showOK :: (Show a, Generalizable a) => a -> Bool +showOK x = show x == dropType (show (expr x)) + where + dropType :: String -> String + dropType cs | " :: " `isPrefixOf` cs = "" + dropType "" = "" + dropType (c:cs) = c : dropType cs + +instancesOK :: (Eq a, Generalizable a) => a -> Bool +instancesOK = namesOK &&& tiersOK + +namesOK :: Generalizable a => a -> Bool +namesOK x = name x == head (x `namesIn` x) + && x `sameNamesIn` [x] + && x `sameNamesIn` [[x]] + && x `sameNamesIn` mayb x + && x `sameNamesIn` (x,x) + && x `sameNamesIn` (x,()) + && x `sameNamesIn` ((),x) + && x `sameNamesIn` (x,(),()) + && x `sameNamesIn` ((),x,()) + && x `sameNamesIn` ((),(),x) + +sameNamesIn :: (Generalizable a, Generalizable b) => a -> b -> Bool +x `sameNamesIn` c = x `namesIn` x + =| 12 |= x `namesIn` c + +namesIn :: (Generalizable a, Generalizable b) => a -> b -> [String] +x `namesIn` c = lookupNames (instances c []) (val x) + +tiersOK :: (Eq a, Generalizable a) => a -> Bool +tiersOK x = x `sameTiersIn` x + && x `sameTiersIn` [x] + && x `sameTiersIn` [[x]] + && x `sameTiersIn` (mayb x) + && x `sameTiersIn` (x,x) + && x `sameTiersIn` (x,()) + && x `sameTiersIn` ((),x) + && x `sameTiersIn` (x,(),()) + && x `sameTiersIn` ((),x,()) + && x `sameTiersIn` ((),(),x) + +bgEqOK :: (Eq a, Generalizable a) => a -> a -> Bool +bgEqOK = (*==*) ==== (==) + &&&& (*/=*) ==== (/=) + +bgEqOrdOK :: (Eq a, Ord a, Generalizable a) => a -> a -> Bool +bgEqOrdOK = bgEqOK &&&& (*<=*) ==== (<=) + &&&& (*<*) ==== (<) + +sameTiersIn :: (Eq a, Generalizable a, Generalizable b) => a -> b -> Bool +x `sameTiersIn` cx = isListableT (instances cx []) (typeOf x) + && (tiers -: [[x]]) =| 6 |= tiersIn cx + +tiersIn :: (Generalizable a, Generalizable b) => b -> [[a]] +tiersIn c = ret + where + ret = mapT (eval . error $ "tiersIn: the imposible happened") + $ lookupTiers (instances c []) (val (head (head ret))) + +subset :: Ord a => [a] -> [a] -> Bool +xs `subset` ys = sort xs `isSubsequenceOf` sort ys + +bgSubset :: (Generalizable a, Generalizable b) => a -> b -> Bool +x `bgSubset` y = backgroundOf x `subset` backgroundOf y + +instancesSubset :: (Eq a, Eq b, Generalizable a, Generalizable b) => a -> b -> Bool +x `instancesSubset` y = x `bgSubset` y + && x `sameTiersIn` y + && x `sameNamesIn` y + +backgroundOf :: Generalizable a => a -> [Expr] +backgroundOf x = concat [evl e | e@(Value "background" _) <- instances x []] + +-- available on Data.List since GHC >= 8.0 +isSubsequenceOf :: Eq a => [a] -> [a] -> Bool +isSubsequenceOf [] _ = True +isSubsequenceOf (_:_) [] = False +isSubsequenceOf (x:xs) (y:ys) + | x == y = xs `isSubsequenceOf` ys + | otherwise = (x:xs) `isSubsequenceOf` ys + +-- Quick and Dirty! +instance Show Thy where + show Thy { rules = rs + , equations = eqs + , canReduceTo = (->-) + , closureLimit = cl + , keepE = keep + } + = "Thy { rules = " + ++ drop 14 (indent 14 . listLines $ map showEquation rs) + ++ " , equations = " + ++ drop 18 (indent 18 . listLines $ map showEquation eqs) + ++ " , canReduceTo = " ++ showCanReduceTo (->-) ++ "\n" + ++ " , closureLimit = " ++ show cl ++ "\n" + ++ " , keepE = " ++ showKeepE keep ++ "\n" + ++ " }" + where + showEquation (e1,e2) = showExpr e1 ++ " == " ++ showExpr e2 + listLines [] = "[]" + listLines ss = '[':(tail . unlines $ map (", " ++) ss) ++ "]" + showCanReduceTo (->-) = "(??)" + showKeepE keep = "\\e -> ??" + indent :: Int -> String -> String + indent n = unlines . map (replicate n ' ' ++) . lines + + diff --git a/test/derive.hs b/test/derive.hs new file mode 100644 --- /dev/null +++ b/test/derive.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} -- for GHC <= 7.8 +-- Copyright (c) 2017-2019 Rudy Matela. +-- Distributed under the 3-Clause BSD licence (see the file LICENSE). +import Test +import Data.List (sort) + +#if __GLASGOW_HASKELL__ < 710 +import Data.Typeable (Typeable) +deriving instance Typeable List +deriving instance Typeable Perhaps +deriving instance Typeable Ship +deriving instance Typeable Arrangement +deriving instance Typeable NonEmptyList +deriving instance Typeable Mutual +deriving instance Typeable Shared +deriving instance Typeable Tree +deriving instance Typeable Leafy +deriving instance Typeable Dict +deriving instance Typeable Data +deriving instance Typeable EqData +deriving instance Typeable OrdData +#endif + +-- List is isomorphic to [] +data List a = Cons a (List a) + | Nil + deriving (Show, Eq, Ord) + +-- Perhaps is isomorphic to Maybe +data Perhaps a = Naught + | Simply a + deriving (Show, Eq, Ord) + +-- Ship is isomorphic to Either +data Ship a b = Port a + | Starboard b + deriving (Show, Eq, Ord) + +-- Arrangement is isomorphic to Ordering +data Arrangement = Lesser + | Equal + | Greater + deriving (Show, Eq, Ord) + +data NonEmptyList a = Buil a (NonEmptyList a) + | Unit a + deriving (Show, Eq, Ord) + +data Mutual a = Mutual a (Shared a) | M a deriving (Show, Eq, Ord) +data Shared a = Shared (Mutual a) a | S a deriving (Show, Eq, Ord) + +data Tree a = Node (Tree a) a (Tree a) | Empty + deriving (Show, Eq, Ord) + +data Leafy a = Branch (Leafy a) (Leafy a) | Leaf a + deriving (Show, Eq, Ord) + +data Dict a b = Meaning a b (Dict a b) + | End + deriving (Show, Eq, Ord) + +data Data = Data deriving (Show) +data EqData = EqData deriving (Show, Eq) +data OrdData = OrdData deriving (Show, Eq, Ord) + + +-- Dummy undefined values -- + +ls :: a -> List a +ls = undefined + +perhaps :: a -> Perhaps a +perhaps = undefined + +ship :: a -> b -> Ship a b +ship = undefined + +arrangement :: Arrangement +arrangement = undefined + +nonEmptyList :: a -> NonEmptyList a +nonEmptyList = undefined + +mutual :: a -> Mutual a +mutual = undefined + +shared :: a -> Shared a +shared = undefined + +tree :: a -> Tree a +tree = undefined + +leafy :: a -> Leafy a +leafy = undefined + +dict :: a -> b -> Dict a b +dict = undefined + + +deriveListable ''List +deriveListable ''Perhaps +deriveListable ''Ship + + +deriveGeneralizable ''List +{- -- derivation: +instance (Generalizable a) => Generalizable (List a) where + name _ = "xs" + expr xs@Nil = value "Nil" (Nil -: xs) + expr xs@(Cons y ys) = value "Cons" (Cons ->>: xs) :$ expr y :$ expr ys + instances xs = this xs + $ (let Cons y ys = Cons undefined undefined -: xs + in instances y . instances ys) + +-- It may seem like its possible to derive just: +--instances xs = this xs +-- $ instances (argTy1of1 xs) +-- However that will restrain us from recursing into non argument types that +-- need to be present (cf. the Mutual & Shared types). +-} + +deriveGeneralizable ''Perhaps +{- -- derivation: +instance (Generalizable a) => Generalizable (Perhaps a) where + expr px@Naught = value "Naught" (Naught -: px) + expr px@(Simply x) = value "Simply" (Simply ->: px) :$ expr x + instances px = ... +-} + +deriveGeneralizable ''Ship +{- -- derivation: +instance (Generalizable a, Generalizable b) => Generalizable (Ship a b) where + expr s@(Port x) = value "Port" (Port ->: s) :$ expr x + expr s@(Starboard y) = value "Starboard" (Starboard ->: s) :$ expr y + instances s = ... +-} + +deriveGeneralizable ''Arrangement + +deriveGeneralizable ''NonEmptyList + +deriveGeneralizableCascading ''Mutual + +deriveGeneralizable ''Tree +deriveGeneralizable ''Leafy + +deriveGeneralizable ''Dict + +deriveGeneralizable ''Data +deriveGeneralizable ''EqData +deriveGeneralizable ''OrdData + +{- -- +-- these should produce warnings because instances already exist: +deriveGeneralizable ''Int +deriveGeneralizable ''Bool +deriveGeneralizable ''Either +-- -} + +-- these should /not/ produce warnings even though instances already exist: +deriveGeneralizableIfNeeded ''Int +deriveGeneralizableIfNeeded ''Bool +deriveGeneralizableIfNeeded ''Either + + +main :: IO () +main = mainTest tests 2160 + +tests :: Int -> [Bool] +tests n = + [ True + + , generalizableOK n $ ls bool + , generalizableOK n $ perhaps int + , generalizableOK n $ ship int char + , generalizableOK n $ arrangement + , generalizableOK n $ nonEmptyList int + , generalizableOK n $ mutual bool + , generalizableOK n $ shared int + , generalizableOK n $ tree bool + , generalizableOK n $ leafy int + , generalizableOK n $ dict bool int +--, generalizableOK n $ Data -- not Eq, can't run test + , generalizableOK n $ EqData + , generalizableOK n $ OrdData + + , int `instancesSubset` ls int + , not $ bool `instancesSubset` ls int + , () `instancesSubset` perhaps () + , not $ () `instancesSubset` perhaps int + , () `bgSubset` perhaps int -- () has no background + , char `instancesSubset` ship char int + , int `instancesSubset` ship char int + , not $ bool `instancesSubset` ship char int + , int `instancesSubset` mutual int + , int `instancesSubset` shared int + , shared int `instancesSubset` mutual int + , mutual () `instancesSubset` shared () + , bool `instancesSubset` tree bool + , int `instancesSubset` leafy int + , int `instancesSubset` dict int bool + , bool `instancesSubset` dict int bool + , bool `instancesSubset` dict int (perhaps (ship char bool)) + , shared (ship (ls char) bool) + `instancesSubset` dict int (perhaps (mutual (ship (ls char) bool))) + + , backgroundOf Data =$ sort $= [] + , backgroundOf EqData =$ sort $= [ value "==" $ (==) -:> EqData + , value "/=" $ (/=) -:> EqData + ] + , backgroundOf OrdData =$ sort $= [ value "==" $ (==) -:> OrdData + , value "/=" $ (/=) -:> OrdData + , value "<=" $ (<=) -:> OrdData + , value "<" $ (<) -:> OrdData + ] + ] diff --git a/test/extrapolate.hs b/test/extrapolate.hs new file mode 100644 --- /dev/null +++ b/test/extrapolate.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} -- for GHC <= 7.8 +-- Copyright (c) 2017-2019 Rudy Matela. +-- Distributed under the 3-Clause BSD licence (see the file LICENSE). +import Test + +import Data.List (sort, nub) + +#if __GLASGOW_HASKELL__ < 710 +import Data.Typeable (Typeable) +deriving instance Typeable NOrd +#endif + +data NOrd = NOrd + deriving Show + +deriveListable ''NOrd +deriveGeneralizable ''NOrd + +nord :: NOrd +nord = undefined + +main :: IO () +main = mainTest tests 10000 + +tests :: Int -> [Bool] +tests n = + [ True + + -- Generalizable instance properties + , generalizableOK n () + , generalizableOK n int + , generalizableOK n integer + , generalizableOK n bool + , generalizableOK n char + , generalizableOK n ordering + , generalizableOK 9 [()] + , generalizableOK n [int] + , generalizableOK n [integer] + , generalizableOK n [bool] + , generalizableOK n [char] + , generalizableOK n [ordering] + , generalizableOK n (mayb ()) + , generalizableOK n (mayb int) + , generalizableOK n (mayb integer) + , generalizableOK n (mayb bool) + , generalizableOK n (mayb char) + , generalizableOK n (eith () int) + , generalizableOK n (eith integer bool) + , generalizableOK n (int,bool) + , generalizableOK n ((),integer) + , generalizableOK n ((),bool,integer) + , generalizableOK n (int,(),bool,integer) + , generalizableOK n (int,(),bool,integer,char) + , generalizableOK n (string,int,(),bool,integer,char) +-- TODO: implement further tuple instances (7,8,9,10,11,12) and uncomment below + , generalizableOK n ((),(),(),(),(),(),()) +#if __GLASGOW_HASKELL__ < 710 +-- no 8-tuples for you +#else + , generalizableOK n ((),(),(),(),(),(),(),()) +--, generalizableOK n ((),(),(),(),(),(),(),(),()) +--, generalizableOK n ((),(),(),(),(),(),(),(),(),()) +--, generalizableOK n ((),(),(),(),(),(),(),(),(),(),()) +--, generalizableOK n ((),(),(),(),(),(),(),(),(),(),(),()) +#endif + + -- Silly test, as it basically replicates the actual implementation: + , backgroundOf int =$ sort $= [ value "==" $ (==) -:> int + , value "/=" $ (/=) -:> int + , value "<=" $ (<=) -:> int + , value "<" $ (<) -:> int + ] + + , background (mayb int) + == [ value "==" ((==) -:> mayb int) + , value "/=" ((/=) -:> mayb int) + , value "<=" ((<=) -:> mayb int) + , value "<" ((<) -:> mayb int) + , value "Just" (Just ->: mayb int) ] + + , background (eith int char) + == [ value "==" ((==) -:> eith int char) + , value "/=" ((/=) -:> eith int char) + , value "<=" ((<=) -:> eith int char) + , value "<" ((<) -:> eith int char) + , value "Left" (Left ->: eith int char) + , value "Right" (Right ->: eith int char) ] + + , background [int] + == [ value "==" ((==) -:> [int]) + , value "/=" ((/=) -:> [int]) + , value "<=" ((<=) -:> [int]) + , value "<" ((<) -:> [int]) + , value "length" (length -:> [int]) + , value "elem" (elem ->:> [int]) ] + + , background (mayb nord) + == [ value "Just" (Just ->: mayb nord) ] + + , background (eith nord nord) + == [ value "Left" (Left ->: eith nord nord) + , value "Right" (Right ->: eith nord nord) ] + + , background [nord] + == [ value "length" (length -:> [nord]) ] + + -- background tests + , listBackgroundOK () + , listBackgroundOK int + , listBackgroundOK bool + , listBackgroundOK [(mayb (),integer,mayb char)] + + , maybeBackgroundOK () + , maybeBackgroundOK integer + , maybeBackgroundOK char + , maybeBackgroundOK [(int,bool,[mayb (char,())])] + + , int `instancesSubset` [mayb [int]] + , bool `instancesSubset` ((),bool,char) + , [mayb ((),char)] `instancesSubset` [(int,(char,[mayb ((),char)]),bool)] + , not $ bool `instancesSubset` [mayb [int]] + , not $ bool `bgSubset` [mayb [int]] + , not $ bool `sameNamesIn` [mayb [int]] + , not $ bool `sameTiersIn` [mayb [int]] + , not $ mayb int `instancesSubset` [mayb [int]] + , not $ mayb int `bgSubset` [mayb [int]] + , not $ mayb int `sameNamesIn` [mayb [int]] + , not $ mayb int `sameTiersIn` [mayb [int]] + + , candidateHoleGeneralizations isListable' (expr [0,0::Int]) + == [ is_ + , i_ -:- is_ + , i_ -:- i_ -:- is_ + , i_ -:- i_ -:- nil + , i_ -:- zero -:- is_ + , i_ -:- zero -:- nil + , zero -:- is_ + , zero -:- i_ -:- is_ + , zero -:- i_ -:- nil + , zero -:- zero -:- is_ + ] + + , candidateGeneralizations (\e -> typ e == typ one) (one -+- two) + == [ xx + , xx -+- yy + , xx -+- xx + , xx -+- two + , one -+- xx + ] + + , [ canonicalizeUsingHolesWith namesFor' g + | g <- candidateGeneralizations isListable' (expr [0,0::Int]) ] + == [ is_ + , i_ -:- is_ + , i_ -:- i_ -:- is_ + , xx -:- xx -:- is_ + , i_ -:- i_ -:- nil + , xx -:- xx -:- nil + , i_ -:- zero -:- is_ + , i_ -:- zero -:- nil + , zero -:- is_ + , zero -:- i_ -:- is_ + , zero -:- i_ -:- nil + , zero -:- zero -:- is_ + ] + +--, holds n $ bgEqOrdOK -:> () -- no Eq or Ord instance on background + , holds n $ bgEqOrdOK -:> int + , holds n $ bgEqOK -:> bool + , holds n $ bgEqOrdOK -:> char + , holds n $ bgEqOrdOK -:> integer + , holds n $ bgEqOrdOK -:> ordering + + , holds n $ bgEqOrdOK -:> (int,int) + , holds n $ bgEqOK -:> (int,bool) + , holds n $ bgEqOK -:> (bool,int) + , holds n $ bgEqOK -:> (bool,bool) + , holds n $ bgEqOrdOK -:> (char,ordering) + + , holds n $ bgEqOrdOK -:> (int,int,int) + , holds n $ bgEqOK -:> (int,int,bool) + , holds n $ bgEqOK -:> (int,bool,int) + , holds n $ bgEqOK -:> (int,bool,bool) + , holds n $ bgEqOK -:> (bool,int,int) + , holds n $ bgEqOK -:> (bool,int,bool) + , holds n $ bgEqOK -:> (bool,bool,int) + , holds n $ bgEqOK -:> (bool,bool,bool) + , holds n $ bgEqOrdOK -:> (integer,char,ordering) + + , holds n $ bgEqOrdOK -:> (int,int,int,int) + , holds n $ bgEqOrdOK -:> (integer,char,ordering,int) + , holds n $ bgEqOK -:> (bool,bool,bool,bool) + + , holds n $ bgEqOrdOK -:> [int] + , holds n $ bgEqOK -:> [bool] + , holds n $ bgEqOrdOK -:> [char] + , holds n $ bgEqOrdOK -:> [integer] + + , holds n $ bgEqOrdOK -:> mayb int + , holds n $ bgEqOK -:> mayb bool + , holds n $ bgEqOrdOK -:> mayb char + + , holds n $ bgEqOrdOK -:> eith int int + , holds n $ bgEqOK -:> eith int bool + , holds n $ bgEqOK -:> eith bool int + , holds n $ bgEqOK -:> eith bool bool + , holds n $ bgEqOrdOK -:> eith char ordering + + , tinstancesUnrepeated $ bool + , tinstancesUnrepeated $ bool >- bool + , tinstancesUnrepeated $ int >- bool + , tinstancesUnrepeated $ char >- bool + , tinstancesUnrepeated $ bool >- bool >- bool + , tinstancesUnrepeated $ int >- int >- bool + , tinstancesUnrepeated $ char >- char >- bool + , tinstancesUnrepeated $ [bool] >- bool + , tinstancesUnrepeated $ [int] >- bool + , tinstancesUnrepeated $ [char] >- bool + , tinstancesUnrepeated $ mayb bool >- bool + , tinstancesUnrepeated $ mayb int >- bool + , tinstancesUnrepeated $ mayb char >- bool + , tinstancesUnrepeated $ eith bool bool >- bool + , tinstancesUnrepeated $ eith int int >- bool + , tinstancesUnrepeated $ eith char char >- bool + , tinstancesUnrepeated $ eith char () >- bool + , tinstancesUnrepeated $ ([bool],[bool]) >- bool + , tinstancesUnrepeated $ ([int], [int]) >- bool + , tinstancesUnrepeated $ ([char],[char]) >- bool + , tinstancesUnrepeated $ eith [bool] [bool] >- ([bool],[bool]) >- bool + ] + +theInstances :: [Expr] +theInstances = instances (undefined :: [Int]) [] + +isListable' :: Expr -> Bool +isListable' = isListable theInstances + +namesFor' :: Expr -> [String] +namesFor' = lookupNames theInstances + +tinstancesUnrepeated :: Testable a => a -> Bool +tinstancesUnrepeated p = nub is == is + where + is = map extractiers $ filter (not . isBackground) $ tinstances p + -- All tiers look the same without evaluating its elements: + -- > > tinstances bool + -- > [tiers :: [[Expr]],name :: Bool -> [Char],background :: [Expr],tiers :: [[Expr]],name :: Int -> [Char],background :: [Expr]] + -- So, this takes a representative to use in the comparison: + extractiers e@(Value "tiers" _) = head $ concat (eval undefined e :: [[Expr]]) + extractiers e = e + -- every background looks the same without evaluating its elements + isBackground (Value "background" _) = True + isBackground _ = False + +listBackgroundOK :: Generalizable a => a -> Bool +listBackgroundOK x = backgroundListOf x `subset` backgroundOf [x] + where + backgroundListOf x = [ value "length" $ length -:> [x] ] + +++ backgroundOf x + +maybeBackgroundOK :: Generalizable a => a -> Bool +maybeBackgroundOK x = backgroundMaybeOf x `subset` backgroundOf (mayb x) + where + backgroundMaybeOf x = [value "Just" $ Just -:> x] +++ backgroundOf x diff --git a/test/model/bench/diff.out b/test/model/bench/diff.out new file mode 100644 --- /dev/null +++ b/test/model/bench/diff.out @@ -0,0 +1,189 @@ +checks :: () + +*** Failed! Falsifiable (after 1 tests): +() () + +Generalization: +_ _ + + +checks :: Bool + +*** Failed! Falsifiable (after 1 tests): +False False + +Generalization: +p p + + +checks :: Int + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +x x + + +checks :: Integer + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +x x + + +checks :: Char + +*** Failed! Falsifiable (after 1 tests): +'a' 'a' + +Generalization: +c c + + +checks :: Ordering + +*** Failed! Falsifiable (after 1 tests): +LT LT + +Generalization: +o o + + +checks :: [()] + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +us us + + +checks :: [Bool] + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +ps ps + + +checks :: [Int] + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +xs xs + + +checks :: [Integer] + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +xs xs + + +checks :: [Char] + +*** Failed! Falsifiable (after 1 tests): +"" "" + +Generalization: +cs cs + + +checks :: [Ordering] + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +os os + + +checks :: ((),Int) + +*** Failed! Falsifiable (after 1 tests): +((),0) ((),0) + +Generalization: +ux ux + +Generalization: +(_,x) (_,x) + + +checks :: (Bool,Char) + +*** Failed! Falsifiable (after 1 tests): +(False,'a') (False,'a') + +Generalization: +pc pc + + +checks :: (Int,(),Bool) + +*** Failed! Falsifiable (after 1 tests): +(0,(),False) (0,(),False) + +Generalization: +xup xup + +Generalization: +(x,_,p) (x,_,p) + + +checks :: (Ordering,Char,Integer) + +*** Failed! Falsifiable (after 1 tests): +(LT,'a',0) (LT,'a',0) + +Generalization: +ocx ocx + + +checks :: Maybe () + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing + +Generalization: +mu mu + + +checks :: Maybe Int + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing + +Generalization: +mx mx + + +checks :: Either () Bool + +*** Failed! Falsifiable (after 1 tests): +(Left ()) (Left ()) + +Generalization: +eup eup + +Generalization: +(Left _) (Left _) + + +checks :: Either Int Char + +*** Failed! Falsifiable (after 1 tests): +(Left 0) (Left 0) + +Generalization: +exc exc + + diff --git a/test/model/bench/eq.out b/test/model/bench/eq.out new file mode 100644 --- /dev/null +++ b/test/model/bench/eq.out @@ -0,0 +1,230 @@ +checks :: () + ++++ OK, passed 1 tests (exhausted). + + +checks :: Bool + +*** Failed! Falsifiable (after 2 tests): +False True + +Conditional Generalization: +p q when p /= q + + +checks :: Int + +*** Failed! Falsifiable (after 2 tests): +0 1 + +Conditional Generalization: +x y when x /= y + + +checks :: Integer + +*** Failed! Falsifiable (after 2 tests): +0 1 + +Conditional Generalization: +x y when x /= y + + +checks :: Char + +*** Failed! Falsifiable (after 2 tests): +'a' ' ' + +Conditional Generalization: +c d when c /= d + + +checks :: Ordering + +*** Failed! Falsifiable (after 2 tests): +LT EQ + +Conditional Generalization: +o p when o /= p + + +checks :: [()] + +*** Failed! Falsifiable (after 2 tests): +[] [()] + +Generalization: +us (_:us) + +Generalization: +[] (_:_) + +Conditional Generalization: +[] us when 0 /= length us + + +checks :: [Bool] + +*** Failed! Falsifiable (after 2 tests): +[] [False] + +Generalization: +ps (_:ps) + +Generalization: +[] (_:_) + +Conditional Generalization: +ps qs when ps /= qs + + +checks :: [Int] + +*** Failed! Falsifiable (after 2 tests): +[] [0] + +Generalization: +xs (_:xs) + +Generalization: +[] (_:_) + +Conditional Generalization: +xs ys when xs /= ys + + +checks :: [Integer] + +*** Failed! Falsifiable (after 2 tests): +[] [0] + +Generalization: +xs (_:xs) + +Generalization: +[] (_:_) + +Conditional Generalization: +xs ys when xs /= ys + + +checks :: [Char] + +*** Failed! Falsifiable (after 2 tests): +"" "a" + +Generalization: +cs (_:cs) + +Generalization: +"" (_:_) + +Conditional Generalization: +cs ds when cs /= ds + + +checks :: [Ordering] + +*** Failed! Falsifiable (after 2 tests): +[] [LT] + +Generalization: +os (_:os) + +Generalization: +[] (_:_) + +Conditional Generalization: +os ps when os /= ps + + +checks :: ((),Int) + +*** Failed! Falsifiable (after 2 tests): +((),0) ((),1) + +Generalization: +(_,0) (_,1) + +Conditional Generalization: +(_,x) (_,y) when x /= y + + +checks :: (Bool,Char) + +*** Failed! Falsifiable (after 2 tests): +(False,'a') (True,'a') + +Generalization: +(False,_) (True,_) + +Conditional Generalization: +pc pc' when pc /= pc' + + +checks :: (Int,(),Bool) + +*** Failed! Falsifiable (after 2 tests): +(0,(),False) (0,(),True) + +Generalization: +(_,_,False) (_,_,True) + +Conditional Generalization: +(x,_,_) (y,_,_) when x /= y + + +checks :: (Ordering,Char,Integer) + +*** Failed! Falsifiable (after 2 tests): +(LT,'a',0) (EQ,'a',0) + +Generalization: +(LT,_,_) (EQ,_,_) + +Conditional Generalization: +ocx ocx' when ocx /= ocx' + + +checks :: Maybe () + +*** Failed! Falsifiable (after 2 tests): +Nothing (Just ()) + +Generalization: +Nothing (Just _) + + +checks :: Maybe Int + +*** Failed! Falsifiable (after 2 tests): +Nothing (Just 0) + +Generalization: +Nothing (Just _) + +Conditional Generalization: +mx mx' when mx /= mx' + + +checks :: Either () Bool + +*** Failed! Falsifiable (after 2 tests): +(Left ()) (Right False) + +Generalization: +(Left _) (Right _) + + +checks :: Either Int Char + +*** Failed! Falsifiable (after 2 tests): +(Left 0) (Right 'a') + +Generalization: +(Left _) (Right _) + +Conditional Generalization: +exc exc' when exc /= exc' + + diff --git a/test/model/bench/false.out b/test/model/bench/false.out new file mode 100644 --- /dev/null +++ b/test/model/bench/false.out @@ -0,0 +1,189 @@ +checks :: () + +*** Failed! Falsifiable (after 1 tests): +() + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +() () + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +() () () + +Generalization: +_ _ _ + + +checks :: Bool + +*** Failed! Falsifiable (after 1 tests): +False + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +False False + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +False False False + +Generalization: +_ _ _ + + +checks :: Int + +*** Failed! Falsifiable (after 1 tests): +0 + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +0 0 0 + +Generalization: +_ _ _ + + +checks :: Integer + +*** Failed! Falsifiable (after 1 tests): +0 + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +0 0 0 + +Generalization: +_ _ _ + + +checks :: Char + +*** Failed! Falsifiable (after 1 tests): +'a' + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +'a' 'a' + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +'a' 'a' 'a' + +Generalization: +_ _ _ + + +checks :: Ordering + +*** Failed! Falsifiable (after 1 tests): +LT + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +LT LT + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +LT LT LT + +Generalization: +_ _ _ + + +checks :: [Integer] + +*** Failed! Falsifiable (after 1 tests): +[] + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +[] [] [] + +Generalization: +_ _ _ + + +checks :: Maybe Int + +*** Failed! Falsifiable (after 1 tests): +Nothing + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing Nothing + +Generalization: +_ _ _ + + +checks :: Either Int Char + +*** Failed! Falsifiable (after 1 tests): +Left 0 + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +(Left 0) (Left 0) + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +(Left 0) (Left 0) (Left 0) + +Generalization: +_ _ _ + + diff --git a/test/model/bench/ord.out b/test/model/bench/ord.out new file mode 100644 --- /dev/null +++ b/test/model/bench/ord.out @@ -0,0 +1,508 @@ +checks :: () + +*** Failed! Falsifiable (after 1 tests): +() () + +Generalization: +_ _ + +*** Failed! Falsifiable (after 1 tests): +() () + +Generalization: +_ _ + ++++ OK, passed 1 tests (exhausted). + ++++ OK, passed 1 tests (exhausted). + + +checks :: Bool + +*** Failed! Falsifiable (after 1 tests): +False False + +Generalization: +p p + +Generalization: +_ False + +*** Failed! Falsifiable (after 1 tests): +False False + +Generalization: +p p + +Generalization: +False _ + +*** Failed! Falsifiable (after 3 tests): +True False + +*** Failed! Falsifiable (after 2 tests): +False True + + +checks :: Int + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +x x + +Conditional Generalization: +x y when y <= x + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +x x + +Conditional Generalization: +x y when x <= y + +*** Failed! Falsifiable (after 3 tests): +1 0 + +Conditional Generalization: +x y when y < x + +*** Failed! Falsifiable (after 2 tests): +0 1 + +Conditional Generalization: +x y when x < y + + +checks :: Integer + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +x x + +Conditional Generalization: +x y when y <= x + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +x x + +Conditional Generalization: +x y when x <= y + +*** Failed! Falsifiable (after 3 tests): +1 0 + +Conditional Generalization: +x y when y < x + +*** Failed! Falsifiable (after 2 tests): +0 1 + +Conditional Generalization: +x y when x < y + + +checks :: Char + +*** Failed! Falsifiable (after 1 tests): +'a' 'a' + +Generalization: +c c + +Conditional Generalization: +c d when d <= c + +*** Failed! Falsifiable (after 1 tests): +'a' 'a' + +Generalization: +c c + +Conditional Generalization: +c d when c <= d + +*** Failed! Falsifiable (after 2 tests): +'a' ' ' + +Conditional Generalization: +c d when d < c + +*** Failed! Falsifiable (after 3 tests): +' ' 'a' + +Conditional Generalization: +c d when c < d + + +checks :: Ordering + +*** Failed! Falsifiable (after 1 tests): +LT LT + +Generalization: +o o + +Generalization: +_ LT + +Conditional Generalization: +o p when p <= o + +*** Failed! Falsifiable (after 1 tests): +LT LT + +Generalization: +o o + +Generalization: +LT _ + +Conditional Generalization: +o p when o <= p + +*** Failed! Falsifiable (after 4 tests): +EQ LT + +Conditional Generalization: +o p when p < o + +*** Failed! Falsifiable (after 2 tests): +LT EQ + +Conditional Generalization: +o p when o < p + + +checks :: [Bool] + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +ps ps + +Generalization: +_ [] + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +ps ps + +Generalization: +[] _ + +*** Failed! Falsifiable (after 4 tests): +[False] [] + +Generalization: +(_:_) [] + +Conditional Generalization: +ps [] when ps /= [] + +*** Failed! Falsifiable (after 2 tests): +[] [False] + +Generalization: +[] (_:_) + +Conditional Generalization: +[] ps when ps /= [] + + +checks :: [Integer] + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +xs xs + +Generalization: +_ [] + +Conditional Generalization: +xs ys when ys <= xs + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +xs xs + +Generalization: +[] _ + +Conditional Generalization: +xs ys when xs <= ys + +*** Failed! Falsifiable (after 3 tests): +[0] [] + +Generalization: +(_:_) [] + +Conditional Generalization: +xs ys when ys < xs + +*** Failed! Falsifiable (after 2 tests): +[] [0] + +Generalization: +[] (_:_) + +Conditional Generalization: +xs ys when xs < ys + + +checks :: (Bool,Char) + +*** Failed! Falsifiable (after 1 tests): +(False,'a') (False,'a') + +Generalization: +pc pc + +Generalization: +(_,c) (False,c) + +Conditional Generalization: +(p,c) (p,d) when d <= c + +*** Failed! Falsifiable (after 1 tests): +(False,'a') (False,'a') + +Generalization: +pc pc + +Generalization: +(False,c) (_,c) + +Conditional Generalization: +(p,c) (p,d) when c <= d + +*** Failed! Falsifiable (after 3 tests): +(True,'a') (False,'a') + +Generalization: +(True,_) (False,_) + +Conditional Generalization: +(p,c) (p,d) when d < c + +*** Failed! Falsifiable (after 2 tests): +(False,'a') (True,'a') + +Generalization: +(False,_) (True,_) + +Conditional Generalization: +(p,c) (p,d) when c < d + + +checks :: (Ordering,Char,Integer) + +*** Failed! Falsifiable (after 1 tests): +(LT,'a',0) (LT,'a',0) + +Generalization: +ocx ocx + +Generalization: +(_,c,x) (LT,c,x) + +Conditional Generalization: +ocx ocx' when ocx' <= ocx + +*** Failed! Falsifiable (after 1 tests): +(LT,'a',0) (LT,'a',0) + +Generalization: +ocx ocx + +Generalization: +(LT,c,x) (_,c,x) + +Conditional Generalization: +ocx ocx' when ocx <= ocx' + +*** Failed! Falsifiable (after 4 tests): +(EQ,'a',0) (LT,'a',0) + +Generalization: +(EQ,_,_) (LT,_,_) + +Conditional Generalization: +ocx ocx' when ocx' < ocx + +*** Failed! Falsifiable (after 2 tests): +(LT,'a',0) (EQ,'a',0) + +Generalization: +(LT,_,_) (EQ,_,_) + +Conditional Generalization: +ocx ocx' when ocx < ocx' + + +checks :: Maybe () + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing + +Generalization: +mu mu + +Generalization: +_ Nothing + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing + +Generalization: +mu mu + +Generalization: +Nothing _ + +*** Failed! Falsifiable (after 3 tests): +(Just ()) Nothing + +Generalization: +(Just _) Nothing + +*** Failed! Falsifiable (after 2 tests): +Nothing (Just ()) + +Generalization: +Nothing (Just _) + + +checks :: Maybe Int + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing + +Generalization: +mx mx + +Generalization: +_ Nothing + +Conditional Generalization: +mx mx' when mx' <= mx + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing + +Generalization: +mx mx + +Generalization: +Nothing _ + +Conditional Generalization: +mx mx' when mx <= mx' + +*** Failed! Falsifiable (after 3 tests): +(Just 0) Nothing + +Generalization: +(Just _) Nothing + +Conditional Generalization: +mx mx' when mx' < mx + +*** Failed! Falsifiable (after 2 tests): +Nothing (Just 0) + +Generalization: +Nothing (Just _) + +Conditional Generalization: +mx mx' when mx < mx' + + +checks :: Either () Bool + +*** Failed! Falsifiable (after 1 tests): +(Left ()) (Left ()) + +Generalization: +eup eup + +Generalization: +_ (Left _) + +*** Failed! Falsifiable (after 1 tests): +(Left ()) (Left ()) + +Generalization: +eup eup + +Generalization: +(Left _) _ + +*** Failed! Falsifiable (after 4 tests): +(Right False) (Left ()) + +Generalization: +(Right _) (Left _) + +*** Failed! Falsifiable (after 2 tests): +(Left ()) (Right False) + +Generalization: +(Left _) (Right _) + + +checks :: Either Int Char + +*** Failed! Falsifiable (after 1 tests): +(Left 0) (Left 0) + +Generalization: +exc exc + +Conditional Generalization: +exc exc' when exc' <= exc + +*** Failed! Falsifiable (after 1 tests): +(Left 0) (Left 0) + +Generalization: +exc exc + +Conditional Generalization: +exc exc' when exc <= exc' + +*** Failed! Falsifiable (after 3 tests): +(Right 'a') (Left 0) + +Generalization: +(Right _) (Left _) + +Conditional Generalization: +exc exc' when exc' < exc + +*** Failed! Falsifiable (after 2 tests): +(Left 0) (Right 'a') + +Generalization: +(Left _) (Right _) + +Conditional Generalization: +exc exc' when exc < exc' + + diff --git a/test/model/bench/true-false.out b/test/model/bench/true-false.out new file mode 100644 --- /dev/null +++ b/test/model/bench/true-false.out @@ -0,0 +1,439 @@ +checks :: () + ++++ OK, passed 1 tests (exhausted). + +*** Failed! Falsifiable (after 1 tests): +() + +Generalization: +_ + ++++ OK, passed 1 tests (exhausted). + +*** Failed! Falsifiable (after 1 tests): +() () + +Generalization: +_ _ + + +checks :: Bool + ++++ OK, passed 2 tests (exhausted). + +*** Failed! Falsifiable (after 1 tests): +False + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +False True + +*** Failed! Falsifiable (after 1 tests): +False False + +Generalization: +p p + + +checks :: Int + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +0 + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +0 1 + +Conditional Generalization: +x y when x /= y + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +x x + + +checks :: Integer + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +0 + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +0 1 + +Conditional Generalization: +x y when x /= y + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +x x + + +checks :: Char + ++++ OK, passed 97 tests (exhausted). + +*** Failed! Falsifiable (after 1 tests): +'a' + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +'a' ' ' + +Conditional Generalization: +c d when c /= d + +*** Failed! Falsifiable (after 1 tests): +'a' 'a' + +Generalization: +c c + + +checks :: Ordering + ++++ OK, passed 3 tests (exhausted). + +*** Failed! Falsifiable (after 1 tests): +LT + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +LT EQ + +*** Failed! Falsifiable (after 1 tests): +LT LT + +Generalization: +o o + + +checks :: [()] + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +[] + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +[] [()] + +Generalization: +us (_:us) + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +us us + + +checks :: [Bool] + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +[] + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +[] [False] + +Generalization: +ps (_:ps) + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +ps ps + + +checks :: [Int] + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +[] + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +[] [0] + +Generalization: +xs (_:xs) + +Conditional Generalization: +xs ys when length xs /= length ys + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +xs xs + + +checks :: [Integer] + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +[] + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +[] [0] + +Generalization: +xs (_:xs) + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +xs xs + + +checks :: [Char] + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +"" + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +"" "a" + +Generalization: +cs (_:cs) + +*** Failed! Falsifiable (after 1 tests): +"" "" + +Generalization: +cs cs + + +checks :: [Ordering] + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +[] + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +[] [LT] + +Generalization: +os (_:os) + +*** Failed! Falsifiable (after 1 tests): +[] [] + +Generalization: +os os + + +checks :: ((),Int) + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +((),0) + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +((),0) ((),1) + +Generalization: +(_,0) (_,1) + +Conditional Generalization: +(_,x) (_,y) when x /= y + +*** Failed! Falsifiable (after 1 tests): +((),0) ((),0) + +Generalization: +ux ux + + +checks :: (Bool,Char) + ++++ OK, passed 194 tests (exhausted). + +*** Failed! Falsifiable (after 1 tests): +(False,'a') + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +(False,'a') (True,'a') + +Generalization: +(False,_) (True,_) + +Conditional Generalization: +(_,c) (_,d) when c /= d + +*** Failed! Falsifiable (after 1 tests): +(False,'a') (False,'a') + +Generalization: +pc pc + + +checks :: (Int,(),Bool) + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +(0,(),False) + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +(0,(),False) (0,(),True) + +Generalization: +(_,_,False) (_,_,True) + +Conditional Generalization: +(x,_,_) (y,_,_) when x /= y + +*** Failed! Falsifiable (after 1 tests): +(0,(),False) (0,(),False) + +Generalization: +xup xup + + +checks :: Maybe () + ++++ OK, passed 2 tests (exhausted). + +*** Failed! Falsifiable (after 1 tests): +Nothing + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +Nothing (Just ()) + +Generalization: +Nothing (Just _) + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing + +Generalization: +mu mu + + +checks :: Maybe Int + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +Nothing + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +Nothing (Just 0) + +Generalization: +Nothing (Just _) + +*** Failed! Falsifiable (after 1 tests): +Nothing Nothing + +Generalization: +mx mx + + +checks :: Either () Bool + ++++ OK, passed 3 tests (exhausted). + +*** Failed! Falsifiable (after 1 tests): +Left () + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +(Left ()) (Right False) + +Generalization: +(Left _) (Right _) + +*** Failed! Falsifiable (after 1 tests): +(Left ()) (Left ()) + +Generalization: +eup eup + + +checks :: Either Int Char + ++++ OK, passed 360 tests. + +*** Failed! Falsifiable (after 1 tests): +Left 0 + +Generalization: +_ + +*** Failed! Falsifiable (after 2 tests): +(Left 0) (Right 'a') + +Generalization: +(Left _) (Right _) + +*** Failed! Falsifiable (after 1 tests): +(Left 0) (Left 0) + +Generalization: +exc exc + + diff --git a/test/model/bench/true.out b/test/model/bench/true.out new file mode 100644 --- /dev/null +++ b/test/model/bench/true.out @@ -0,0 +1,180 @@ +checks :: () + ++++ OK, passed 1 tests (exhausted). + ++++ OK, passed 1 tests (exhausted). + ++++ OK, passed 1 tests (exhausted). + + +checks :: Bool + ++++ OK, passed 2 tests (exhausted). + ++++ OK, passed 4 tests (exhausted). + ++++ OK, passed 8 tests (exhausted). + + +checks :: Int + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: Integer + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: Char + ++++ OK, passed 97 tests (exhausted). + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: Ordering + ++++ OK, passed 3 tests (exhausted). + ++++ OK, passed 9 tests (exhausted). + ++++ OK, passed 27 tests (exhausted). + + +checks :: [()] + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: [Bool] + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: [Int] + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: [Integer] + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: [Char] + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: [Ordering] + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: ((),Int) + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: (Bool,Char) + ++++ OK, passed 194 tests (exhausted). + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: (Int,(),Bool) + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: (Ordering,Char,Integer) + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: Maybe () + ++++ OK, passed 2 tests (exhausted). + ++++ OK, passed 4 tests (exhausted). + ++++ OK, passed 8 tests (exhausted). + + +checks :: Maybe Int + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +checks :: Either () Bool + ++++ OK, passed 3 tests (exhausted). + ++++ OK, passed 9 tests (exhausted). + ++++ OK, passed 27 tests (exhausted). + + +checks :: Either Int Char + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + diff --git a/test/model/eg/calculator.out b/test/model/eg/calculator.out new file mode 100644 --- /dev/null +++ b/test/model/eg/calculator.out @@ -0,0 +1,20 @@ +*** Failed! Falsifiable (after 20 tests): +Div (C 0) (Add (C 0) (C 0)) + +Generalization: +Div (C _) (Add (C 0) (C 0)) + +Conditional Generalization: +Div e1 (Add (C 0) (C 0)) when noDiv0 e1 + +*** Failed! Falsifiable (after 5 tests): +Div (C 0) (C 0) + +Generalization: +Div _ (C 0) + +Conditional Generalization: +e1 when not (noDiv0 e1) + +False +True diff --git a/test/model/eg/gencalc.out b/test/model/eg/gencalc.out new file mode 100644 --- /dev/null +++ b/test/model/eg/gencalc.out @@ -0,0 +1,14 @@ +*** Failed! Falsifiable (after 20 tests): +Div (C 0) (Add (C 0) (C 0)) + +Generalization: +Div (C _) (Add (C 0) (C 0)) + +*** Failed! Falsifiable (after 5 tests): +Div (C 0) (C 0) + +Generalization: +Div _ (C 0) + +False +True diff --git a/test/model/eg/heap.out b/test/model/eg/heap.out new file mode 100644 --- /dev/null +++ b/test/model/eg/heap.out @@ -0,0 +1,8 @@ +*** Failed! Falsifiable (after 1053 tests): +(HeapPP {program = Insert 0 (Insert 1 (Insert 0 (Unit 0))), theHeap = Node 0 (Node 0 (Node 1 Nil Nil) (Node 0 Nil Nil)) Nil}) +*** Failed! Falsifiable (after 1053 tests): +heappp (Insert 0 (Insert 1 (Insert 0 (Unit 0)))) + +Conditional Generalization: +heappp (Insert x (Insert y (Insert x (Unit x)))) when x < y + diff --git a/test/model/eg/int.out b/test/model/eg/int.out new file mode 100644 --- /dev/null +++ b/test/model/eg/int.out @@ -0,0 +1,53 @@ +Properties that should be OK: ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + ++++ OK, passed 500 tests. + + +Properties that should fail: +*** Failed! Falsifiable (after 1 tests): +0 + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +0 + +Generalization: +_ + +*** Failed! Falsifiable (after 1 tests): +0 0 + +Generalization: +x x + +*** Failed! Falsifiable (after 1 tests): +0 0 0 + +Generalization: +_ x x + +Generalization: +x x _ + +*** Failed! Falsifiable (after 1 tests): +(0,0) + +Generalization: +(x,x) + +*** Failed! Falsifiable (after 1 tests): +(0,0,0) + +Generalization: +(_,x,x) + +Generalization: +(x,x,_) + diff --git a/test/model/eg/list.out b/test/model/eg/list.out new file mode 100644 --- /dev/null +++ b/test/model/eg/list.out @@ -0,0 +1,49 @@ ++++ OK, passed 500 tests. + +*** Failed! Falsifiable (after 4 tests): +[] [0,0] + +Generalization: +xs (x:x:xs) + +Generalization: +[] (x:x:_) + +Conditional Generalization: +xs (_:xs) when xs /= [] + +*** Failed! Falsifiable (after 6 tests): +[0,1] + +Conditional Generalization: +[x,y] when x /= y + +*** Failed! Falsifiable (after 3 tests): +[0,0] + +Generalization: +x:x:_ + +Conditional Generalization: +x:xs when elem x xs + +*** Failed! Falsifiable (after 2 tests): +[0] + +Generalization: +_:_ + +Conditional Generalization: +xs when xs /= [] + +*** Failed! Falsifiable (after 2 tests): +[] [0] + +Generalization: +_ (_:_) + +Conditional Generalization: +_ xs when xs /= [] + ++++ OK, passed 500 tests. + diff --git a/test/model/eg/overflow.out b/test/model/eg/overflow.out new file mode 100644 --- /dev/null +++ b/test/model/eg/overflow.out @@ -0,0 +1,3 @@ +*** Failed! Falsifiable (after 8792 tests): +T [] [] [] [-1] [-32768] + diff --git a/test/model/eg/overflow8.out b/test/model/eg/overflow8.out new file mode 100644 --- /dev/null +++ b/test/model/eg/overflow8.out @@ -0,0 +1,6 @@ +*** Failed! Falsifiable (after 896 tests): +T [-1] [-128] + +Conditional Generalization: +T ((-1):xs) ((-128):xs) when 0 == sum xs + diff --git a/test/model/eg/parser.out b/test/model/eg/parser.out new file mode 100644 --- /dev/null +++ b/test/model/eg/parser.out @@ -0,0 +1,11 @@ +*** Failed! Falsifiable (after 96 tests): +(Lang {modules = [], funcs = [Func {fnName = Var "a", args = [And (Int 0) (Bool False)], stmts = []}]}) +*** Failed! Falsifiable (after 96 tests): +Lang [] [Func (Var "a") [And (Int 0) (Bool False)] []] + +Generalization: +Lang _ (Func _ (And (Int _) (Bool _):_) _:_) + +Conditional Generalization: +Lang _ (Func _ (And e f:_) _:_) when e /= f + diff --git a/test/model/eg/redblack.out b/test/model/eg/redblack.out new file mode 100644 --- /dev/null +++ b/test/model/eg/redblack.out @@ -0,0 +1,20 @@ ++++ OK, passed 1080 tests. + ++++ OK, passed 1080 tests. + ++++ OK, passed 1080 tests. + ++++ OK, passed 1080 tests. + ++++ OK, passed 1080 tests. + ++++ OK, passed 1080 tests. + ++++ OK, passed 1080 tests. + ++++ OK, passed 1080 tests. + ++++ OK, passed 1080 tests. + ++++ OK, passed 1080 tests. + diff --git a/test/model/eg/sorting.out b/test/model/eg/sorting.out new file mode 100644 --- /dev/null +++ b/test/model/eg/sorting.out @@ -0,0 +1,31 @@ ++++ OK, passed 500 tests. + +*** Failed! Falsifiable (after 4 tests): +0 [0,0] + +Generalization: +x (x:x:_) + +Conditional Generalization: +x xs when count x xs > 1 + +*** Failed! Falsifiable (after 4 tests): +0 [0,0] + +Generalization: +x (x:x:_) + +Conditional Generalization: +x (x:xs) when elem x xs + ++++ OK, passed 99 tests. + +*** Failed! Falsifiable (after 7 tests): +False [False,False] + +Generalization: +p (p:p:_) + +Conditional Generalization: +p (p:ps) when elem p ps + diff --git a/test/model/eg/word-refinements.out b/test/model/eg/word-refinements.out new file mode 100644 --- /dev/null +++ b/test/model/eg/word-refinements.out @@ -0,0 +1,35 @@ +*** Failed! Falsifiable (after 4 tests): +" " + +Generalization: +' ':_ + +Conditional Generalization: +c:_ when c <= ' ' + +*** Failed! Falsifiable (after 4 tests): +" " + +Generalization: +' ':_ + +Conditional Generalization: +c:_ when isSpace c + +*** Failed! Falsifiable (after 43 tests): +"a a" + +Conditional Generalization: +c:' ':' ':c:"" when not (isSpace c) + +*** Failed! Falsifiable (after 4 tests): +" " + +Generalization: +' ':_ + +Conditional Generalization: +cs when " " `isInfixOf` cs + ++++ OK, passed 500 tests. + diff --git a/test/sdist b/test/sdist new file mode 100644 --- /dev/null +++ b/test/sdist @@ -0,0 +1,33 @@ +#!/bin/bash +# +# test-sdist: tests the package generated by "cabal sdist". +# +# Copyright (c) 2015-2018 Rudy Matela. +# Distributed under the 3-Clause BSD licence. +export LC_ALL=C # consistent sort +pkgver=` cat *.cabal | grep "^version:" | sed -e "s/version: *//"` +pkgname=`cat *.cabal | grep "^name:" | sed -e "s/name: *//"` +pkg=$pkgname-$pkgver +set -x +cabal sdist && +cd dist && +tar -tf $pkg.tar.gz | sort --ignore-case > ls-cabal-i && +tar -tf $pkg.tar.gz | sort --ignore-case --unique > ls-cabal-iu && +diff -rud ls-cabal-i ls-cabal-iu && +rm -f ls-cabal ls-cabal-ignore-case && +if [ -d ../.git ] +then + # on git repo, test if files are the same + git -C .. ls-files | sort > ls-git && + tar -tf $pkg.tar.gz | grep -v "/$" | sed -e "s,$pkg/,," | sort > ls-cabal && + diff -rud ls-git ls-cabal && + rm -f ls-git ls-cabal +else + # outside of git repo, test build + rm -rf $pkg/ && + tar -xzf $pkg.tar.gz && + cd $pkg/ && + cabal configure --enable-tests --enable-benchmarks && + cabal build && + cabal test +fi diff --git a/test/step-by-step.hs b/test/step-by-step.hs new file mode 100644 --- /dev/null +++ b/test/step-by-step.hs @@ -0,0 +1,138 @@ +-- Copyright (c) 2017-2019 Rudy Matela. +-- Distributed under the 3-Clause BSD licence (see the file LICENSE). +import Test +import Data.List (nub) + +main :: IO () +main = mainTest tests 10000 + +tests :: Int -> [Bool] +tests n = + [ True + + , testableBackground prop + == [ operatorE (is_ -==- is_) + , operatorE (is_ -/=- is_) + , operatorE (is_ -<=- is_) + , operatorE (is_ -<- is_) + , lengthE + , elemE + + , operatorE (b_ -==- b_) + , operatorE (b_ -/=- b_) + , notE + + , operatorE (i_ -==- i_) + , operatorE (i_ -/=- i_) + , operatorE (i_ -<=- i_) + , operatorE (i_ -<- i_) + ] + + , concat (take 2 $ testableAtoms prop) + == [ b_ + , i_ + , is_ + , nil + , false + , true + , zero + + , operatorE (is_ -==- is_) + , operatorE (is_ -/=- is_) + , operatorE (is_ -<=- is_) + , operatorE (is_ -<- is_) + , lengthE + , elemE + + , operatorE (b_ -==- b_) + , operatorE (b_ -/=- b_) + , notE + + , operatorE (i_ -==- i_) + , operatorE (i_ -/=- i_) + , operatorE (i_ -<=- i_) + , operatorE (i_ -<- i_) + + , val [0::Int] + , one + ] + + , snd thyes + == [ b_ + , false + , true + , not' b_ + + , is_ -==- is_ + , is_ -==- nil + , is_ -/=- is_ + , is_ -/=- nil + , is_ -<=- is_ + , is_ -<- is_ + , elem' i_ is_ + , elem' zero is_ + + , b_ -==- b_ + , b_ -/=- b_ + + , i_ -==- i_ + , i_ -==- zero + , i_ -/=- i_ + , i_ -/=- zero + , i_ -<=- i_ + , i_ -<=- zero + , zero -<=- i_ + , i_ -<- i_ + , i_ -<- zero + , zero -<- i_ + ] + + , candidateConditions (testableGrounds prop) thyes (prop' xxs) + == [ true + , xxs -/=- nil + , elem' zero xxs + ] + + , validConditions thyes (testableGrounds prop) (prop' xxs) + == [false] + + , candidateConditions (testableGrounds prop) thyes (prop' $ xx -:- xxs) + == [ true + , xxs -/=- nil + , elem' xx xxs + , elem' zero xxs + , xx -/=- zero + , xx -<=- zero + , zero -<=- xx + , xx -<- zero + , zero -<- xx + ] + + , validConditions thyes (testableGrounds prop) (prop' $ xx -:- xxs) + == [ elem' xx xxs + , false + ] + ] + +thyes :: (Thy,[Expr]) +thyes = theoryAndReprConds (testableMaxConditionSize prop) (===) (testableAtoms prop) + where + e1 === e2 = isTrue grounds $ e1 -==- e2 + grounds = testableGrounds prop + (-==-) = testableMkEquation prop + +prop' :: Expr -> Expr +prop' e = propE :$ e + +propE :: Expr +propE = value "prop" prop_nubid + +prop :: (WithOption ([Int] -> Bool)) +prop = prop_nubid `With` MaxConditionSize 3 + +prop_nubid :: [Int] -> Bool +prop_nubid xs = nub xs == xs + +elemE, lengthE :: Expr +lengthE = value "length" (length :: [Int] -> Int) +elemE = value "elem" (elem :: Int -> [Int] -> Bool) diff --git a/test/utils.hs b/test/utils.hs new file mode 100644 --- /dev/null +++ b/test/utils.hs @@ -0,0 +1,127 @@ +-- Copyright (c) 2017-2019 Rudy Matela. +-- Distributed under the 3-Clause BSD licence (see the file LICENSE). +import Test + +main :: IO () +main = mainTest tests 1000 + +tests :: Int -> [Bool] +tests n = + [ True + + , holds n $ elemBy (==) ==== elem -:> () + , holds n $ elemBy (==) ==== elem -:> int + , holds n $ elemBy (==) ==== elem -:> bool + , holds n $ elemBy (==) ==== elem -:> [int] + , holds n $ elemBy (==) ==== elem -:> [bool] + + , holds n $ listEq (==) ==== (==) -:> [()] + , holds n $ listEq (==) ==== (==) -:> [int] + , holds n $ listEq (==) ==== (==) -:> [bool] + , holds n $ listEq (==) ==== (==) -:> [[int]] + , holds n $ listEq (==) ==== (==) -:> [[bool]] + + , holds n $ listOrd (<=) ==== (<=) -:> [()] + , holds n $ listOrd (<=) ==== (<=) -:> [int] + , holds n $ listOrd (<=) ==== (<=) -:> [bool] + , holds n $ listOrd (<=) ==== (<=) -:> [[int]] + , holds n $ listOrd (<=) ==== (<=) -:> [[bool]] + + , holds n $ maybeEq (==) ==== (==) -:> mayb () + , holds n $ maybeEq (==) ==== (==) -:> mayb int + , holds n $ maybeEq (==) ==== (==) -:> mayb bool + , holds n $ maybeEq (==) ==== (==) -:> mayb [int] + , holds n $ maybeEq (==) ==== (==) -:> mayb [bool] + + , holds n $ maybeOrd (<=) ==== (<=) -:> mayb () + , holds n $ maybeOrd (<=) ==== (<=) -:> mayb int + , holds n $ maybeOrd (<=) ==== (<=) -:> mayb bool + , holds n $ maybeOrd (<=) ==== (<=) -:> mayb [int] + , holds n $ maybeOrd (<=) ==== (<=) -:> mayb [bool] + + , holds n $ eitherEq (==) (==) ==== (==) -:> eith () () + , holds n $ eitherEq (==) (==) ==== (==) -:> eith int int + , holds n $ eitherEq (==) (==) ==== (==) -:> eith int bool + , holds n $ eitherEq (==) (==) ==== (==) -:> eith bool int + , holds n $ eitherEq (==) (==) ==== (==) -:> eith bool bool + + , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith () () + , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith int int + , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith int bool + , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith bool int + , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith bool bool + + , holds n $ pairEq (==) (==) ==== (==) -:> ((),()) + , holds n $ pairEq (==) (==) ==== (==) -:> (int,int) + , holds n $ pairEq (==) (==) ==== (==) -:> (int,bool) + , holds n $ pairEq (==) (==) ==== (==) -:> (bool,int) + , holds n $ pairEq (==) (==) ==== (==) -:> (bool,bool) + + , holds n $ pairOrd (<=) (<=) ==== (<=) -:> ((),()) + , holds n $ pairOrd (<=) (<=) ==== (<=) -:> (int,int) + , holds n $ pairOrd (<=) (<=) ==== (<=) -:> (int,bool) + , holds n $ pairOrd (<=) (<=) ==== (<=) -:> (bool,int) + , holds n $ pairOrd (<=) (<=) ==== (<=) -:> (bool,bool) + + , holds n $ tripleEq (==) (==) (==) ==== (==) -:> ((),(),()) + , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (int,int,int) + , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (int,int,bool) + , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (int,bool,int) + , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (int,bool,bool) + , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (bool,int,int) + , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (bool,int,bool) + , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (bool,bool,int) + , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (bool,bool,bool) + + , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> ((),(),()) + , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (int,int,int) + , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (int,int,bool) + , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (int,bool,int) + , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (int,bool,bool) + , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (bool,int,int) + , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (bool,int,bool) + , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (bool,bool,int) + , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (bool,bool,bool) + + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> ((),(),(),()) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,int,int,int) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,int,int,bool) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,int,bool,int) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,int,bool,bool) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,bool,int,int) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,bool,int,bool) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,bool,bool,int) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,bool,bool,bool) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,int,int,int) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,int,int,bool) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,int,bool,int) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,int,bool,bool) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,bool,int,int) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,bool,int,bool) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,bool,bool,int) + , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,bool,bool,bool) + + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> ((),(),(),()) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,int,int,int) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,int,int,bool) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,int,bool,int) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,int,bool,bool) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,bool,int,int) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,bool,int,bool) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,bool,bool,int) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,bool,bool,bool) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,int,int,int) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,int,int,bool) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,int,bool,int) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,int,bool,bool) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,bool,int,int) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,bool,int,bool) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,bool,bool,int) + , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,bool,bool,bool) + + , minimumOn fst [(1,6),(2,5),(3,4)::(Int,Int)] == (1,6) + , minimumOn snd [(1,6),(2,5),(3,4)::(Int,Int)] == (3,4) + , maximumOn fst [(1,6),(2,5),(3,4)::(Int,Int)] == (3,4) + , maximumOn snd [(1,6),(2,5),(3,4)::(Int,Int)] == (1,6) + , maximumOn fst [(1,6),(1,5),(1,4)::(Int,Int)] == (1,6) + ] diff --git a/tests/Test.hs b/tests/Test.hs deleted file mode 100644 --- a/tests/Test.hs +++ /dev/null @@ -1,349 +0,0 @@ --- Copyright (c) 2017 Rudy Matela. --- Distributed under the 3-Clause BSD licence (see the file LICENSE). -module Test - ( module Test.Extrapolate - , module Test.Extrapolate.Core - , module Test.LeanCheck.Utils.Operators - - , reportTests - , getMaxTestsFromArgs - , mainTest - , printLines - - , (-:-), ll, llb, llmi - - , (-+-) - - , _i, xx, yy - , _is, xxs, yys - , _b, pp, qq - , _mi, mxx - , zero, one - - , false, true - , not' - , notE - - , elem', length' - , elemE, lengthE - - , nothing, nothingBool, just - - , comma - - , operatorE - - , (-==-) - , (-/=-) - , (-<-) - , (-<=-) - - -- * Properties and Tests - , generalizableOK - , exprOK - , idExprEval, showOK - , instancesOK - , namesOK, sameNamesIn, namesIn - , tiersOK, sameTiersIn, tiersIn - , bgEqOK, bgEqOrdOK - - , subset, bgSubset - - , instancesSubset - ) -where - -import System.Exit (exitFailure) -import Data.List (elemIndices) -import System.Environment (getArgs) -import Test.Speculate.Expr (typ) -import Test.Speculate.Expr.Instance as I -import Data.Typeable (typeOf) -import Data.List (isPrefixOf, sort) -import Data.Maybe (fromMaybe) -import Test.Speculate.Reason -import Test.Speculate.Reason.Order - -import Test.Extrapolate -import Test.Extrapolate.Utils -import Test.Extrapolate.Core hiding (false, true, lengthE) -import qualified Test.Extrapolate.Core as Core -import Test.LeanCheck.Utils.Operators - -reportTests :: [Bool] -> IO () -reportTests tests = - case elemIndices False tests of - [] -> putStrLn "Tests passed!" - is -> do putStrLn ("Failed tests:" ++ show is) - exitFailure - -getMaxTestsFromArgs :: Int -> IO Int -getMaxTestsFromArgs n = do - as <- getArgs - return $ case as of - (s:_) -> read s - _ -> n - -mainTest :: (Int -> [Bool]) -> Int -> IO () -mainTest tests n' = do - n <- getMaxTestsFromArgs n' - reportTests (tests n) - -printLines :: Show a => [a] -> IO () -printLines = putStrLn . unlines . map show - -(-:-) :: Expr -> Expr -> Expr -x -:- xs = consE :$ x :$ xs - where - consE = case show $ typ x of - "Int" -> consEint - "Bool" -> consEbool - "Maybe Int" -> consEmint - t -> error $ "(-:-): unhandled type " ++ t - consEint = constant ":" ((:) -:> int) - consEbool = constant ":" ((:) -:> bool) - consEmint = constant ":" ((:) -:> mayb int) -infixr 5 -:- - -ll :: Expr -ll = expr ([] :: [Int]) - -_i, xx, yy :: Expr -_i = var "" int -xx = var "x" int -yy = var "y" int - -_is, xxs, yys :: Expr -_is = var "" [int] -xxs = var "xs" [int] -yys = var "ys" [int] - -_mi, mxx :: Expr -_mi = var "" (mayb int) -mxx = var "mx" (mayb int) - -_b, pp, qq :: Expr -_b = var "" bool -pp = var "p" bool -qq = var "q" bool - -zero :: Expr -zero = expr (0 :: Int) - -one :: Expr -one = expr (1 :: Int) - -llb :: Expr -llb = expr ([] :: [Bool]) - -llmi :: Expr -llmi = expr ([] :: [Maybe Int]) - -false :: Expr -false = expr False - -true :: Expr -true = expr True - -nothing :: Expr -nothing = constant "Nothing" (Nothing :: Maybe Int) - -nothingBool :: Expr -nothingBool = constant "Nothing" (Nothing :: Maybe Bool) - -elem' :: Expr -> Expr -> Expr -elem' x xs = elemE :$ x :$ xs - -elemE :: Expr -elemE = constant "elem" (elem :: Int -> [Int] -> Bool) - -length' :: Expr -> Expr -length' xs = lengthE :$ xs - -lengthE = constant "length" (length :: [Int] -> Int) - -not' :: Expr -> Expr -not' p = notE :$ p - -notE :: Expr -notE = constant "not" not - -just :: Expr -> Expr -just x = justE :$ x - where - justE = case show $ typ x of - "Int" -> justEint - "Bool" -> justEbool - t -> error $ "(-:-): unhandled type " ++ t - justEint = constant "Just" (Just -:> int) - justEbool = constant "Just" (Just -:> bool) - -comma :: Expr -> Expr -> Expr -comma x y = commaE :$ x :$ y - where - commaE = case (show $ typ x, show $ typ y) of - ("Int", "Int") -> commaEii - ("Int", "Bool") -> commaEib - ("Bool","Int") -> commaEbi - ("Bool","Bool") -> commaEbb - (t,t') -> error $ "(-:-): unhandled types " ++ t ++ " " ++ t' - commaEii = constant "," ((,) ->>: (int,int)) - commaEib = constant "," ((,) ->>: (int,bool)) - commaEbi = constant "," ((,) ->>: (bool,int)) - commaEbb = constant "," ((,) ->>: (bool,bool)) - -(-+-) :: Expr -> Expr -> Expr -e1 -+- e2 = plusE :$ e1 :$ e2 -infixl 6 -+- - -plusE :: Expr -plusE = constant "+" ((+) :: Int -> Int -> Int) - -operatorE :: Expr -> Expr -operatorE ((opE :$ _) :$ _) = opE - -(-==-) :: Expr -> Expr -> Expr -e1 -==- e2 = - fromMaybe (error $ "(-==-): cannot equate " ++ show e1 ++ " and " ++ show e2) - (equation preludeInstances e1 e2) -infix 4 -==- - -(-/=-) :: Expr -> Expr -> Expr -e1 -/=- e2 = - fromMaybe (error $ "(-/=-): cannot inequate " ++ show e1 ++ " and " ++ show e2) - (inequality preludeInstances e1 e2) -infix 4 -/=- - -(-<=-) :: Expr -> Expr -> Expr -e1 -<=- e2 = - fromMaybe (error $ "(-<=-): cannot lessEq " ++ show e1 ++ " and " ++ show e2) - (comparisonLE preludeInstances e1 e2) -infix 4 -<=- - -(-<-) :: Expr -> Expr -> Expr -e1 -<- e2 = - fromMaybe (error $ "(-<-): cannot less " ++ show e1 ++ " and " ++ show e2) - (comparisonLT preludeInstances e1 e2) -infix 4 -<- - - - --- Properties and tests -- - -generalizableOK :: (Eq a, Show a, Generalizable a) => Int -> a -> Bool -generalizableOK n x = holds n (exprOK -:> x) - && instancesOK (und -: x) - where - und = error "generalizableOK: this should not get evaluated" - -exprOK :: (Eq a, Show a, Generalizable a) => a -> Bool -exprOK = idExprEval &&& showOK - -idExprEval :: (Eq a, Generalizable a) => a -> Bool -idExprEval x = eval (error "idExprEval: could not eval") (expr x) == x - -showOK :: (Show a, Generalizable a) => a -> Bool -showOK x = show x == dropType (show (expr x)) - where - dropType :: String -> String - dropType cs | " :: " `isPrefixOf` cs = "" - dropType "" = "" - dropType (c:cs) = c : dropType cs - -instancesOK :: (Eq a, Generalizable a) => a -> Bool -instancesOK = namesOK &&& tiersOK - -namesOK :: Generalizable a => a -> Bool -namesOK x = Core.name x == head (x `namesIn` x) - && x `sameNamesIn` [x] - && x `sameNamesIn` [[x]] - && x `sameNamesIn` mayb x - && x `sameNamesIn` (x,x) - && x `sameNamesIn` (x,()) - && x `sameNamesIn` ((),x) - && x `sameNamesIn` (x,(),()) - && x `sameNamesIn` ((),x,()) - && x `sameNamesIn` ((),(),x) - -sameNamesIn :: (Generalizable a, Generalizable b) => a -> b -> Bool -x `sameNamesIn` c = x `namesIn` x - =| 12 |= x `namesIn` c - -namesIn :: (Generalizable a, Generalizable b) => a -> b -> [String] -x `namesIn` c = I.names (instances c []) (typeOf x) - -tiersOK :: (Eq a, Generalizable a) => a -> Bool -tiersOK x = x `sameTiersIn` x - && x `sameTiersIn` [x] - && x `sameTiersIn` [[x]] - && x `sameTiersIn` (mayb x) - && x `sameTiersIn` (x,x) - && x `sameTiersIn` (x,()) - && x `sameTiersIn` ((),x) - && x `sameTiersIn` (x,(),()) - && x `sameTiersIn` ((),x,()) - && x `sameTiersIn` ((),(),x) - -bgEqOK :: (Eq a, Generalizable a) => a -> a -> Bool -bgEqOK = (*==*) ==== (==) - &&&& (*/=*) ==== (/=) - -bgEqOrdOK :: (Eq a, Ord a, Generalizable a) => a -> a -> Bool -bgEqOrdOK = bgEqOK &&&& (*<=*) ==== (<=) - &&&& (*<*) ==== (<) - -sameTiersIn :: (Eq a, Generalizable a, Generalizable b) => a -> b -> Bool -x `sameTiersIn` cx = isListable (instances cx []) (typeOf x) - && (tiers -: [[x]]) =| 6 |= tiersIn cx - -tiersIn :: (Generalizable a, Generalizable b) => b -> [[a]] -tiersIn c = ret - where - ret = mapT (eval . error $ "tiersIn: the imposible happened") - $ tiersE (instances c []) (typeOf (head (head ret))) - -subset :: Ord a => [a] -> [a] -> Bool -xs `subset` ys = sort xs `isSubsequenceOf` sort ys - -bgSubset :: (Generalizable a, Generalizable b) => a -> b -> Bool -x `bgSubset` y = backgroundOf x `subset` backgroundOf y - -instancesSubset :: (Eq a, Eq b, Generalizable a, Generalizable b) => a -> b -> Bool -x `instancesSubset` y = x `bgSubset` y - && x `sameTiersIn` y - && x `sameNamesIn` y - --- available on Data.List since GHC >= 8.0 -isSubsequenceOf :: Eq a => [a] -> [a] -> Bool -isSubsequenceOf [] _ = True -isSubsequenceOf (_:_) [] = False -isSubsequenceOf (x:xs) (y:ys) - | x == y = xs `isSubsequenceOf` ys - | otherwise = (x:xs) `isSubsequenceOf` ys - --- Quick and Dirty! -instance Show Thy where - show Thy { rules = rs - , equations = eqs - , canReduceTo = (->-) - , closureLimit = cl - , keepE = keep - } - = "Thy { rules = " - ++ drop 14 (indent 14 . listLines $ map showEquation rs) - ++ " , equations = " - ++ drop 18 (indent 18 . listLines $ map showEquation eqs) - ++ " , canReduceTo = " ++ showCanReduceTo (->-) ++ "\n" - ++ " , closureLimit = " ++ show cl ++ "\n" - ++ " , keepE = " ++ showKeepE keep ++ "\n" - ++ " }" - where - showEquation (e1,e2) = showExpr e1 ++ " == " ++ showExpr e2 - listLines [] = "[]" - listLines ss = '[':(tail . unlines $ map (", " ++) ss) ++ "]" - showCanReduceTo (->-) = "(??)" - showKeepE keep = "\\e -> ??" - indent :: Int -> String -> String - indent n = unlines . map (replicate n ' ' ++) . lines - - diff --git a/tests/model/bench/diff.out b/tests/model/bench/diff.out deleted file mode 100644 --- a/tests/model/bench/diff.out +++ /dev/null @@ -1,180 +0,0 @@ -checks :: () - -*** Failed! Falsifiable (after 1 tests): -() () - -Generalization: -_ _ - - -checks :: Bool - -*** Failed! Falsifiable (after 1 tests): -False False - -Generalization: -p p - - -checks :: Int - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -x x - - -checks :: Integer - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -x x - - -checks :: Char - -*** Failed! Falsifiable (after 1 tests): -'a' 'a' - -Generalization: -c c - - -checks :: Ordering - -*** Failed! Falsifiable (after 1 tests): -LT LT - -Generalization: -o o - - -checks :: [()] - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -us us - - -checks :: [Bool] - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -ps ps - - -checks :: [Int] - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -xs xs - - -checks :: [Integer] - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -xs xs - - -checks :: [Char] - -*** Failed! Falsifiable (after 1 tests): -"" "" - -Generalization: -cs cs - - -checks :: [Ordering] - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -os os - - -checks :: ((),Int) - -*** Failed! Falsifiable (after 1 tests): -((),0) ((),0) - -Generalization: -ux ux - - -checks :: (Bool,Char) - -*** Failed! Falsifiable (after 1 tests): -(False,'a') (False,'a') - -Generalization: -pc pc - - -checks :: (Int,(),Bool) - -*** Failed! Falsifiable (after 1 tests): -(0,(),False) (0,(),False) - -Generalization: -xup xup - - -checks :: (Ordering,Char,Integer) - -*** Failed! Falsifiable (after 1 tests): -(LT,'a',0) (LT,'a',0) - -Generalization: -ocx ocx - - -checks :: Maybe () - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing - -Generalization: -mu mu - - -checks :: Maybe Int - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing - -Generalization: -mx mx - - -checks :: Either () Bool - -*** Failed! Falsifiable (after 1 tests): -(Left ()) (Left ()) - -Generalization: -eup eup - - -checks :: Either Int Char - -*** Failed! Falsifiable (after 1 tests): -(Left 0) (Left 0) - -Generalization: -exc exc - - diff --git a/tests/model/bench/eq.out b/tests/model/bench/eq.out deleted file mode 100644 --- a/tests/model/bench/eq.out +++ /dev/null @@ -1,209 +0,0 @@ -checks :: () - -+++ OK, passed 1 tests (exhausted). - - -checks :: Bool - -*** Failed! Falsifiable (after 2 tests): -False True - - -checks :: Int - -*** Failed! Falsifiable (after 2 tests): -0 1 - -Conditional Generalization: -x y when x /= y - - -checks :: Integer - -*** Failed! Falsifiable (after 2 tests): -0 1 - -Conditional Generalization: -x y when x /= y - - -checks :: Char - -*** Failed! Falsifiable (after 2 tests): -'a' ' ' - -Conditional Generalization: -c d when c /= d - - -checks :: Ordering - -*** Failed! Falsifiable (after 2 tests): -LT EQ - -Conditional Generalization: -o p when o /= p - - -checks :: [()] - -*** Failed! Falsifiable (after 2 tests): -[] [()] - -Generalization: -us (_:us) - -Conditional Generalization: -[] us when 0 /= length us - - -checks :: [Bool] - -*** Failed! Falsifiable (after 2 tests): -[] [False] - -Generalization: -ps (_:ps) - -Conditional Generalization: -ps qs when ps /= qs - - -checks :: [Int] - -*** Failed! Falsifiable (after 2 tests): -[] [0] - -Generalization: -xs (_:xs) - -Conditional Generalization: -xs ys when xs /= ys - - -checks :: [Integer] - -*** Failed! Falsifiable (after 2 tests): -[] [0] - -Generalization: -xs (_:xs) - -Conditional Generalization: -xs ys when xs /= ys - - -checks :: [Char] - -*** Failed! Falsifiable (after 2 tests): -"" "a" - -Generalization: -cs (_:cs) - -Conditional Generalization: -cs ds when cs /= ds - - -checks :: [Ordering] - -*** Failed! Falsifiable (after 2 tests): -[] [LT] - -Generalization: -os (_:os) - -Conditional Generalization: -os ps when os /= ps - - -checks :: ((),Int) - -*** Failed! Falsifiable (after 2 tests): -((),0) ((),1) - -Generalization: -(_,0) (_,1) - -Conditional Generalization: -(_,x) (_,y) when x /= y - - -checks :: (Bool,Char) - -*** Failed! Falsifiable (after 2 tests): -(False,'a') (True,'a') - -Generalization: -(False,_) (True,_) - -Conditional Generalization: -pc pc' when pc /= pc' - - -checks :: (Int,(),Bool) - -*** Failed! Falsifiable (after 2 tests): -(0,(),False) (0,(),True) - -Generalization: -(_,_,False) (_,_,True) - -Conditional Generalization: -(x,_,_) (y,_,_) when x /= y - - -checks :: (Ordering,Char,Integer) - -*** Failed! Falsifiable (after 2 tests): -(LT,'a',0) (EQ,'a',0) - -Generalization: -(LT,_,_) (EQ,_,_) - -Conditional Generalization: -ocx ocx' when ocx /= ocx' - - -checks :: Maybe () - -*** Failed! Falsifiable (after 2 tests): -Nothing (Just ()) - -Generalization: -Nothing (Just _) - - -checks :: Maybe Int - -*** Failed! Falsifiable (after 2 tests): -Nothing (Just 0) - -Generalization: -Nothing (Just _) - -Conditional Generalization: -mx mx' when mx /= mx' - - -checks :: Either () Bool - -*** Failed! Falsifiable (after 2 tests): -(Left ()) (Right False) - -Generalization: -(Left _) (Right _) - - -checks :: Either Int Char - -*** Failed! Falsifiable (after 2 tests): -(Left 0) (Right 'a') - -Generalization: -(Left _) (Right _) - -Conditional Generalization: -exc exc' when exc /= exc' - - diff --git a/tests/model/bench/false.out b/tests/model/bench/false.out deleted file mode 100644 --- a/tests/model/bench/false.out +++ /dev/null @@ -1,189 +0,0 @@ -checks :: () - -*** Failed! Falsifiable (after 1 tests): -() - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -() () - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -() () () - -Generalization: -_ _ _ - - -checks :: Bool - -*** Failed! Falsifiable (after 1 tests): -False - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -False False - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -False False False - -Generalization: -_ _ _ - - -checks :: Int - -*** Failed! Falsifiable (after 1 tests): -0 - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -0 0 0 - -Generalization: -_ _ _ - - -checks :: Integer - -*** Failed! Falsifiable (after 1 tests): -0 - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -0 0 0 - -Generalization: -_ _ _ - - -checks :: Char - -*** Failed! Falsifiable (after 1 tests): -'a' - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -'a' 'a' - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -'a' 'a' 'a' - -Generalization: -_ _ _ - - -checks :: Ordering - -*** Failed! Falsifiable (after 1 tests): -LT - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -LT LT - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -LT LT LT - -Generalization: -_ _ _ - - -checks :: [Integer] - -*** Failed! Falsifiable (after 1 tests): -[] - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -[] [] [] - -Generalization: -_ _ _ - - -checks :: Maybe Int - -*** Failed! Falsifiable (after 1 tests): -Nothing - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing Nothing - -Generalization: -_ _ _ - - -checks :: Either Int Char - -*** Failed! Falsifiable (after 1 tests): -Left 0 - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -(Left 0) (Left 0) - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -(Left 0) (Left 0) (Left 0) - -Generalization: -_ _ _ - - diff --git a/tests/model/bench/ord.out b/tests/model/bench/ord.out deleted file mode 100644 --- a/tests/model/bench/ord.out +++ /dev/null @@ -1,454 +0,0 @@ -checks :: () - -*** Failed! Falsifiable (after 1 tests): -() () - -Generalization: -_ _ - -*** Failed! Falsifiable (after 1 tests): -() () - -Generalization: -_ _ - -+++ OK, passed 1 tests (exhausted). - -+++ OK, passed 1 tests (exhausted). - - -checks :: Bool - -*** Failed! Falsifiable (after 1 tests): -False False - -Generalization: -p p - -*** Failed! Falsifiable (after 1 tests): -False False - -Generalization: -p p - -*** Failed! Falsifiable (after 3 tests): -True False - -*** Failed! Falsifiable (after 2 tests): -False True - - -checks :: Int - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -x x - -Conditional Generalization: -y x when x <= y - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -x x - -Conditional Generalization: -x y when x <= y - -*** Failed! Falsifiable (after 3 tests): -1 0 - -Conditional Generalization: -y x when x < y - -*** Failed! Falsifiable (after 2 tests): -0 1 - -Conditional Generalization: -x y when x < y - - -checks :: Integer - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -x x - -Conditional Generalization: -y x when x <= y - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -x x - -Conditional Generalization: -x y when x <= y - -*** Failed! Falsifiable (after 3 tests): -1 0 - -Conditional Generalization: -y x when x < y - -*** Failed! Falsifiable (after 2 tests): -0 1 - -Conditional Generalization: -x y when x < y - - -checks :: Char - -*** Failed! Falsifiable (after 1 tests): -'a' 'a' - -Generalization: -c c - -Conditional Generalization: -d c when c <= d - -*** Failed! Falsifiable (after 1 tests): -'a' 'a' - -Generalization: -c c - -Conditional Generalization: -c d when c <= d - -*** Failed! Falsifiable (after 2 tests): -'a' ' ' - -Conditional Generalization: -d c when c < d - -*** Failed! Falsifiable (after 3 tests): -' ' 'a' - -Conditional Generalization: -c d when c < d - - -checks :: Ordering - -*** Failed! Falsifiable (after 1 tests): -LT LT - -Generalization: -o o - -Conditional Generalization: -p o when o <= p - -*** Failed! Falsifiable (after 1 tests): -LT LT - -Generalization: -o o - -Conditional Generalization: -o p when o <= p - -*** Failed! Falsifiable (after 4 tests): -EQ LT - -Conditional Generalization: -p o when o < p - -*** Failed! Falsifiable (after 2 tests): -LT EQ - -Conditional Generalization: -o p when o < p - - -checks :: [Bool] - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -ps ps - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -ps ps - -*** Failed! Falsifiable (after 4 tests): -[False] [] - -Generalization: -(_:_) [] - -Conditional Generalization: -ps [] when ps /= [] - -*** Failed! Falsifiable (after 2 tests): -[] [False] - -Generalization: -[] (_:_) - -Conditional Generalization: -[] ps when ps /= [] - - -checks :: [Integer] - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -xs xs - -Conditional Generalization: -ys xs when xs <= ys - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -xs xs - -Conditional Generalization: -xs ys when xs <= ys - -*** Failed! Falsifiable (after 3 tests): -[0] [] - -Generalization: -(_:_) [] - -Conditional Generalization: -ys xs when xs < ys - -*** Failed! Falsifiable (after 2 tests): -[] [0] - -Generalization: -[] (_:_) - -Conditional Generalization: -xs ys when xs < ys - - -checks :: (Bool,Char) - -*** Failed! Falsifiable (after 1 tests): -(False,'a') (False,'a') - -Generalization: -pc pc - -Conditional Generalization: -(p,d) (p,c) when c <= d - -*** Failed! Falsifiable (after 1 tests): -(False,'a') (False,'a') - -Generalization: -pc pc - -Conditional Generalization: -(p,c) (p,d) when c <= d - -*** Failed! Falsifiable (after 3 tests): -(True,'a') (False,'a') - -Generalization: -(True,_) (False,_) - -Conditional Generalization: -(p,d) (p,c) when c < d - -*** Failed! Falsifiable (after 2 tests): -(False,'a') (True,'a') - -Generalization: -(False,_) (True,_) - -Conditional Generalization: -(p,c) (p,d) when c < d - - -checks :: (Ordering,Char,Integer) - -*** Failed! Falsifiable (after 1 tests): -(LT,'a',0) (LT,'a',0) - -Generalization: -ocx ocx - -Conditional Generalization: -ocx' ocx when ocx <= ocx' - -*** Failed! Falsifiable (after 1 tests): -(LT,'a',0) (LT,'a',0) - -Generalization: -ocx ocx - -Conditional Generalization: -ocx ocx' when ocx <= ocx' - -*** Failed! Falsifiable (after 4 tests): -(EQ,'a',0) (LT,'a',0) - -Generalization: -(EQ,_,_) (LT,_,_) - -Conditional Generalization: -ocx' ocx when ocx < ocx' - -*** Failed! Falsifiable (after 2 tests): -(LT,'a',0) (EQ,'a',0) - -Generalization: -(LT,_,_) (EQ,_,_) - -Conditional Generalization: -ocx ocx' when ocx < ocx' - - -checks :: Maybe () - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing - -Generalization: -mu mu - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing - -Generalization: -mu mu - -*** Failed! Falsifiable (after 3 tests): -(Just ()) Nothing - -Generalization: -(Just _) Nothing - -*** Failed! Falsifiable (after 2 tests): -Nothing (Just ()) - -Generalization: -Nothing (Just _) - - -checks :: Maybe Int - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing - -Generalization: -mx mx - -Conditional Generalization: -mx' mx when mx <= mx' - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing - -Generalization: -mx mx - -Conditional Generalization: -mx mx' when mx <= mx' - -*** Failed! Falsifiable (after 3 tests): -(Just 0) Nothing - -Generalization: -(Just _) Nothing - -Conditional Generalization: -mx' mx when mx < mx' - -*** Failed! Falsifiable (after 2 tests): -Nothing (Just 0) - -Generalization: -Nothing (Just _) - -Conditional Generalization: -mx mx' when mx < mx' - - -checks :: Either () Bool - -*** Failed! Falsifiable (after 1 tests): -(Left ()) (Left ()) - -Generalization: -eup eup - -*** Failed! Falsifiable (after 1 tests): -(Left ()) (Left ()) - -Generalization: -eup eup - -*** Failed! Falsifiable (after 4 tests): -(Right False) (Left ()) - -Generalization: -(Right _) (Left _) - -*** Failed! Falsifiable (after 2 tests): -(Left ()) (Right False) - -Generalization: -(Left _) (Right _) - - -checks :: Either Int Char - -*** Failed! Falsifiable (after 1 tests): -(Left 0) (Left 0) - -Generalization: -exc exc - -Conditional Generalization: -exc' exc when exc <= exc' - -*** Failed! Falsifiable (after 1 tests): -(Left 0) (Left 0) - -Generalization: -exc exc - -Conditional Generalization: -exc exc' when exc <= exc' - -*** Failed! Falsifiable (after 3 tests): -(Right 'a') (Left 0) - -Generalization: -(Right _) (Left _) - -Conditional Generalization: -exc' exc when exc < exc' - -*** Failed! Falsifiable (after 2 tests): -(Left 0) (Right 'a') - -Generalization: -(Left _) (Right _) - -Conditional Generalization: -exc exc' when exc < exc' - - diff --git a/tests/model/bench/true-false.out b/tests/model/bench/true-false.out deleted file mode 100644 --- a/tests/model/bench/true-false.out +++ /dev/null @@ -1,439 +0,0 @@ -checks :: () - -+++ OK, passed 1 tests (exhausted). - -*** Failed! Falsifiable (after 1 tests): -() - -Generalization: -_ - -+++ OK, passed 1 tests (exhausted). - -*** Failed! Falsifiable (after 1 tests): -() () - -Generalization: -_ _ - - -checks :: Bool - -+++ OK, passed 2 tests (exhausted). - -*** Failed! Falsifiable (after 1 tests): -False - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -False True - -*** Failed! Falsifiable (after 1 tests): -False False - -Generalization: -p p - - -checks :: Int - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -0 - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -0 1 - -Conditional Generalization: -x y when x /= y - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -x x - - -checks :: Integer - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -0 - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -0 1 - -Conditional Generalization: -x y when x /= y - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -x x - - -checks :: Char - -+++ OK, passed 97 tests (exhausted). - -*** Failed! Falsifiable (after 1 tests): -'a' - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -'a' ' ' - -Conditional Generalization: -c d when c /= d - -*** Failed! Falsifiable (after 1 tests): -'a' 'a' - -Generalization: -c c - - -checks :: Ordering - -+++ OK, passed 3 tests (exhausted). - -*** Failed! Falsifiable (after 1 tests): -LT - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -LT EQ - -*** Failed! Falsifiable (after 1 tests): -LT LT - -Generalization: -o o - - -checks :: [()] - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -[] - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -[] [()] - -Generalization: -us (_:us) - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -us us - - -checks :: [Bool] - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -[] - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -[] [False] - -Generalization: -ps (_:ps) - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -ps ps - - -checks :: [Int] - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -[] - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -[] [0] - -Generalization: -xs (_:xs) - -Conditional Generalization: -xs ys when length xs /= length ys - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -xs xs - - -checks :: [Integer] - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -[] - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -[] [0] - -Generalization: -xs (_:xs) - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -xs xs - - -checks :: [Char] - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -"" - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -"" "a" - -Generalization: -cs (_:cs) - -*** Failed! Falsifiable (after 1 tests): -"" "" - -Generalization: -cs cs - - -checks :: [Ordering] - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -[] - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -[] [LT] - -Generalization: -os (_:os) - -*** Failed! Falsifiable (after 1 tests): -[] [] - -Generalization: -os os - - -checks :: ((),Int) - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -((),0) - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -((),0) ((),1) - -Generalization: -(_,0) (_,1) - -Conditional Generalization: -(_,x) (_,y) when x /= y - -*** Failed! Falsifiable (after 1 tests): -((),0) ((),0) - -Generalization: -ux ux - - -checks :: (Bool,Char) - -+++ OK, passed 194 tests (exhausted). - -*** Failed! Falsifiable (after 1 tests): -(False,'a') - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -(False,'a') (True,'a') - -Generalization: -(False,_) (True,_) - -Conditional Generalization: -(_,c) (_,d) when c /= d - -*** Failed! Falsifiable (after 1 tests): -(False,'a') (False,'a') - -Generalization: -pc pc - - -checks :: (Int,(),Bool) - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -(0,(),False) - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -(0,(),False) (0,(),True) - -Generalization: -(_,_,False) (_,_,True) - -Conditional Generalization: -(x,_,_) (y,_,_) when x /= y - -*** Failed! Falsifiable (after 1 tests): -(0,(),False) (0,(),False) - -Generalization: -xup xup - - -checks :: Maybe () - -+++ OK, passed 2 tests (exhausted). - -*** Failed! Falsifiable (after 1 tests): -Nothing - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -Nothing (Just ()) - -Generalization: -Nothing (Just _) - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing - -Generalization: -mu mu - - -checks :: Maybe Int - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -Nothing - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -Nothing (Just 0) - -Generalization: -Nothing (Just _) - -*** Failed! Falsifiable (after 1 tests): -Nothing Nothing - -Generalization: -mx mx - - -checks :: Either () Bool - -+++ OK, passed 3 tests (exhausted). - -*** Failed! Falsifiable (after 1 tests): -Left () - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -(Left ()) (Right False) - -Generalization: -(Left _) (Right _) - -*** Failed! Falsifiable (after 1 tests): -(Left ()) (Left ()) - -Generalization: -eup eup - - -checks :: Either Int Char - -+++ OK, passed 360 tests. - -*** Failed! Falsifiable (after 1 tests): -Left 0 - -Generalization: -_ - -*** Failed! Falsifiable (after 2 tests): -(Left 0) (Right 'a') - -Generalization: -(Left _) (Right _) - -*** Failed! Falsifiable (after 1 tests): -(Left 0) (Left 0) - -Generalization: -exc exc - - diff --git a/tests/model/bench/true.out b/tests/model/bench/true.out deleted file mode 100644 --- a/tests/model/bench/true.out +++ /dev/null @@ -1,180 +0,0 @@ -checks :: () - -+++ OK, passed 1 tests (exhausted). - -+++ OK, passed 1 tests (exhausted). - -+++ OK, passed 1 tests (exhausted). - - -checks :: Bool - -+++ OK, passed 2 tests (exhausted). - -+++ OK, passed 4 tests (exhausted). - -+++ OK, passed 8 tests (exhausted). - - -checks :: Int - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: Integer - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: Char - -+++ OK, passed 97 tests (exhausted). - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: Ordering - -+++ OK, passed 3 tests (exhausted). - -+++ OK, passed 9 tests (exhausted). - -+++ OK, passed 27 tests (exhausted). - - -checks :: [()] - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: [Bool] - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: [Int] - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: [Integer] - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: [Char] - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: [Ordering] - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: ((),Int) - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: (Bool,Char) - -+++ OK, passed 194 tests (exhausted). - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: (Int,(),Bool) - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: (Ordering,Char,Integer) - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: Maybe () - -+++ OK, passed 2 tests (exhausted). - -+++ OK, passed 4 tests (exhausted). - -+++ OK, passed 8 tests (exhausted). - - -checks :: Maybe Int - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -checks :: Either () Bool - -+++ OK, passed 3 tests (exhausted). - -+++ OK, passed 9 tests (exhausted). - -+++ OK, passed 27 tests (exhausted). - - -checks :: Either Int Char - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - diff --git a/tests/model/eg/calculator.out b/tests/model/eg/calculator.out deleted file mode 100644 --- a/tests/model/eg/calculator.out +++ /dev/null @@ -1,20 +0,0 @@ -*** Failed! Falsifiable (after 20 tests): -Div (C 0) (Add (C 0) (C 0)) - -Generalization: -Div (C _) (Add (C 0) (C 0)) - -Conditional Generalization: -Div e1 (Add (C 0) (C 0)) when noDiv0 e1 - -*** Failed! Falsifiable (after 5 tests): -Div (C 0) (C 0) - -Generalization: -Div _ (C 0) - -Conditional Generalization: -e1 when not (noDiv0 e1) - -False -True diff --git a/tests/model/eg/gencalc.out b/tests/model/eg/gencalc.out deleted file mode 100644 --- a/tests/model/eg/gencalc.out +++ /dev/null @@ -1,14 +0,0 @@ -*** Failed! Falsifiable (after 20 tests): -Div (C 0) (Add (C 0) (C 0)) - -Generalization: -Div (C _) (Add (C 0) (C 0)) - -*** Failed! Falsifiable (after 5 tests): -Div (C 0) (C 0) - -Generalization: -Div _ (C 0) - -False -True diff --git a/tests/model/eg/heap.out b/tests/model/eg/heap.out deleted file mode 100644 --- a/tests/model/eg/heap.out +++ /dev/null @@ -1,8 +0,0 @@ -*** Failed! Falsifiable (after 1053 tests): -(HeapPP {program = Insert 0 (Insert 1 (Insert 0 (Unit 0))), theHeap = Node 0 (Node 0 (Node 1 Nil Nil) (Node 0 Nil Nil)) Nil}) -*** Failed! Falsifiable (after 1053 tests): -heappp (Insert 0 (Insert 1 (Insert 0 (Unit 0)))) - -Conditional Generalization: -heappp (Insert x (Insert y (Insert x (Unit x)))) when x < y - diff --git a/tests/model/eg/int.out b/tests/model/eg/int.out deleted file mode 100644 --- a/tests/model/eg/int.out +++ /dev/null @@ -1,47 +0,0 @@ -Properties that should be OK: -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - -+++ OK, passed 500 tests. - - -Properties that should fail: -*** Failed! Falsifiable (after 1 tests): -0 - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -0 - -Generalization: -_ - -*** Failed! Falsifiable (after 1 tests): -0 0 - -Generalization: -x x - -*** Failed! Falsifiable (after 1 tests): -0 0 0 - -Generalization: -_ x x - -*** Failed! Falsifiable (after 1 tests): -(0,0) - -Generalization: -(x,x) - -*** Failed! Falsifiable (after 1 tests): -(0,0,0) - -Generalization: -(_,x,x) - diff --git a/tests/model/eg/list.out b/tests/model/eg/list.out deleted file mode 100644 --- a/tests/model/eg/list.out +++ /dev/null @@ -1,46 +0,0 @@ -+++ OK, passed 500 tests. - -*** Failed! Falsifiable (after 4 tests): -[] [0,0] - -Generalization: -xs (x:x:xs) - -Conditional Generalization: -xs (_:xs) when xs /= [] - -*** Failed! Falsifiable (after 6 tests): -[0,1] - -Conditional Generalization: -[x,y] when x /= y - -*** Failed! Falsifiable (after 3 tests): -[0,0] - -Generalization: -x:x:_ - -Conditional Generalization: -x:xs when elem x xs - -*** Failed! Falsifiable (after 2 tests): -[0] - -Generalization: -_:_ - -Conditional Generalization: -xs when xs /= [] - -*** Failed! Falsifiable (after 2 tests): -[] [0] - -Generalization: -_ (_:_) - -Conditional Generalization: -_ xs when xs /= [] - -+++ OK, passed 500 tests. - diff --git a/tests/model/eg/overflow.out b/tests/model/eg/overflow.out deleted file mode 100644 --- a/tests/model/eg/overflow.out +++ /dev/null @@ -1,3 +0,0 @@ -*** Failed! Falsifiable (after 8792 tests): -T [] [] [] [-1] [-32768] - diff --git a/tests/model/eg/overflow8.out b/tests/model/eg/overflow8.out deleted file mode 100644 --- a/tests/model/eg/overflow8.out +++ /dev/null @@ -1,6 +0,0 @@ -*** Failed! Falsifiable (after 896 tests): -T [-1] [-128] - -Conditional Generalization: -T ((-1):xs) ((-128):xs) when 0 == sum xs - diff --git a/tests/model/eg/parser.out b/tests/model/eg/parser.out deleted file mode 100644 --- a/tests/model/eg/parser.out +++ /dev/null @@ -1,11 +0,0 @@ -*** Failed! Falsifiable (after 96 tests): -(Lang {modules = [], funcs = [Func {fnName = Var "a", args = [And (Int 0) (Bool False)], stmts = []}]}) -*** Failed! Falsifiable (after 96 tests): -Lang [] [Func (Var "a") [And (Int 0) (Bool False)] []] - -Generalization: -Lang _ (Func _ (And (Int _) (Bool _):_) _:_) - -Conditional Generalization: -Lang _ (Func _ (And e f:_) _:_) when e /= f - diff --git a/tests/model/eg/redblack.out b/tests/model/eg/redblack.out deleted file mode 100644 --- a/tests/model/eg/redblack.out +++ /dev/null @@ -1,20 +0,0 @@ -+++ OK, passed 1080 tests. - -+++ OK, passed 1080 tests. - -+++ OK, passed 1080 tests. - -+++ OK, passed 1080 tests. - -+++ OK, passed 1080 tests. - -+++ OK, passed 1080 tests. - -+++ OK, passed 1080 tests. - -+++ OK, passed 1080 tests. - -+++ OK, passed 1080 tests. - -+++ OK, passed 1080 tests. - diff --git a/tests/model/eg/sorting.out b/tests/model/eg/sorting.out deleted file mode 100644 --- a/tests/model/eg/sorting.out +++ /dev/null @@ -1,31 +0,0 @@ -+++ OK, passed 500 tests. - -*** Failed! Falsifiable (after 4 tests): -0 [0,0] - -Generalization: -x (x:x:_) - -Conditional Generalization: -x xs when count x xs > 1 - -*** Failed! Falsifiable (after 4 tests): -0 [0,0] - -Generalization: -x (x:x:_) - -Conditional Generalization: -x (x:xs) when elem x xs - -+++ OK, passed 99 tests. - -*** Failed! Falsifiable (after 7 tests): -False [False,False] - -Generalization: -p (p:p:_) - -Conditional Generalization: -p (p:ps) when elem p ps - diff --git a/tests/model/eg/word-refinements.out b/tests/model/eg/word-refinements.out deleted file mode 100644 --- a/tests/model/eg/word-refinements.out +++ /dev/null @@ -1,35 +0,0 @@ -*** Failed! Falsifiable (after 4 tests): -" " - -Generalization: -' ':_ - -Conditional Generalization: -c:_ when c <= ' ' - -*** Failed! Falsifiable (after 4 tests): -" " - -Generalization: -' ':_ - -Conditional Generalization: -c:_ when isSpace c - -*** Failed! Falsifiable (after 43 tests): -"a a" - -Conditional Generalization: -c:' ':' ':c:"" when not (isSpace c) - -*** Failed! Falsifiable (after 4 tests): -" " - -Generalization: -' ':_ - -Conditional Generalization: -cs when " " `isInfixOf` cs - -+++ OK, passed 500 tests. - diff --git a/tests/test-derive.hs b/tests/test-derive.hs deleted file mode 100644 --- a/tests/test-derive.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} -- for GHC <= 7.8 --- Copyright (c) 2017 Rudy Matela. --- Distributed under the 3-Clause BSD licence (see the file LICENSE). -import Test -import Data.List (sort) - -#if __GLASGOW_HASKELL__ < 710 -import Data.Typeable (Typeable) -deriving instance Typeable List -deriving instance Typeable Perhaps -deriving instance Typeable Ship -deriving instance Typeable Arrangement -deriving instance Typeable NonEmptyList -deriving instance Typeable Mutual -deriving instance Typeable Shared -deriving instance Typeable Tree -deriving instance Typeable Leafy -deriving instance Typeable Dict -deriving instance Typeable Data -deriving instance Typeable EqData -deriving instance Typeable OrdData -#endif - --- List is isomorphic to [] -data List a = Cons a (List a) - | Nil - deriving (Show, Eq, Ord) - --- Perhaps is isomorphic to Maybe -data Perhaps a = Naught - | Simply a - deriving (Show, Eq, Ord) - --- Ship is isomorphic to Either -data Ship a b = Port a - | Starboard b - deriving (Show, Eq, Ord) - --- Arrangement is isomorphic to Ordering -data Arrangement = Lesser - | Equal - | Greater - deriving (Show, Eq, Ord) - -data NonEmptyList a = Buil a (NonEmptyList a) - | Unit a - deriving (Show, Eq, Ord) - -data Mutual a = Mutual a (Shared a) | M a deriving (Show, Eq, Ord) -data Shared a = Shared (Mutual a) a | S a deriving (Show, Eq, Ord) - -data Tree a = Node (Tree a) a (Tree a) | Empty - deriving (Show, Eq, Ord) - -data Leafy a = Branch (Leafy a) (Leafy a) | Leaf a - deriving (Show, Eq, Ord) - -data Dict a b = Meaning a b (Dict a b) - | End - deriving (Show, Eq, Ord) - -data Data = Data deriving (Show) -data EqData = EqData deriving (Show, Eq) -data OrdData = OrdData deriving (Show, Eq, Ord) - - --- Dummy undefined values -- - -ls :: a -> List a -ls = undefined - -perhaps :: a -> Perhaps a -perhaps = undefined - -ship :: a -> b -> Ship a b -ship = undefined - -arrangement :: Arrangement -arrangement = undefined - -nonEmptyList :: a -> NonEmptyList a -nonEmptyList = undefined - -mutual :: a -> Mutual a -mutual = undefined - -shared :: a -> Shared a -shared = undefined - -tree :: a -> Tree a -tree = undefined - -leafy :: a -> Leafy a -leafy = undefined - -dict :: a -> b -> Dict a b -dict = undefined - - -deriveListable ''List -deriveListable ''Perhaps -deriveListable ''Ship - - -deriveGeneralizable ''List -{- -- derivation: -instance (Generalizable a) => Generalizable (List a) where - name _ = "xs" - expr xs@Nil = constant "Nil" (Nil -: xs) - expr xs@(Cons y ys) = constant "Cons" (Cons ->>: xs) :$ expr y :$ expr ys - instances xs = this xs - $ (let Cons y ys = Cons undefined undefined -: xs - in instances y . instances ys) - --- It may seem like its possible to derive just: ---instances xs = this xs --- $ instances (argTy1of1 xs) --- However that will restrain us from recursing into non argument types that --- need to be present (cf. the Mutual & Shared types). --} - -deriveGeneralizable ''Perhaps -{- -- derivation: -instance (Generalizable a) => Generalizable (Perhaps a) where - expr px@Naught = constant "Naught" (Naught -: px) - expr px@(Simply x) = constant "Simply" (Simply ->: px) :$ expr x - instances px = ... --} - -deriveGeneralizable ''Ship -{- -- derivation: -instance (Generalizable a, Generalizable b) => Generalizable (Ship a b) where - expr s@(Port x) = constant "Port" (Port ->: s) :$ expr x - expr s@(Starboard y) = constant "Starboard" (Starboard ->: s) :$ expr y - instances s = ... --} - -deriveGeneralizable ''Arrangement - -deriveGeneralizable ''NonEmptyList - -deriveGeneralizable ''Mutual -deriveGeneralizable ''Shared - -deriveGeneralizable ''Tree -deriveGeneralizable ''Leafy - -deriveGeneralizable ''Dict - -deriveGeneralizable ''Data -deriveGeneralizable ''EqData -deriveGeneralizable ''OrdData - - -main :: IO () -main = mainTest tests 2160 - -tests :: Int -> [Bool] -tests n = - [ True - - , generalizableOK n (ls bool) - , generalizableOK n (perhaps int) - , generalizableOK n (ship int char) - , generalizableOK n (arrangement) - , generalizableOK n (mutual bool) - , generalizableOK n (shared int) - , generalizableOK n (tree bool) - , generalizableOK n (leafy int) - , generalizableOK n (dict bool int) - , generalizableOK n EqData - , generalizableOK n OrdData - - , int `instancesSubset` ls int - , not $ bool `instancesSubset` ls int - , () `instancesSubset` perhaps () - , not $ () `instancesSubset` perhaps int - , () `bgSubset` perhaps int -- () has no background - , char `instancesSubset` ship char int - , int `instancesSubset` ship char int - , not $ bool `instancesSubset` ship char int - , int `instancesSubset` mutual int - , int `instancesSubset` shared int - , shared int `instancesSubset` mutual int - , mutual () `instancesSubset` shared () - , bool `instancesSubset` tree bool - , int `instancesSubset` leafy int - , int `instancesSubset` dict int bool - , bool `instancesSubset` dict int bool - , bool `instancesSubset` dict int (perhaps (ship char bool)) - , shared (ship (ls char) bool) - `instancesSubset` dict int (perhaps (mutual (ship (ls char) bool))) - - , backgroundOf Data =$ sort $= [] - , backgroundOf EqData =$ sort $= [ constant "==" $ (==) -:> EqData - , constant "/=" $ (/=) -:> EqData - ] - , backgroundOf OrdData =$ sort $= [ constant "==" $ (==) -:> OrdData - , constant "/=" $ (/=) -:> OrdData - , constant "<=" $ (<=) -:> OrdData - , constant "<" $ (<) -:> OrdData - ] - ] diff --git a/tests/test-extrapolate.hs b/tests/test-extrapolate.hs deleted file mode 100644 --- a/tests/test-extrapolate.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} -- for GHC <= 7.8 --- Copyright (c) 2017 Rudy Matela. --- Distributed under the 3-Clause BSD licence (see the file LICENSE). -import Test - -import Data.List (sort, nub, union) - -#if __GLASGOW_HASKELL__ < 710 -import Data.Typeable (Typeable) -deriving instance Typeable NOrd -#endif - -data NOrd = NOrd - deriving Show - -deriveListable ''NOrd -deriveGeneralizable ''NOrd - -nord :: NOrd -nord = undefined - -main :: IO () -main = mainTest tests 10000 - -tests :: Int -> [Bool] -tests n = - [ True - - -- Transforming lists into Exprs - , expr ([]::[Int]) == constant "[]" ([]::[Int]) - , expr ([0::Int]) == zero -:- ll - , expr ([0::Int,1]) == zero -:- one -:- ll - , holds n $ \xs -> expr xs == foldr (-:-) ll (map expr (xs :: [Int])) - , holds n $ \ps -> expr ps == foldr (-:-) llb (map expr (ps :: [Bool])) - - -- Transforming Maybes into Exprs - , expr (Nothing :: Maybe Int) == nothing - , expr (Nothing :: Maybe Bool) == nothingBool - , expr (Just 1 :: Maybe Int) == just one - , expr (Just False :: Maybe Bool) == just false - , holds n $ \x -> expr (Just x) == just (expr (x :: Int)) - , holds n $ \p -> expr (Just p) == just (expr (p :: Bool)) - - -- Transforming Tuples into Exprs - , expr ((0,False) :: (Int,Bool)) == zero `comma` false - , expr ((True,1) :: (Bool,Int)) == true `comma` one - - -- Showing of Exprs - , holds n $ \x -> show (expr x) == show (x :: ()) ++ " :: ()" - , holds n $ \x -> show (expr x) == show (x :: Int) ++ " :: Int" - , holds n $ \p -> show (expr p) == show (p :: Bool) ++ " :: Bool" - , holds n $ \x -> show (expr x) == show (x :: ((),Maybe Int,[Bool])) - ++ " :: ((),(Maybe Int),[Bool])" - - -- Generalizable instance properties - , generalizableOK n () - , generalizableOK n int - , generalizableOK n integer - , generalizableOK n bool - , generalizableOK n char - , generalizableOK n ordering - , generalizableOK 9 [()] - , generalizableOK n [int] - , generalizableOK n [integer] - , generalizableOK n [bool] - , generalizableOK n [char] - , generalizableOK n [ordering] - , generalizableOK n (mayb ()) - , generalizableOK n (mayb int) - , generalizableOK n (mayb integer) - , generalizableOK n (mayb bool) - , generalizableOK n (mayb char) - , generalizableOK n (eith () int) - , generalizableOK n (eith integer bool) - , generalizableOK n (int,bool) - , generalizableOK n ((),integer) - , generalizableOK n ((),bool,integer) - , generalizableOK n (int,(),bool,integer) - , generalizableOK n (int,(),bool,integer,char) - , generalizableOK n (string,int,(),bool,integer,char) --- TODO: implement further tuple instances (7,8,9,10,11,12) and uncomment below - , generalizableOK n ((),(),(),(),(),(),()) -#if __GLASGOW_HASKELL__ < 710 --- no 8-tuples for you -#else - , generalizableOK n ((),(),(),(),(),(),(),()) ---, generalizableOK n ((),(),(),(),(),(),(),(),()) ---, generalizableOK n ((),(),(),(),(),(),(),(),(),()) ---, generalizableOK n ((),(),(),(),(),(),(),(),(),(),()) ---, generalizableOK n ((),(),(),(),(),(),(),(),(),(),(),()) -#endif - - -- Silly test, as it basically replicates the actual implementation: - , backgroundOf int =$ sort $= [ constant "==" $ (==) -:> int - , constant "/=" $ (/=) -:> int - , constant "<=" $ (<=) -:> int - , constant "<" $ (<) -:> int - ] - - , background (mayb int) - == [ constant "==" ((==) -:> mayb int) - , constant "/=" ((/=) -:> mayb int) - , constant "<=" ((<=) -:> mayb int) - , constant "<" ((<) -:> mayb int) - , constant "Just" (Just ->: mayb int) ] - - , background (eith int char) - == [ constant "==" ((==) -:> eith int char) - , constant "/=" ((/=) -:> eith int char) - , constant "<=" ((<=) -:> eith int char) - , constant "<" ((<) -:> eith int char) - , constant "Left" (Left ->: eith int char) - , constant "Right" (Right ->: eith int char) ] - - , background [int] - == [ constant "==" ((==) -:> [int]) - , constant "/=" ((/=) -:> [int]) - , constant "<=" ((<=) -:> [int]) - , constant "<" ((<) -:> [int]) - , constant "length" (length -:> [int]) - , constant "elem" (elem ->:> [int]) ] - - , background (mayb nord) - == [ constant "Just" (Just ->: mayb nord) ] - - , background (eith nord nord) - == [ constant "Left" (Left ->: eith nord nord) - , constant "Right" (Right ->: eith nord nord) ] - - , background [nord] - == [ constant "length" (length -:> [nord]) ] - - -- background tests - , listBackgroundOK () - , listBackgroundOK int - , listBackgroundOK bool - , listBackgroundOK [(mayb (),integer,mayb char)] - - , maybeBackgroundOK () - , maybeBackgroundOK integer - , maybeBackgroundOK char - , maybeBackgroundOK [(int,bool,[mayb (char,())])] - - , int `instancesSubset` [mayb [int]] - , bool `instancesSubset` ((),bool,char) - , [mayb ((),char)] `instancesSubset` [(int,(char,[mayb ((),char)]),bool)] - , not $ bool `instancesSubset` [mayb [int]] - , not $ bool `bgSubset` [mayb [int]] - , not $ bool `sameNamesIn` [mayb [int]] - , not $ bool `sameTiersIn` [mayb [int]] - , not $ mayb int `instancesSubset` [mayb [int]] - , not $ mayb int `bgSubset` [mayb [int]] - , not $ mayb int `sameNamesIn` [mayb [int]] - , not $ mayb int `sameTiersIn` [mayb [int]] - - , generalizations (instances (undefined :: [Int]) []) [expr [0,0::Int]] - == map (:[]) - [ _is - , _i -:- _is - , _i -:- _i -:- _is - , _i -:- _i -:- ll - , _i -:- zero -:- _is - , _i -:- zero -:- ll - , zero -:- _is - , zero -:- _i -:- _is - , zero -:- _i -:- ll - , zero -:- zero -:- _is - ] - - , [ canonicalizeWith (instances (undefined :: [Int]) []) g' - | g <- generalizations (instances (undefined :: [Int]) []) [expr [0,0::Int]] - , g' <- vassignments g ] - == map (:[]) - [ _is - , _i -:- _is - , _i -:- _i -:- _is - , xx -:- xx -:- _is - , _i -:- _i -:- ll - , xx -:- xx -:- ll - , _i -:- zero -:- _is - , _i -:- zero -:- ll - , zero -:- _is - , zero -:- _i -:- _is - , zero -:- _i -:- ll - , zero -:- zero -:- _is - ] - ---, holds n $ bgEqOrdOK -:> () -- no Eq or Ord instance on background - , holds n $ bgEqOrdOK -:> int - , holds n $ bgEqOK -:> bool - , holds n $ bgEqOrdOK -:> char - , holds n $ bgEqOrdOK -:> integer - , holds n $ bgEqOrdOK -:> ordering - - , holds n $ bgEqOrdOK -:> (int,int) - , holds n $ bgEqOK -:> (int,bool) - , holds n $ bgEqOK -:> (bool,int) - , holds n $ bgEqOK -:> (bool,bool) - , holds n $ bgEqOrdOK -:> (char,ordering) - - , holds n $ bgEqOrdOK -:> (int,int,int) - , holds n $ bgEqOK -:> (int,int,bool) - , holds n $ bgEqOK -:> (int,bool,int) - , holds n $ bgEqOK -:> (int,bool,bool) - , holds n $ bgEqOK -:> (bool,int,int) - , holds n $ bgEqOK -:> (bool,int,bool) - , holds n $ bgEqOK -:> (bool,bool,int) - , holds n $ bgEqOK -:> (bool,bool,bool) - , holds n $ bgEqOrdOK -:> (integer,char,ordering) - - , holds n $ bgEqOrdOK -:> (int,int,int,int) - , holds n $ bgEqOrdOK -:> (integer,char,ordering,int) - , holds n $ bgEqOK -:> (bool,bool,bool,bool) - - , holds n $ bgEqOrdOK -:> [int] - , holds n $ bgEqOK -:> [bool] - , holds n $ bgEqOrdOK -:> [char] - , holds n $ bgEqOrdOK -:> [integer] - - , holds n $ bgEqOrdOK -:> mayb int - , holds n $ bgEqOK -:> mayb bool - , holds n $ bgEqOrdOK -:> mayb char - - , holds n $ bgEqOrdOK -:> eith int int - , holds n $ bgEqOK -:> eith int bool - , holds n $ bgEqOK -:> eith bool int - , holds n $ bgEqOK -:> eith bool bool - , holds n $ bgEqOrdOK -:> eith char ordering - - , tinstancesUnrepeated $ bool - , tinstancesUnrepeated $ bool >- bool - , tinstancesUnrepeated $ int >- bool - , tinstancesUnrepeated $ char >- bool - , tinstancesUnrepeated $ bool >- bool >- bool - , tinstancesUnrepeated $ int >- int >- bool - , tinstancesUnrepeated $ char >- char >- bool - , tinstancesUnrepeated $ [bool] >- bool - , tinstancesUnrepeated $ [int] >- bool - , tinstancesUnrepeated $ [char] >- bool - , tinstancesUnrepeated $ mayb bool >- bool - , tinstancesUnrepeated $ mayb int >- bool - , tinstancesUnrepeated $ mayb char >- bool - , tinstancesUnrepeated $ eith bool bool >- bool - , tinstancesUnrepeated $ eith int int >- bool - , tinstancesUnrepeated $ eith char char >- bool - , tinstancesUnrepeated $ eith char () >- bool - , tinstancesUnrepeated $ ([bool],[bool]) >- bool - , tinstancesUnrepeated $ ([int], [int]) >- bool - , tinstancesUnrepeated $ ([char],[char]) >- bool - , tinstancesUnrepeated $ eith [bool] [bool] >- ([bool],[bool]) >- bool - ] - -tinstancesUnrepeated :: Testable a => a -> Bool -tinstancesUnrepeated p = nub is == is - && nub is' == is' - where - is = tinstances p - is' = fullInstances p - -listBackgroundOK :: Generalizable a => a -> Bool -listBackgroundOK x = backgroundListOf x `subset` backgroundOf [x] - where - backgroundListOf x = [ constant "length" $ length -:> [x] ] - +++ backgroundOf x - -maybeBackgroundOK :: Generalizable a => a -> Bool -maybeBackgroundOK x = backgroundMaybeOf x `subset` backgroundOf (mayb x) - where - backgroundMaybeOf x = [constant "Just" $ Just -:> x] +++ backgroundOf x diff --git a/tests/test-new.hs b/tests/test-new.hs deleted file mode 100644 --- a/tests/test-new.hs +++ /dev/null @@ -1,51 +0,0 @@ --- Copyright (c) 2017 Rudy Matela. --- Distributed under the 3-Clause BSD licence (see the file LICENSE). -import Test - -import Data.List (sort, nub, union) - -import Test.Extrapolate.New - -main :: IO () -main = mainTest tests 10000 - -tests :: Int -> [Bool] -tests n = - [ True - - -- tests about lgg - , lggOK n int - , lggOK n [int] - , lggOK n [[int]] - , lggOK n [([int],eith int char)] - , lgg1 (expr [0,0::Int]) (expr [1,1::Int]) == _i -:- _i -:- ll - , lgg1 (expr [0,1::Int]) (expr [1,0::Int]) == _i -:- _i -:- ll - , lgg1 (expr [0,0::Int]) (expr [0,0,1::Int]) == zero -:- zero -:- _is - , lgg1 (expr [1,1::Int]) (expr [2,2,2::Int]) == _i -:- _i -:- _is - , lgg1 (expr (Just (0::Int))) (expr (Nothing :: Maybe Int)) == _mi - , lgg1 (expr (Just (0::Int))) (expr (Just (1 :: Int))) == just _i - , lgg1 (expr [Just 1, Just (0::Int)]) (expr [Nothing, Just (1::Int)]) - == _mi -:- just _i -:- llmi - - , head (generalizedCounterExamples 360 $ \xs -> nub xs == (xs::[Int])) - == [_i -:- _i -:- _is] - , head (generalizedCounterExamples 360 $ \xs ys -> xs `union` ys == ys `union` (xs::[Int])) - == [ll, zero -:- zero -:- ll] --- but should be: --- == [_is, _i -:- _i -:- _is] - ] - -lggOK :: Generalizable a => Int -> a -> Bool -lggOK n x = holds n (lggCommutative -:> x) - && holds n (lggAssociative -:> x) - && holds n (lggIdempotent -:> x) - -lggCommutative :: Generalizable a => a -> a -> Bool -lggCommutative x y = lgg1 (expr x) (expr y) == lgg1 (expr y) (expr x) - -lggAssociative :: Generalizable a => a -> a -> a -> Bool -lggAssociative x y z = (associative lgg1) (expr x) (expr y) (expr z) - -lggIdempotent :: Generalizable a => a -> a -> Bool -lggIdempotent x y = let z = expr x `lgg1` expr y - in z == (z `lgg1` expr y) diff --git a/tests/test-sdist b/tests/test-sdist deleted file mode 100644 --- a/tests/test-sdist +++ /dev/null @@ -1,28 +0,0 @@ -#!/bin/bash -# -# test-sdist: tests the package generated by "cabal sdist". -# -# Copyright (c) 2015-2018 Rudy Matela. -# Distributed under the 3-Clause BSD licence. -pkgver=` cat *.cabal | grep "^version:" | sed -e "s/version: *//"` -pkgname=`cat *.cabal | grep "^name:" | sed -e "s/name: *//"` -pkg=$pkgname-$pkgver -set -x -cabal sdist && -cd dist && -if [ -d ../.git ] -then - # on git repo, test if files are the same - git -C .. ls-files | sort > ls-git && - tar -tf $pkg.tar.gz | grep -v "/$" | sed -e "s,$pkg/,," | sort > ls-cabal && - diff -rud ls-git ls-cabal && - rm -f ls-git ls-cabal -else - # outside of git repo, test build - rm -rf $pkg/ && - tar -xzf $pkg.tar.gz && - cd $pkg/ && - cabal configure --enable-tests --enable-benchmarks && - cabal build && - cabal test -fi diff --git a/tests/test-step-by-step.hs b/tests/test-step-by-step.hs deleted file mode 100644 --- a/tests/test-step-by-step.hs +++ /dev/null @@ -1,121 +0,0 @@ --- Copyright (c) 2017 Rudy Matela. --- Distributed under the 3-Clause BSD licence (see the file LICENSE). -import Test -import Data.List (nub) - -main :: IO () -main = mainTest tests 10000 - -tests :: Int -> [Bool] -tests n = - [ True - - , tBackground prop - == [ operatorE (_is -==- _is) - , operatorE (_is -/=- _is) - , operatorE (_is -<=- _is) - , operatorE (_is -<- _is) - , lengthE - , elemE - - , operatorE (_b -==- _b) - , operatorE (_b -/=- _b) - , notE - - , operatorE (_i -==- _i) - , operatorE (_i -/=- _i) - , operatorE (_i -<- _i) - , operatorE (_i -<=- _i) ] - - , concat (take 2 $ atoms prop) - == [ _b - , _i - , _is - , ll - , false - , true - , zero - - , operatorE (_is -==- _is) - , operatorE (_is -/=- _is) - , operatorE (_is -<=- _is) - , operatorE (_is -<- _is) - , lengthE - , elemE - - , operatorE (_b -==- _b) - , operatorE (_b -/=- _b) - , notE - - , operatorE (_i -==- _i) - , operatorE (_i -/=- _i) - , operatorE (_i -<- _i) - , operatorE (_i -<=- _i) - - , showConstant [0::Int] - , one - ] - - , snd thyes - == [ _b - , false - , true - , not' _b - - , _is -==- _is - , _is -==- ll - , _is -/=- _is - , _is -/=- ll - , _is -<=- _is - , _is -<- _is - , elem' _i _is - , elem' zero _is - - , _b -==- _b - , _b -/=- _b - - , _i -==- _i - , _i -==- zero - , _i -/=- _i - , _i -/=- zero - , _i -<- _i - , _i -<- zero - , zero -<- _i - , _i -<=- _i - , _i -<=- zero - , zero -<=- _i - ] - - , candidateConditions thyes prop [xxs] - == [ true - , xxs -/=- ll - , elem' zero xxs - ] - - , validConditions thyes prop [xxs] - == [(false, 0)] - - , candidateConditions thyes prop [xx -:- xxs] - == [ true - , xxs -/=- ll - , elem' xx xxs - , elem' zero xxs - , xx -/=- zero - , xx -<- zero - , zero -<- xx - , xx -<=- zero - , zero -<=- xx - ] - - , validConditions thyes prop [xx -:- xxs] - =$ map fst - $= [ (elem' xx xxs, 323) -- TODO: why is this 317 on GHC 8.0? - , (false, 0) - ] - ] - -thyes = theoryAndReprConds prop -prop = prop_nubid `With` MaxConditionSize 3 `With` ConstantBound Nothing - -prop_nubid :: [Int] -> Bool -prop_nubid xs = nub xs == xs diff --git a/tests/test-utils.hs b/tests/test-utils.hs deleted file mode 100644 --- a/tests/test-utils.hs +++ /dev/null @@ -1,128 +0,0 @@ --- Copyright (c) 2017 Rudy Matela. --- Distributed under the 3-Clause BSD licence (see the file LICENSE). -import Test -import Test.Extrapolate.Utils - -main :: IO () -main = mainTest tests 1000 - -tests :: Int -> [Bool] -tests n = - [ True - - , holds n $ elemBy (==) ==== elem -:> () - , holds n $ elemBy (==) ==== elem -:> int - , holds n $ elemBy (==) ==== elem -:> bool - , holds n $ elemBy (==) ==== elem -:> [int] - , holds n $ elemBy (==) ==== elem -:> [bool] - - , holds n $ listEq (==) ==== (==) -:> [()] - , holds n $ listEq (==) ==== (==) -:> [int] - , holds n $ listEq (==) ==== (==) -:> [bool] - , holds n $ listEq (==) ==== (==) -:> [[int]] - , holds n $ listEq (==) ==== (==) -:> [[bool]] - - , holds n $ listOrd (<=) ==== (<=) -:> [()] - , holds n $ listOrd (<=) ==== (<=) -:> [int] - , holds n $ listOrd (<=) ==== (<=) -:> [bool] - , holds n $ listOrd (<=) ==== (<=) -:> [[int]] - , holds n $ listOrd (<=) ==== (<=) -:> [[bool]] - - , holds n $ maybeEq (==) ==== (==) -:> mayb () - , holds n $ maybeEq (==) ==== (==) -:> mayb int - , holds n $ maybeEq (==) ==== (==) -:> mayb bool - , holds n $ maybeEq (==) ==== (==) -:> mayb [int] - , holds n $ maybeEq (==) ==== (==) -:> mayb [bool] - - , holds n $ maybeOrd (<=) ==== (<=) -:> mayb () - , holds n $ maybeOrd (<=) ==== (<=) -:> mayb int - , holds n $ maybeOrd (<=) ==== (<=) -:> mayb bool - , holds n $ maybeOrd (<=) ==== (<=) -:> mayb [int] - , holds n $ maybeOrd (<=) ==== (<=) -:> mayb [bool] - - , holds n $ eitherEq (==) (==) ==== (==) -:> eith () () - , holds n $ eitherEq (==) (==) ==== (==) -:> eith int int - , holds n $ eitherEq (==) (==) ==== (==) -:> eith int bool - , holds n $ eitherEq (==) (==) ==== (==) -:> eith bool int - , holds n $ eitherEq (==) (==) ==== (==) -:> eith bool bool - - , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith () () - , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith int int - , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith int bool - , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith bool int - , holds n $ eitherOrd (<=) (<=) ==== (<=) -:> eith bool bool - - , holds n $ pairEq (==) (==) ==== (==) -:> ((),()) - , holds n $ pairEq (==) (==) ==== (==) -:> (int,int) - , holds n $ pairEq (==) (==) ==== (==) -:> (int,bool) - , holds n $ pairEq (==) (==) ==== (==) -:> (bool,int) - , holds n $ pairEq (==) (==) ==== (==) -:> (bool,bool) - - , holds n $ pairOrd (<=) (<=) ==== (<=) -:> ((),()) - , holds n $ pairOrd (<=) (<=) ==== (<=) -:> (int,int) - , holds n $ pairOrd (<=) (<=) ==== (<=) -:> (int,bool) - , holds n $ pairOrd (<=) (<=) ==== (<=) -:> (bool,int) - , holds n $ pairOrd (<=) (<=) ==== (<=) -:> (bool,bool) - - , holds n $ tripleEq (==) (==) (==) ==== (==) -:> ((),(),()) - , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (int,int,int) - , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (int,int,bool) - , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (int,bool,int) - , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (int,bool,bool) - , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (bool,int,int) - , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (bool,int,bool) - , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (bool,bool,int) - , holds n $ tripleEq (==) (==) (==) ==== (==) -:> (bool,bool,bool) - - , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> ((),(),()) - , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (int,int,int) - , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (int,int,bool) - , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (int,bool,int) - , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (int,bool,bool) - , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (bool,int,int) - , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (bool,int,bool) - , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (bool,bool,int) - , holds n $ tripleOrd (<=) (<=) (<=) ==== (<=) -:> (bool,bool,bool) - - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> ((),(),(),()) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,int,int,int) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,int,int,bool) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,int,bool,int) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,int,bool,bool) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,bool,int,int) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,bool,int,bool) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,bool,bool,int) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (int,bool,bool,bool) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,int,int,int) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,int,int,bool) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,int,bool,int) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,int,bool,bool) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,bool,int,int) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,bool,int,bool) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,bool,bool,int) - , holds n $ quadrupleEq (==) (==) (==) (==) ==== (==) -:> (bool,bool,bool,bool) - - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> ((),(),(),()) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,int,int,int) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,int,int,bool) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,int,bool,int) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,int,bool,bool) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,bool,int,int) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,bool,int,bool) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,bool,bool,int) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (int,bool,bool,bool) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,int,int,int) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,int,int,bool) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,int,bool,int) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,int,bool,bool) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,bool,int,int) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,bool,int,bool) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,bool,bool,int) - , holds n $ quadrupleOrd (<=) (<=) (<=) (<=) ==== (<=) -:> (bool,bool,bool,bool) - - , minimumOn fst [(1,6),(2,5),(3,4)] == (1,6) - , minimumOn snd [(1,6),(2,5),(3,4)] == (3,4) - , maximumOn fst [(1,6),(2,5),(3,4)] == (3,4) - , maximumOn snd [(1,6),(2,5),(3,4)] == (1,6) - , maximumOn fst [(1,6),(1,5),(1,4)] == (1,6) - ]